Adapted to new inductive definition package.
authorberghofe
Wed Feb 07 17:44:07 2007 +0100 (2007-02-07)
changeset 2227151a80e238b29
parent 22270 4ccb7e6be929
child 22272 aac2ac7c32fd
Adapted to new inductive definition package.
src/HOL/Lambda/InductTermi.thy
src/HOL/Lambda/Lambda.thy
src/HOL/Lambda/ListBeta.thy
src/HOL/Lambda/ParRed.thy
src/HOL/Lambda/StrongNorm.thy
src/HOL/Lambda/Type.thy
src/HOL/Lambda/WeakNorm.thy
src/HOL/MicroJava/BV/BVExample.thy
src/HOL/MicroJava/BV/BVNoTypeError.thy
src/HOL/MicroJava/BV/BVSpecTypeSafe.thy
src/HOL/MicroJava/BV/Correct.thy
src/HOL/MicroJava/BV/EffectMono.thy
src/HOL/MicroJava/BV/Err.thy
src/HOL/MicroJava/BV/JType.thy
src/HOL/MicroJava/BV/JVM.thy
src/HOL/MicroJava/BV/JVMType.thy
src/HOL/MicroJava/BV/Kildall.thy
src/HOL/MicroJava/BV/Listn.thy
src/HOL/MicroJava/BV/Opt.thy
src/HOL/MicroJava/BV/Product.thy
src/HOL/MicroJava/BV/Semilat.thy
src/HOL/MicroJava/Comp/CorrComp.thy
src/HOL/MicroJava/Comp/LemmasComp.thy
src/HOL/MicroJava/J/Eval.thy
src/HOL/MicroJava/J/Example.thy
src/HOL/MicroJava/J/JTypeSafe.thy
src/HOL/MicroJava/J/TypeRel.thy
src/HOL/MicroJava/J/WellForm.thy
src/HOL/MicroJava/J/WellType.thy
src/HOL/Nominal/Examples/Compile.thy
src/HOL/Nominal/Examples/SN.thy
src/HOL/Tools/inductive_codegen.ML
src/HOL/Tools/inductive_realizer.ML
     1.1 --- a/src/HOL/Lambda/InductTermi.thy	Wed Feb 07 17:41:11 2007 +0100
     1.2 +++ b/src/HOL/Lambda/InductTermi.thy	Wed Feb 07 17:44:07 2007 +0100
     1.3 @@ -14,21 +14,18 @@
     1.4  
     1.5  subsection {* Terminating lambda terms *}
     1.6  
     1.7 -consts
     1.8 -  IT :: "dB set"
     1.9 -
    1.10 -inductive IT
    1.11 -  intros
    1.12 -    Var [intro]: "rs : lists IT ==> Var n \<degree>\<degree> rs : IT"
    1.13 -    Lambda [intro]: "r : IT ==> Abs r : IT"
    1.14 -    Beta [intro]: "(r[s/0]) \<degree>\<degree> ss : IT ==> s : IT ==> (Abs r \<degree> s) \<degree>\<degree> ss : IT"
    1.15 +inductive2 IT :: "dB => bool"
    1.16 +  where
    1.17 +    Var [intro]: "listsp IT rs ==> IT (Var n \<degree>\<degree> rs)"
    1.18 +  | Lambda [intro]: "IT r ==> IT (Abs r)"
    1.19 +  | Beta [intro]: "IT ((r[s/0]) \<degree>\<degree> ss) ==> IT s ==> IT ((Abs r \<degree> s) \<degree>\<degree> ss)"
    1.20  
    1.21  
    1.22  subsection {* Every term in IT terminates *}
    1.23  
    1.24  lemma double_induction_lemma [rule_format]:
    1.25 -  "s : termi beta ==> \<forall>t. t : termi beta -->
    1.26 -    (\<forall>r ss. t = r[s/0] \<degree>\<degree> ss --> Abs r \<degree> s \<degree>\<degree> ss : termi beta)"
    1.27 +  "termi beta s ==> \<forall>t. termi beta t -->
    1.28 +    (\<forall>r ss. t = r[s/0] \<degree>\<degree> ss --> termi beta (Abs r \<degree> s \<degree>\<degree> ss))"
    1.29    apply (erule acc_induct)
    1.30    apply (rule allI)
    1.31    apply (rule impI)
    1.32 @@ -39,17 +36,15 @@
    1.33    apply (safe elim!: apps_betasE)
    1.34       apply assumption
    1.35      apply (blast intro: subst_preserves_beta apps_preserves_beta)
    1.36 -   apply (blast intro: apps_preserves_beta2 subst_preserves_beta2 rtrancl_converseI
    1.37 +   apply (blast intro: apps_preserves_beta2 subst_preserves_beta2 rtrancl_converseI'
    1.38       dest: acc_downwards)  (* FIXME: acc_downwards can be replaced by acc(R ^* ) = acc(r) *)
    1.39    apply (blast dest: apps_preserves_betas)
    1.40    done
    1.41  
    1.42 -lemma IT_implies_termi: "t : IT ==> t : termi beta"
    1.43 +lemma IT_implies_termi: "IT t ==> termi beta t"
    1.44    apply (induct set: IT)
    1.45 -    apply (drule rev_subsetD)
    1.46 -     apply (rule lists_mono)
    1.47 -     apply (rule Int_lower2)
    1.48 -    apply simp
    1.49 +    apply (drule rev_predicate1D [OF _ listsp_mono [where B="termi beta"]])
    1.50 +    apply fast
    1.51      apply (drule lists_accD)
    1.52      apply (erule acc_induct)
    1.53      apply (rule accI)
    1.54 @@ -72,12 +67,12 @@
    1.55    "(Abs r \<degree> s \<degree>\<degree> ss = Abs r' \<degree> s' \<degree>\<degree> ss') = (r = r' \<and> s = s' \<and> ss = ss')"
    1.56    by (simp add: foldl_Cons [symmetric] del: foldl_Cons)
    1.57  
    1.58 -inductive_cases [elim!]:
    1.59 -  "Var n \<degree>\<degree> ss : IT"
    1.60 -  "Abs t : IT"
    1.61 -  "Abs r \<degree> s \<degree>\<degree> ts : IT"
    1.62 +inductive_cases2 [elim!]:
    1.63 +  "IT (Var n \<degree>\<degree> ss)"
    1.64 +  "IT (Abs t)"
    1.65 +  "IT (Abs r \<degree> s \<degree>\<degree> ts)"
    1.66  
    1.67 -theorem termi_implies_IT: "r : termi beta ==> r : IT"
    1.68 +theorem termi_implies_IT: "termi beta r ==> IT r"
    1.69    apply (erule acc_induct)
    1.70    apply (rename_tac r)
    1.71    apply (erule thin_rl)
    1.72 @@ -90,8 +85,8 @@
    1.73     apply (drule bspec, assumption)
    1.74     apply (erule mp)
    1.75     apply clarify
    1.76 -   apply (drule converseI)
    1.77 -   apply (drule ex_step1I, assumption)
    1.78 +   apply (drule_tac r=beta in conversepI)
    1.79 +   apply (drule_tac r="beta^--1" in ex_step1I, assumption)
    1.80     apply clarify
    1.81     apply (rename_tac us)
    1.82     apply (erule_tac x = "Var n \<degree>\<degree> us" in allE)
     2.1 --- a/src/HOL/Lambda/Lambda.thy	Wed Feb 07 17:41:11 2007 +0100
     2.2 +++ b/src/HOL/Lambda/Lambda.thy	Wed Feb 07 17:44:07 2007 +0100
     2.3 @@ -53,29 +53,21 @@
     2.4  
     2.5  subsection {* Beta-reduction *}
     2.6  
     2.7 -consts
     2.8 -  beta :: "(dB \<times> dB) set"
     2.9 -
    2.10 -abbreviation
    2.11 -  beta_red :: "[dB, dB] => bool"  (infixl "->" 50) where
    2.12 -  "s -> t == (s, t) \<in> beta"
    2.13 +inductive2 beta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
    2.14 +  where
    2.15 +    beta [simp, intro!]: "Abs s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
    2.16 +  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
    2.17 +  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
    2.18 +  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs s \<rightarrow>\<^sub>\<beta> Abs t"
    2.19  
    2.20  abbreviation
    2.21    beta_reds :: "[dB, dB] => bool"  (infixl "->>" 50) where
    2.22 -  "s ->> t == (s, t) \<in> beta^*"
    2.23 +  "s ->> t == beta^** s t"
    2.24  
    2.25  notation (latex)
    2.26 -  beta_red  (infixl "\<rightarrow>\<^sub>\<beta>" 50) and
    2.27    beta_reds  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50)
    2.28  
    2.29 -inductive beta
    2.30 -  intros
    2.31 -    beta [simp, intro!]: "Abs s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
    2.32 -    appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
    2.33 -    appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
    2.34 -    abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs s \<rightarrow>\<^sub>\<beta> Abs t"
    2.35 -
    2.36 -inductive_cases beta_cases [elim!]:
    2.37 +inductive_cases2 beta_cases [elim!]:
    2.38    "Var i \<rightarrow>\<^sub>\<beta> t"
    2.39    "Abs r \<rightarrow>\<^sub>\<beta> s"
    2.40    "s \<degree> t \<rightarrow>\<^sub>\<beta> u"
    2.41 @@ -88,19 +80,19 @@
    2.42  
    2.43  lemma rtrancl_beta_Abs [intro!]:
    2.44      "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> Abs s \<rightarrow>\<^sub>\<beta>\<^sup>* Abs s'"
    2.45 -  by (induct set: rtrancl) (blast intro: rtrancl_into_rtrancl)+
    2.46 +  by (induct set: rtrancl) (blast intro: rtrancl.rtrancl_into_rtrancl)+
    2.47  
    2.48  lemma rtrancl_beta_AppL:
    2.49      "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t"
    2.50 -  by (induct set: rtrancl) (blast intro: rtrancl_into_rtrancl)+
    2.51 +  by (induct set: rtrancl) (blast intro: rtrancl.rtrancl_into_rtrancl)+
    2.52  
    2.53  lemma rtrancl_beta_AppR:
    2.54      "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<degree> t'"
    2.55 -  by (induct set: rtrancl) (blast intro: rtrancl_into_rtrancl)+
    2.56 +  by (induct set: rtrancl) (blast intro: rtrancl.rtrancl_into_rtrancl)+
    2.57  
    2.58  lemma rtrancl_beta_App [intro]:
    2.59      "[| s \<rightarrow>\<^sub>\<beta>\<^sup>* s'; t \<rightarrow>\<^sub>\<beta>\<^sup>* t' |] ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'"
    2.60 -  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtrancl_trans)
    2.61 +  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtrancl_trans')
    2.62  
    2.63  
    2.64  subsection {* Substitution-lemmas *}
    2.65 @@ -164,8 +156,8 @@
    2.66  
    2.67  theorem subst_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> r[t/i] \<rightarrow>\<^sub>\<beta>\<^sup>* s[t/i]"
    2.68    apply (induct set: rtrancl)
    2.69 -   apply (rule rtrancl_refl)
    2.70 -  apply (erule rtrancl_into_rtrancl)
    2.71 +   apply (rule rtrancl.rtrancl_refl)
    2.72 +  apply (erule rtrancl.rtrancl_into_rtrancl)
    2.73    apply (erule subst_preserves_beta)
    2.74    done
    2.75  
    2.76 @@ -175,22 +167,22 @@
    2.77  
    2.78  theorem lift_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> lift r i \<rightarrow>\<^sub>\<beta>\<^sup>* lift s i"
    2.79    apply (induct set: rtrancl)
    2.80 -   apply (rule rtrancl_refl)
    2.81 -  apply (erule rtrancl_into_rtrancl)
    2.82 +   apply (rule rtrancl.rtrancl_refl)
    2.83 +  apply (erule rtrancl.rtrancl_into_rtrancl)
    2.84    apply (erule lift_preserves_beta)
    2.85    done
    2.86  
    2.87  theorem subst_preserves_beta2 [simp]: "r \<rightarrow>\<^sub>\<beta> s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
    2.88    apply (induct t arbitrary: r s i)
    2.89 -    apply (simp add: subst_Var r_into_rtrancl)
    2.90 +    apply (simp add: subst_Var r_into_rtrancl')
    2.91     apply (simp add: rtrancl_beta_App)
    2.92    apply (simp add: rtrancl_beta_Abs)
    2.93    done
    2.94  
    2.95  theorem subst_preserves_beta2': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
    2.96    apply (induct set: rtrancl)
    2.97 -   apply (rule rtrancl_refl)
    2.98 -  apply (erule rtrancl_trans)
    2.99 +   apply (rule rtrancl.rtrancl_refl)
   2.100 +  apply (erule rtrancl_trans')
   2.101    apply (erule subst_preserves_beta2)
   2.102    done
   2.103  
     3.1 --- a/src/HOL/Lambda/ListBeta.thy	Wed Feb 07 17:41:11 2007 +0100
     3.2 +++ b/src/HOL/Lambda/ListBeta.thy	Wed Feb 07 17:44:07 2007 +0100
     3.3 @@ -14,10 +14,10 @@
     3.4  
     3.5  abbreviation
     3.6    list_beta :: "dB list => dB list => bool"  (infixl "=>" 50) where
     3.7 -  "rs => ss == (rs, ss) : step1 beta"
     3.8 +  "rs => ss == step1 beta rs ss"
     3.9  
    3.10  lemma head_Var_reduction:
    3.11 -  "Var n \<degree>\<degree> rs -> v \<Longrightarrow> \<exists>ss. rs => ss \<and> v = Var n \<degree>\<degree> ss"
    3.12 +  "Var n \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> v \<Longrightarrow> \<exists>ss. rs => ss \<and> v = Var n \<degree>\<degree> ss"
    3.13    apply (induct u == "Var n \<degree>\<degree> rs" v arbitrary: rs set: beta)
    3.14       apply simp
    3.15      apply (rule_tac xs = rs in rev_exhaust)
    3.16 @@ -29,14 +29,14 @@
    3.17    done
    3.18  
    3.19  lemma apps_betasE [elim!]:
    3.20 -  assumes major: "r \<degree>\<degree> rs -> s"
    3.21 -    and cases: "!!r'. [| r -> r'; s = r' \<degree>\<degree> rs |] ==> R"
    3.22 +  assumes major: "r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> s"
    3.23 +    and cases: "!!r'. [| r \<rightarrow>\<^sub>\<beta> r'; s = r' \<degree>\<degree> rs |] ==> R"
    3.24        "!!rs'. [| rs => rs'; s = r \<degree>\<degree> rs' |] ==> R"
    3.25        "!!t u us. [| r = Abs t; rs = u # us; s = t[u/0] \<degree>\<degree> us |] ==> R"
    3.26    shows R
    3.27  proof -
    3.28    from major have
    3.29 -   "(\<exists>r'. r -> r' \<and> s = r' \<degree>\<degree> rs) \<or>
    3.30 +   "(\<exists>r'. r \<rightarrow>\<^sub>\<beta> r' \<and> s = r' \<degree>\<degree> rs) \<or>
    3.31      (\<exists>rs'. rs => rs' \<and> s = r \<degree>\<degree> rs') \<or>
    3.32      (\<exists>t u us. r = Abs t \<and> rs = u # us \<and> s = t[u/0] \<degree>\<degree> us)"
    3.33      apply (induct u == "r \<degree>\<degree> rs" s arbitrary: r rs set: beta)
    3.34 @@ -66,18 +66,18 @@
    3.35  qed
    3.36  
    3.37  lemma apps_preserves_beta [simp]:
    3.38 -    "r -> s ==> r \<degree>\<degree> ss -> s \<degree>\<degree> ss"
    3.39 +    "r \<rightarrow>\<^sub>\<beta> s ==> r \<degree>\<degree> ss \<rightarrow>\<^sub>\<beta> s \<degree>\<degree> ss"
    3.40    by (induct ss rule: rev_induct) auto
    3.41  
    3.42  lemma apps_preserves_beta2 [simp]:
    3.43      "r ->> s ==> r \<degree>\<degree> ss ->> s \<degree>\<degree> ss"
    3.44    apply (induct set: rtrancl)
    3.45     apply blast
    3.46 -  apply (blast intro: apps_preserves_beta rtrancl_into_rtrancl)
    3.47 +  apply (blast intro: apps_preserves_beta rtrancl.rtrancl_into_rtrancl)
    3.48    done
    3.49  
    3.50  lemma apps_preserves_betas [simp]:
    3.51 -    "rs => ss \<Longrightarrow> r \<degree>\<degree> rs -> r \<degree>\<degree> ss"
    3.52 +    "rs => ss \<Longrightarrow> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> r \<degree>\<degree> ss"
    3.53    apply (induct rs arbitrary: ss rule: rev_induct)
    3.54     apply simp
    3.55    apply simp
     4.1 --- a/src/HOL/Lambda/ParRed.thy	Wed Feb 07 17:41:11 2007 +0100
     4.2 +++ b/src/HOL/Lambda/ParRed.thy	Wed Feb 07 17:44:07 2007 +0100
     4.3 @@ -14,21 +14,14 @@
     4.4  
     4.5  subsection {* Parallel reduction *}
     4.6  
     4.7 -consts
     4.8 -  par_beta :: "(dB \<times> dB) set"
     4.9 -
    4.10 -abbreviation
    4.11 -  par_beta_red :: "[dB, dB] => bool"  (infixl "=>" 50) where
    4.12 -  "s => t == (s, t) \<in> par_beta"
    4.13 +inductive2 par_beta :: "[dB, dB] => bool"  (infixl "=>" 50)
    4.14 +  where
    4.15 +    var [simp, intro!]: "Var n => Var n"
    4.16 +  | abs [simp, intro!]: "s => t ==> Abs s => Abs t"
    4.17 +  | app [simp, intro!]: "[| s => s'; t => t' |] ==> s \<degree> t => s' \<degree> t'"
    4.18 +  | beta [simp, intro!]: "[| s => s'; t => t' |] ==> (Abs s) \<degree> t => s'[t'/0]"
    4.19  
    4.20 -inductive par_beta
    4.21 -  intros
    4.22 -    var [simp, intro!]: "Var n => Var n"
    4.23 -    abs [simp, intro!]: "s => t ==> Abs s => Abs t"
    4.24 -    app [simp, intro!]: "[| s => s'; t => t' |] ==> s \<degree> t => s' \<degree> t'"
    4.25 -    beta [simp, intro!]: "[| s => s'; t => t' |] ==> (Abs s) \<degree> t => s'[t'/0]"
    4.26 -
    4.27 -inductive_cases par_beta_cases [elim!]:
    4.28 +inductive_cases2 par_beta_cases [elim!]:
    4.29    "Var n => t"
    4.30    "Abs s => Abs t"
    4.31    "(Abs s) \<degree> t => u"
    4.32 @@ -48,18 +41,16 @@
    4.33    by (induct t) simp_all
    4.34  
    4.35  lemma beta_subset_par_beta: "beta <= par_beta"
    4.36 -  apply (rule subsetI)
    4.37 -  apply clarify
    4.38 +  apply (rule predicate2I)
    4.39    apply (erule beta.induct)
    4.40       apply (blast intro!: par_beta_refl)+
    4.41    done
    4.42  
    4.43 -lemma par_beta_subset_beta: "par_beta <= beta^*"
    4.44 -  apply (rule subsetI)
    4.45 -  apply clarify
    4.46 +lemma par_beta_subset_beta: "par_beta <= beta^**"
    4.47 +  apply (rule predicate2I)
    4.48    apply (erule par_beta.induct)
    4.49       apply blast
    4.50 -    apply (blast del: rtrancl_refl intro: rtrancl_into_rtrancl)+
    4.51 +    apply (blast del: rtrancl.rtrancl_refl intro: rtrancl.rtrancl_into_rtrancl)+
    4.52        -- {* @{thm[source] rtrancl_refl} complicates the proof by increasing the branching factor *}
    4.53    done
    4.54  
     5.1 --- a/src/HOL/Lambda/StrongNorm.thy	Wed Feb 07 17:41:11 2007 +0100
     5.2 +++ b/src/HOL/Lambda/StrongNorm.thy	Wed Feb 07 17:44:07 2007 +0100
     5.3 @@ -16,41 +16,38 @@
     5.4  
     5.5  subsection {* Properties of @{text IT} *}
     5.6  
     5.7 -lemma lift_IT [intro!]: "t \<in> IT \<Longrightarrow> lift t i \<in> IT"
     5.8 +lemma lift_IT [intro!]: "IT t \<Longrightarrow> IT (lift t i)"
     5.9    apply (induct arbitrary: i set: IT)
    5.10      apply (simp (no_asm))
    5.11      apply (rule conjI)
    5.12       apply
    5.13        (rule impI,
    5.14         rule IT.Var,
    5.15 -       erule lists.induct,
    5.16 +       erule listsp.induct,
    5.17         simp (no_asm),
    5.18 -       rule lists.Nil,
    5.19 +       rule listsp.Nil,
    5.20         simp (no_asm),
    5.21 -       erule IntE,
    5.22 -       rule lists.Cons,
    5.23 +       rule listsp.Cons,
    5.24         blast,
    5.25         assumption)+
    5.26       apply auto
    5.27     done
    5.28  
    5.29 -lemma lifts_IT: "ts \<in> lists IT \<Longrightarrow> map (\<lambda>t. lift t 0) ts \<in> lists IT"
    5.30 +lemma lifts_IT: "listsp IT ts \<Longrightarrow> listsp IT (map (\<lambda>t. lift t 0) ts)"
    5.31    by (induct ts) auto
    5.32  
    5.33 -lemma subst_Var_IT: "r \<in> IT \<Longrightarrow> r[Var i/j] \<in> IT"
    5.34 +lemma subst_Var_IT: "IT r \<Longrightarrow> IT (r[Var i/j])"
    5.35    apply (induct arbitrary: i j set: IT)
    5.36      txt {* Case @{term Var}: *}
    5.37      apply (simp (no_asm) add: subst_Var)
    5.38      apply
    5.39      ((rule conjI impI)+,
    5.40        rule IT.Var,
    5.41 -      erule lists.induct,
    5.42 -      simp (no_asm),
    5.43 -      rule lists.Nil,
    5.44 +      erule listsp.induct,
    5.45        simp (no_asm),
    5.46 -      erule IntE,
    5.47 -      erule CollectE,
    5.48 -      rule lists.Cons,
    5.49 +      rule listsp.Nil,
    5.50 +      simp (no_asm),
    5.51 +      rule listsp.Cons,
    5.52        fast,
    5.53        assumption)+
    5.54     txt {* Case @{term Lambda}: *}
    5.55 @@ -65,21 +62,21 @@
    5.56     apply auto
    5.57    done
    5.58  
    5.59 -lemma Var_IT: "Var n \<in> IT"
    5.60 -  apply (subgoal_tac "Var n \<degree>\<degree> [] \<in> IT")
    5.61 +lemma Var_IT: "IT (Var n)"
    5.62 +  apply (subgoal_tac "IT (Var n \<degree>\<degree> [])")
    5.63     apply simp
    5.64    apply (rule IT.Var)
    5.65 -  apply (rule lists.Nil)
    5.66 +  apply (rule listsp.Nil)
    5.67    done
    5.68  
    5.69 -lemma app_Var_IT: "t \<in> IT \<Longrightarrow> t \<degree> Var i \<in> IT"
    5.70 +lemma app_Var_IT: "IT t \<Longrightarrow> IT (t \<degree> Var i)"
    5.71    apply (induct set: IT)
    5.72      apply (subst app_last)
    5.73      apply (rule IT.Var)
    5.74      apply simp
    5.75 -    apply (rule lists.Cons)
    5.76 +    apply (rule listsp.Cons)
    5.77       apply (rule Var_IT)
    5.78 -    apply (rule lists.Nil)
    5.79 +    apply (rule listsp.Nil)
    5.80     apply (rule IT.Beta [where ?ss = "[]", unfolded foldl_Nil [THEN eq_reflection]])
    5.81      apply (erule subst_Var_IT)
    5.82     apply (rule Var_IT)
    5.83 @@ -94,26 +91,26 @@
    5.84  subsection {* Well-typed substitution preserves termination *}
    5.85  
    5.86  lemma subst_type_IT:
    5.87 -  "\<And>t e T u i. t \<in> IT \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow>
    5.88 -    u \<in> IT \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> t[u/i] \<in> IT"
    5.89 +  "\<And>t e T u i. IT t \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow>
    5.90 +    IT u \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> IT (t[u/i])"
    5.91    (is "PROP ?P U" is "\<And>t e T u i. _ \<Longrightarrow> PROP ?Q t e T u i U")
    5.92  proof (induct U)
    5.93    fix T t
    5.94    assume MI1: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T1"
    5.95    assume MI2: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T2"
    5.96 -  assume "t \<in> IT"
    5.97 +  assume "IT t"
    5.98    thus "\<And>e T' u i. PROP ?Q t e T' u i T"
    5.99    proof induct
   5.100      fix e T' u i
   5.101 -    assume uIT: "u \<in> IT"
   5.102 +    assume uIT: "IT u"
   5.103      assume uT: "e \<turnstile> u : T"
   5.104      {
   5.105 -      case (Var n rs e_ T'_ u_ i_)
   5.106 +      case (Var rs n e_ T'_ u_ i_)
   5.107        assume nT: "e\<langle>i:T\<rangle> \<turnstile> Var n \<degree>\<degree> rs : T'"
   5.108 -      let ?ty = "{t. \<exists>T'. e\<langle>i:T\<rangle> \<turnstile> t : T'}"
   5.109 +      let ?ty = "\<lambda>t. \<exists>T'. e\<langle>i:T\<rangle> \<turnstile> t : T'"
   5.110        let ?R = "\<lambda>t. \<forall>e T' u i.
   5.111 -        e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> u \<in> IT \<longrightarrow> e \<turnstile> u : T \<longrightarrow> t[u/i] \<in> IT"
   5.112 -      show "(Var n \<degree>\<degree> rs)[u/i] \<in> IT"
   5.113 +        e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> IT u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> IT (t[u/i])"
   5.114 +      show "IT ((Var n \<degree>\<degree> rs)[u/i])"
   5.115        proof (cases "n = i")
   5.116          case True
   5.117          show ?thesis
   5.118 @@ -134,13 +131,13 @@
   5.119            from varT True have T: "T = T'' \<Rightarrow> Ts \<Rrightarrow> T'"
   5.120              by cases auto
   5.121            with uT have uT': "e \<turnstile> u : T'' \<Rightarrow> Ts \<Rrightarrow> T'" by simp
   5.122 -          from T have "(Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0)
   5.123 -            (map (\<lambda>t. t[u/i]) as))[(u \<degree> a[u/i])/0] \<in> IT"
   5.124 +          from T have "IT ((Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0)
   5.125 +            (map (\<lambda>t. t[u/i]) as))[(u \<degree> a[u/i])/0])"
   5.126            proof (rule MI2)
   5.127 -            from T have "(lift u 0 \<degree> Var 0)[a[u/i]/0] \<in> IT"
   5.128 +            from T have "IT ((lift u 0 \<degree> Var 0)[a[u/i]/0])"
   5.129              proof (rule MI1)
   5.130 -              have "lift u 0 \<in> IT" by (rule lift_IT)
   5.131 -              thus "lift u 0 \<degree> Var 0 \<in> IT" by (rule app_Var_IT)
   5.132 +              have "IT (lift u 0)" by (rule lift_IT)
   5.133 +              thus "IT (lift u 0 \<degree> Var 0)" by (rule app_Var_IT)
   5.134                show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 \<degree> Var 0 : Ts \<Rrightarrow> T'"
   5.135                proof (rule typing.App)
   5.136                  show "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 : T'' \<Rightarrow> Ts \<Rrightarrow> T'"
   5.137 @@ -149,19 +146,19 @@
   5.138                    by (rule typing.Var) simp
   5.139                qed
   5.140                from Var have "?R a" by cases (simp_all add: Cons)
   5.141 -              with argT uIT uT show "a[u/i] \<in> IT" by simp
   5.142 +              with argT uIT uT show "IT (a[u/i])" by simp
   5.143                from argT uT show "e \<turnstile> a[u/i] : T''"
   5.144                  by (rule subst_lemma) simp
   5.145              qed
   5.146 -            thus "u \<degree> a[u/i] \<in> IT" by simp
   5.147 -            from Var have "as \<in> lists {t. ?R t}"
   5.148 +            thus "IT (u \<degree> a[u/i])" by simp
   5.149 +            from Var have "listsp ?R as"
   5.150                by cases (simp_all add: Cons)
   5.151 -            moreover from argsT have "as \<in> lists ?ty"
   5.152 +            moreover from argsT have "listsp ?ty as"
   5.153                by (rule lists_typings)
   5.154 -            ultimately have "as \<in> lists ({t. ?R t} \<inter> ?ty)"
   5.155 -              by (rule lists_IntI)
   5.156 -            hence "map (\<lambda>t. lift t 0) (map (\<lambda>t. t[u/i]) as) \<in> lists IT"
   5.157 -              (is "(?ls as) \<in> _")
   5.158 +            ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) as"
   5.159 +              by simp
   5.160 +            hence "listsp IT (map (\<lambda>t. lift t 0) (map (\<lambda>t. t[u/i]) as))"
   5.161 +              (is "listsp IT (?ls as)")
   5.162              proof induct
   5.163                case Nil
   5.164                show ?case by fastsimp
   5.165 @@ -169,13 +166,13 @@
   5.166                case (Cons b bs)
   5.167                hence I: "?R b" by simp
   5.168                from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> b : U" by fast
   5.169 -              with uT uIT I have "b[u/i] \<in> IT" by simp
   5.170 -              hence "lift (b[u/i]) 0 \<in> IT" by (rule lift_IT)
   5.171 -              hence "lift (b[u/i]) 0 # ?ls bs \<in> lists IT"
   5.172 -                by (rule lists.Cons) (rule Cons)
   5.173 +              with uT uIT I have "IT (b[u/i])" by simp
   5.174 +              hence "IT (lift (b[u/i]) 0)" by (rule lift_IT)
   5.175 +              hence "listsp IT (lift (b[u/i]) 0 # ?ls bs)"
   5.176 +                by (rule listsp.Cons) (rule Cons)
   5.177                thus ?case by simp
   5.178              qed
   5.179 -            thus "Var 0 \<degree>\<degree> ?ls as \<in> IT" by (rule IT.Var)
   5.180 +            thus "IT (Var 0 \<degree>\<degree> ?ls as)" by (rule IT.Var)
   5.181              have "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 : Ts \<Rrightarrow> T'"
   5.182                by (rule typing.Var) simp
   5.183              moreover from uT argsT have "e \<tturnstile> map (\<lambda>t. t[u/i]) as : Ts"
   5.184 @@ -194,13 +191,13 @@
   5.185          qed
   5.186        next
   5.187          case False
   5.188 -        from Var have "rs \<in> lists {t. ?R t}" by simp
   5.189 +        from Var have "listsp ?R rs" by simp
   5.190          moreover from nT obtain Ts where "e\<langle>i:T\<rangle> \<tturnstile> rs : Ts"
   5.191            by (rule list_app_typeE)
   5.192 -        hence "rs \<in> lists ?ty" by (rule lists_typings)
   5.193 -        ultimately have "rs \<in> lists ({t. ?R t} \<inter> ?ty)"
   5.194 -          by (rule lists_IntI)
   5.195 -        hence "map (\<lambda>x. x[u/i]) rs \<in> lists IT"
   5.196 +        hence "listsp ?ty rs" by (rule lists_typings)
   5.197 +        ultimately have "listsp (\<lambda>t. ?R t \<and> ?ty t) rs"
   5.198 +          by simp
   5.199 +        hence "listsp IT (map (\<lambda>x. x[u/i]) rs)"
   5.200          proof induct
   5.201            case Nil
   5.202            show ?case by fastsimp
   5.203 @@ -208,9 +205,9 @@
   5.204            case (Cons a as)
   5.205            hence I: "?R a" by simp
   5.206            from Cons obtain U where "e\<langle>i:T\<rangle> \<turnstile> a : U" by fast
   5.207 -          with uT uIT I have "a[u/i] \<in> IT" by simp
   5.208 -          hence "(a[u/i] # map (\<lambda>t. t[u/i]) as) \<in> lists IT"
   5.209 -            by (rule lists.Cons) (rule Cons)
   5.210 +          with uT uIT I have "IT (a[u/i])" by simp
   5.211 +          hence "listsp IT (a[u/i] # map (\<lambda>t. t[u/i]) as)"
   5.212 +            by (rule listsp.Cons) (rule Cons)
   5.213            thus ?case by simp
   5.214          qed
   5.215          with False show ?thesis by (auto simp add: subst_Var)
   5.216 @@ -219,29 +216,29 @@
   5.217        case (Lambda r e_ T'_ u_ i_)
   5.218        assume "e\<langle>i:T\<rangle> \<turnstile> Abs r : T'"
   5.219          and "\<And>e T' u i. PROP ?Q r e T' u i T"
   5.220 -      with uIT uT show "Abs r[u/i] \<in> IT"
   5.221 +      with uIT uT show "IT (Abs r[u/i])"
   5.222          by fastsimp
   5.223      next
   5.224        case (Beta r a as e_ T'_ u_ i_)
   5.225        assume T: "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a \<degree>\<degree> as : T'"
   5.226        assume SI1: "\<And>e T' u i. PROP ?Q (r[a/0] \<degree>\<degree> as) e T' u i T"
   5.227        assume SI2: "\<And>e T' u i. PROP ?Q a e T' u i T"
   5.228 -      have "Abs (r[lift u 0/Suc i]) \<degree> a[u/i] \<degree>\<degree> map (\<lambda>t. t[u/i]) as \<in> IT"
   5.229 +      have "IT (Abs (r[lift u 0/Suc i]) \<degree> a[u/i] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
   5.230        proof (rule IT.Beta)
   5.231          have "Abs r \<degree> a \<degree>\<degree> as \<rightarrow>\<^sub>\<beta> r[a/0] \<degree>\<degree> as"
   5.232            by (rule apps_preserves_beta) (rule beta.beta)
   5.233          with T have "e\<langle>i:T\<rangle> \<turnstile> r[a/0] \<degree>\<degree> as : T'"
   5.234            by (rule subject_reduction)
   5.235 -        hence "(r[a/0] \<degree>\<degree> as)[u/i] \<in> IT"
   5.236 +        hence "IT ((r[a/0] \<degree>\<degree> as)[u/i])"
   5.237            by (rule SI1)
   5.238 -        thus "r[lift u 0/Suc i][a[u/i]/0] \<degree>\<degree> map (\<lambda>t. t[u/i]) as \<in> IT"
   5.239 +        thus "IT (r[lift u 0/Suc i][a[u/i]/0] \<degree>\<degree> map (\<lambda>t. t[u/i]) as)"
   5.240            by (simp del: subst_map add: subst_subst subst_map [symmetric])
   5.241          from T obtain U where "e\<langle>i:T\<rangle> \<turnstile> Abs r \<degree> a : U"
   5.242            by (rule list_app_typeE) fast
   5.243          then obtain T'' where "e\<langle>i:T\<rangle> \<turnstile> a : T''" by cases simp_all
   5.244 -        thus "a[u/i] \<in> IT" by (rule SI2)
   5.245 +        thus "IT (a[u/i])" by (rule SI2)
   5.246        qed
   5.247 -      thus "(Abs r \<degree> a \<degree>\<degree> as)[u/i] \<in> IT" by simp
   5.248 +      thus "IT ((Abs r \<degree> a \<degree>\<degree> as)[u/i])" by simp
   5.249      }
   5.250    qed
   5.251  qed
   5.252 @@ -251,7 +248,7 @@
   5.253  
   5.254  lemma type_implies_IT:
   5.255    assumes "e \<turnstile> t : T"
   5.256 -  shows "t \<in> IT"
   5.257 +  shows "IT t"
   5.258    using prems
   5.259  proof induct
   5.260    case Var
   5.261 @@ -260,14 +257,14 @@
   5.262    case Abs
   5.263    show ?case by (rule IT.Lambda)
   5.264  next
   5.265 -  case (App T U e s t)
   5.266 -  have "(Var 0 \<degree> lift t 0)[s/0] \<in> IT"
   5.267 +  case (App e s T U t)
   5.268 +  have "IT ((Var 0 \<degree> lift t 0)[s/0])"
   5.269    proof (rule subst_type_IT)
   5.270 -    have "lift t 0 \<in> IT" by (rule lift_IT)
   5.271 -    hence "[lift t 0] \<in> lists IT" by (rule lists.Cons) (rule lists.Nil)
   5.272 -    hence "Var 0 \<degree>\<degree> [lift t 0] \<in> IT" by (rule IT.Var)
   5.273 +    have "IT (lift t 0)" by (rule lift_IT)
   5.274 +    hence "listsp IT [lift t 0]" by (rule listsp.Cons) (rule listsp.Nil)
   5.275 +    hence "IT (Var 0 \<degree>\<degree> [lift t 0])" by (rule IT.Var)
   5.276      also have "Var 0 \<degree>\<degree> [lift t 0] = Var 0 \<degree> lift t 0" by simp
   5.277 -    finally show "\<dots> \<in> IT" .
   5.278 +    finally show "IT \<dots>" .
   5.279      have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 : T \<Rightarrow> U"
   5.280        by (rule typing.Var) simp
   5.281      moreover have "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> lift t 0 : T"
   5.282 @@ -278,10 +275,10 @@
   5.283    thus ?case by simp
   5.284  qed
   5.285  
   5.286 -theorem type_implies_termi: "e \<turnstile> t : T \<Longrightarrow> t \<in> termi beta"
   5.287 +theorem type_implies_termi: "e \<turnstile> t : T \<Longrightarrow> termi beta t"
   5.288  proof -
   5.289    assume "e \<turnstile> t : T"
   5.290 -  hence "t \<in> IT" by (rule type_implies_IT)
   5.291 +  hence "IT t" by (rule type_implies_IT)
   5.292    thus ?thesis by (rule IT_implies_termi)
   5.293  qed
   5.294  
     6.1 --- a/src/HOL/Lambda/Type.thy	Wed Feb 07 17:41:11 2007 +0100
     6.2 +++ b/src/HOL/Lambda/Type.thy	Wed Feb 07 17:44:07 2007 +0100
     6.3 @@ -45,8 +45,18 @@
     6.4      Atom nat
     6.5    | Fun type type    (infixr "\<Rightarrow>" 200)
     6.6  
     6.7 +inductive2 typing :: "(nat \<Rightarrow> type) \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ : _" [50, 50, 50] 50)
     6.8 +  where
     6.9 +    Var [intro!]: "env x = T \<Longrightarrow> env \<turnstile> Var x : T"
    6.10 +  | Abs [intro!]: "env\<langle>0:T\<rangle> \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs t : (T \<Rightarrow> U)"
    6.11 +  | App [intro!]: "env \<turnstile> s : T \<Rightarrow> U \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"
    6.12 +
    6.13 +inductive_cases2 typing_elims [elim!]:
    6.14 +  "e \<turnstile> Var i : T"
    6.15 +  "e \<turnstile> t \<degree> u : T"
    6.16 +  "e \<turnstile> Abs t : T"
    6.17 +
    6.18  consts
    6.19 -  typing :: "((nat \<Rightarrow> type) \<times> dB \<times> type) set"
    6.20    typings :: "(nat \<Rightarrow> type) \<Rightarrow> dB list \<Rightarrow> type list \<Rightarrow> bool"
    6.21  
    6.22  abbreviation
    6.23 @@ -54,32 +64,14 @@
    6.24    "Ts =>> T == foldr Fun Ts T"
    6.25  
    6.26  abbreviation
    6.27 -  typing_rel :: "(nat \<Rightarrow> type) \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ |- _ : _" [50, 50, 50] 50) where
    6.28 -  "env |- t : T == (env, t, T) \<in> typing"
    6.29 -
    6.30 -abbreviation
    6.31    typings_rel :: "(nat \<Rightarrow> type) \<Rightarrow> dB list \<Rightarrow> type list \<Rightarrow> bool"
    6.32      ("_ ||- _ : _" [50, 50, 50] 50) where
    6.33    "env ||- ts : Ts == typings env ts Ts"
    6.34  
    6.35 -notation (xsymbols)
    6.36 -  typing_rel  ("_ \<turnstile> _ : _" [50, 50, 50] 50)
    6.37 -
    6.38  notation (latex)
    6.39    funs  (infixr "\<Rrightarrow>" 200) and
    6.40    typings_rel  ("_ \<tturnstile> _ : _" [50, 50, 50] 50)
    6.41  
    6.42 -inductive typing
    6.43 -  intros
    6.44 -    Var [intro!]: "env x = T \<Longrightarrow> env \<turnstile> Var x : T"
    6.45 -    Abs [intro!]: "env\<langle>0:T\<rangle> \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs t : (T \<Rightarrow> U)"
    6.46 -    App [intro!]: "env \<turnstile> s : T \<Rightarrow> U \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"
    6.47 -
    6.48 -inductive_cases typing_elims [elim!]:
    6.49 -  "e \<turnstile> Var i : T"
    6.50 -  "e \<turnstile> t \<degree> u : T"
    6.51 -  "e \<turnstile> Abs t : T"
    6.52 -
    6.53  primrec
    6.54    "(e \<tturnstile> [] : Ts) = (Ts = [])"
    6.55    "(e \<tturnstile> (t # ts) : Ts) =
    6.56 @@ -100,16 +92,16 @@
    6.57  subsection {* Lists of types *}
    6.58  
    6.59  lemma lists_typings:
    6.60 -    "e \<tturnstile> ts : Ts \<Longrightarrow> ts \<in> lists {t. \<exists>T. e \<turnstile> t : T}"
    6.61 +    "e \<tturnstile> ts : Ts \<Longrightarrow> listsp (\<lambda>t. \<exists>T. e \<turnstile> t : T) ts"
    6.62    apply (induct ts arbitrary: Ts)
    6.63     apply (case_tac Ts)
    6.64       apply simp
    6.65 -     apply (rule lists.Nil)
    6.66 +     apply (rule listsp.Nil)
    6.67      apply simp
    6.68    apply (case_tac Ts)
    6.69     apply simp
    6.70    apply simp
    6.71 -  apply (rule lists.Cons)
    6.72 +  apply (rule listsp.Cons)
    6.73     apply blast
    6.74    apply blast
    6.75    done
    6.76 @@ -172,7 +164,7 @@
    6.77    apply (erule impE)
    6.78     apply assumption
    6.79    apply (elim exE conjE)
    6.80 -  apply (ind_cases "e \<turnstile> t \<degree> u : T")
    6.81 +  apply (ind_cases2 "e \<turnstile> t \<degree> u : T" for t u T)
    6.82    apply (rule_tac x = "Ta # Ts" in exI)
    6.83    apply simp
    6.84    done
    6.85 @@ -210,12 +202,12 @@
    6.86    "e \<turnstile> Var i \<degree>\<degree> ts : T \<Longrightarrow> e \<turnstile> Var i \<degree>\<degree> ts : U \<Longrightarrow> T = U"
    6.87    apply (induct ts arbitrary: T U rule: rev_induct)
    6.88    apply simp
    6.89 -  apply (ind_cases "e \<turnstile> Var i : T")
    6.90 -  apply (ind_cases "e \<turnstile> Var i : T")
    6.91 +  apply (ind_cases2 "e \<turnstile> Var i : T" for T)
    6.92 +  apply (ind_cases2 "e \<turnstile> Var i : T" for T)
    6.93    apply simp
    6.94    apply simp
    6.95 -  apply (ind_cases "e \<turnstile> t \<degree> u : T")
    6.96 -  apply (ind_cases "e \<turnstile> t \<degree> u : T")
    6.97 +  apply (ind_cases2 "e \<turnstile> t \<degree> u : T" for t u T)
    6.98 +  apply (ind_cases2 "e \<turnstile> t \<degree> u : T" for t u T)
    6.99    apply atomize
   6.100    apply (erule_tac x="Ta \<Rightarrow> T" in allE)
   6.101    apply (erule_tac x="Tb \<Rightarrow> U" in allE)
   6.102 @@ -238,7 +230,7 @@
   6.103    apply (rule FalseE)
   6.104    apply simp
   6.105    apply (erule list_app_typeE)
   6.106 -  apply (ind_cases "e \<turnstile> t \<degree> u : T")
   6.107 +  apply (ind_cases2 "e \<turnstile> t \<degree> u : T" for t u T)
   6.108    apply (drule_tac T="Atom nat" and U="Ta \<Rightarrow> Tsa \<Rrightarrow> T" in var_app_type_eq)
   6.109    apply assumption
   6.110    apply simp
   6.111 @@ -250,7 +242,7 @@
   6.112    apply (rule types_snoc)
   6.113    apply assumption
   6.114    apply (erule list_app_typeE)
   6.115 -  apply (ind_cases "e \<turnstile> t \<degree> u : T")
   6.116 +  apply (ind_cases2 "e \<turnstile> t \<degree> u : T" for t u T)
   6.117    apply (drule_tac T="type1 \<Rightarrow> type2" and U="Ta \<Rightarrow> Tsa \<Rrightarrow> T" in var_app_type_eq)
   6.118    apply assumption
   6.119    apply simp
   6.120 @@ -258,7 +250,7 @@
   6.121    apply (rule typing.App)
   6.122    apply assumption
   6.123    apply (erule list_app_typeE)
   6.124 -  apply (ind_cases "e \<turnstile> t \<degree> u : T")
   6.125 +  apply (ind_cases2 "e \<turnstile> t \<degree> u : T" for t u T)
   6.126    apply (frule_tac T="type1 \<Rightarrow> type2" and U="Ta \<Rightarrow> Tsa \<Rrightarrow> T" in var_app_type_eq)
   6.127    apply assumption
   6.128    apply simp
   6.129 @@ -266,7 +258,7 @@
   6.130    apply (rule_tac x="type1 # Us" in exI)
   6.131    apply simp
   6.132    apply (erule list_app_typeE)
   6.133 -  apply (ind_cases "e \<turnstile> t \<degree> u : T")
   6.134 +  apply (ind_cases2 "e \<turnstile> t \<degree> u : T" for t u T)
   6.135    apply (frule_tac T="type1 \<Rightarrow> Us \<Rrightarrow> T" and U="Ta \<Rightarrow> Tsa \<Rrightarrow> T" in var_app_type_eq)
   6.136    apply assumption
   6.137    apply simp
   6.138 @@ -281,13 +273,13 @@
   6.139  lemma abs_typeE: "e \<turnstile> Abs t : T \<Longrightarrow> (\<And>U V. e\<langle>0:U\<rangle> \<turnstile> t : V \<Longrightarrow> P) \<Longrightarrow> P"
   6.140    apply (cases T)
   6.141    apply (rule FalseE)
   6.142 -  apply (erule typing.elims)
   6.143 +  apply (erule typing.cases)
   6.144    apply simp_all
   6.145    apply atomize
   6.146    apply (erule_tac x="type1" in allE)
   6.147    apply (erule_tac x="type2" in allE)
   6.148    apply (erule mp)
   6.149 -  apply (erule typing.elims)
   6.150 +  apply (erule typing.cases)
   6.151    apply simp_all
   6.152    done
   6.153  
   6.154 @@ -335,14 +327,14 @@
   6.155  
   6.156  subsection {* Subject reduction *}
   6.157  
   6.158 -lemma subject_reduction: "e \<turnstile> t : T \<Longrightarrow> t -> t' \<Longrightarrow> e \<turnstile> t' : T"
   6.159 +lemma subject_reduction: "e \<turnstile> t : T \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> e \<turnstile> t' : T"
   6.160    apply (induct arbitrary: t' set: typing)
   6.161      apply blast
   6.162     apply blast
   6.163    apply atomize
   6.164 -  apply (ind_cases "s \<degree> t -> t'")
   6.165 +  apply (ind_cases2 "s \<degree> t \<rightarrow>\<^sub>\<beta> t'" for s t t')
   6.166      apply hypsubst
   6.167 -    apply (ind_cases "env \<turnstile> Abs t : T \<Rightarrow> U")
   6.168 +    apply (ind_cases2 "env \<turnstile> Abs t : T \<Rightarrow> U" for env t T U)
   6.169      apply (rule subst_lemma)
   6.170        apply assumption
   6.171       apply assumption
     7.1 --- a/src/HOL/Lambda/WeakNorm.thy	Wed Feb 07 17:41:11 2007 +0100
     7.2 +++ b/src/HOL/Lambda/WeakNorm.thy	Wed Feb 07 17:44:07 2007 +0100
     7.3 @@ -73,11 +73,10 @@
     7.4    -- {* Currently needed for strange technical reasons *}
     7.5    by (unfold listall_def) simp
     7.6  
     7.7 -consts NF :: "dB set"
     7.8 -inductive NF
     7.9 -intros
    7.10 -  App: "listall (\<lambda>t. t \<in> NF) ts \<Longrightarrow> Var x \<degree>\<degree> ts \<in> NF"
    7.11 -  Abs: "t \<in> NF \<Longrightarrow> Abs t \<in> NF"
    7.12 +inductive2 NF :: "dB \<Rightarrow> bool"
    7.13 +where
    7.14 +  App: "listall NF ts \<Longrightarrow> NF (Var x \<degree>\<degree> ts)"
    7.15 +| Abs: "NF t \<Longrightarrow> NF (Abs t)"
    7.16  monos listall_def
    7.17  
    7.18  lemma nat_eq_dec: "\<And>n::nat. m = n \<or> m \<noteq> n"
    7.19 @@ -94,26 +93,26 @@
    7.20    apply (simp del: simp_thms, iprover?)+
    7.21    done
    7.22  
    7.23 -lemma App_NF_D: assumes NF: "Var n \<degree>\<degree> ts \<in> NF"
    7.24 -  shows "listall (\<lambda>t. t \<in> NF) ts" using NF
    7.25 +lemma App_NF_D: assumes NF: "NF (Var n \<degree>\<degree> ts)"
    7.26 +  shows "listall NF ts" using NF
    7.27    by cases simp_all
    7.28  
    7.29  
    7.30  subsection {* Properties of @{text NF} *}
    7.31  
    7.32 -lemma Var_NF: "Var n \<in> NF"
    7.33 -  apply (subgoal_tac "Var n \<degree>\<degree> [] \<in> NF")
    7.34 +lemma Var_NF: "NF (Var n)"
    7.35 +  apply (subgoal_tac "NF (Var n \<degree>\<degree> [])")
    7.36     apply simp
    7.37    apply (rule NF.App)
    7.38    apply simp
    7.39    done
    7.40  
    7.41 -lemma subst_terms_NF: "listall (\<lambda>t. t \<in> NF) ts \<Longrightarrow>
    7.42 -    listall (\<lambda>t. \<forall>i j. t[Var i/j] \<in> NF) ts \<Longrightarrow>
    7.43 -    listall (\<lambda>t. t \<in> NF) (map (\<lambda>t. t[Var i/j]) ts)"
    7.44 +lemma subst_terms_NF: "listall NF ts \<Longrightarrow>
    7.45 +    listall (\<lambda>t. \<forall>i j. NF (t[Var i/j])) ts \<Longrightarrow>
    7.46 +    listall NF (map (\<lambda>t. t[Var i/j]) ts)"
    7.47    by (induct ts) simp_all
    7.48  
    7.49 -lemma subst_Var_NF: "t \<in> NF \<Longrightarrow> t[Var i/j] \<in> NF"
    7.50 +lemma subst_Var_NF: "NF t \<Longrightarrow> NF (t[Var i/j])"
    7.51    apply (induct arbitrary: i j set: NF)
    7.52    apply simp
    7.53    apply (frule listall_conj1)
    7.54 @@ -132,30 +131,30 @@
    7.55    apply (iprover intro: NF.Abs)
    7.56    done
    7.57  
    7.58 -lemma app_Var_NF: "t \<in> NF \<Longrightarrow> \<exists>t'. t \<degree> Var i \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> t' \<in> NF"
    7.59 +lemma app_Var_NF: "NF t \<Longrightarrow> \<exists>t'. t \<degree> Var i \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
    7.60    apply (induct set: NF)
    7.61    apply (simplesubst app_last)  --{*Using @{text subst} makes extraction fail*}
    7.62    apply (rule exI)
    7.63    apply (rule conjI)
    7.64 -  apply (rule rtrancl_refl)
    7.65 +  apply (rule rtrancl.rtrancl_refl)
    7.66    apply (rule NF.App)
    7.67    apply (drule listall_conj1)
    7.68    apply (simp add: listall_app)
    7.69    apply (rule Var_NF)
    7.70    apply (rule exI)
    7.71    apply (rule conjI)
    7.72 -  apply (rule rtrancl_into_rtrancl)
    7.73 -  apply (rule rtrancl_refl)
    7.74 +  apply (rule rtrancl.rtrancl_into_rtrancl)
    7.75 +  apply (rule rtrancl.rtrancl_refl)
    7.76    apply (rule beta)
    7.77    apply (erule subst_Var_NF)
    7.78    done
    7.79  
    7.80 -lemma lift_terms_NF: "listall (\<lambda>t. t \<in> NF) ts \<Longrightarrow>
    7.81 -    listall (\<lambda>t. \<forall>i. lift t i \<in> NF) ts \<Longrightarrow>
    7.82 -    listall (\<lambda>t. t \<in> NF) (map (\<lambda>t. lift t i) ts)"
    7.83 +lemma lift_terms_NF: "listall NF ts \<Longrightarrow>
    7.84 +    listall (\<lambda>t. \<forall>i. NF (lift t i)) ts \<Longrightarrow>
    7.85 +    listall NF (map (\<lambda>t. lift t i) ts)"
    7.86    by (induct ts) simp_all
    7.87  
    7.88 -lemma lift_NF: "t \<in> NF \<Longrightarrow> lift t i \<in> NF"
    7.89 +lemma lift_NF: "NF t \<Longrightarrow> NF (lift t i)"
    7.90    apply (induct arbitrary: i set: NF)
    7.91    apply (frule listall_conj1)
    7.92    apply (drule listall_conj2)
    7.93 @@ -178,13 +177,13 @@
    7.94  
    7.95  lemma norm_list:
    7.96    assumes f_compat: "\<And>t t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> f t \<rightarrow>\<^sub>\<beta>\<^sup>* f t'"
    7.97 -  and f_NF: "\<And>t. t \<in> NF \<Longrightarrow> f t \<in> NF"
    7.98 -  and uNF: "u \<in> NF" and uT: "e \<turnstile> u : T"
    7.99 +  and f_NF: "\<And>t. NF t \<Longrightarrow> NF (f t)"
   7.100 +  and uNF: "NF u" and uT: "e \<turnstile> u : T"
   7.101    shows "\<And>Us. e\<langle>i:T\<rangle> \<tturnstile> as : Us \<Longrightarrow>
   7.102      listall (\<lambda>t. \<forall>e T' u i. e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow>
   7.103 -      u \<in> NF \<longrightarrow> e \<turnstile> u : T \<longrightarrow> (\<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> t' \<in> NF)) as \<Longrightarrow>
   7.104 +      NF u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> (\<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')) as \<Longrightarrow>
   7.105      \<exists>as'. \<forall>j. Var j \<degree>\<degree> map (\<lambda>t. f (t[u/i])) as \<rightarrow>\<^sub>\<beta>\<^sup>*
   7.106 -      Var j \<degree>\<degree> map f as' \<and> Var j \<degree>\<degree> map f as' \<in> NF"
   7.107 +      Var j \<degree>\<degree> map f as' \<and> NF (Var j \<degree>\<degree> map f as')"
   7.108    (is "\<And>Us. _ \<Longrightarrow> listall ?R as \<Longrightarrow> \<exists>as'. ?ex Us as as'")
   7.109  proof (induct as rule: rev_induct)
   7.110    case (Nil Us)
   7.111 @@ -200,18 +199,18 @@
   7.112    with bs have "\<exists>bs'. ?ex Vs bs bs'" by (rule snoc)
   7.113    then obtain bs' where
   7.114      bsred: "\<And>j. Var j \<degree>\<degree> map (\<lambda>t. f (t[u/i])) bs \<rightarrow>\<^sub>\<beta>\<^sup>* Var j \<degree>\<degree> map f bs'"
   7.115 -    and bsNF: "\<And>j. Var j \<degree>\<degree> map f bs' \<in> NF" by iprover
   7.116 +    and bsNF: "\<And>j. NF (Var j \<degree>\<degree> map f bs')" by iprover
   7.117    from snoc have "?R b" by simp
   7.118 -  with bT and uNF and uT have "\<exists>b'. b[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* b' \<and> b' \<in> NF"
   7.119 +  with bT and uNF and uT have "\<exists>b'. b[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* b' \<and> NF b'"
   7.120      by iprover
   7.121 -  then obtain b' where bred: "b[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* b'" and bNF: "b' \<in> NF"
   7.122 +  then obtain b' where bred: "b[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* b'" and bNF: "NF b'"
   7.123      by iprover
   7.124 -  from bsNF [of 0] have "listall (\<lambda>t. t \<in> NF) (map f bs')"
   7.125 +  from bsNF [of 0] have "listall NF (map f bs')"
   7.126      by (rule App_NF_D)
   7.127 -  moreover have "f b' \<in> NF" by (rule f_NF)
   7.128 -  ultimately have "listall (\<lambda>t. t \<in> NF) (map f (bs' @ [b']))"
   7.129 +  moreover have "NF (f b')" by (rule f_NF)
   7.130 +  ultimately have "listall NF (map f (bs' @ [b']))"
   7.131      by simp
   7.132 -  hence "\<And>j. Var j \<degree>\<degree> map f (bs' @ [b']) \<in> NF" by (rule NF.App)
   7.133 +  hence "\<And>j. NF (Var j \<degree>\<degree> map f (bs' @ [b']))" by (rule NF.App)
   7.134    moreover from bred have "f (b[u/i]) \<rightarrow>\<^sub>\<beta>\<^sup>* f b'"
   7.135      by (rule f_compat)
   7.136    with bsred have
   7.137 @@ -222,18 +221,18 @@
   7.138  qed
   7.139  
   7.140  lemma subst_type_NF:
   7.141 -  "\<And>t e T u i. t \<in> NF \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow> u \<in> NF \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> \<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> t' \<in> NF"
   7.142 +  "\<And>t e T u i. NF t \<Longrightarrow> e\<langle>i:U\<rangle> \<turnstile> t : T \<Longrightarrow> NF u \<Longrightarrow> e \<turnstile> u : U \<Longrightarrow> \<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
   7.143    (is "PROP ?P U" is "\<And>t e T u i. _ \<Longrightarrow> PROP ?Q t e T u i U")
   7.144  proof (induct U)
   7.145    fix T t
   7.146    let ?R = "\<lambda>t. \<forall>e T' u i.
   7.147 -    e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> u \<in> NF \<longrightarrow> e \<turnstile> u : T \<longrightarrow> (\<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> t' \<in> NF)"
   7.148 +    e\<langle>i:T\<rangle> \<turnstile> t : T' \<longrightarrow> NF u \<longrightarrow> e \<turnstile> u : T \<longrightarrow> (\<exists>t'. t[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')"
   7.149    assume MI1: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T1"
   7.150    assume MI2: "\<And>T1 T2. T = T1 \<Rightarrow> T2 \<Longrightarrow> PROP ?P T2"
   7.151 -  assume "t \<in> NF"
   7.152 +  assume "NF t"
   7.153    thus "\<And>e T' u i. PROP ?Q t e T' u i T"
   7.154    proof induct
   7.155 -    fix e T' u i assume uNF: "u \<in> NF" and uT: "e \<turnstile> u : T"
   7.156 +    fix e T' u i assume uNF: "NF u" and uT: "e \<turnstile> u : T"
   7.157      {
   7.158        case (App ts x e_ T'_ u_ i_)
   7.159        assume "e\<langle>i:T\<rangle> \<turnstile> Var x \<degree>\<degree> ts : T'"
   7.160 @@ -241,7 +240,7 @@
   7.161  	where varT: "e\<langle>i:T\<rangle> \<turnstile> Var x : Us \<Rrightarrow> T'"
   7.162  	and argsT: "e\<langle>i:T\<rangle> \<tturnstile> ts : Us"
   7.163  	by (rule var_app_typesE)
   7.164 -      from nat_eq_dec show "\<exists>t'. (Var x \<degree>\<degree> ts)[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> t' \<in> NF"
   7.165 +      from nat_eq_dec show "\<exists>t'. (Var x \<degree>\<degree> ts)[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
   7.166        proof
   7.167  	assume eq: "x = i"
   7.168  	show ?thesis
   7.169 @@ -264,20 +263,20 @@
   7.170  	  with lift_preserves_beta' lift_NF uNF uT argsT'
   7.171  	  have "\<exists>as'. \<forall>j. Var j \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as \<rightarrow>\<^sub>\<beta>\<^sup>*
   7.172              Var j \<degree>\<degree> map (\<lambda>t. lift t 0) as' \<and>
   7.173 -	    Var j \<degree>\<degree> map (\<lambda>t. lift t 0) as' \<in> NF" by (rule norm_list)
   7.174 +	    NF (Var j \<degree>\<degree> map (\<lambda>t. lift t 0) as')" by (rule norm_list)
   7.175  	  then obtain as' where
   7.176  	    asred: "Var 0 \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as \<rightarrow>\<^sub>\<beta>\<^sup>*
   7.177  	      Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as'"
   7.178 -	    and asNF: "Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as' \<in> NF" by iprover
   7.179 +	    and asNF: "NF (Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')" by iprover
   7.180  	  from App and Cons have "?R a" by simp
   7.181 -	  with argT and uNF and uT have "\<exists>a'. a[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* a' \<and> a' \<in> NF"
   7.182 +	  with argT and uNF and uT have "\<exists>a'. a[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* a' \<and> NF a'"
   7.183  	    by iprover
   7.184 -	  then obtain a' where ared: "a[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* a'" and aNF: "a' \<in> NF" by iprover
   7.185 -	  from uNF have "lift u 0 \<in> NF" by (rule lift_NF)
   7.186 -	  hence "\<exists>u'. lift u 0 \<degree> Var 0 \<rightarrow>\<^sub>\<beta>\<^sup>* u' \<and> u' \<in> NF" by (rule app_Var_NF)
   7.187 -	  then obtain u' where ured: "lift u 0 \<degree> Var 0 \<rightarrow>\<^sub>\<beta>\<^sup>* u'" and u'NF: "u' \<in> NF"
   7.188 +	  then obtain a' where ared: "a[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* a'" and aNF: "NF a'" by iprover
   7.189 +	  from uNF have "NF (lift u 0)" by (rule lift_NF)
   7.190 +	  hence "\<exists>u'. lift u 0 \<degree> Var 0 \<rightarrow>\<^sub>\<beta>\<^sup>* u' \<and> NF u'" by (rule app_Var_NF)
   7.191 +	  then obtain u' where ured: "lift u 0 \<degree> Var 0 \<rightarrow>\<^sub>\<beta>\<^sup>* u'" and u'NF: "NF u'"
   7.192  	    by iprover
   7.193 -	  from T and u'NF have "\<exists>ua. u'[a'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* ua \<and> ua \<in> NF"
   7.194 +	  from T and u'NF have "\<exists>ua. u'[a'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* ua \<and> NF ua"
   7.195  	  proof (rule MI1)
   7.196  	    have "e\<langle>0:T''\<rangle> \<turnstile> lift u 0 \<degree> Var 0 : Ts \<Rrightarrow> T'"
   7.197  	    proof (rule typing.App)
   7.198 @@ -287,7 +286,7 @@
   7.199  	    with ured show "e\<langle>0:T''\<rangle> \<turnstile> u' : Ts \<Rrightarrow> T'" by (rule subject_reduction')
   7.200  	    from ared aT show "e \<turnstile> a' : T''" by (rule subject_reduction')
   7.201  	  qed
   7.202 -	  then obtain ua where uared: "u'[a'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* ua" and uaNF: "ua \<in> NF"
   7.203 +	  then obtain ua where uared: "u'[a'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* ua" and uaNF: "NF ua"
   7.204  	    by iprover
   7.205  	  from ared have "(lift u 0 \<degree> Var 0)[a[u/i]/0] \<rightarrow>\<^sub>\<beta>\<^sup>* (lift u 0 \<degree> Var 0)[a'/0]"
   7.206  	    by (rule subst_preserves_beta2')
   7.207 @@ -296,7 +295,7 @@
   7.208  	  also note uared
   7.209  	  finally have "(lift u 0 \<degree> Var 0)[a[u/i]/0] \<rightarrow>\<^sub>\<beta>\<^sup>* ua" .
   7.210  	  hence uared': "u \<degree> a[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* ua" by simp
   7.211 -	  from T have "\<exists>r. (Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[ua/0] \<rightarrow>\<^sub>\<beta>\<^sup>* r \<and> r \<in> NF"
   7.212 +	  from T have "\<exists>r. (Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[ua/0] \<rightarrow>\<^sub>\<beta>\<^sup>* r \<and> NF r"
   7.213  	  proof (rule MI2)
   7.214  	    have "e\<langle>0:Ts \<Rrightarrow> T'\<rangle> \<turnstile> Var 0 \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as : T'"
   7.215  	    proof (rule list_app_typeI)
   7.216 @@ -315,7 +314,7 @@
   7.217  	    with uared' show "e \<turnstile> ua : Ts \<Rrightarrow> T'" by (rule subject_reduction')
   7.218  	  qed
   7.219  	  then obtain r where rred: "(Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[ua/0] \<rightarrow>\<^sub>\<beta>\<^sup>* r"
   7.220 -	    and rnf: "r \<in> NF" by iprover
   7.221 +	    and rnf: "NF r" by iprover
   7.222  	  from asred have
   7.223  	    "(Var 0 \<degree>\<degree> map (\<lambda>t. lift (t[u/i]) 0) as)[u \<degree> a[u/i]/0] \<rightarrow>\<^sub>\<beta>\<^sup>*
   7.224  	    (Var 0 \<degree>\<degree> map (\<lambda>t. lift t 0) as')[u \<degree> a[u/i]/0]"
   7.225 @@ -332,7 +331,7 @@
   7.226  	from App have "listall ?R ts" by (iprover dest: listall_conj2)
   7.227  	with TrueI TrueI uNF uT argsT
   7.228  	have "\<exists>ts'. \<forall>j. Var j \<degree>\<degree> map (\<lambda>t. t[u/i]) ts \<rightarrow>\<^sub>\<beta>\<^sup>* Var j \<degree>\<degree> ts' \<and>
   7.229 -	  Var j \<degree>\<degree> ts' \<in> NF" (is "\<exists>ts'. ?ex ts'")
   7.230 +	  NF (Var j \<degree>\<degree> ts')" (is "\<exists>ts'. ?ex ts'")
   7.231  	  by (rule norm_list [of "\<lambda>t. t", simplified])
   7.232  	then obtain ts' where NF: "?ex ts'" ..
   7.233  	from nat_le_dec show ?thesis
   7.234 @@ -348,31 +347,22 @@
   7.235        case (Abs r e_ T'_ u_ i_)
   7.236        assume absT: "e\<langle>i:T\<rangle> \<turnstile> Abs r : T'"
   7.237        then obtain R S where "e\<langle>0:R\<rangle>\<langle>Suc i:T\<rangle>  \<turnstile> r : S" by (rule abs_typeE) simp
   7.238 -      moreover have "lift u 0 \<in> NF" by (rule lift_NF)
   7.239 +      moreover have "NF (lift u 0)" by (rule lift_NF)
   7.240        moreover have "e\<langle>0:R\<rangle> \<turnstile> lift u 0 : T" by (rule lift_type)
   7.241 -      ultimately have "\<exists>t'. r[lift u 0/Suc i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> t' \<in> NF" by (rule Abs)
   7.242 -      thus "\<exists>t'. Abs r[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> t' \<in> NF"
   7.243 +      ultimately have "\<exists>t'. r[lift u 0/Suc i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" by (rule Abs)
   7.244 +      thus "\<exists>t'. Abs r[u/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
   7.245  	by simp (iprover intro: rtrancl_beta_Abs NF.Abs)
   7.246      }
   7.247    qed
   7.248  qed
   7.249  
   7.250  
   7.251 -consts -- {* A computationally relevant copy of @{term "e \<turnstile> t : T"} *}
   7.252 -  rtyping :: "((nat \<Rightarrow> type) \<times> dB \<times> type) set"
   7.253 -
   7.254 -abbreviation
   7.255 -  rtyping_rel :: "(nat \<Rightarrow> type) \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ |-\<^sub>R _ : _" [50, 50, 50] 50) where
   7.256 -  "e |-\<^sub>R t : T == (e, t, T) \<in> rtyping"
   7.257 -
   7.258 -notation (xsymbols)
   7.259 -  rtyping_rel  ("_ \<turnstile>\<^sub>R _ : _" [50, 50, 50] 50)
   7.260 -
   7.261 -inductive rtyping
   7.262 -  intros
   7.263 +-- {* A computationally relevant copy of @{term "e \<turnstile> t : T"} *}
   7.264 +inductive2 rtyping :: "(nat \<Rightarrow> type) \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile>\<^sub>R _ : _" [50, 50, 50] 50)
   7.265 +  where
   7.266      Var: "e x = T \<Longrightarrow> e \<turnstile>\<^sub>R Var x : T"
   7.267 -    Abs: "e\<langle>0:T\<rangle> \<turnstile>\<^sub>R t : U \<Longrightarrow> e \<turnstile>\<^sub>R Abs t : (T \<Rightarrow> U)"
   7.268 -    App: "e \<turnstile>\<^sub>R s : T \<Rightarrow> U \<Longrightarrow> e \<turnstile>\<^sub>R t : T \<Longrightarrow> e \<turnstile>\<^sub>R (s \<degree> t) : U"
   7.269 +  | Abs: "e\<langle>0:T\<rangle> \<turnstile>\<^sub>R t : U \<Longrightarrow> e \<turnstile>\<^sub>R Abs t : (T \<Rightarrow> U)"
   7.270 +  | App: "e \<turnstile>\<^sub>R s : T \<Rightarrow> U \<Longrightarrow> e \<turnstile>\<^sub>R t : T \<Longrightarrow> e \<turnstile>\<^sub>R (s \<degree> t) : U"
   7.271  
   7.272  lemma rtyping_imp_typing: "e \<turnstile>\<^sub>R t : T \<Longrightarrow> e \<turnstile> t : T"
   7.273    apply (induct set: rtyping)
   7.274 @@ -385,7 +375,7 @@
   7.275  
   7.276  theorem type_NF:
   7.277    assumes "e \<turnstile>\<^sub>R t : T"
   7.278 -  shows "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> t' \<in> NF" using prems
   7.279 +  shows "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" using prems
   7.280  proof induct
   7.281    case Var
   7.282    show ?case by (iprover intro: Var_NF)
   7.283 @@ -393,16 +383,16 @@
   7.284    case Abs
   7.285    thus ?case by (iprover intro: rtrancl_beta_Abs NF.Abs)
   7.286  next
   7.287 -  case (App T U e s t)
   7.288 +  case (App e s T U t)
   7.289    from App obtain s' t' where
   7.290 -    sred: "s \<rightarrow>\<^sub>\<beta>\<^sup>* s'" and sNF: "s' \<in> NF"
   7.291 -    and tred: "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and tNF: "t' \<in> NF" by iprover
   7.292 -  have "\<exists>u. (Var 0 \<degree> lift t' 0)[s'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* u \<and> u \<in> NF"
   7.293 +    sred: "s \<rightarrow>\<^sub>\<beta>\<^sup>* s'" and sNF: "NF s'"
   7.294 +    and tred: "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and tNF: "NF t'" by iprover
   7.295 +  have "\<exists>u. (Var 0 \<degree> lift t' 0)[s'/0] \<rightarrow>\<^sub>\<beta>\<^sup>* u \<and> NF u"
   7.296    proof (rule subst_type_NF)
   7.297 -    have "lift t' 0 \<in> NF" by (rule lift_NF)
   7.298 -    hence "listall (\<lambda>t. t \<in> NF) [lift t' 0]" by (rule listall_cons) (rule listall_nil)
   7.299 -    hence "Var 0 \<degree>\<degree> [lift t' 0] \<in> NF" by (rule NF.App)
   7.300 -    thus "Var 0 \<degree> lift t' 0 \<in> NF" by simp
   7.301 +    have "NF (lift t' 0)" by (rule lift_NF)
   7.302 +    hence "listall NF [lift t' 0]" by (rule listall_cons) (rule listall_nil)
   7.303 +    hence "NF (Var 0 \<degree>\<degree> [lift t' 0])" by (rule NF.App)
   7.304 +    thus "NF (Var 0 \<degree> lift t' 0)" by simp
   7.305      show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 \<degree> lift t' 0 : U"
   7.306      proof (rule typing.App)
   7.307        show "e\<langle>0:T \<Rightarrow> U\<rangle> \<turnstile> Var 0 : T \<Rightarrow> U"
   7.308 @@ -415,9 +405,9 @@
   7.309      from sred show "e \<turnstile> s' : T \<Rightarrow> U"
   7.310        by (rule subject_reduction') (rule rtyping_imp_typing)
   7.311    qed
   7.312 -  then obtain u where ured: "s' \<degree> t' \<rightarrow>\<^sub>\<beta>\<^sup>* u" and unf: "u \<in> NF" by simp iprover
   7.313 +  then obtain u where ured: "s' \<degree> t' \<rightarrow>\<^sub>\<beta>\<^sup>* u" and unf: "NF u" by simp iprover
   7.314    from sred tred have "s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'" by (rule rtrancl_beta_App)
   7.315 -  hence "s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using ured by (rule rtrancl_trans)
   7.316 +  hence "s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using ured by (rule rtrancl_trans')
   7.317    with unf show ?case by iprover
   7.318  qed
   7.319  
   7.320 @@ -427,23 +417,23 @@
   7.321  declare NF.induct [ind_realizer]
   7.322  declare rtrancl.induct [ind_realizer irrelevant]
   7.323  declare rtyping.induct [ind_realizer]
   7.324 -lemmas [extraction_expand] = trans_def conj_assoc listall_cons_eq
   7.325 +lemmas [extraction_expand] = conj_assoc listall_cons_eq
   7.326  
   7.327  extract type_NF
   7.328  
   7.329 -lemma rtranclR_rtrancl_eq: "((a, b) \<in> rtranclR r) = ((a, b) \<in> rtrancl (Collect r))"
   7.330 +lemma rtranclR_rtrancl_eq: "rtranclR r a b = rtrancl r a b"
   7.331    apply (rule iffI)
   7.332    apply (erule rtranclR.induct)
   7.333 -  apply (rule rtrancl_refl)
   7.334 -  apply (erule rtrancl_into_rtrancl)
   7.335 -  apply (erule CollectI)
   7.336 +  apply (rule rtrancl.rtrancl_refl)
   7.337 +  apply (erule rtrancl.rtrancl_into_rtrancl)
   7.338 +  apply assumption
   7.339    apply (erule rtrancl.induct)
   7.340    apply (rule rtranclR.rtrancl_refl)
   7.341    apply (erule rtranclR.rtrancl_into_rtrancl)
   7.342 -  apply (erule CollectD)
   7.343 +  apply assumption
   7.344    done
   7.345  
   7.346 -lemma NFR_imp_NF: "(nf, t) \<in> NFR \<Longrightarrow> t \<in> NF"
   7.347 +lemma NFR_imp_NF: "NFR nf t \<Longrightarrow> NF t"
   7.348    apply (erule NFR.induct)
   7.349    apply (rule NF.intros)
   7.350    apply (simp add: listall_def)
     8.1 --- a/src/HOL/MicroJava/BV/BVExample.thy	Wed Feb 07 17:41:11 2007 +0100
     8.2 +++ b/src/HOL/MicroJava/BV/BVExample.thy	Wed Feb 07 17:44:07 2007 +0100
     8.3 @@ -65,27 +65,27 @@
     8.4  
     8.5  text {* The subclass releation spelled out: *}
     8.6  lemma subcls1:
     8.7 -  "subcls1 E = {(list_name,Object), (test_name,Object), (Xcpt NullPointer, Object),
     8.8 +  "subcls1 E = member2 {(list_name,Object), (test_name,Object), (Xcpt NullPointer, Object),
     8.9                  (Xcpt ClassCast, Object), (Xcpt OutOfMemory, Object)}"
    8.10    apply (simp add: subcls1_def2)
    8.11    apply (simp add: name_defs class_defs system_defs E_def class_def)
    8.12 -  apply (auto split: split_if_asm)
    8.13 +  apply (auto simp: member2_inject split: split_if_asm)
    8.14    done
    8.15  
    8.16  text {* The subclass relation is acyclic; hence its converse is well founded: *}
    8.17  lemma notin_rtrancl:
    8.18 -  "(a,b) \<in> r\<^sup>* \<Longrightarrow> a \<noteq> b \<Longrightarrow> (\<And>y. (a,y) \<notin> r) \<Longrightarrow> False"
    8.19 -  by (auto elim: converse_rtranclE)  
    8.20 +  "r\<^sup>*\<^sup>* a b \<Longrightarrow> a \<noteq> b \<Longrightarrow> (\<And>y. \<not> r a y) \<Longrightarrow> False"
    8.21 +  by (auto elim: converse_rtranclE')
    8.22  
    8.23 -lemma acyclic_subcls1_E: "acyclic (subcls1 E)"
    8.24 -  apply (rule acyclicI)
    8.25 +lemma acyclic_subcls1_E: "acyclicP (subcls1 E)"
    8.26 +  apply (rule acyclicI [to_pred])
    8.27    apply (simp add: subcls1)
    8.28 -  apply (auto dest!: tranclD)
    8.29 +  apply (auto dest!: tranclD')
    8.30    apply (auto elim!: notin_rtrancl simp add: name_defs distinct_classes)
    8.31    done
    8.32  
    8.33 -lemma wf_subcls1_E: "wf ((subcls1 E)\<inverse>)"
    8.34 -  apply (rule finite_acyclic_wf_converse)
    8.35 +lemma wf_subcls1_E: "wfP ((subcls1 E)\<inverse>\<inverse>)"
    8.36 +  apply (rule finite_acyclic_wf_converse [to_pred])
    8.37    apply (simp add: subcls1)
    8.38    apply (rule acyclic_subcls1_E)
    8.39    done  
    8.40 @@ -431,8 +431,6 @@
    8.41    apply simp+
    8.42    done
    8.43  
    8.44 -lemmas [code] = lessThan_0 lessThan_Suc
    8.45 -
    8.46  constdefs
    8.47    some_elem :: "'a set \<Rightarrow> 'a"
    8.48    "some_elem == (%S. SOME x. x : S)"
    8.49 @@ -464,7 +462,7 @@
    8.50    meta_eq_to_obj_eq [OF JType.sup_def [unfolded exec_lub_def]]
    8.51    meta_eq_to_obj_eq [OF JVM_le_unfold]
    8.52  
    8.53 -lemmas [code ind] = rtrancl_refl converse_rtrancl_into_rtrancl
    8.54 +lemmas [code ind] = rtrancl.rtrancl_refl converse_rtrancl_into_rtrancl'
    8.55  
    8.56  code_module BV
    8.57  contains
     9.1 --- a/src/HOL/MicroJava/BV/BVNoTypeError.thy	Wed Feb 07 17:41:11 2007 +0100
     9.2 +++ b/src/HOL/MicroJava/BV/BVNoTypeError.thy	Wed Feb 07 17:44:07 2007 +0100
     9.3 @@ -190,7 +190,7 @@
     9.4  lemma isIntgI [intro, simp]: "G,hp \<turnstile> v ::\<preceq> PrimT Integer \<Longrightarrow> isIntg v"
     9.5    apply (unfold conf_def)
     9.6    apply auto
     9.7 -  apply (erule widen.elims)
     9.8 +  apply (erule widen.cases)
     9.9    apply auto
    9.10    apply (cases v)
    9.11    apply auto
    9.12 @@ -322,7 +322,7 @@
    9.13        obtain apTs X ST' where
    9.14          ST: "ST = rev apTs @ X # ST'" and
    9.15          ps: "length apTs = length ps" and
    9.16 -        w:   "\<forall>x\<in>set (zip apTs ps). x \<in> widen G" and
    9.17 +        w:   "\<forall>(x, y)\<in>set (zip apTs ps). G \<turnstile> x \<preceq> y" and
    9.18          C:   "G \<turnstile> X \<preceq> Class C" and
    9.19          mth: "method (G, C) (mn, ps) \<noteq> None"
    9.20          by (simp del: app'.simps) blast
    10.1 --- a/src/HOL/MicroJava/BV/BVSpecTypeSafe.thy	Wed Feb 07 17:41:11 2007 +0100
    10.2 +++ b/src/HOL/MicroJava/BV/BVSpecTypeSafe.thy	Wed Feb 07 17:44:07 2007 +0100
    10.3 @@ -91,7 +91,7 @@
    10.4      from False C
    10.5      have "\<not> match_exception_entry G C pc e"
    10.6        by - (erule contrapos_nn, 
    10.7 -            auto simp add: match_exception_entry_def elim: rtrancl_trans)
    10.8 +            auto simp add: match_exception_entry_def)
    10.9      with m
   10.10      have "match_exception_table G C pc (e#es) = Some pc'" by simp
   10.11      moreover note C
   10.12 @@ -640,7 +640,7 @@
   10.13   apply (simp add: null)
   10.14  apply (clarsimp simp add: conf_def obj_ty_def)
   10.15  apply (cases v)
   10.16 -apply (auto intro: rtrancl_trans)
   10.17 +apply auto
   10.18  done
   10.19  
   10.20  lemmas defs2 = defs1 raise_system_xcpt_def
   10.21 @@ -838,7 +838,7 @@
   10.22      s:  "s = (rev apTs @ X # ST, LT)" and
   10.23      l:  "length apTs = length pTs" and
   10.24      X:  "G\<turnstile> X \<preceq> Class C'" and
   10.25 -    w:  "\<forall>x\<in>set (zip apTs pTs). x \<in> widen G" and
   10.26 +    w:  "\<forall>(x, y)\<in>set (zip apTs pTs). G \<turnstile> x \<preceq> y" and
   10.27      mC':"method (G, C') (mn, pTs) = Some (D', rT, body)" and
   10.28      pc: "Suc pc < length ins" and
   10.29      eff: "G \<turnstile> norm_eff (Invoke C' mn pTs) G (Some s) <=' phi C sig!Suc pc"
    11.1 --- a/src/HOL/MicroJava/BV/Correct.thy	Wed Feb 07 17:41:11 2007 +0100
    11.2 +++ b/src/HOL/MicroJava/BV/Correct.thy	Wed Feb 07 17:44:07 2007 +0100
    11.3 @@ -224,7 +224,7 @@
    11.4    by (simp add: list_all2_append2 approx_stk_def approx_loc_def)
    11.5  
    11.6  lemma approx_stk_all_widen:
    11.7 -  "\<lbrakk> approx_stk G hp stk ST; \<forall>x \<in> set (zip ST ST'). x \<in> widen G; length ST = length ST'; wf_prog wt G \<rbrakk> 
    11.8 +  "\<lbrakk> approx_stk G hp stk ST; \<forall>(x, y) \<in> set (zip ST ST'). G \<turnstile> x \<preceq> y; length ST = length ST'; wf_prog wt G \<rbrakk> 
    11.9    \<Longrightarrow> approx_stk G hp stk ST'"
   11.10  apply (unfold approx_stk_def)
   11.11  apply (clarsimp simp add: approx_loc_conv_all_nth all_set_conv_all_nth)
    12.1 --- a/src/HOL/MicroJava/BV/EffectMono.thy	Wed Feb 07 17:41:11 2007 +0100
    12.2 +++ b/src/HOL/MicroJava/BV/EffectMono.thy	Wed Feb 07 17:44:07 2007 +0100
    12.3 @@ -10,7 +10,7 @@
    12.4  
    12.5  
    12.6  lemma PrimT_PrimT: "(G \<turnstile> xb \<preceq> PrimT p) = (xb = PrimT p)"
    12.7 -  by (auto elim: widen.elims)
    12.8 +  by (auto elim: widen.cases)
    12.9  
   12.10  
   12.11  lemma sup_loc_some [rule_format]:
   12.12 @@ -42,7 +42,7 @@
   12.13  
   12.14  lemma all_widen_is_sup_loc:
   12.15  "\<forall>b. length a = length b \<longrightarrow> 
   12.16 -     (\<forall>x\<in>set (zip a b). x \<in> widen G) = (G \<turnstile> (map OK a) <=l (map OK b))" 
   12.17 +     (\<forall>(x, y)\<in>set (zip a b). G \<turnstile> x \<preceq> y) = (G \<turnstile> (map OK a) <=l (map OK b))" 
   12.18   (is "\<forall>b. length a = length b \<longrightarrow> ?Q a b" is "?P a")
   12.19  proof (induct "a")
   12.20    show "?P []" by simp
   12.21 @@ -219,7 +219,7 @@
   12.22          l:  "length apTs = length list" and
   12.23          c:  "is_class G cname" and
   12.24          C:  "G \<turnstile> X \<preceq> Class cname" and
   12.25 -        w:  "\<forall>x \<in> set (zip apTs list). x \<in> widen G" and
   12.26 +        w:  "\<forall>(x, y) \<in> set (zip apTs list). G \<turnstile> x \<preceq> y" and
   12.27          m:  "method (G, cname) (mname, list) = Some (mD', rT', b')" and
   12.28          x:  "\<forall>C \<in> set (match_any G pc et). is_class G C"
   12.29          by (simp del: not_None_eq, elim exE conjE) (rule that)
   12.30 @@ -261,7 +261,7 @@
   12.31        have "G \<turnstile> map OK apTs' <=l map OK list" .
   12.32  
   12.33        with l'
   12.34 -      have w': "\<forall>x \<in> set (zip apTs' list). x \<in> widen G"
   12.35 +      have w': "\<forall>(x, y) \<in> set (zip apTs' list). G \<turnstile> x \<preceq> y"
   12.36          by (simp add: all_widen_is_sup_loc)
   12.37  
   12.38        from Invoke s2 l' w' C' m c x
    13.1 --- a/src/HOL/MicroJava/BV/Err.thy	Wed Feb 07 17:41:11 2007 +0100
    13.2 +++ b/src/HOL/MicroJava/BV/Err.thy	Wed Feb 07 17:44:07 2007 +0100
    13.3 @@ -155,7 +155,7 @@
    13.4  
    13.5  lemma acc_err [simp, intro!]:  "acc r \<Longrightarrow> acc(le r)"
    13.6  apply (unfold acc_def lesub_def le_def lesssub_def)
    13.7 -apply (simp add: wf_eq_minimal split: err.split)
    13.8 +apply (simp add: wfP_eq_minimal split: err.split)
    13.9  apply clarify
   13.10  apply (case_tac "Err : Q")
   13.11   apply blast
    14.1 --- a/src/HOL/MicroJava/BV/JType.thy	Wed Feb 07 17:41:11 2007 +0100
    14.2 +++ b/src/HOL/MicroJava/BV/JType.thy	Wed Feb 07 17:44:07 2007 +0100
    14.3 @@ -13,7 +13,7 @@
    14.4    "super G C == fst (the (class G C))"
    14.5  
    14.6  lemma superI:
    14.7 -  "(C,D) \<in> subcls1 G \<Longrightarrow> super G C = D"
    14.8 +  "G \<turnstile> C \<prec>C1 D \<Longrightarrow> super G C = D"
    14.9    by (unfold super_def) (auto dest: subcls1D)
   14.10  
   14.11  constdefs
   14.12 @@ -34,7 +34,7 @@
   14.13  
   14.14    is_ty :: "'c prog \<Rightarrow> ty \<Rightarrow> bool"
   14.15    "is_ty G T == case T of PrimT P \<Rightarrow> True | RefT R \<Rightarrow>
   14.16 -               (case R of NullT \<Rightarrow> True | ClassT C \<Rightarrow> (C,Object):(subcls1 G)^*)"
   14.17 +               (case R of NullT \<Rightarrow> True | ClassT C \<Rightarrow> (subcls1 G)^** C Object)"
   14.18  
   14.19  
   14.20  translations
   14.21 @@ -45,10 +45,10 @@
   14.22    "esl G == (types G, subtype G, sup G)"
   14.23  
   14.24  lemma PrimT_PrimT: "(G \<turnstile> xb \<preceq> PrimT p) = (xb = PrimT p)"
   14.25 -  by (auto elim: widen.elims)
   14.26 +  by (auto elim: widen.cases)
   14.27  
   14.28  lemma PrimT_PrimT2: "(G \<turnstile> PrimT p \<preceq> xb) = (xb = PrimT p)"
   14.29 -  by (auto elim: widen.elims)
   14.30 +  by (auto elim: widen.cases)
   14.31  
   14.32  lemma is_tyI:
   14.33    "\<lbrakk> is_type G T; ws_prog G \<rbrakk> \<Longrightarrow> is_ty G T"
   14.34 @@ -77,8 +77,8 @@
   14.35      from R wf ty
   14.36      have "R \<noteq> ClassT Object \<Longrightarrow> ?thesis"
   14.37       by (auto simp add: is_ty_def is_class_def split_tupled_all
   14.38 -               elim!: subcls1.elims
   14.39 -               elim: converse_rtranclE
   14.40 +               elim!: subcls1.cases
   14.41 +               elim: converse_rtranclE'
   14.42                 split: ref_ty.splits)
   14.43      ultimately    
   14.44      show ?thesis by blast
   14.45 @@ -86,7 +86,7 @@
   14.46  qed
   14.47  
   14.48  lemma order_widen:
   14.49 -  "acyclic (subcls1 G) \<Longrightarrow> order (subtype G)"
   14.50 +  "acyclicP (subcls1 G) \<Longrightarrow> order (subtype G)"
   14.51    apply (unfold Semilat.order_def lesub_def subtype_def)
   14.52    apply (auto intro: widen_trans)
   14.53    apply (case_tac x)
   14.54 @@ -102,16 +102,16 @@
   14.55    apply (case_tac ref_tya)
   14.56     apply simp
   14.57    apply simp
   14.58 -  apply (auto dest: acyclic_impl_antisym_rtrancl antisymD)  
   14.59 +  apply (auto dest: acyclic_impl_antisym_rtrancl [to_pred] antisymD)
   14.60    done
   14.61  
   14.62  lemma wf_converse_subcls1_impl_acc_subtype:
   14.63 -  "wf ((subcls1 G)^-1) \<Longrightarrow> acc (subtype G)"
   14.64 -apply (unfold acc_def lesssub_def)
   14.65 -apply (drule_tac p = "(subcls1 G)^-1 - Id" in wf_subset)
   14.66 - apply blast
   14.67 -apply (drule wf_trancl)
   14.68 -apply (simp add: wf_eq_minimal)
   14.69 +  "wfP ((subcls1 G)^--1) \<Longrightarrow> acc (subtype G)"
   14.70 +apply (unfold Semilat.acc_def lesssub_def)
   14.71 +apply (drule_tac p = "meet ((subcls1 G)^--1) op \<noteq>" in wfP_subset)
   14.72 + apply auto
   14.73 +apply (drule wfP_trancl)
   14.74 +apply (simp add: wfP_eq_minimal)
   14.75  apply clarify
   14.76  apply (unfold lesub_def subtype_def)
   14.77  apply (rename_tac M T) 
   14.78 @@ -146,20 +146,20 @@
   14.79  apply (case_tac t)
   14.80   apply simp
   14.81  apply simp
   14.82 -apply (insert rtrancl_r_diff_Id [symmetric, standard, of "(subcls1 G)"])
   14.83 +apply (insert rtrancl_r_diff_Id' [symmetric, standard, of "subcls1 G"])
   14.84  apply simp
   14.85 -apply (erule rtranclE)
   14.86 +apply (erule rtrancl.cases)
   14.87   apply blast
   14.88 -apply (drule rtrancl_converseI)
   14.89 -apply (subgoal_tac "((subcls1 G)-Id)^-1 = ((subcls1 G)^-1 - Id)")
   14.90 +apply (drule rtrancl_converseI')
   14.91 +apply (subgoal_tac "(meet (subcls1 G) op \<noteq>)^--1 = (meet ((subcls1 G)^--1) op \<noteq>)")
   14.92   prefer 2
   14.93 - apply blast
   14.94 -apply simp 
   14.95 -apply (blast intro: rtrancl_into_trancl2)
   14.96 + apply (simp add: converse_meet)
   14.97 +apply simp
   14.98 +apply (blast intro: rtrancl_into_trancl2')
   14.99  done 
  14.100  
  14.101  lemma closed_err_types:
  14.102 -  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G) \<rbrakk> 
  14.103 +  "\<lbrakk> ws_prog G; single_valuedP (subcls1 G); acyclicP (subcls1 G) \<rbrakk> 
  14.104    \<Longrightarrow> closed (err (types G)) (lift2 (sup G))"
  14.105    apply (unfold closed_def plussub_def lift2_def sup_def)
  14.106    apply (auto split: err.split)
  14.107 @@ -171,13 +171,13 @@
  14.108  
  14.109  
  14.110  lemma sup_subtype_greater:
  14.111 -  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G);
  14.112 +  "\<lbrakk> ws_prog G; single_valuedP (subcls1 G); acyclicP (subcls1 G);
  14.113        is_type G t1; is_type G t2; sup G t1 t2 = OK s \<rbrakk> 
  14.114    \<Longrightarrow> subtype G t1 s \<and> subtype G t2 s"
  14.115  proof -
  14.116    assume ws_prog:       "ws_prog G"
  14.117 -  assume single_valued: "single_valued (subcls1 G)" 
  14.118 -  assume acyclic:       "acyclic (subcls1 G)"
  14.119 +  assume single_valued: "single_valuedP (subcls1 G)"
  14.120 +  assume acyclic:       "acyclicP (subcls1 G)"
  14.121   
  14.122    { fix c1 c2
  14.123      assume is_class: "is_class G c1" "is_class G c2"
  14.124 @@ -188,12 +188,12 @@
  14.125        by (blast intro: subcls_C_Object)
  14.126      with ws_prog single_valued
  14.127      obtain u where
  14.128 -      "is_lub ((subcls1 G)^* ) c1 c2 u"      
  14.129 +      "is_lub ((subcls1 G)^** ) c1 c2 u"
  14.130        by (blast dest: single_valued_has_lubs)
  14.131      moreover
  14.132      note acyclic
  14.133      moreover
  14.134 -    have "\<forall>x y. (x, y) \<in> subcls1 G \<longrightarrow> super G x = y"
  14.135 +    have "\<forall>x y. G \<turnstile> x \<prec>C1 y \<longrightarrow> super G x = y"
  14.136        by (blast intro: superI)
  14.137      ultimately
  14.138      have "G \<turnstile> c1 \<preceq>C exec_lub (subcls1 G) (super G) c1 c2 \<and>
  14.139 @@ -210,14 +210,14 @@
  14.140  qed
  14.141  
  14.142  lemma sup_subtype_smallest:
  14.143 -  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G);
  14.144 +  "\<lbrakk> ws_prog G; single_valuedP (subcls1 G); acyclicP (subcls1 G);
  14.145        is_type G a; is_type G b; is_type G c; 
  14.146        subtype G a c; subtype G b c; sup G a b = OK d \<rbrakk>
  14.147    \<Longrightarrow> subtype G d c"
  14.148  proof -
  14.149    assume ws_prog:       "ws_prog G"
  14.150 -  assume single_valued: "single_valued (subcls1 G)" 
  14.151 -  assume acyclic:       "acyclic (subcls1 G)"
  14.152 +  assume single_valued: "single_valuedP (subcls1 G)"
  14.153 +  assume acyclic:       "acyclicP (subcls1 G)"
  14.154  
  14.155    { fix c1 c2 D
  14.156      assume is_class: "is_class G c1" "is_class G c2"
  14.157 @@ -229,7 +229,7 @@
  14.158        by (blast intro: subcls_C_Object)
  14.159      with ws_prog single_valued
  14.160      obtain u where
  14.161 -      lub: "is_lub ((subcls1 G)^* ) c1 c2 u"
  14.162 +      lub: "is_lub ((subcls1 G)^** ) c1 c2 u"
  14.163        by (blast dest: single_valued_has_lubs)   
  14.164      with acyclic
  14.165      have "exec_lub (subcls1 G) (super G) c1 c2 = u"
  14.166 @@ -260,12 +260,12 @@
  14.167             split: ty.splits ref_ty.splits)
  14.168  
  14.169  lemma err_semilat_JType_esl_lemma:
  14.170 -  "\<lbrakk> ws_prog G; single_valued (subcls1 G); acyclic (subcls1 G) \<rbrakk> 
  14.171 +  "\<lbrakk> ws_prog G; single_valuedP (subcls1 G); acyclicP (subcls1 G) \<rbrakk> 
  14.172    \<Longrightarrow> err_semilat (esl G)"
  14.173  proof -
  14.174    assume ws_prog:   "ws_prog G"
  14.175 -  assume single_valued: "single_valued (subcls1 G)" 
  14.176 -  assume acyclic:   "acyclic (subcls1 G)"
  14.177 +  assume single_valued: "single_valuedP (subcls1 G)"
  14.178 +  assume acyclic:   "acyclicP (subcls1 G)"
  14.179    
  14.180    hence "order (subtype G)"
  14.181      by (rule order_widen)
  14.182 @@ -297,9 +297,9 @@
  14.183  qed
  14.184  
  14.185  lemma single_valued_subcls1:
  14.186 -  "ws_prog G \<Longrightarrow> single_valued (subcls1 G)"
  14.187 +  "ws_prog G \<Longrightarrow> single_valuedP (subcls1 G)"
  14.188    by (auto simp add: ws_prog_def unique_def single_valued_def
  14.189 -    intro: subcls1I elim!: subcls1.elims)
  14.190 +    intro: subcls1I elim!: subcls1.cases)
  14.191  
  14.192  theorem err_semilat_JType_esl:
  14.193    "ws_prog G \<Longrightarrow> err_semilat (esl G)"
    15.1 --- a/src/HOL/MicroJava/BV/JVM.thy	Wed Feb 07 17:41:11 2007 +0100
    15.2 +++ b/src/HOL/MicroJava/BV/JVM.thy	Wed Feb 07 17:44:07 2007 +0100
    15.3 @@ -40,7 +40,7 @@
    15.4  	 simp add: symmetric sl_triple_conv)
    15.5        apply (simp (no_asm) add: JVM_le_unfold)
    15.6        apply (blast intro!: order_widen wf_converse_subcls1_impl_acc_subtype
    15.7 -                   dest: wf_subcls1 wf_acyclic wf_prog_ws_prog)
    15.8 +                   dest: wf_subcls1 wfP_acyclicP wf_prog_ws_prog)
    15.9       apply (simp add: JVM_le_unfold)
   15.10      apply (erule exec_pres_type)
   15.11     apply assumption
    16.1 --- a/src/HOL/MicroJava/BV/JVMType.thy	Wed Feb 07 17:41:11 2007 +0100
    16.2 +++ b/src/HOL/MicroJava/BV/JVMType.thy	Wed Feb 07 17:44:07 2007 +0100
    16.3 @@ -193,7 +193,7 @@
    16.4  
    16.5  lemma widen_PrimT_conv1 [simp]:
    16.6    "\<lbrakk> G \<turnstile> S \<preceq> T; S = PrimT x\<rbrakk> \<Longrightarrow> T = PrimT x"
    16.7 -  by (auto elim: widen.elims)
    16.8 +  by (auto elim: widen.cases)
    16.9  
   16.10  theorem sup_PTS_eq:
   16.11    "(G \<turnstile> OK (PrimT p) <=o X) = (X=Err \<or> X = OK (PrimT p))"
    17.1 --- a/src/HOL/MicroJava/BV/Kildall.thy	Wed Feb 07 17:41:11 2007 +0100
    17.2 +++ b/src/HOL/MicroJava/BV/Kildall.thy	Wed Feb 07 17:44:07 2007 +0100
    17.3 @@ -402,7 +402,7 @@
    17.4  -- "Well-foundedness of the termination relation:"
    17.5  apply (rule wf_lex_prod)
    17.6   apply (insert orderI [THEN acc_le_listI])
    17.7 - apply (simp only: acc_def lesssub_def)
    17.8 + apply (simp add: acc_def lesssub_def wfP_wf_eq [symmetric])
    17.9  apply (rule wf_finite_psubset) 
   17.10  
   17.11  -- "Loop decreases along termination relation:"
    18.1 --- a/src/HOL/MicroJava/BV/Listn.thy	Wed Feb 07 17:41:11 2007 +0100
    18.2 +++ b/src/HOL/MicroJava/BV/Listn.thy	Wed Feb 07 17:44:07 2007 +0100
    18.3 @@ -321,22 +321,22 @@
    18.4    "\<lbrakk> order r; acc r \<rbrakk> \<Longrightarrow> acc(Listn.le r)"
    18.5  apply (unfold acc_def)
    18.6  apply (subgoal_tac
    18.7 - "wf(UN n. {(ys,xs). size xs = n & size ys = n & xs <_(Listn.le r) ys})")
    18.8 - apply (erule wf_subset)
    18.9 + "wfP (SUP n. (\<lambda>ys xs. size xs = n & size ys = n & xs <_(Listn.le r) ys))")
   18.10 + apply (erule wfP_subset)
   18.11   apply (blast intro: lesssub_list_impl_same_size)
   18.12 -apply (rule wf_UN)
   18.13 +apply (rule wfP_SUP)
   18.14   prefer 2
   18.15   apply clarify
   18.16   apply (rename_tac m n)
   18.17   apply (case_tac "m=n")
   18.18    apply simp
   18.19 - apply (fast intro!: equals0I dest: not_sym)
   18.20 + apply (fast intro!: equals0I [to_pred] dest: not_sym)
   18.21  apply clarify
   18.22  apply (rename_tac n)
   18.23  apply (induct_tac n)
   18.24   apply (simp add: lesssub_def cong: conj_cong)
   18.25  apply (rename_tac k)
   18.26 -apply (simp add: wf_eq_minimal)
   18.27 +apply (simp add: wfP_eq_minimal)
   18.28  apply (simp (no_asm) add: length_Suc_conv cong: conj_cong)
   18.29  apply clarify
   18.30  apply (rename_tac M m)
    19.1 --- a/src/HOL/MicroJava/BV/Opt.thy	Wed Feb 07 17:41:11 2007 +0100
    19.2 +++ b/src/HOL/MicroJava/BV/Opt.thy	Wed Feb 07 17:44:07 2007 +0100
    19.3 @@ -272,7 +272,7 @@
    19.4  lemma acc_le_optI [intro!]:
    19.5    "acc r \<Longrightarrow> acc(le r)"
    19.6  apply (unfold acc_def lesub_def le_def lesssub_def)
    19.7 -apply (simp add: wf_eq_minimal split: option.split)
    19.8 +apply (simp add: wfP_eq_minimal split: option.split)
    19.9  apply clarify
   19.10  apply (case_tac "? a. Some a : Q")
   19.11   apply (erule_tac x = "{a . Some a : Q}" in allE)
    20.1 --- a/src/HOL/MicroJava/BV/Product.thy	Wed Feb 07 17:41:11 2007 +0100
    20.2 +++ b/src/HOL/MicroJava/BV/Product.thy	Wed Feb 07 17:44:07 2007 +0100
    20.3 @@ -51,8 +51,8 @@
    20.4  lemma acc_le_prodI [intro!]:
    20.5    "\<lbrakk> acc rA; acc rB \<rbrakk> \<Longrightarrow> acc(Product.le rA rB)"
    20.6  apply (unfold acc_def)
    20.7 -apply (rule wf_subset)
    20.8 - apply (erule wf_lex_prod)
    20.9 +apply (rule wfP_subset)
   20.10 + apply (erule wf_lex_prod [to_pred, THEN wfP_wf_eq [THEN iffD2]])
   20.11   apply assumption
   20.12  apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
   20.13  done
    21.1 --- a/src/HOL/MicroJava/BV/Semilat.thy	Wed Feb 07 17:41:11 2007 +0100
    21.2 +++ b/src/HOL/MicroJava/BV/Semilat.thy	Wed Feb 07 17:44:07 2007 +0100
    21.3 @@ -40,16 +40,13 @@
    21.4  
    21.5  
    21.6  constdefs
    21.7 - ord :: "('a*'a)set \<Rightarrow> 'a ord"
    21.8 -"ord r == %x y. (x,y):r"
    21.9 -
   21.10   order :: "'a ord \<Rightarrow> bool"
   21.11  "order r == (!x. x <=_r x) &
   21.12              (!x y. x <=_r y & y <=_r x \<longrightarrow> x=y) &
   21.13              (!x y z. x <=_r y & y <=_r z \<longrightarrow> x <=_r z)"
   21.14  
   21.15   acc :: "'a ord \<Rightarrow> bool"
   21.16 -"acc r == wf{(y,x) . x <_r y}"
   21.17 +"acc r == wfP (\<lambda>y x. x <_r y)"
   21.18  
   21.19   top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
   21.20  "top r T == !x. x <=_r T"
   21.21 @@ -63,13 +60,13 @@
   21.22                  (!x:A. !y:A. y <=_r x +_f y)  &
   21.23                  (!x:A. !y:A. !z:A. x <=_r z & y <=_r z \<longrightarrow> x +_f y <=_r z)"
   21.24  
   21.25 - is_ub :: "('a*'a)set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   21.26 -"is_ub r x y u == (x,u):r & (y,u):r"
   21.27 + is_ub :: "'a ord \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   21.28 +"is_ub r x y u == r x u & r y u"
   21.29  
   21.30 - is_lub :: "('a*'a)set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   21.31 -"is_lub r x y u == is_ub r x y u & (!z. is_ub r x y z \<longrightarrow> (u,z):r)"
   21.32 + is_lub :: "'a ord \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   21.33 +"is_lub r x y u == is_ub r x y u & (!z. is_ub r x y z \<longrightarrow> r u z)"
   21.34  
   21.35 - some_lub :: "('a*'a)set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
   21.36 + some_lub :: "'a ord \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"
   21.37  "some_lub r x y == SOME z. is_lub r x y z";
   21.38  
   21.39  locale (open) semilat =
   21.40 @@ -244,113 +241,113 @@
   21.41  by(blast intro: order_antisym plus_com_lemma)
   21.42  
   21.43  lemma is_lubD:
   21.44 -  "is_lub r x y u \<Longrightarrow> is_ub r x y u & (!z. is_ub r x y z \<longrightarrow> (u,z):r)"
   21.45 +  "is_lub r x y u \<Longrightarrow> is_ub r x y u & (!z. is_ub r x y z \<longrightarrow> r u z)"
   21.46    by (simp add: is_lub_def)
   21.47  
   21.48  lemma is_ubI:
   21.49 -  "\<lbrakk> (x,u) : r; (y,u) : r \<rbrakk> \<Longrightarrow> is_ub r x y u"
   21.50 +  "\<lbrakk> r x u; r y u \<rbrakk> \<Longrightarrow> is_ub r x y u"
   21.51    by (simp add: is_ub_def)
   21.52  
   21.53  lemma is_ubD:
   21.54 -  "is_ub r x y u \<Longrightarrow> (x,u) : r & (y,u) : r"
   21.55 +  "is_ub r x y u \<Longrightarrow> r x u & r y u"
   21.56    by (simp add: is_ub_def)
   21.57  
   21.58  
   21.59  lemma is_lub_bigger1 [iff]:  
   21.60 -  "is_lub (r^* ) x y y = ((x,y):r^* )"
   21.61 +  "is_lub (r^** ) x y y = r^** x y"
   21.62  apply (unfold is_lub_def is_ub_def)
   21.63  apply blast
   21.64  done
   21.65  
   21.66  lemma is_lub_bigger2 [iff]:
   21.67 -  "is_lub (r^* ) x y x = ((y,x):r^* )"
   21.68 +  "is_lub (r^** ) x y x = r^** y x"
   21.69  apply (unfold is_lub_def is_ub_def)
   21.70  apply blast 
   21.71  done
   21.72  
   21.73  lemma extend_lub:
   21.74 -  "\<lbrakk> single_valued r; is_lub (r^* ) x y u; (x',x) : r \<rbrakk> 
   21.75 -  \<Longrightarrow> EX v. is_lub (r^* ) x' y v"
   21.76 +  "\<lbrakk> single_valuedP r; is_lub (r^** ) x y u; r x' x \<rbrakk> 
   21.77 +  \<Longrightarrow> EX v. is_lub (r^** ) x' y v"
   21.78  apply (unfold is_lub_def is_ub_def)
   21.79 -apply (case_tac "(y,x) : r^*")
   21.80 - apply (case_tac "(y,x') : r^*")
   21.81 +apply (case_tac "r^** y x")
   21.82 + apply (case_tac "r^** y x'")
   21.83    apply blast
   21.84 - apply (blast elim: converse_rtranclE dest: single_valuedD)
   21.85 + apply (blast elim: converse_rtranclE' dest: single_valuedD)
   21.86  apply (rule exI)
   21.87  apply (rule conjI)
   21.88 - apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
   21.89 -apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl 
   21.90 -             elim: converse_rtranclE dest: single_valuedD)
   21.91 + apply (blast intro: converse_rtrancl_into_rtrancl' dest: single_valuedD)
   21.92 +apply (blast intro: rtrancl.rtrancl_into_rtrancl converse_rtrancl_into_rtrancl'
   21.93 +             elim: converse_rtranclE' dest: single_valuedD)
   21.94  done
   21.95  
   21.96  lemma single_valued_has_lubs [rule_format]:
   21.97 -  "\<lbrakk> single_valued r; (x,u) : r^* \<rbrakk> \<Longrightarrow> (!y. (y,u) : r^* \<longrightarrow> 
   21.98 -  (EX z. is_lub (r^* ) x y z))"
   21.99 -apply (erule converse_rtrancl_induct)
  21.100 +  "\<lbrakk> single_valuedP r; r^** x u \<rbrakk> \<Longrightarrow> (!y. r^** y u \<longrightarrow> 
  21.101 +  (EX z. is_lub (r^** ) x y z))"
  21.102 +apply (erule converse_rtrancl_induct')
  21.103   apply clarify
  21.104 - apply (erule converse_rtrancl_induct)
  21.105 + apply (erule converse_rtrancl_induct')
  21.106    apply blast
  21.107 - apply (blast intro: converse_rtrancl_into_rtrancl)
  21.108 + apply (blast intro: converse_rtrancl_into_rtrancl')
  21.109  apply (blast intro: extend_lub)
  21.110  done
  21.111  
  21.112  lemma some_lub_conv:
  21.113 -  "\<lbrakk> acyclic r; is_lub (r^* ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^* ) x y = u"
  21.114 +  "\<lbrakk> acyclicP r; is_lub (r^** ) x y u \<rbrakk> \<Longrightarrow> some_lub (r^** ) x y = u"
  21.115  apply (unfold some_lub_def is_lub_def)
  21.116  apply (rule someI2)
  21.117   apply assumption
  21.118 -apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
  21.119 +apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl [to_pred])
  21.120  done
  21.121  
  21.122  lemma is_lub_some_lub:
  21.123 -  "\<lbrakk> single_valued r; acyclic r; (x,u):r^*; (y,u):r^* \<rbrakk> 
  21.124 -  \<Longrightarrow> is_lub (r^* ) x y (some_lub (r^* ) x y)";
  21.125 +  "\<lbrakk> single_valuedP r; acyclicP r; r^** x u; r^** y u \<rbrakk> 
  21.126 +  \<Longrightarrow> is_lub (r^** ) x y (some_lub (r^** ) x y)";
  21.127    by (fastsimp dest: single_valued_has_lubs simp add: some_lub_conv)
  21.128  
  21.129  subsection{*An executable lub-finder*}
  21.130  
  21.131  constdefs
  21.132 - exec_lub :: "('a * 'a) set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop"
  21.133 -"exec_lub r f x y == while (\<lambda>z. (x,z) \<notin> r\<^sup>*) f y"
  21.134 + exec_lub :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop"
  21.135 +"exec_lub r f x y == while (\<lambda>z. \<not> r\<^sup>*\<^sup>* x z) f y"
  21.136  
  21.137  
  21.138  lemma acyclic_single_valued_finite:
  21.139 - "\<lbrakk>acyclic r; single_valued r; (x,y) \<in> r\<^sup>*\<rbrakk>
  21.140 -  \<Longrightarrow> finite (r \<inter> {a. (x, a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})"
  21.141 -apply(erule converse_rtrancl_induct)
  21.142 + "\<lbrakk>acyclicP r; single_valuedP r; r\<^sup>*\<^sup>* x y \<rbrakk>
  21.143 +  \<Longrightarrow> finite (Collect2 r \<inter> {a. r\<^sup>*\<^sup>* x a} \<times> {b. r\<^sup>*\<^sup>* b y})"
  21.144 +apply(erule converse_rtrancl_induct')
  21.145   apply(rule_tac B = "{}" in finite_subset)
  21.146 -  apply(simp only:acyclic_def)
  21.147 -  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
  21.148 +  apply(simp only:acyclic_def [to_pred])
  21.149 +  apply(blast intro:rtrancl_into_trancl2' rtrancl_trancl_trancl')
  21.150   apply simp
  21.151  apply(rename_tac x x')
  21.152 -apply(subgoal_tac "r \<inter> {a. (x,a) \<in> r\<^sup>*} \<times> {b. (b,y) \<in> r\<^sup>*} =
  21.153 -                   insert (x,x') (r \<inter> {a. (x', a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})")
  21.154 +apply(subgoal_tac "Collect2 r \<inter> {a. r\<^sup>*\<^sup>* x a} \<times> {b. r\<^sup>*\<^sup>* b y} =
  21.155 +                   insert (x,x') (Collect2 r \<inter> {a. r\<^sup>*\<^sup>* x' a} \<times> {b. r\<^sup>*\<^sup>* b y})")
  21.156   apply simp
  21.157 -apply(blast intro:converse_rtrancl_into_rtrancl
  21.158 -            elim:converse_rtranclE dest:single_valuedD)
  21.159 +apply(blast intro:converse_rtrancl_into_rtrancl'
  21.160 +            elim:converse_rtranclE' dest:single_valuedD)
  21.161  done
  21.162  
  21.163  
  21.164  lemma exec_lub_conv:
  21.165 -  "\<lbrakk> acyclic r; !x y. (x,y) \<in> r \<longrightarrow> f x = y; is_lub (r\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
  21.166 +  "\<lbrakk> acyclicP r; !x y. r x y \<longrightarrow> f x = y; is_lub (r\<^sup>*\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
  21.167    exec_lub r f x y = u";
  21.168  apply(unfold exec_lub_def)
  21.169 -apply(rule_tac P = "\<lambda>z. (y,z) \<in> r\<^sup>* \<and> (z,u) \<in> r\<^sup>*" and
  21.170 -               r = "(r \<inter> {(a,b). (y,a) \<in> r\<^sup>* \<and> (b,u) \<in> r\<^sup>*})^-1" in while_rule)
  21.171 +apply(rule_tac P = "\<lambda>z. r\<^sup>*\<^sup>* y z \<and> r\<^sup>*\<^sup>* z u" and
  21.172 +               r = "(Collect2 r \<inter> {(a,b). r\<^sup>*\<^sup>* y a \<and> r\<^sup>*\<^sup>* b u})^-1" in while_rule)
  21.173      apply(blast dest: is_lubD is_ubD)
  21.174     apply(erule conjE)
  21.175 -   apply(erule_tac z = u in converse_rtranclE)
  21.176 +   apply(erule_tac z = u in converse_rtranclE')
  21.177      apply(blast dest: is_lubD is_ubD)
  21.178 -   apply(blast dest:rtrancl_into_rtrancl)
  21.179 +   apply(blast dest: rtrancl.rtrancl_into_rtrancl)
  21.180    apply(rename_tac s)
  21.181 -  apply(subgoal_tac "is_ub (r\<^sup>*) x y s")
  21.182 +  apply(subgoal_tac "is_ub (r\<^sup>*\<^sup>*) x y s")
  21.183     prefer 2; apply(simp add:is_ub_def)
  21.184 -  apply(subgoal_tac "(u, s) \<in> r\<^sup>*")
  21.185 +  apply(subgoal_tac "r\<^sup>*\<^sup>* u s")
  21.186     prefer 2; apply(blast dest:is_lubD)
  21.187 -  apply(erule converse_rtranclE)
  21.188 +  apply(erule converse_rtranclE')
  21.189     apply blast
  21.190 -  apply(simp only:acyclic_def)
  21.191 -  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
  21.192 +  apply(simp only:acyclic_def [to_pred])
  21.193 +  apply(blast intro:rtrancl_into_trancl2' rtrancl_trancl_trancl')
  21.194   apply(rule finite_acyclic_wf)
  21.195    apply simp
  21.196    apply(erule acyclic_single_valued_finite)
  21.197 @@ -361,14 +358,14 @@
  21.198   apply blast
  21.199  apply simp
  21.200  apply(erule conjE)
  21.201 -apply(erule_tac z = u in converse_rtranclE)
  21.202 +apply(erule_tac z = u in converse_rtranclE')
  21.203   apply(blast dest: is_lubD is_ubD)
  21.204 -apply(blast dest:rtrancl_into_rtrancl)
  21.205 +apply blast
  21.206  done
  21.207  
  21.208  lemma is_lub_exec_lub:
  21.209 -  "\<lbrakk> single_valued r; acyclic r; (x,u):r^*; (y,u):r^*; !x y. (x,y) \<in> r \<longrightarrow> f x = y \<rbrakk>
  21.210 -  \<Longrightarrow> is_lub (r^* ) x y (exec_lub r f x y)"
  21.211 +  "\<lbrakk> single_valuedP r; acyclicP r; r^** x u; r^** y u; !x y. r x y \<longrightarrow> f x = y \<rbrakk>
  21.212 +  \<Longrightarrow> is_lub (r^** ) x y (exec_lub r f x y)"
  21.213    by (fastsimp dest: single_valued_has_lubs simp add: exec_lub_conv)
  21.214  
  21.215  end
    22.1 --- a/src/HOL/MicroJava/Comp/CorrComp.thy	Wed Feb 07 17:41:11 2007 +0100
    22.2 +++ b/src/HOL/MicroJava/Comp/CorrComp.thy	Wed Feb 07 17:44:07 2007 +0100
    22.3 @@ -14,14 +14,14 @@
    22.4  (* If no exception is present after evaluation/execution, 
    22.5    none can have been present before *)
    22.6  lemma eval_evals_exec_xcpt:
    22.7 - "((xs,ex,val,xs') \<in> Eval.eval G \<longrightarrow> gx xs' = None \<longrightarrow> gx xs = None) \<and>
    22.8 -  ((xs,exs,vals,xs') \<in> Eval.evals G \<longrightarrow> gx xs' = None \<longrightarrow> gx xs = None) \<and>
    22.9 -  ((xs,st,xs') \<in> Eval.exec G \<longrightarrow> gx xs' = None \<longrightarrow> gx xs = None)"
   22.10 + "(G \<turnstile> xs -ex\<succ>val-> xs' \<longrightarrow> gx xs' = None \<longrightarrow> gx xs = None) \<and>
   22.11 +  (G \<turnstile> xs -exs[\<succ>]vals-> xs' \<longrightarrow> gx xs' = None \<longrightarrow> gx xs = None) \<and>
   22.12 +  (G \<turnstile> xs -st-> xs' \<longrightarrow> gx xs' = None \<longrightarrow> gx xs = None)"
   22.13  by (induct rule: eval_evals_exec.induct, auto)
   22.14  
   22.15  
   22.16  (* instance of eval_evals_exec_xcpt for eval *)
   22.17 -lemma eval_xcpt: "(xs,ex,val,xs') \<in> Eval.eval G \<Longrightarrow> gx xs' = None \<Longrightarrow> gx xs = None"
   22.18 +lemma eval_xcpt: "G \<turnstile> xs -ex\<succ>val-> xs' \<Longrightarrow> gx xs' = None \<Longrightarrow> gx xs = None"
   22.19   (is "?H1 \<Longrightarrow> ?H2 \<Longrightarrow> ?T")
   22.20  proof-
   22.21    assume h1: ?H1
   22.22 @@ -30,7 +30,7 @@
   22.23  qed
   22.24  
   22.25  (* instance of eval_evals_exec_xcpt for evals *)
   22.26 -lemma evals_xcpt: "(xs,exs,vals,xs') \<in> Eval.evals G \<Longrightarrow> gx xs' = None \<Longrightarrow> gx xs = None"
   22.27 +lemma evals_xcpt: "G \<turnstile> xs -exs[\<succ>]vals-> xs' \<Longrightarrow> gx xs' = None \<Longrightarrow> gx xs = None"
   22.28   (is "?H1 \<Longrightarrow> ?H2 \<Longrightarrow> ?T")
   22.29  proof-
   22.30    assume h1: ?H1
   22.31 @@ -39,7 +39,7 @@
   22.32  qed
   22.33  
   22.34  (* instance of eval_evals_exec_xcpt for exec *)
   22.35 -lemma exec_xcpt: "(xs,st,xs') \<in> Eval.exec G \<Longrightarrow> gx xs' = None \<Longrightarrow> gx xs = None"
   22.36 +lemma exec_xcpt: "G \<turnstile> xs -st-> xs' \<Longrightarrow> gx xs' = None \<Longrightarrow> gx xs = None"
   22.37   (is "?H1 \<Longrightarrow> ?H2 \<Longrightarrow> ?T")
   22.38  proof-
   22.39    assume h1: ?H1
   22.40 @@ -404,7 +404,7 @@
   22.41         E\<turnstile>ps[::]pTs & max_spec (prg E) C (mn, pTs) = {((md,rT),pTs')})"
   22.42  apply (simp only: wtpd_expr_def wtpd_exprs_def)
   22.43  apply (erule exE)
   22.44 -apply (ind_cases "E \<turnstile> {C}a..mn( {pTs'}ps) :: T")
   22.45 +apply (ind_cases2 "E \<turnstile> {C}a..mn( {pTs'}ps) :: T" for T)
   22.46  apply (auto simp: max_spec_preserves_length)
   22.47  done
   22.48  
   22.49 @@ -437,7 +437,7 @@
   22.50    "\<forall> xs'. (G \<turnstile> xk -xj\<succ>xi-> xh \<longrightarrow> True) & 
   22.51    (G\<turnstile> xs -es[\<succ>]vs-> xs' \<longrightarrow>  (\<exists> s. (xs' = (None, s))) \<longrightarrow> 
   22.52    length es = length vs) &
   22.53 -  ((xc, xb, xa) \<in> Eval.exec G \<longrightarrow> True)")
   22.54 +  (G \<turnstile> xc -xb-> xa \<longrightarrow> True)")
   22.55  apply blast
   22.56  apply (rule allI)
   22.57  apply (rule Eval.eval_evals_exec.induct)
   22.58 @@ -576,7 +576,7 @@
   22.59  done
   22.60  
   22.61  lemma state_ok_evals: "\<lbrakk>xs::\<preceq>E; wf_java_prog (prg E); wtpd_exprs E es;
   22.62 -  (xs,es,vs,xs') \<in> Eval.evals (prg E)\<rbrakk> \<Longrightarrow> xs'::\<preceq>E"
   22.63 +  prg E \<turnstile> xs -es[\<succ>]vs-> xs'\<rbrakk> \<Longrightarrow> xs'::\<preceq>E"
   22.64  apply (simp only: wtpd_exprs_def)
   22.65  apply (erule exE)
   22.66  apply (case_tac xs) apply (case_tac xs')
   22.67 @@ -584,7 +584,7 @@
   22.68  done
   22.69  
   22.70  lemma state_ok_exec: "\<lbrakk>xs::\<preceq>E; wf_java_prog (prg E); wtpd_stmt E st;
   22.71 -  (xs,st,xs') \<in> Eval.exec (prg E)\<rbrakk> \<Longrightarrow>  xs'::\<preceq>E"
   22.72 +  prg E \<turnstile> xs -st-> xs'\<rbrakk> \<Longrightarrow>  xs'::\<preceq>E"
   22.73  apply (simp only: wtpd_stmt_def)
   22.74  apply (case_tac xs', case_tac xs)
   22.75  apply (auto dest: exec_type_sound)
   22.76 @@ -618,13 +618,13 @@
   22.77  apply simp
   22.78  apply (rule allI)
   22.79  apply (rule iffI)
   22.80 -  apply (ind_cases "E \<turnstile> [] [::] Ts", assumption)
   22.81 +  apply (ind_cases2 "E \<turnstile> [] [::] Ts" for Ts, assumption)
   22.82    apply simp apply (rule WellType.Nil)
   22.83  apply (simp add: list_all2_Cons1)
   22.84  apply (rule allI)
   22.85  apply (rule iffI)
   22.86    apply (rename_tac a exs Ts)
   22.87 -  apply (ind_cases "E \<turnstile> a # exs  [::] Ts") apply blast
   22.88 +  apply (ind_cases2 "E \<turnstile> a # exs  [::] Ts" for a exs Ts) apply blast
   22.89    apply (auto intro: WellType.Cons)
   22.90  done
   22.91  
   22.92 @@ -718,7 +718,7 @@
   22.93  (* 2. possibly skip env_of_jmb ??? *)
   22.94  theorem compiler_correctness: 
   22.95    "wf_java_prog G \<Longrightarrow>
   22.96 -  ((xs,ex,val,xs') \<in> Eval.eval G \<longrightarrow>
   22.97 +  (G \<turnstile> xs -ex\<succ>val-> xs' \<longrightarrow>
   22.98    gx xs = None \<longrightarrow> gx xs' = None \<longrightarrow>
   22.99    (\<forall> os CL S.
  22.100    (class_sig_defined G CL S) \<longrightarrow> 
  22.101 @@ -729,7 +729,7 @@
  22.102      >- (compExpr (gmb G CL S) ex) \<rightarrow>
  22.103      {gh xs', val#os, locvars_xstate G CL S xs'}))) \<and> 
  22.104  
  22.105 - ((xs,exs,vals,xs') \<in> Eval.evals G \<longrightarrow>
  22.106 + (G \<turnstile> xs -exs[\<succ>]vals-> xs' \<longrightarrow>
  22.107    gx xs = None \<longrightarrow> gx xs' = None \<longrightarrow>
  22.108    (\<forall> os CL S.
  22.109    (class_sig_defined G CL S) \<longrightarrow> 
  22.110 @@ -740,7 +740,7 @@
  22.111      >- (compExprs (gmb G CL S) exs) \<rightarrow>
  22.112      {gh xs', (rev vals)@os, (locvars_xstate G CL S xs')}))) \<and> 
  22.113  
  22.114 -  ((xs,st,xs') \<in> Eval.exec G \<longrightarrow>
  22.115 +  (G \<turnstile> xs -st-> xs' \<longrightarrow>
  22.116     gx xs = None \<longrightarrow> gx xs' = None \<longrightarrow>
  22.117    (\<forall> os CL S.
  22.118    (class_sig_defined G CL S) \<longrightarrow> 
  22.119 @@ -1189,7 +1189,7 @@
  22.120    (* show list_all2 (conf G h) pvs pTs *)
  22.121  apply (erule exE)+ apply (erule conjE)+
  22.122  apply (rule_tac Ts="pTsa" in conf_list_gext_widen) apply assumption
  22.123 -apply (subgoal_tac "((gx s1, gs s1), ps, pvs, x, h, l) \<in> evals G")
  22.124 +apply (subgoal_tac "G \<turnstile> (gx s1, gs s1) -ps[\<succ>]pvs-> (x, h, l)")
  22.125  apply (frule_tac E="env_of_jmb G CL S" in evals_type_sound)
  22.126  apply assumption+
  22.127  apply (simp only: env_of_jmb_fst) 
  22.128 @@ -1247,7 +1247,7 @@
  22.129  done
  22.130  
  22.131  theorem compiler_correctness_exec: "
  22.132 -  \<lbrakk> ((None,hp,loc), st, (None,hp',loc')) \<in> Eval.exec G;
  22.133 +  \<lbrakk> G \<turnstile> Norm (hp, loc) -st-> Norm (hp', loc');
  22.134    wf_java_prog G;
  22.135    class_sig_defined G C S;
  22.136    wtpd_stmt (env_of_jmb G C S) st;
    23.1 --- a/src/HOL/MicroJava/Comp/LemmasComp.thy	Wed Feb 07 17:41:11 2007 +0100
    23.2 +++ b/src/HOL/MicroJava/Comp/LemmasComp.thy	Wed Feb 07 17:44:07 2007 +0100
    23.3 @@ -109,22 +109,24 @@
    23.4  by (case_tac "class G C", auto simp: is_class_def dest: comp_class_imp)
    23.5  
    23.6  lemma comp_subcls1: "subcls1 (comp G) = subcls1 G"
    23.7 -by (auto simp add: subcls1_def2 comp_classname comp_is_class)
    23.8 +by (auto simp add: subcls1_def2 comp_classname comp_is_class member2_inject)
    23.9  
   23.10 -lemma comp_widen: "((ty1,ty2) \<in> widen (comp G)) = ((ty1,ty2) \<in> widen G)"
   23.11 -  apply rule
   23.12 -  apply (cases "(ty1,ty2)" "comp G" rule: widen.cases) 
   23.13 +lemma comp_widen: "widen (comp G) = widen G"
   23.14 +  apply (simp add: expand_fun_eq)
   23.15 +  apply (intro allI iffI)
   23.16 +  apply (erule widen.cases) 
   23.17    apply (simp_all add: comp_subcls1 widen.null)
   23.18 -  apply (cases "(ty1,ty2)" G rule: widen.cases) 
   23.19 +  apply (erule widen.cases) 
   23.20    apply (simp_all add: comp_subcls1 widen.null)
   23.21    done
   23.22  
   23.23 -lemma comp_cast: "((ty1,ty2) \<in> cast (comp G)) = ((ty1,ty2) \<in> cast G)"
   23.24 -  apply rule
   23.25 -  apply (cases "(ty1,ty2)" "comp G" rule: cast.cases) 
   23.26 +lemma comp_cast: "cast (comp G) = cast G"
   23.27 +  apply (simp add: expand_fun_eq)
   23.28 +  apply (intro allI iffI)
   23.29 +  apply (erule cast.cases) 
   23.30    apply (simp_all add: comp_subcls1 cast.widen cast.subcls)
   23.31    apply (rule cast.widen) apply (simp add: comp_widen)
   23.32 -  apply (cases "(ty1,ty2)" G rule: cast.cases)
   23.33 +  apply (erule cast.cases)
   23.34    apply (simp_all add: comp_subcls1 cast.widen cast.subcls)
   23.35    apply (rule cast.widen) apply (simp add: comp_widen)
   23.36    done
   23.37 @@ -180,16 +182,16 @@
   23.38  done
   23.39  
   23.40  
   23.41 -lemma comp_class_rec: " wf ((subcls1 G)^-1) \<Longrightarrow> 
   23.42 +lemma comp_class_rec: " wfP ((subcls1 G)^--1) \<Longrightarrow> 
   23.43  class_rec (comp G) C t f = 
   23.44    class_rec G C t (\<lambda> C' fs' ms' r'. f C' fs' (map (compMethod G C') ms') r')"
   23.45 -apply (rule_tac a = C in  wf_induct) apply assumption
   23.46 -apply (subgoal_tac "wf ((subcls1 (comp G))\<inverse>)")
   23.47 +apply (rule_tac a = C in  wfP_induct) apply assumption
   23.48 +apply (subgoal_tac "wfP ((subcls1 (comp G))\<inverse>\<inverse>)")
   23.49  apply (subgoal_tac "(class G x = None) \<or> (\<exists> D fs ms. (class G x = Some (D, fs, ms)))")
   23.50  apply (erule disjE)
   23.51  
   23.52    (* case class G x = None *)
   23.53 -apply (simp (no_asm_simp) add: class_rec_def comp_subcls1 wfrec cut_apply)
   23.54 +apply (simp (no_asm_simp) add: class_rec_def comp_subcls1 wfrec [to_pred] cut_apply)
   23.55  apply (simp add: comp_class_None)
   23.56  
   23.57    (* case \<exists> D fs ms. (class G x = Some (D, fs, ms)) *)
   23.58 @@ -214,11 +216,11 @@
   23.59  apply (simp add: comp_subcls1)
   23.60  done
   23.61  
   23.62 -lemma comp_fields: "wf ((subcls1 G)^-1) \<Longrightarrow> 
   23.63 +lemma comp_fields: "wfP ((subcls1 G)^--1) \<Longrightarrow> 
   23.64    fields (comp G,C) = fields (G,C)" 
   23.65  by (simp add: fields_def comp_class_rec)
   23.66  
   23.67 -lemma comp_field: "wf ((subcls1 G)^-1) \<Longrightarrow> 
   23.68 +lemma comp_field: "wfP ((subcls1 G)^--1) \<Longrightarrow> 
   23.69    field (comp G,C) = field (G,C)" 
   23.70  by (simp add: field_def comp_fields)
   23.71  
   23.72 @@ -230,7 +232,7 @@
   23.73    \<Longrightarrow> ((class G C) \<noteq> None) \<longrightarrow> 
   23.74    R (class_rec G C t1 f1) (class_rec G C t2 f2)"
   23.75  apply (frule wf_subcls1) (* establish wf ((subcls1 G)^-1) *)
   23.76 -apply (rule_tac a = C in  wf_induct) apply assumption
   23.77 +apply (rule_tac a = C in  wfP_induct) apply assumption
   23.78  apply (intro strip)
   23.79  apply (subgoal_tac "(\<exists>D rT mb. class G x = Some (D, rT, mb))")
   23.80    apply (erule exE)+
    24.1 --- a/src/HOL/MicroJava/J/Eval.thy	Wed Feb 07 17:41:11 2007 +0100
    24.2 +++ b/src/HOL/MicroJava/J/Eval.thy	Wed Feb 07 17:44:07 2007 +0100
    24.3 @@ -32,86 +32,62 @@
    24.4  
    24.5    -- "Evaluation relations"
    24.6  
    24.7 -consts
    24.8 -  eval  :: "java_mb prog => (xstate \<times> expr      \<times> val      \<times> xstate) set"
    24.9 -  evals :: "java_mb prog => (xstate \<times> expr list \<times> val list \<times> xstate) set"
   24.10 -  exec  :: "java_mb prog => (xstate \<times> stmt                 \<times> xstate) set"
   24.11 -
   24.12 -syntax (xsymbols)
   24.13 +inductive2
   24.14    eval :: "[java_mb prog,xstate,expr,val,xstate] => bool "
   24.15            ("_ \<turnstile> _ -_\<succ>_-> _" [51,82,60,82,82] 81)
   24.16 -  evals:: "[java_mb prog,xstate,expr list,
   24.17 +  and evals :: "[java_mb prog,xstate,expr list,
   24.18                          val list,xstate] => bool "
   24.19            ("_ \<turnstile> _ -_[\<succ>]_-> _" [51,82,60,51,82] 81)
   24.20 -  exec :: "[java_mb prog,xstate,stmt,    xstate] => bool "
   24.21 +  and exec :: "[java_mb prog,xstate,stmt,    xstate] => bool "
   24.22            ("_ \<turnstile> _ -_-> _" [51,82,60,82] 81)
   24.23 -
   24.24 -syntax
   24.25 -  eval :: "[java_mb prog,xstate,expr,val,xstate] => bool "
   24.26 -          ("_ |- _ -_>_-> _" [51,82,60,82,82] 81)
   24.27 -  evals:: "[java_mb prog,xstate,expr list,
   24.28 -                        val list,xstate] => bool "
   24.29 -          ("_ |- _ -_[>]_-> _" [51,82,60,51,82] 81)
   24.30 -  exec :: "[java_mb prog,xstate,stmt,    xstate] => bool "
   24.31 -          ("_ |- _ -_-> _" [51,82,60,82] 81)
   24.32 -
   24.33 +  for G :: "java_mb prog"
   24.34 +where
   24.35  
   24.36 -translations
   24.37 -  "G\<turnstile>s -e \<succ> v-> (x,s')" <= "(s, e, v, x, s') \<in> eval  G"
   24.38 -  "G\<turnstile>s -e \<succ> v->    s' " == "(s, e, v,    s') \<in> eval  G"
   24.39 -  "G\<turnstile>s -e[\<succ>]v-> (x,s')" <= "(s, e, v, x, s') \<in> evals G"
   24.40 -  "G\<turnstile>s -e[\<succ>]v->    s' " == "(s, e, v,    s') \<in> evals G"
   24.41 -  "G\<turnstile>s -c    -> (x,s')" <= "(s, c, x, s') \<in> exec G"
   24.42 -  "G\<turnstile>s -c    ->    s' " == "(s, c,    s') \<in> exec G"
   24.43 -
   24.44 -
   24.45 -inductive "eval G" "evals G" "exec G" intros
   24.46 -
   24.47 -  (* evaluation of expressions *)
   24.48 +  -- "evaluation of expressions"
   24.49  
   24.50    XcptE:"G\<turnstile>(Some xc,s) -e\<succ>arbitrary-> (Some xc,s)"  -- "cf. 15.5"
   24.51  
   24.52    -- "cf. 15.8.1"
   24.53 -  NewC: "[| h = heap s; (a,x) = new_Addr h;
   24.54 +| NewC: "[| h = heap s; (a,x) = new_Addr h;
   24.55              h'= h(a\<mapsto>(C,init_vars (fields (G,C)))) |] ==>
   24.56           G\<turnstile>Norm s -NewC C\<succ>Addr a-> c_hupd h' (x,s)"
   24.57  
   24.58    -- "cf. 15.15"
   24.59 -  Cast: "[| G\<turnstile>Norm s0 -e\<succ>v-> (x1,s1);
   24.60 +| Cast: "[| G\<turnstile>Norm s0 -e\<succ>v-> (x1,s1);
   24.61              x2 = raise_if (\<not> cast_ok G C (heap s1) v) ClassCast x1 |] ==>
   24.62           G\<turnstile>Norm s0 -Cast C e\<succ>v-> (x2,s1)"
   24.63  
   24.64    -- "cf. 15.7.1"
   24.65 -  Lit:  "G\<turnstile>Norm s -Lit v\<succ>v-> Norm s"
   24.66 +| Lit:  "G\<turnstile>Norm s -Lit v\<succ>v-> Norm s"
   24.67  
   24.68 -  BinOp:"[| G\<turnstile>Norm s -e1\<succ>v1-> s1;
   24.69 +| BinOp:"[| G\<turnstile>Norm s -e1\<succ>v1-> s1;
   24.70              G\<turnstile>s1     -e2\<succ>v2-> s2;
   24.71              v = (case bop of Eq  => Bool (v1 = v2)
   24.72                             | Add => Intg (the_Intg v1 + the_Intg v2)) |] ==>
   24.73           G\<turnstile>Norm s -BinOp bop e1 e2\<succ>v-> s2"
   24.74  
   24.75    -- "cf. 15.13.1, 15.2"
   24.76 -  LAcc: "G\<turnstile>Norm s -LAcc v\<succ>the (locals s v)-> Norm s"
   24.77 +| LAcc: "G\<turnstile>Norm s -LAcc v\<succ>the (locals s v)-> Norm s"
   24.78  
   24.79    -- "cf. 15.25.1"
   24.80 -  LAss: "[| G\<turnstile>Norm s -e\<succ>v-> (x,(h,l));
   24.81 +| LAss: "[| G\<turnstile>Norm s -e\<succ>v-> (x,(h,l));
   24.82              l' = (if x = None then l(va\<mapsto>v) else l) |] ==>
   24.83           G\<turnstile>Norm s -va::=e\<succ>v-> (x,(h,l'))"
   24.84  
   24.85    -- "cf. 15.10.1, 15.2"
   24.86 -  FAcc: "[| G\<turnstile>Norm s0 -e\<succ>a'-> (x1,s1); 
   24.87 +| FAcc: "[| G\<turnstile>Norm s0 -e\<succ>a'-> (x1,s1); 
   24.88              v = the (snd (the (heap s1 (the_Addr a'))) (fn,T)) |] ==>
   24.89           G\<turnstile>Norm s0 -{T}e..fn\<succ>v-> (np a' x1,s1)"
   24.90  
   24.91    -- "cf. 15.25.1"
   24.92 -  FAss: "[| G\<turnstile>     Norm s0  -e1\<succ>a'-> (x1,s1); a = the_Addr a';
   24.93 +| FAss: "[| G\<turnstile>     Norm s0  -e1\<succ>a'-> (x1,s1); a = the_Addr a';
   24.94              G\<turnstile>(np a' x1,s1) -e2\<succ>v -> (x2,s2);
   24.95              h  = heap s2; (c,fs) = the (h a);
   24.96              h' = h(a\<mapsto>(c,(fs((fn,T)\<mapsto>v)))) |] ==>
   24.97           G\<turnstile>Norm s0 -{T}e1..fn:=e2\<succ>v-> c_hupd h' (x2,s2)"
   24.98  
   24.99    -- "cf. 15.11.4.1, 15.11.4.2, 15.11.4.4, 15.11.4.5, 14.15"
  24.100 -  Call: "[| G\<turnstile>Norm s0 -e\<succ>a'-> s1; a = the_Addr a';
  24.101 +| Call: "[| G\<turnstile>Norm s0 -e\<succ>a'-> s1; a = the_Addr a';
  24.102              G\<turnstile>s1 -ps[\<succ>]pvs-> (x,(h,l)); dynT = fst (the (h a));
  24.103              (md,rT,pns,lvars,blk,res) = the (method (G,dynT) (mn,pTs));
  24.104              G\<turnstile>(np a' x,(h,(init_vars lvars)(pns[\<mapsto>]pvs)(This\<mapsto>a'))) -blk-> s3;
  24.105 @@ -122,13 +98,13 @@
  24.106    -- "evaluation of expression lists"
  24.107  
  24.108    -- "cf. 15.5"
  24.109 -  XcptEs:"G\<turnstile>(Some xc,s) -e[\<succ>]arbitrary-> (Some xc,s)"
  24.110 +| XcptEs:"G\<turnstile>(Some xc,s) -e[\<succ>]arbitrary-> (Some xc,s)"
  24.111  
  24.112    -- "cf. 15.11.???"
  24.113 -  Nil:  "G\<turnstile>Norm s0 -[][\<succ>][]-> Norm s0"
  24.114 +| Nil:  "G\<turnstile>Norm s0 -[][\<succ>][]-> Norm s0"
  24.115  
  24.116    -- "cf. 15.6.4"
  24.117 -  Cons: "[| G\<turnstile>Norm s0 -e  \<succ> v -> s1;
  24.118 +| Cons: "[| G\<turnstile>Norm s0 -e  \<succ> v -> s1;
  24.119              G\<turnstile>     s1 -es[\<succ>]vs-> s2 |] ==>
  24.120           G\<turnstile>Norm s0 -e#es[\<succ>]v#vs-> s2"
  24.121  
  24.122 @@ -136,29 +112,29 @@
  24.123    -- "execution of statements"
  24.124  
  24.125    -- "cf. 14.1"
  24.126 -  XcptS:"G\<turnstile>(Some xc,s) -c-> (Some xc,s)"
  24.127 +| XcptS:"G\<turnstile>(Some xc,s) -c-> (Some xc,s)"
  24.128  
  24.129    -- "cf. 14.5"
  24.130 -  Skip: "G\<turnstile>Norm s -Skip-> Norm s"
  24.131 +| Skip: "G\<turnstile>Norm s -Skip-> Norm s"
  24.132  
  24.133    -- "cf. 14.7"
  24.134 -  Expr: "[| G\<turnstile>Norm s0 -e\<succ>v-> s1 |] ==>
  24.135 +| Expr: "[| G\<turnstile>Norm s0 -e\<succ>v-> s1 |] ==>
  24.136           G\<turnstile>Norm s0 -Expr e-> s1"
  24.137  
  24.138    -- "cf. 14.2"
  24.139 -  Comp: "[| G\<turnstile>Norm s0 -c1-> s1;
  24.140 +| Comp: "[| G\<turnstile>Norm s0 -c1-> s1;
  24.141              G\<turnstile>     s1 -c2-> s2|] ==>
  24.142           G\<turnstile>Norm s0 -c1;; c2-> s2"
  24.143  
  24.144    -- "cf. 14.8.2"
  24.145 -  Cond: "[| G\<turnstile>Norm s0  -e\<succ>v-> s1;
  24.146 +| Cond: "[| G\<turnstile>Norm s0  -e\<succ>v-> s1;
  24.147              G\<turnstile> s1 -(if the_Bool v then c1 else c2)-> s2|] ==>
  24.148           G\<turnstile>Norm s0 -If(e) c1 Else c2-> s2"
  24.149  
  24.150    -- "cf. 14.10, 14.10.1"
  24.151 -  LoopF:"[| G\<turnstile>Norm s0 -e\<succ>v-> s1; \<not>the_Bool v |] ==>
  24.152 +| LoopF:"[| G\<turnstile>Norm s0 -e\<succ>v-> s1; \<not>the_Bool v |] ==>
  24.153           G\<turnstile>Norm s0 -While(e) c-> s1"
  24.154 -  LoopT:"[| G\<turnstile>Norm s0 -e\<succ>v-> s1;  the_Bool v;
  24.155 +| LoopT:"[| G\<turnstile>Norm s0 -e\<succ>v-> s1;  the_Bool v;
  24.156        G\<turnstile>s1 -c-> s2; G\<turnstile>s2 -While(e) c-> s3 |] ==>
  24.157           G\<turnstile>Norm s0 -While(e) c-> s3"
  24.158  
    25.1 --- a/src/HOL/MicroJava/J/Example.thy	Wed Feb 07 17:41:11 2007 +0100
    25.2 +++ b/src/HOL/MicroJava/J/Example.thy	Wed Feb 07 17:44:07 2007 +0100
    25.3 @@ -172,19 +172,19 @@
    25.4  apply (simp (no_asm))
    25.5  done
    25.6  
    25.7 -lemma not_Object_subcls [elim!]: "(Object,C) \<in> (subcls1 tprg)^+ ==> R"
    25.8 -apply (auto dest!: tranclD subcls1D)
    25.9 +lemma not_Object_subcls [elim!]: "(subcls1 tprg)^++ Object C ==> R"
   25.10 +apply (auto dest!: tranclD' subcls1D)
   25.11  done
   25.12  
   25.13  lemma subcls_ObjectD [dest!]: "tprg\<turnstile>Object\<preceq>C C ==> C = Object"
   25.14 -apply (erule rtrancl_induct)
   25.15 +apply (erule rtrancl_induct')
   25.16  apply  auto
   25.17  apply (drule subcls1D)
   25.18  apply auto
   25.19  done
   25.20  
   25.21 -lemma not_Base_subcls_Ext [elim!]: "(Base, Ext) \<in> (subcls1 tprg)^+ ==> R"
   25.22 -apply (auto dest!: tranclD subcls1D)
   25.23 +lemma not_Base_subcls_Ext [elim!]: "(subcls1 tprg)^++ Base Ext ==> R"
   25.24 +apply (auto dest!: tranclD' subcls1D)
   25.25  done
   25.26  
   25.27  lemma class_tprgD: 
   25.28 @@ -193,11 +193,11 @@
   25.29  apply (auto split add: split_if_asm simp add: map_of_Cons)
   25.30  done
   25.31  
   25.32 -lemma not_class_subcls_class [elim!]: "(C,C) \<in> (subcls1 tprg)^+ ==> R"
   25.33 -apply (auto dest!: tranclD subcls1D)
   25.34 +lemma not_class_subcls_class [elim!]: "(subcls1 tprg)^++ C C ==> R"
   25.35 +apply (auto dest!: tranclD' subcls1D)
   25.36  apply (frule class_tprgD)
   25.37  apply (auto dest!:)
   25.38 -apply (drule rtranclD)
   25.39 +apply (drule rtranclD')
   25.40  apply auto
   25.41  done
   25.42  
   25.43 @@ -205,7 +205,7 @@
   25.44  apply (simp (no_asm) add: ObjectC_def BaseC_def ExtC_def NullPointerC_def ClassCastC_def OutOfMemoryC_def)
   25.45  done
   25.46  
   25.47 -lemmas subcls_direct = subcls1I [THEN r_into_rtrancl]
   25.48 +lemmas subcls_direct = subcls1I [THEN r_into_rtrancl' [where r="subcls1 G"], standard]
   25.49  
   25.50  lemma Ext_subcls_Base [simp]: "tprg\<turnstile>Ext\<preceq>C Base"
   25.51  apply (rule subcls_direct)
   25.52 @@ -219,12 +219,12 @@
   25.53  
   25.54  declare ty_expr_ty_exprs_wt_stmt.intros [intro!]
   25.55  
   25.56 -lemma acyclic_subcls1_: "acyclic (subcls1 tprg)"
   25.57 -apply (rule acyclicI)
   25.58 +lemma acyclic_subcls1_: "acyclicP (subcls1 tprg)"
   25.59 +apply (rule acyclicI [to_pred])
   25.60  apply safe
   25.61  done
   25.62  
   25.63 -lemmas wf_subcls1_ = acyclic_subcls1_ [THEN finite_subcls1 [THEN finite_acyclic_wf_converse]]
   25.64 +lemmas wf_subcls1_ = acyclic_subcls1_ [THEN finite_subcls1 [THEN finite_acyclic_wf_converse [to_pred]]]
   25.65  
   25.66  lemmas fields_rec_ = wf_subcls1_ [THEN [2] fields_rec_lemma]
   25.67  
   25.68 @@ -345,7 +345,7 @@
   25.69  apply (fold ExtC_def)
   25.70  apply (rule mp) defer apply (rule wf_foo_Ext)
   25.71  apply (auto simp add: wf_mdecl_def)
   25.72 -apply (drule rtranclD)
   25.73 +apply (drule rtranclD')
   25.74  apply auto
   25.75  done
   25.76  
    26.1 --- a/src/HOL/MicroJava/J/JTypeSafe.thy	Wed Feb 07 17:41:11 2007 +0100
    26.2 +++ b/src/HOL/MicroJava/J/JTypeSafe.thy	Wed Feb 07 17:44:07 2007 +0100
    26.3 @@ -27,7 +27,7 @@
    26.4  apply (case_tac "ref_ty")
    26.5  apply (clarsimp simp add: conf_def)
    26.6  apply simp
    26.7 -apply (ind_cases "G \<turnstile> Class cname \<preceq>? Class D", simp) 
    26.8 +apply (ind_cases2 "G \<turnstile> Class cname \<preceq>? Class D" for cname, simp)
    26.9  apply (rule conf_widen, assumption+) apply (erule widen.subcls)
   26.10  
   26.11  apply (unfold cast_ok_def)
   26.12 @@ -205,7 +205,7 @@
   26.13  -- "several simplifications, XcptE, XcptEs, XcptS, Skip, Nil??"
   26.14  apply( simp_all)
   26.15  apply( tactic "ALLGOALS strip_tac")
   26.16 -apply( tactic {* ALLGOALS (eresolve_tac (thms "ty_expr_ty_exprs_wt_stmt.elims") 
   26.17 +apply( tactic {* ALLGOALS (eresolve_tac [thm "ty_expr.cases", thm "ty_exprs.cases", thm "wt_stmt.cases"]
   26.18                   THEN_ALL_NEW Full_simp_tac) *})
   26.19  apply(tactic "ALLGOALS (EVERY' [REPEAT o (etac conjE), REPEAT o hyp_subst_tac])")
   26.20  
   26.21 @@ -222,7 +222,7 @@
   26.22  apply( rule conjI)
   26.23  apply(  force elim!: NewC_conforms)
   26.24  apply( rule conf_obj_AddrI)
   26.25 -apply(  rule_tac [2] rtrancl_refl)
   26.26 +apply(  rule_tac [2] rtrancl.rtrancl_refl)
   26.27  apply( simp (no_asm))
   26.28  
   26.29  -- "for Cast"
   26.30 @@ -245,22 +245,22 @@
   26.31  apply( fast elim: conforms_localD [THEN lconfD])
   26.32  
   26.33  -- "for FAss"
   26.34 -apply( tactic {* EVERY'[eresolve_tac (thms "ty_expr_ty_exprs_wt_stmt.elims") 
   26.35 +apply( tactic {* EVERY'[eresolve_tac [thm "ty_expr.cases", thm "ty_exprs.cases", thm "wt_stmt.cases"] 
   26.36         THEN_ALL_NEW Full_simp_tac, REPEAT o (etac conjE), hyp_subst_tac] 3*})
   26.37  
   26.38  -- "for if"
   26.39 -apply( tactic {* (case_tac "the_Bool v" THEN_ALL_NEW Asm_full_simp_tac) 8*})
   26.40 +apply( tactic {* (case_tac "the_Bool v" THEN_ALL_NEW Asm_full_simp_tac) 7*})
   26.41  
   26.42  apply (tactic "forward_hyp_tac")
   26.43  
   26.44  -- "11+1 if"
   26.45 -prefer 8
   26.46 +prefer 7
   26.47  apply(  fast intro: hext_trans)
   26.48 -prefer 8
   26.49 +prefer 7
   26.50  apply(  fast intro: hext_trans)
   26.51  
   26.52  -- "10 Expr"
   26.53 -prefer 7
   26.54 +prefer 6
   26.55  apply( fast)
   26.56  
   26.57  -- "9 ???"
   26.58 @@ -280,7 +280,7 @@
   26.59  
   26.60  -- "7 LAss"
   26.61  apply (fold fun_upd_def)
   26.62 -apply( tactic {* (eresolve_tac (thms "ty_expr_ty_exprs_wt_stmt.elims") 
   26.63 +apply( tactic {* (eresolve_tac [thm "ty_expr.cases", thm "ty_exprs.cases", thm "wt_stmt.cases"] 
   26.64                   THEN_ALL_NEW Full_simp_tac) 1 *})
   26.65  apply (intro strip)
   26.66  apply (case_tac E)
   26.67 @@ -315,7 +315,7 @@
   26.68  
   26.69  
   26.70  -- "2 FAss"
   26.71 -apply (subgoal_tac "(np a' x1, ab, ba) ::\<preceq> (G, lT)")
   26.72 +apply (subgoal_tac "(np a' x1, aa, ba) ::\<preceq> (G, lT)")
   26.73    prefer 2
   26.74    apply (simp add: np_def)
   26.75    apply (fast intro: conforms_xcpt_change xconf_raise_if)
    27.1 --- a/src/HOL/MicroJava/J/TypeRel.thy	Wed Feb 07 17:41:11 2007 +0100
    27.2 +++ b/src/HOL/MicroJava/J/TypeRel.thy	Wed Feb 07 17:44:07 2007 +0100
    27.3 @@ -8,61 +8,45 @@
    27.4  
    27.5  theory TypeRel imports Decl begin
    27.6  
    27.7 -consts
    27.8 -  subcls1 :: "'c prog => (cname \<times> cname) set"  -- "subclass"
    27.9 -  widen   :: "'c prog => (ty    \<times> ty   ) set"  -- "widening"
   27.10 -  cast    :: "'c prog => (ty    \<times> ty   ) set"  -- "casting"
   27.11 -
   27.12 -syntax (xsymbols)
   27.13 +-- "direct subclass, cf. 8.1.3"
   27.14 +inductive2
   27.15    subcls1 :: "'c prog => [cname, cname] => bool" ("_ \<turnstile> _ \<prec>C1 _" [71,71,71] 70)
   27.16 -  subcls  :: "'c prog => [cname, cname] => bool" ("_ \<turnstile> _ \<preceq>C _"  [71,71,71] 70)
   27.17 -  widen   :: "'c prog => [ty   , ty   ] => bool" ("_ \<turnstile> _ \<preceq> _"   [71,71,71] 70)
   27.18 -  cast    :: "'c prog => [ty   , ty   ] => bool" ("_ \<turnstile> _ \<preceq>? _"  [71,71,71] 70)
   27.19 +  for G :: "'c prog"
   27.20 +where
   27.21 +  subcls1I: "\<lbrakk>class G C = Some (D,rest); C \<noteq> Object\<rbrakk> \<Longrightarrow> G\<turnstile>C\<prec>C1D"
   27.22  
   27.23 -syntax
   27.24 -  subcls1 :: "'c prog => [cname, cname] => bool" ("_ |- _ <=C1 _" [71,71,71] 70)
   27.25 -  subcls  :: "'c prog => [cname, cname] => bool" ("_ |- _ <=C _"  [71,71,71] 70)
   27.26 -  widen   :: "'c prog => [ty   , ty   ] => bool" ("_ |- _ <= _"   [71,71,71] 70)
   27.27 -  cast    :: "'c prog => [ty   , ty   ] => bool" ("_ |- _ <=? _"  [71,71,71] 70)
   27.28 -
   27.29 -translations
   27.30 -  "G\<turnstile>C \<prec>C1 D" == "(C,D) \<in> subcls1 G"
   27.31 -  "G\<turnstile>C \<preceq>C  D" == "(C,D) \<in> (subcls1 G)^*"
   27.32 -  "G\<turnstile>S \<preceq>   T" == "(S,T) \<in> widen   G"
   27.33 -  "G\<turnstile>C \<preceq>?  D" == "(C,D) \<in> cast    G"
   27.34 -
   27.35 --- "direct subclass, cf. 8.1.3"
   27.36 -inductive "subcls1 G" intros
   27.37 -  subcls1I: "\<lbrakk>class G C = Some (D,rest); C \<noteq> Object\<rbrakk> \<Longrightarrow> G\<turnstile>C\<prec>C1D"
   27.38 +abbreviation
   27.39 +  subcls  :: "'c prog => [cname, cname] => bool" ("_ \<turnstile> _ \<preceq>C _"  [71,71,71] 70)
   27.40 +  where "G\<turnstile>C \<preceq>C  D \<equiv> (subcls1 G)^** C D"
   27.41    
   27.42  lemma subcls1D: 
   27.43    "G\<turnstile>C\<prec>C1D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>fs ms. class G C = Some (D,fs,ms))"
   27.44 -apply (erule subcls1.elims)
   27.45 +apply (erule subcls1.cases)
   27.46  apply auto
   27.47  done
   27.48  
   27.49  lemma subcls1_def2: 
   27.50 -  "subcls1 G = 
   27.51 +  "subcls1 G = member2
   27.52       (SIGMA C: {C. is_class G C} . {D. C\<noteq>Object \<and> fst (the (class G C))=D})"
   27.53 -  by (auto simp add: is_class_def dest: subcls1D intro: subcls1I)
   27.54 +  by (auto simp add: is_class_def expand_fun_eq dest: subcls1D intro: subcls1I)
   27.55  
   27.56 -lemma finite_subcls1: "finite (subcls1 G)"
   27.57 -apply(subst subcls1_def2)
   27.58 +lemma finite_subcls1: "finite (Collect2 (subcls1 G))"
   27.59 +apply(simp add: subcls1_def2)
   27.60  apply(rule finite_SigmaI [OF finite_is_class])
   27.61  apply(rule_tac B = "{fst (the (class G C))}" in finite_subset)
   27.62  apply  auto
   27.63  done
   27.64  
   27.65 -lemma subcls_is_class: "(C,D) \<in> (subcls1 G)^+ ==> is_class G C"
   27.66 +lemma subcls_is_class: "(subcls1 G)^++ C D ==> is_class G C"
   27.67  apply (unfold is_class_def)
   27.68 -apply(erule trancl_trans_induct)
   27.69 +apply(erule trancl_trans_induct')
   27.70  apply (auto dest!: subcls1D)
   27.71  done
   27.72  
   27.73  lemma subcls_is_class2 [rule_format (no_asm)]: 
   27.74    "G\<turnstile>C\<preceq>C D \<Longrightarrow> is_class G D \<longrightarrow> is_class G C"
   27.75  apply (unfold is_class_def)
   27.76 -apply (erule rtrancl_induct)
   27.77 +apply (erule rtrancl_induct')
   27.78  apply  (drule_tac [2] subcls1D)
   27.79  apply  auto
   27.80  done
   27.81 @@ -70,18 +54,19 @@
   27.82  constdefs
   27.83    class_rec :: "'c prog \<Rightarrow> cname \<Rightarrow> 'a \<Rightarrow>
   27.84      (cname \<Rightarrow> fdecl list \<Rightarrow> 'c mdecl list \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a"
   27.85 -  "class_rec G == wfrec ((subcls1 G)^-1)
   27.86 +  "class_rec G == wfrec (Collect2 ((subcls1 G)^--1))
   27.87      (\<lambda>r C t f. case class G C of
   27.88           None \<Rightarrow> arbitrary
   27.89         | Some (D,fs,ms) \<Rightarrow> 
   27.90             f C fs ms (if C = Object then t else r D t f))"
   27.91  
   27.92 -lemma class_rec_lemma: "wf ((subcls1 G)^-1) \<Longrightarrow> class G C = Some (D,fs,ms) \<Longrightarrow>
   27.93 +lemma class_rec_lemma: "wfP ((subcls1 G)^--1) \<Longrightarrow> class G C = Some (D,fs,ms) \<Longrightarrow>
   27.94   class_rec G C t f = f C fs ms (if C=Object then t else class_rec G D t f)"
   27.95 -  by (simp add: class_rec_def wfrec cut_apply [OF converseI [OF subcls1I]])
   27.96 +  by (simp add: class_rec_def wfrec [to_pred]
   27.97 +    cut_apply [OF Collect2I [where P="(subcls1 G)^--1"], OF conversepI, OF subcls1I])
   27.98  
   27.99  definition
  27.100 -  "wf_class G = wf ((subcls1 G)^-1)"
  27.101 +  "wf_class G = wfP ((subcls1 G)^--1)"
  27.102  
  27.103  lemma class_rec_func [code func]:
  27.104    "class_rec G C t f = (if wf_class G then
  27.105 @@ -93,13 +78,14 @@
  27.106    case False then show ?thesis by auto
  27.107  next
  27.108    case True
  27.109 -  from `wf_class G` have wf: "wf ((subcls1 G)^-1)"
  27.110 +  from `wf_class G` have wf: "wfP ((subcls1 G)^--1)"
  27.111      unfolding wf_class_def .
  27.112    show ?thesis
  27.113    proof (cases "class G C")
  27.114      case None
  27.115      with wf show ?thesis
  27.116 -      by (simp add: class_rec_def wfrec cut_apply [OF converseI [OF subcls1I]])
  27.117 +      by (simp add: class_rec_def wfrec [to_pred]
  27.118 +        cut_apply [OF Collect2I [where P="(subcls1 G)^--1"], OF conversepI, OF subcls1I])
  27.119    next
  27.120      case (Some x) show ?thesis
  27.121      proof (cases x)
  27.122 @@ -121,7 +107,7 @@
  27.123  defs method_def: "method \<equiv> \<lambda>(G,C). class_rec G C empty (\<lambda>C fs ms ts.
  27.124                             ts ++ map_of (map (\<lambda>(s,m). (s,(C,m))) ms))"
  27.125  
  27.126 -lemma method_rec_lemma: "[|class G C = Some (D,fs,ms); wf ((subcls1 G)^-1)|] ==>
  27.127 +lemma method_rec_lemma: "[|class G C = Some (D,fs,ms); wfP ((subcls1 G)^--1)|] ==>
  27.128    method (G,C) = (if C = Object then empty else method (G,D)) ++  
  27.129    map_of (map (\<lambda>(s,m). (s,(C,m))) ms)"
  27.130  apply (unfold method_def)
  27.131 @@ -135,7 +121,7 @@
  27.132  defs fields_def: "fields \<equiv> \<lambda>(G,C). class_rec G C []    (\<lambda>C fs ms ts.
  27.133                             map (\<lambda>(fn,ft). ((fn,C),ft)) fs @ ts)"
  27.134  
  27.135 -lemma fields_rec_lemma: "[|class G C = Some (D,fs,ms); wf ((subcls1 G)^-1)|] ==>
  27.136 +lemma fields_rec_lemma: "[|class G C = Some (D,fs,ms); wfP ((subcls1 G)^--1)|] ==>
  27.137   fields (G,C) = 
  27.138    map (\<lambda>(fn,ft). ((fn,C),ft)) fs @ (if C = Object then [] else fields (G,D))"
  27.139  apply (unfold fields_def)
  27.140 @@ -156,56 +142,62 @@
  27.141  
  27.142  
  27.143  -- "widening, viz. method invocation conversion,cf. 5.3 i.e. sort of syntactic subtyping"
  27.144 -inductive "widen G" intros 
  27.145 +inductive2
  27.146 +  widen   :: "'c prog => [ty   , ty   ] => bool" ("_ \<turnstile> _ \<preceq> _"   [71,71,71] 70)
  27.147 +  for G :: "'c prog"
  27.148 +where
  27.149    refl   [intro!, simp]:       "G\<turnstile>      T \<preceq> T"   -- "identity conv., cf. 5.1.1"
  27.150 -  subcls         : "G\<turnstile>C\<preceq>C D ==> G\<turnstile>Class C \<preceq> Class D"
  27.151 -  null   [intro!]:             "G\<turnstile>     NT \<preceq> RefT R"
  27.152 +| subcls         : "G\<turnstile>C\<preceq>C D ==> G\<turnstile>Class C \<preceq> Class D"
  27.153 +| null   [intro!]:             "G\<turnstile>     NT \<preceq> RefT R"
  27.154  
  27.155  -- "casting conversion, cf. 5.5 / 5.1.5"
  27.156  -- "left out casts on primitve types"
  27.157 -inductive "cast G" intros
  27.158 +inductive2
  27.159 +  cast    :: "'c prog => [ty   , ty   ] => bool" ("_ \<turnstile> _ \<preceq>? _"  [71,71,71] 70)
  27.160 +  for G :: "'c prog"
  27.161 +where
  27.162    widen:  "G\<turnstile> C\<preceq> D ==> G\<turnstile>C \<preceq>? D"
  27.163 -  subcls: "G\<turnstile> D\<preceq>C C ==> G\<turnstile>Class C \<preceq>? Class D"
  27.164 +| subcls: "G\<turnstile> D\<preceq>C C ==> G\<turnstile>Class C \<preceq>? Class D"
  27.165  
  27.166  lemma widen_PrimT_RefT [iff]: "(G\<turnstile>PrimT pT\<preceq>RefT rT) = False"
  27.167  apply (rule iffI)
  27.168 -apply (erule widen.elims)
  27.169 +apply (erule widen.cases)
  27.170  apply auto
  27.171  done
  27.172  
  27.173  lemma widen_RefT: "G\<turnstile>RefT R\<preceq>T ==> \<exists>t. T=RefT t"
  27.174 -apply (ind_cases "G\<turnstile>S\<preceq>T")
  27.175 +apply (ind_cases2 "G\<turnstile>RefT R\<preceq>T")
  27.176  apply auto
  27.177  done
  27.178  
  27.179  lemma widen_RefT2: "G\<turnstile>S\<preceq>RefT R ==> \<exists>t. S=RefT t"
  27.180 -apply (ind_cases "G\<turnstile>S\<preceq>T")
  27.181 +apply (ind_cases2 "G\<turnstile>S\<preceq>RefT R")
  27.182  apply auto
  27.183  done
  27.184  
  27.185  lemma widen_Class: "G\<turnstile>Class C\<preceq>T ==> \<exists>D. T=Class D"
  27.186 -apply (ind_cases "G\<turnstile>S\<preceq>T")
  27.187 +apply (ind_cases2 "G\<turnstile>Class C\<preceq>T")
  27.188  apply auto
  27.189  done
  27.190  
  27.191  lemma widen_Class_NullT [iff]: "(G\<turnstile>Class C\<preceq>NT) = False"
  27.192  apply (rule iffI)
  27.193 -apply (ind_cases "G\<turnstile>S\<preceq>T")
  27.194 +apply (ind_cases2 "G\<turnstile>Class C\<preceq>NT")
  27.195  apply auto
  27.196  done
  27.197  
  27.198  lemma widen_Class_Class [iff]: "(G\<turnstile>Class C\<preceq> Class D) = (G\<turnstile>C\<preceq>C D)"
  27.199  apply (rule iffI)
  27.200 -apply (ind_cases "G\<turnstile>S\<preceq>T")
  27.201 +apply (ind_cases2 "G\<turnstile>Class C \<preceq> Class D")
  27.202  apply (auto elim: widen.subcls)
  27.203  done
  27.204  
  27.205  lemma widen_NT_Class [simp]: "G \<turnstile> T \<preceq> NT \<Longrightarrow> G \<turnstile> T \<preceq> Class D"
  27.206 -by (ind_cases "G \<turnstile> T \<preceq> NT",  auto)
  27.207 +by (ind_cases2 "G \<turnstile> T \<preceq> NT",  auto)
  27.208  
  27.209  lemma cast_PrimT_RefT [iff]: "(G\<turnstile>PrimT pT\<preceq>? RefT rT) = False"
  27.210  apply (rule iffI)
  27.211 -apply (erule cast.elims)
  27.212 +apply (erule cast.cases)
  27.213  apply auto
  27.214  done
  27.215  
  27.216 @@ -223,7 +215,7 @@
  27.217    next
  27.218      case (subcls C D T)
  27.219      then obtain E where "T = Class E" by (blast dest: widen_Class)
  27.220 -    with subcls show "G\<turnstile>Class C\<preceq>T" by (auto elim: rtrancl_trans)
  27.221 +    with subcls show "G\<turnstile>Class C\<preceq>T" by auto
  27.222    next
  27.223      case (null R RT)
  27.224      then obtain rt where "RT = RefT rt" by (blast dest: widen_RefT)
    28.1 --- a/src/HOL/MicroJava/J/WellForm.thy	Wed Feb 07 17:41:11 2007 +0100
    28.2 +++ b/src/HOL/MicroJava/J/WellForm.thy	Wed Feb 07 17:44:07 2007 +0100
    28.3 @@ -134,13 +134,13 @@
    28.4    apply (auto intro!: map_of_SomeI)
    28.5    done
    28.6  
    28.7 -lemma subcls1_wfD: "[|G\<turnstile>C\<prec>C1D; ws_prog G|] ==> D \<noteq> C \<and> \<not>(D,C)\<in>(subcls1 G)^+"
    28.8 -apply( frule r_into_trancl)
    28.9 +lemma subcls1_wfD: "[|G\<turnstile>C\<prec>C1D; ws_prog G|] ==> D \<noteq> C \<and> \<not> (subcls1 G)^++ D C"
   28.10 +apply( frule trancl.r_into_trancl [where r="subcls1 G"])
   28.11  apply( drule subcls1D)
   28.12  apply(clarify)
   28.13  apply( drule (1) class_wf_struct)
   28.14  apply( unfold ws_cdecl_def)
   28.15 -apply(force simp add: reflcl_trancl [THEN sym] simp del: reflcl_trancl)
   28.16 +apply(force simp add: reflcl_trancl' [THEN sym] simp del: reflcl_trancl')
   28.17  done
   28.18  
   28.19  lemma wf_cdecl_supD: 
   28.20 @@ -149,42 +149,42 @@
   28.21  apply (auto split add: option.split_asm)
   28.22  done
   28.23  
   28.24 -lemma subcls_asym: "[|ws_prog G; (C,D)\<in>(subcls1 G)^+|] ==> \<not>(D,C)\<in>(subcls1 G)^+"
   28.25 -apply(erule tranclE)
   28.26 +lemma subcls_asym: "[|ws_prog G; (subcls1 G)^++ C D|] ==> \<not> (subcls1 G)^++ D C"
   28.27 +apply(erule trancl.cases)
   28.28  apply(fast dest!: subcls1_wfD )
   28.29 -apply(fast dest!: subcls1_wfD intro: trancl_trans)
   28.30 +apply(fast dest!: subcls1_wfD intro: trancl_trans')
   28.31  done
   28.32  
   28.33 -lemma subcls_irrefl: "[|ws_prog G; (C,D)\<in>(subcls1 G)^+|] ==> C \<noteq> D"
   28.34 -apply (erule trancl_trans_induct)
   28.35 +lemma subcls_irrefl: "[|ws_prog G; (subcls1 G)^++ C D|] ==> C \<noteq> D"
   28.36 +apply (erule trancl_trans_induct')
   28.37  apply  (auto dest: subcls1_wfD subcls_asym)
   28.38  done
   28.39  
   28.40 -lemma acyclic_subcls1: "ws_prog G ==> acyclic (subcls1 G)"
   28.41 -apply (unfold acyclic_def)
   28.42 +lemma acyclic_subcls1: "ws_prog G ==> acyclicP (subcls1 G)"
   28.43 +apply (simp add: acyclic_def [to_pred])
   28.44  apply (fast dest: subcls_irrefl)
   28.45  done
   28.46  
   28.47 -lemma wf_subcls1: "ws_prog G ==> wf ((subcls1 G)^-1)"
   28.48 -apply (rule finite_acyclic_wf)
   28.49 -apply ( subst finite_converse)
   28.50 +lemma wf_subcls1: "ws_prog G ==> wfP ((subcls1 G)^--1)"
   28.51 +apply (rule finite_acyclic_wf [to_pred])
   28.52 +apply ( subst finite_converse [to_pred])
   28.53  apply ( rule finite_subcls1)
   28.54 -apply (subst acyclic_converse)
   28.55 +apply (subst acyclic_converse [to_pred])
   28.56  apply (erule acyclic_subcls1)
   28.57  done
   28.58  
   28.59  
   28.60  lemma subcls_induct: 
   28.61 -"[|wf_prog wf_mb G; !!C. \<forall>D. (C,D)\<in>(subcls1 G)^+ --> P D ==> P C|] ==> P C"
   28.62 +"[|wf_prog wf_mb G; !!C. \<forall>D. (subcls1 G)^++ C D --> P D ==> P C|] ==> P C"
   28.63  (is "?A \<Longrightarrow> PROP ?P \<Longrightarrow> _")
   28.64  proof -
   28.65    assume p: "PROP ?P"
   28.66    assume ?A thus ?thesis apply -
   28.67  apply (drule wf_prog_ws_prog)
   28.68  apply(drule wf_subcls1)
   28.69 -apply(drule wf_trancl)
   28.70 -apply(simp only: trancl_converse)
   28.71 -apply(erule_tac a = C in wf_induct)
   28.72 +apply(drule wfP_trancl)
   28.73 +apply(simp only: trancl_converse')
   28.74 +apply(erule_tac a = C in wfP_induct)
   28.75  apply(rule p)
   28.76  apply(auto)
   28.77  done
   28.78 @@ -225,15 +225,15 @@
   28.79  qed
   28.80  
   28.81  lemma subcls_induct_struct: 
   28.82 -"[|ws_prog G; !!C. \<forall>D. (C,D)\<in>(subcls1 G)^+ --> P D ==> P C|] ==> P C"
   28.83 +"[|ws_prog G; !!C. \<forall>D. (subcls1 G)^++ C D --> P D ==> P C|] ==> P C"
   28.84  (is "?A \<Longrightarrow> PROP ?P \<Longrightarrow> _")
   28.85  proof -
   28.86    assume p: "PROP ?P"
   28.87    assume ?A thus ?thesis apply -
   28.88  apply(drule wf_subcls1)
   28.89 -apply(drule wf_trancl)
   28.90 -apply(simp only: trancl_converse)
   28.91 -apply(erule_tac a = C in wf_induct)
   28.92 +apply(drule wfP_trancl)
   28.93 +apply(simp only: trancl_converse')
   28.94 +apply(erule_tac a = C in wfP_induct)
   28.95  apply(rule p)
   28.96  apply(auto)
   28.97  done
   28.98 @@ -339,7 +339,7 @@
   28.99  apply( simp (no_asm))
  28.100  apply( erule UnE)
  28.101  apply(  force)
  28.102 -apply( erule r_into_rtrancl [THEN rtrancl_trans])
  28.103 +apply( erule r_into_rtrancl' [THEN rtrancl_trans'])
  28.104  apply auto
  28.105  done
  28.106  
  28.107 @@ -381,9 +381,9 @@
  28.108  done
  28.109  
  28.110  lemma fields_mono_lemma [rule_format (no_asm)]: 
  28.111 -  "[|ws_prog G; (C',C)\<in>(subcls1 G)^*|] ==>  
  28.112 +  "[|ws_prog G; (subcls1 G)^** C' C|] ==>  
  28.113    x \<in> set (fields (G,C)) --> x \<in> set (fields (G,C'))"
  28.114 -apply(erule converse_rtrancl_induct)
  28.115 +apply(erule converse_rtrancl_induct')
  28.116  apply( safe dest!: subcls1D)
  28.117  apply(subst fields_rec)
  28.118  apply(  auto)
  28.119 @@ -402,10 +402,10 @@
  28.120  "[|field (G,C) fn = Some (fd, fT); G\<turnstile>D\<preceq>C C; ws_prog G|]==>  
  28.121    map_of (fields (G,D)) (fn, fd) = Some fT"
  28.122  apply (drule field_fields)
  28.123 -apply (drule rtranclD)
  28.124 +apply (drule rtranclD')
  28.125  apply safe
  28.126  apply (frule subcls_is_class)
  28.127 -apply (drule trancl_into_rtrancl)
  28.128 +apply (drule trancl_into_rtrancl')
  28.129  apply (fast dest: fields_mono)
  28.130  done
  28.131  
  28.132 @@ -437,10 +437,10 @@
  28.133  apply (frule map_of_SomeD)
  28.134  apply (clarsimp simp add: wf_cdecl_def)
  28.135  apply( clarify)
  28.136 -apply( rule rtrancl_trans)
  28.137 +apply( rule rtrancl_trans')
  28.138  prefer 2
  28.139  apply(  assumption)
  28.140 -apply( rule r_into_rtrancl)
  28.141 +apply( rule r_into_rtrancl')
  28.142  apply( fast intro: subcls1I)
  28.143  done
  28.144  
  28.145 @@ -473,10 +473,10 @@
  28.146  apply (clarsimp simp add: ws_cdecl_def)
  28.147  apply blast
  28.148  apply clarify
  28.149 -apply( rule rtrancl_trans)
  28.150 +apply( rule rtrancl_trans')
  28.151  prefer 2
  28.152  apply(  assumption)
  28.153 -apply( rule r_into_rtrancl)
  28.154 +apply( rule r_into_rtrancl')
  28.155  apply( fast intro: subcls1I)
  28.156  done
  28.157  
  28.158 @@ -484,15 +484,15 @@
  28.159    "[|G\<turnstile>T'\<preceq>C T; wf_prog wf_mb G|] ==>  
  28.160     \<forall>D rT b. method (G,T) sig = Some (D,rT ,b) --> 
  28.161    (\<exists>D' rT' b'. method (G,T') sig = Some (D',rT',b') \<and> G\<turnstile>D'\<preceq>C D \<and> G\<turnstile>rT'\<preceq>rT)"
  28.162 -apply( drule rtranclD)
  28.163 +apply( drule rtranclD')
  28.164  apply( erule disjE)
  28.165  apply(  fast)
  28.166  apply( erule conjE)
  28.167 -apply( erule trancl_trans_induct)
  28.168 +apply( erule trancl_trans_induct')
  28.169  prefer 2
  28.170  apply(  clarify)
  28.171  apply(  drule spec, drule spec, drule spec, erule (1) impE)
  28.172 -apply(  fast elim: widen_trans rtrancl_trans)
  28.173 +apply(  fast elim: widen_trans rtrancl_trans')
  28.174  apply( clarify)
  28.175  apply( drule subcls1D)
  28.176  apply( clarify)
  28.177 @@ -512,7 +512,7 @@
  28.178  apply( unfold wf_cdecl_def)
  28.179  apply( drule map_of_SomeD)
  28.180  apply (auto simp add: wf_mrT_def)
  28.181 -apply (rule rtrancl_trans)
  28.182 +apply (rule rtrancl_trans')
  28.183  defer
  28.184  apply (rule method_wf_mhead [THEN conjunct1])
  28.185  apply (simp only: wf_prog_def)
    29.1 --- a/src/HOL/MicroJava/J/WellType.thy	Wed Feb 07 17:41:11 2007 +0100
    29.2 +++ b/src/HOL/MicroJava/J/WellType.thy	Wed Feb 07 17:44:07 2007 +0100
    29.3 @@ -106,74 +106,57 @@
    29.4    java_mb = "vname list \<times> (vname \<times> ty) list \<times> stmt \<times> expr"
    29.5  -- "method body with parameter names, local variables, block, result expression."
    29.6  -- "local variables might include This, which is hidden anyway"
    29.7 -
    29.8 -consts
    29.9 -  ty_expr :: "('c env \<times> expr      \<times> ty     ) set"
   29.10 -  ty_exprs:: "('c env \<times> expr list \<times> ty list) set"
   29.11 -  wt_stmt :: "('c env \<times> stmt               ) set"
   29.12 -
   29.13 -syntax (xsymbols)
   29.14 -  ty_expr :: "'c env => [expr     , ty     ] => bool" ("_ \<turnstile> _ :: _"   [51,51,51]50)
   29.15 -  ty_exprs:: "'c env => [expr list, ty list] => bool" ("_ \<turnstile> _ [::] _" [51,51,51]50)
   29.16 -  wt_stmt :: "'c env =>  stmt                => bool" ("_ \<turnstile> _ \<surd>"      [51,51   ]50)
   29.17 -
   29.18 -syntax
   29.19 -  ty_expr :: "'c env => [expr     , ty     ] => bool" ("_ |- _ :: _"   [51,51,51]50)
   29.20 -  ty_exprs:: "'c env => [expr list, ty list] => bool" ("_ |- _ [::] _" [51,51,51]50)
   29.21 -  wt_stmt :: "'c env =>  stmt                => bool" ("_ |- _ [ok]"   [51,51   ]50)
   29.22 -
   29.23 -
   29.24 -translations
   29.25 -  "E\<turnstile>e :: T" == "(E,e,T) \<in> ty_expr"
   29.26 -  "E\<turnstile>e[::]T" == "(E,e,T) \<in> ty_exprs"
   29.27 -  "E\<turnstile>c \<surd>"    == "(E,c)   \<in> wt_stmt"
   29.28    
   29.29 -inductive "ty_expr" "ty_exprs" "wt_stmt" intros
   29.30 +inductive2
   29.31 +  ty_expr :: "'c env => expr => ty => bool" ("_ \<turnstile> _ :: _" [51, 51, 51] 50)
   29.32 +  and ty_exprs :: "'c env => expr list => ty list => bool" ("_ \<turnstile> _ [::] _" [51, 51, 51] 50)
   29.33 +  and wt_stmt :: "'c env => stmt => bool" ("_ \<turnstile> _ \<surd>" [51, 51] 50)
   29.34 +where
   29.35    
   29.36    NewC: "[| is_class (prg E) C |] ==>
   29.37           E\<turnstile>NewC C::Class C"  -- "cf. 15.8"
   29.38  
   29.39    -- "cf. 15.15"
   29.40 -  Cast: "[| E\<turnstile>e::C; is_class (prg E) D;
   29.41 +| Cast: "[| E\<turnstile>e::C; is_class (prg E) D;
   29.42              prg E\<turnstile>C\<preceq>? Class D |] ==>
   29.43           E\<turnstile>Cast D e:: Class D"
   29.44  
   29.45    -- "cf. 15.7.1"
   29.46 -  Lit:    "[| typeof (\<lambda>v. None) x = Some T |] ==>
   29.47 +| Lit:    "[| typeof (\<lambda>v. None) x = Some T |] ==>
   29.48           E\<turnstile>Lit x::T"
   29.49  
   29.50    
   29.51    -- "cf. 15.13.1"
   29.52 -  LAcc: "[| localT E v = Some T; is_type (prg E) T |] ==>
   29.53 +| LAcc: "[| localT E v = Some T; is_type (prg E) T |] ==>
   29.54           E\<turnstile>LAcc v::T"
   29.55  
   29.56 -  BinOp:"[| E\<turnstile>e1::T;
   29.57 +| BinOp:"[| E\<turnstile>e1::T;
   29.58              E\<turnstile>e2::T;
   29.59              if bop = Eq then T' = PrimT Boolean
   29.60                          else T' = T \<and> T = PrimT Integer|] ==>
   29.61              E\<turnstile>BinOp bop e1 e2::T'"
   29.62  
   29.63    -- "cf. 15.25, 15.25.1"
   29.64 -  LAss: "[| v ~= This;
   29.65 +| LAss: "[| v ~= This;
   29.66              E\<turnstile>LAcc v::T;
   29.67              E\<turnstile>e::T';
   29.68              prg E\<turnstile>T'\<preceq>T |] ==>
   29.69           E\<turnstile>v::=e::T'"
   29.70  
   29.71    -- "cf. 15.10.1"
   29.72 -  FAcc: "[| E\<turnstile>a::Class C; 
   29.73 +| FAcc: "[| E\<turnstile>a::Class C; 
   29.74              field (prg E,C) fn = Some (fd,fT) |] ==>
   29.75              E\<turnstile>{fd}a..fn::fT"
   29.76  
   29.77    -- "cf. 15.25, 15.25.1"
   29.78 -  FAss: "[| E\<turnstile>{fd}a..fn::T;
   29.79 +| FAss: "[| E\<turnstile>{fd}a..fn::T;
   29.80              E\<turnstile>v        ::T';
   29.81              prg E\<turnstile>T'\<preceq>T |] ==>
   29.82           E\<turnstile>{fd}a..fn:=v::T'"
   29.83  
   29.84  
   29.85    -- "cf. 15.11.1, 15.11.2, 15.11.3"
   29.86 -  Call: "[| E\<turnstile>a::Class C;
   29.87 +| Call: "[| E\<turnstile>a::Class C;
   29.88              E\<turnstile>ps[::]pTs;
   29.89              max_spec (prg E) C (mn, pTs) = {((md,rT),pTs')} |] ==>
   29.90           E\<turnstile>{C}a..mn({pTs'}ps)::rT"
   29.91 @@ -181,32 +164,32 @@
   29.92  -- "well-typed expression lists"
   29.93  
   29.94    -- "cf. 15.11.???"
   29.95 -  Nil: "E\<turnstile>[][::][]"
   29.96 +| Nil: "E\<turnstile>[][::][]"
   29.97  
   29.98    -- "cf. 15.11.???"
   29.99 -  Cons:"[| E\<turnstile>e::T;
  29.100 +| Cons:"[| E\<turnstile>e::T;
  29.101             E\<turnstile>es[::]Ts |] ==>
  29.102          E\<turnstile>e#es[::]T#Ts"
  29.103  
  29.104  -- "well-typed statements"
  29.105  
  29.106 -  Skip:"E\<turnstile>Skip\<surd>"
  29.107 +| Skip:"E\<turnstile>Skip\<surd>"
  29.108  
  29.109 -  Expr:"[| E\<turnstile>e::T |] ==>
  29.110 +| Expr:"[| E\<turnstile>e::T |] ==>
  29.111          E\<turnstile>Expr e\<surd>"
  29.112  
  29.113 -  Comp:"[| E\<turnstile>s1\<surd>; 
  29.114 +| Comp:"[| E\<turnstile>s1\<surd>; 
  29.115             E\<turnstile>s2\<surd> |] ==>
  29.116          E\<turnstile>s1;; s2\<surd>"
  29.117  
  29.118    -- "cf. 14.8"
  29.119 -  Cond:"[| E\<turnstile>e::PrimT Boolean;
  29.120 +| Cond:"[| E\<turnstile>e::PrimT Boolean;
  29.121             E\<turnstile>s1\<surd>;
  29.122             E\<turnstile>s2\<surd> |] ==>
  29.123           E\<turnstile>If(e) s1 Else s2\<surd>"
  29.124  
  29.125    -- "cf. 14.10"
  29.126 -  Loop:"[| E\<turnstile>e::PrimT Boolean;
  29.127 +| Loop:"[| E\<turnstile>e::PrimT Boolean;
  29.128             E\<turnstile>s\<surd> |] ==>
  29.129          E\<turnstile>While(e) s\<surd>"
  29.130  
    30.1 --- a/src/HOL/Nominal/Examples/Compile.thy	Wed Feb 07 17:41:11 2007 +0100
    30.2 +++ b/src/HOL/Nominal/Examples/Compile.thy	Wed Feb 07 17:44:07 2007 +0100
    30.3 @@ -45,62 +45,42 @@
    30.4  
    30.5  text {* valid contexts *}
    30.6  
    30.7 -consts
    30.8 -  ctxts :: "((name\<times>'a::pt_name) list) set" 
    30.9 -  valid :: "(name\<times>'a::pt_name) list \<Rightarrow> bool"
   30.10 -translations
   30.11 -  "valid \<Gamma>" \<rightleftharpoons> "\<Gamma> \<in> ctxts"  
   30.12 -
   30.13 -inductive ctxts
   30.14 -intros
   30.15 -v1[intro]: "valid []"
   30.16 -v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)" (* maybe dom of \<Gamma> *)
   30.17 +inductive2 valid :: "(name\<times>'a::pt_name) list \<Rightarrow> bool"
   30.18 +where
   30.19 +  v1[intro]: "valid []"
   30.20 +| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)" (* maybe dom of \<Gamma> *)
   30.21  
   30.22  text {* typing judgements for trms *}
   30.23  
   30.24 -consts
   30.25 -  typing :: "(((name\<times>ty) list)\<times>trm\<times>ty) set" 
   30.26 -syntax
   30.27 -  "_typing_judge" :: "(name\<times>ty) list\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [80,80,80] 80) 
   30.28 -translations
   30.29 -  "\<Gamma> \<turnstile> t : \<tau>" \<rightleftharpoons> "(\<Gamma>,t,\<tau>) \<in> typing"  
   30.30 -
   30.31 -inductive typing
   30.32 -intros
   30.33 -t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Var x : \<tau>"
   30.34 -t1[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> \<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> App e1 e2 : \<tau>2"
   30.35 -t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) \<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : \<tau>1\<rightarrow>\<tau>2"
   30.36 -t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n : Data(DNat)"
   30.37 -t4[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : Data(\<sigma>1); \<Gamma> \<turnstile> e2 : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Pr e1 e2 : Data (DProd \<sigma>1 \<sigma>2)"
   30.38 -t5[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Fst e : Data(\<sigma>1)"
   30.39 -t6[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Snd e : Data(\<sigma>2)"
   30.40 -t7[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>1)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InL e : Data(DSum \<sigma>1 \<sigma>2)"
   30.41 -t8[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InR e : Data(DSum \<sigma>1 \<sigma>2)"
   30.42 -t9[intro]: "\<lbrakk>x1\<sharp>\<Gamma>; x2\<sharp>\<Gamma>; \<Gamma> \<turnstile> e: Data(DSum \<sigma>1 \<sigma>2); 
   30.43 +inductive2 typing :: "(name\<times>ty) list\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [80,80,80] 80)
   30.44 +where
   30.45 +  t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Var x : \<tau>"
   30.46 +| t1[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> \<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> App e1 e2 : \<tau>2"
   30.47 +| t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) \<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : \<tau>1\<rightarrow>\<tau>2"
   30.48 +| t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n : Data(DNat)"
   30.49 +| t4[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : Data(\<sigma>1); \<Gamma> \<turnstile> e2 : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Pr e1 e2 : Data (DProd \<sigma>1 \<sigma>2)"
   30.50 +| t5[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Fst e : Data(\<sigma>1)"
   30.51 +| t6[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Snd e : Data(\<sigma>2)"
   30.52 +| t7[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>1)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InL e : Data(DSum \<sigma>1 \<sigma>2)"
   30.53 +| t8[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InR e : Data(DSum \<sigma>1 \<sigma>2)"
   30.54 +| t9[intro]: "\<lbrakk>x1\<sharp>\<Gamma>; x2\<sharp>\<Gamma>; \<Gamma> \<turnstile> e: Data(DSum \<sigma>1 \<sigma>2); 
   30.55               ((x1,Data(\<sigma>1))#\<Gamma>) \<turnstile> e1 : \<tau>; ((x2,Data(\<sigma>2))#\<Gamma>) \<turnstile> e2 : \<tau>\<rbrakk> 
   30.56               \<Longrightarrow> \<Gamma> \<turnstile> (Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2) : \<tau>"
   30.57  
   30.58  text {* typing judgements for Itrms *}
   30.59  
   30.60 -consts
   30.61 -  Ityping :: "(((name\<times>tyI) list)\<times>trmI\<times>tyI) set" 
   30.62 -syntax
   30.63 -  "_typing_judge" :: "(name\<times>tyI) list\<Rightarrow>trmI\<Rightarrow>tyI\<Rightarrow>bool" (" _ I\<turnstile> _ : _ " [80,80,80] 80) 
   30.64 -translations
   30.65 -  "\<Gamma> I\<turnstile> t : \<tau>" \<rightleftharpoons> "(\<Gamma>,t,\<tau>) \<in> Ityping"  
   30.66 -
   30.67 -inductive Ityping
   30.68 -intros
   30.69 -t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IVar x : \<tau>"
   30.70 -t1[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> I\<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IApp e1 e2 : \<tau>2"
   30.71 -t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) I\<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> ILam [x].t : \<tau>1\<rightarrow>\<tau>2"
   30.72 -t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> IUnit : DataI(OneI)"
   30.73 -t4[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> INat(n) : DataI(NatI)"
   30.74 -t5[intro]: "\<Gamma> I\<turnstile> e : DataI(NatI) \<Longrightarrow> \<Gamma> I\<turnstile> ISucc(e) : DataI(NatI)"
   30.75 -t6[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> IRef e : DataI (NatI)"
   30.76 -t7[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1\<mapsto>e2 : DataI(OneI)"
   30.77 -t8[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1;;e2 : \<tau>"
   30.78 -t9[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e: DataI(NatI); \<Gamma> I\<turnstile> e1 : \<tau>; \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> Iif e e1 e2 : \<tau>"
   30.79 +inductive2 Ityping :: "(name\<times>tyI) list\<Rightarrow>trmI\<Rightarrow>tyI\<Rightarrow>bool" (" _ I\<turnstile> _ : _ " [80,80,80] 80)
   30.80 +where
   30.81 +  t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IVar x : \<tau>"
   30.82 +| t1[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> I\<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IApp e1 e2 : \<tau>2"
   30.83 +| t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) I\<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> ILam [x].t : \<tau>1\<rightarrow>\<tau>2"
   30.84 +| t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> IUnit : DataI(OneI)"
   30.85 +| t4[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> INat(n) : DataI(NatI)"
   30.86 +| t5[intro]: "\<Gamma> I\<turnstile> e : DataI(NatI) \<Longrightarrow> \<Gamma> I\<turnstile> ISucc(e) : DataI(NatI)"
   30.87 +| t6[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> IRef e : DataI (NatI)"
   30.88 +| t7[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1\<mapsto>e2 : DataI(OneI)"
   30.89 +| t8[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1;;e2 : \<tau>"
   30.90 +| t9[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e: DataI(NatI); \<Gamma> I\<turnstile> e1 : \<tau>; \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> Iif e e1 e2 : \<tau>"
   30.91  
   30.92  text {* capture-avoiding substitution *}
   30.93  
   30.94 @@ -257,46 +237,32 @@
   30.95  
   30.96  text {* big-step evaluation for trms *}
   30.97  
   30.98 -consts
   30.99 -  big :: "(trm\<times>trm) set" 
  30.100 -syntax
  30.101 -  "_big_judge" :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80) 
  30.102 -translations
  30.103 -  "e1 \<Down> e2" \<rightleftharpoons> "(e1,e2) \<in> big"
  30.104 -
  30.105 -inductive big
  30.106 -intros
  30.107 -b0[intro]: "Lam [x].e \<Down> Lam [x].e"
  30.108 -b1[intro]: "\<lbrakk>e1\<Down>Lam [x].e; e2\<Down>e2'; e[x::=e2']\<Down>e'\<rbrakk> \<Longrightarrow> App e1 e2 \<Down> e'"
  30.109 -b2[intro]: "Const n \<Down> Const n"
  30.110 -b3[intro]: "\<lbrakk>e1\<Down>e1'; e2\<Down>e2'\<rbrakk> \<Longrightarrow> Pr e1 e2 \<Down> Pr e1' e2'"
  30.111 -b4[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Fst e\<Down>e1"
  30.112 -b5[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Snd e\<Down>e2"
  30.113 -b6[intro]: "e\<Down>e' \<Longrightarrow> InL e \<Down> InL e'"
  30.114 -b7[intro]: "e\<Down>e' \<Longrightarrow> InR e \<Down> InR e'"
  30.115 -b8[intro]: "\<lbrakk>e\<Down>InL e'; e1[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"
  30.116 -b9[intro]: "\<lbrakk>e\<Down>InR e'; e2[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"
  30.117 +inductive2 big :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
  30.118 +where
  30.119 +  b0[intro]: "Lam [x].e \<Down> Lam [x].e"
  30.120 +| b1[intro]: "\<lbrakk>e1\<Down>Lam [x].e; e2\<Down>e2'; e[x::=e2']\<Down>e'\<rbrakk> \<Longrightarrow> App e1 e2 \<Down> e'"
  30.121 +| b2[intro]: "Const n \<Down> Const n"
  30.122 +| b3[intro]: "\<lbrakk>e1\<Down>e1'; e2\<Down>e2'\<rbrakk> \<Longrightarrow> Pr e1 e2 \<Down> Pr e1' e2'"
  30.123 +| b4[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Fst e\<Down>e1"
  30.124 +| b5[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Snd e\<Down>e2"
  30.125 +| b6[intro]: "e\<Down>e' \<Longrightarrow> InL e \<Down> InL e'"
  30.126 +| b7[intro]: "e\<Down>e' \<Longrightarrow> InR e \<Down> InR e'"
  30.127 +| b8[intro]: "\<lbrakk>e\<Down>InL e'; e1[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"
  30.128 +| b9[intro]: "\<lbrakk>e\<Down>InR e'; e2[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"
  30.129  
  30.130 -consts
  30.131 -  Ibig :: "(((nat\<Rightarrow>nat)\<times>trmI)\<times>((nat\<Rightarrow>nat)\<times>trmI)) set" 
  30.132 -syntax
  30.133 -  "_Ibig_judge" :: "((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>bool" ("_ I\<Down> _" [80,80] 80) 
  30.134 -translations
  30.135 -  "(m,e1) I\<Down> (m',e2)" \<rightleftharpoons> "((m,e1),(m',e2)) \<in> Ibig"
  30.136 -
  30.137 -inductive Ibig
  30.138 -intros
  30.139 -m0[intro]: "(m,ILam [x].e) I\<Down> (m,ILam [x].e)"
  30.140 -m1[intro]: "\<lbrakk>(m,e1)I\<Down>(m',ILam [x].e); (m',e2)I\<Down>(m'',e3); (m'',e[x::=e3])I\<Down>(m''',e4)\<rbrakk> 
  30.141 +inductive2 Ibig :: "((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>bool" ("_ I\<Down> _" [80,80] 80)
  30.142 +where
  30.143 +  m0[intro]: "(m,ILam [x].e) I\<Down> (m,ILam [x].e)"
  30.144 +| m1[intro]: "\<lbrakk>(m,e1)I\<Down>(m',ILam [x].e); (m',e2)I\<Down>(m'',e3); (m'',e[x::=e3])I\<Down>(m''',e4)\<rbrakk> 
  30.145              \<Longrightarrow> (m,IApp e1 e2) I\<Down> (m''',e4)"
  30.146 -m2[intro]: "(m,IUnit) I\<Down> (m,IUnit)"
  30.147 -m3[intro]: "(m,INat(n))I\<Down>(m,INat(n))"
  30.148 -m4[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,ISucc(e))I\<Down>(m',INat(n+1))"
  30.149 -m5[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,IRef(e))I\<Down>(m',INat(m' n))"
  30.150 -m6[intro]: "\<lbrakk>(m,e1)I\<Down>(m',INat(n1)); (m',e2)I\<Down>(m'',INat(n2))\<rbrakk> \<Longrightarrow> (m,e1\<mapsto>e2)I\<Down>(m''(n1:=n2),IUnit)"
  30.151 -m7[intro]: "\<lbrakk>(m,e1)I\<Down>(m',IUnit); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,e1;;e2)I\<Down>(m'',e)"
  30.152 -m8[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(n)); n\<noteq>0; (m',e1)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"
  30.153 -m9[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(0)); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"
  30.154 +| m2[intro]: "(m,IUnit) I\<Down> (m,IUnit)"
  30.155 +| m3[intro]: "(m,INat(n))I\<Down>(m,INat(n))"
  30.156 +| m4[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,ISucc(e))I\<Down>(m',INat(n+1))"
  30.157 +| m5[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,IRef(e))I\<Down>(m',INat(m' n))"
  30.158 +| m6[intro]: "\<lbrakk>(m,e1)I\<Down>(m',INat(n1)); (m',e2)I\<Down>(m'',INat(n2))\<rbrakk> \<Longrightarrow> (m,e1\<mapsto>e2)I\<Down>(m''(n1:=n2),IUnit)"
  30.159 +| m7[intro]: "\<lbrakk>(m,e1)I\<Down>(m',IUnit); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,e1;;e2)I\<Down>(m'',e)"
  30.160 +| m8[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(n)); n\<noteq>0; (m',e1)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"
  30.161 +| m9[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(0)); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"
  30.162  
  30.163  text {* Translation functions *}
  30.164  
    31.1 --- a/src/HOL/Nominal/Examples/SN.thy	Wed Feb 07 17:41:11 2007 +0100
    31.2 +++ b/src/HOL/Nominal/Examples/SN.thy	Wed Feb 07 17:44:07 2007 +0100
    31.3 @@ -45,21 +45,16 @@
    31.4  apply(simp_all add: fresh_atm)
    31.5  done
    31.6  
    31.7 -consts
    31.8 -  Beta :: "(lam\<times>lam) set"
    31.9 -syntax 
   31.10 -  "_Beta"       :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^isub>\<beta> _" [80,80] 80)
   31.11 -  "_Beta_star"  :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^isub>\<beta>\<^sup>* _" [80,80] 80)
   31.12 -translations 
   31.13 -  "t1 \<longrightarrow>\<^isub>\<beta> t2" \<rightleftharpoons> "(t1,t2) \<in> Beta"
   31.14 -  "t1 \<longrightarrow>\<^isub>\<beta>\<^sup>* t2" \<rightleftharpoons> "(t1,t2) \<in> Beta\<^sup>*"
   31.15 -inductive Beta
   31.16 -  intros
   31.17 +inductive2 Beta :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^isub>\<beta> _" [80,80] 80)
   31.18 +where
   31.19    b1[intro!]: "s1\<longrightarrow>\<^isub>\<beta>s2 \<Longrightarrow> (App s1 t)\<longrightarrow>\<^isub>\<beta>(App s2 t)"
   31.20 -  b2[intro!]: "s1\<longrightarrow>\<^isub>\<beta>s2 \<Longrightarrow> (App t s1)\<longrightarrow>\<^isub>\<beta>(App t s2)"
   31.21 -  b3[intro!]: "s1\<longrightarrow>\<^isub>\<beta>s2 \<Longrightarrow> (Lam [a].s1)\<longrightarrow>\<^isub>\<beta> (Lam [(a::name)].s2)"
   31.22 -  b4[intro!]: "(App (Lam [(a::name)].s1) s2)\<longrightarrow>\<^isub>\<beta>(s1[a::=s2])"
   31.23 +| b2[intro!]: "s1\<longrightarrow>\<^isub>\<beta>s2 \<Longrightarrow> (App t s1)\<longrightarrow>\<^isub>\<beta>(App t s2)"
   31.24 +| b3[intro!]: "s1\<longrightarrow>\<^isub>\<beta>s2 \<Longrightarrow> (Lam [a].s1)\<longrightarrow>\<^isub>\<beta> (Lam [(a::name)].s2)"
   31.25 +| b4[intro!]: "(App (Lam [(a::name)].s1) s2)\<longrightarrow>\<^isub>\<beta>(s1[a::=s2])"
   31.26  
   31.27 +abbreviation "Beta_star"  :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^isub>\<beta>\<^sup>* _" [80,80] 80) where
   31.28 +  "t1 \<longrightarrow>\<^isub>\<beta>\<^sup>* t2 \<equiv> Beta\<^sup>*\<^sup>* t1 t2"
   31.29 + 
   31.30  lemma eqvt_beta: 
   31.31    fixes pi :: "name prm"
   31.32    and   t  :: "lam"
   31.33 @@ -86,7 +81,7 @@
   31.34    next
   31.35      case b2 thus ?case using a2 by (simp, blast intro: eqvt_beta)
   31.36    next
   31.37 -    case (b3 a s1 s2)
   31.38 +    case (b3 s1 s2 a)
   31.39      have j1: "s1 \<longrightarrow>\<^isub>\<beta> s2" by fact
   31.40      have j2: "\<And>x (pi::name prm). P x (pi\<bullet>s1) (pi\<bullet>s2)" by fact
   31.41      show ?case 
   31.42 @@ -137,7 +132,7 @@
   31.43  
   31.44  
   31.45  lemma beta_abs: "Lam [a].t\<longrightarrow>\<^isub>\<beta> t'\<Longrightarrow>\<exists>t''. t'=Lam [a].t'' \<and> t\<longrightarrow>\<^isub>\<beta> t''"
   31.46 -apply(ind_cases "Lam [a].t  \<longrightarrow>\<^isub>\<beta> t'")
   31.47 +apply(ind_cases2 "Lam [a].t  \<longrightarrow>\<^isub>\<beta> t'")
   31.48  apply(auto simp add: lam.distinct lam.inject)
   31.49  apply(auto simp add: alpha)
   31.50  apply(rule_tac x="[(a,aa)]\<bullet>s2" in exI)
   31.51 @@ -201,15 +196,10 @@
   31.52    "dom_ty []    = []"
   31.53    "dom_ty (x#\<Gamma>) = (fst x)#(dom_ty \<Gamma>)" 
   31.54  
   31.55 -consts
   31.56 -  ctxts :: "((name\<times>ty) list) set" 
   31.57 -  valid :: "(name\<times>ty) list \<Rightarrow> bool"
   31.58 -translations
   31.59 -  "valid \<Gamma>" \<rightleftharpoons> "\<Gamma> \<in> ctxts"  
   31.60 -inductive ctxts
   31.61 -intros
   31.62 -v1[intro]: "valid []"
   31.63 -v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)"
   31.64 +inductive2 valid :: "(name\<times>ty) list \<Rightarrow> bool"
   31.65 +where
   31.66 +  v1[intro]: "valid []"
   31.67 +| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)"
   31.68  
   31.69  lemma valid_eqvt:
   31.70    fixes   pi:: "name prm"
   31.71 @@ -238,7 +228,7 @@
   31.72    and    a :: "name"
   31.73    and    \<tau> :: "ty"
   31.74    shows "valid ((a,\<tau>)#\<Gamma>) \<Longrightarrow> valid \<Gamma> \<and> a\<sharp>\<Gamma>"
   31.75 -apply(ind_cases "valid ((a,\<tau>)#\<Gamma>)", simp)
   31.76 +apply(ind_cases2 "valid ((a,\<tau>)#\<Gamma>)", simp)
   31.77  done
   31.78  
   31.79  lemma valid_unicity[rule_format]: 
   31.80 @@ -251,18 +241,11 @@
   31.81  apply(auto dest!: valid_elim fresh_context)
   31.82  done
   31.83  
   31.84 -consts
   31.85 -  typing :: "(((name\<times>ty) list)\<times>lam\<times>ty) set" 
   31.86 -syntax
   31.87 -  "_typing_judge" :: "(name\<times>ty) list\<Rightarrow>lam\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [80,80,80] 80) 
   31.88 -translations
   31.89 -  "\<Gamma> \<turnstile> t : \<tau>" \<rightleftharpoons> "(\<Gamma>,t,\<tau>) \<in> typing"  
   31.90 -
   31.91 -inductive typing
   31.92 -intros
   31.93 -t1[intro]: "\<lbrakk>valid \<Gamma>; (a,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Var a : \<tau>"
   31.94 -t2[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : \<tau>\<rightarrow>\<sigma>; \<Gamma> \<turnstile> t2 : \<tau>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> App t1 t2 : \<sigma>"
   31.95 -t3[intro]: "\<lbrakk>a\<sharp>\<Gamma>;((a,\<tau>)#\<Gamma>) \<turnstile> t : \<sigma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [a].t : \<tau>\<rightarrow>\<sigma>"
   31.96 +inductive2 typing :: "(name\<times>ty) list\<Rightarrow>lam\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [80,80,80] 80)
   31.97 +where
   31.98 +  t1[intro]: "\<lbrakk>valid \<Gamma>; (a,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Var a : \<tau>"
   31.99 +| t2[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : \<tau>\<rightarrow>\<sigma>; \<Gamma> \<turnstile> t2 : \<tau>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> App t1 t2 : \<sigma>"
  31.100 +| t3[intro]: "\<lbrakk>a\<sharp>\<Gamma>;((a,\<tau>)#\<Gamma>) \<turnstile> t : \<sigma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [a].t : \<tau>\<rightarrow>\<sigma>"
  31.101  
  31.102  lemma eqvt_typing: 
  31.103    fixes  \<Gamma> :: "(name\<times>ty) list"
  31.104 @@ -273,14 +256,14 @@
  31.105    shows "(pi\<bullet>\<Gamma>) \<turnstile> (pi\<bullet>t) : \<tau>"
  31.106  using a
  31.107  proof (induct)
  31.108 -  case (t1 \<Gamma> \<tau> a)
  31.109 +  case (t1 \<Gamma> a \<tau>)
  31.110    have "valid (pi\<bullet>\<Gamma>)" by (rule valid_eqvt)
  31.111    moreover
  31.112    have "(pi\<bullet>(a,\<tau>))\<in>((pi::name prm)\<bullet>set \<Gamma>)" by (rule pt_set_bij2[OF pt_name_inst, OF at_name_inst])
  31.113    ultimately show "(pi\<bullet>\<Gamma>) \<turnstile> ((pi::name prm)\<bullet>Var a) : \<tau>"
  31.114      using typing.t1 by (force simp add: pt_list_set_pi[OF pt_name_inst, symmetric])
  31.115  next 
  31.116 -  case (t3 \<Gamma> \<sigma> \<tau> a t)
  31.117 +  case (t3 a \<Gamma> \<tau> t \<sigma>)
  31.118    moreover have "(pi\<bullet>a)\<sharp>(pi\<bullet>\<Gamma>)" by (simp add: fresh_bij)
  31.119    ultimately show "(pi\<bullet>\<Gamma>) \<turnstile> (pi\<bullet>Lam [a].t) :\<tau>\<rightarrow>\<sigma>" by force 
  31.120  qed (auto)
  31.121 @@ -302,7 +285,7 @@
  31.122  proof -
  31.123    from a have "\<And>(pi::name prm) x. P x (pi\<bullet>\<Gamma>) (pi\<bullet>t) \<tau>"
  31.124    proof (induct)
  31.125 -    case (t1 \<Gamma> \<tau> a)
  31.126 +    case (t1 \<Gamma> a \<tau>)
  31.127      have j1: "valid \<Gamma>" by fact
  31.128      have j2: "(a,\<tau>)\<in>set \<Gamma>" by fact
  31.129      from j1 have j3: "valid (pi\<bullet>\<Gamma>)" by (rule valid_eqvt)
  31.130 @@ -310,10 +293,10 @@
  31.131      hence j4: "(pi\<bullet>a,\<tau>)\<in>set (pi\<bullet>\<Gamma>)" by (simp add: pt_list_set_pi[OF pt_name_inst])
  31.132      show "P x (pi\<bullet>\<Gamma>) (pi\<bullet>(Var a)) \<tau>" using a1 j3 j4 by simp
  31.133    next
  31.134 -    case (t2 \<Gamma> \<sigma> \<tau> t1 t2)
  31.135 +    case (t2 \<Gamma> t1 \<tau> \<sigma> t2)
  31.136      thus ?case using a2 by (simp, blast intro: eqvt_typing)
  31.137    next
  31.138 -    case (t3 \<Gamma> \<sigma> \<tau> a t)
  31.139 +    case (t3 a \<Gamma> \<tau> t \<sigma>)
  31.140      have k1: "a\<sharp>\<Gamma>" by fact
  31.141      have k2: "((a,\<tau>)#\<Gamma>)\<turnstile>t:\<sigma>" by fact
  31.142      have k3: "\<And>(pi::name prm) (x::'a::fs_name). P x (pi \<bullet>((a,\<tau>)#\<Gamma>)) (pi\<bullet>t) \<sigma>" by fact
  31.143 @@ -375,17 +358,17 @@
  31.144  done
  31.145  
  31.146  lemma t1_elim: "\<Gamma> \<turnstile> Var a : \<tau> \<Longrightarrow> valid \<Gamma> \<and> (a,\<tau>) \<in> set \<Gamma>"
  31.147 -apply(ind_cases "\<Gamma> \<turnstile> Var a : \<tau>")
  31.148 +apply(ind_cases2 "\<Gamma> \<turnstile> Var a : \<tau>")
  31.149  apply(auto simp add: lam.inject lam.distinct)
  31.150  done
  31.151  
  31.152  lemma t2_elim: "\<Gamma> \<turnstile> App t1 t2 : \<sigma> \<Longrightarrow> \<exists>\<tau>. (\<Gamma> \<turnstile> t1 : \<tau>\<rightarrow>\<sigma> \<and> \<Gamma> \<turnstile> t2 : \<tau>)"
  31.153 -apply(ind_cases "\<Gamma> \<turnstile> App t1 t2 : \<sigma>")
  31.154 +apply(ind_cases2 "\<Gamma> \<turnstile> App t1 t2 : \<sigma>")
  31.155  apply(auto simp add: lam.inject lam.distinct)
  31.156  done
  31.157  
  31.158  lemma t3_elim: "\<lbrakk>\<Gamma> \<turnstile> Lam [a].t : \<sigma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> \<exists>\<tau> \<tau>'. \<sigma>=\<tau>\<rightarrow>\<tau>' \<and> ((a,\<tau>)#\<Gamma>) \<turnstile> t : \<tau>'"
  31.159 -apply(ind_cases "\<Gamma> \<turnstile> Lam [a].t : \<sigma>")
  31.160 +apply(ind_cases2 "\<Gamma> \<turnstile> Lam [a].t : \<sigma>")
  31.161  apply(auto simp add: lam.distinct lam.inject alpha) 
  31.162  apply(drule_tac pi="[(a,aa)]::name prm" in eqvt_typing)
  31.163  apply(simp)
  31.164 @@ -534,7 +517,7 @@
  31.165  
  31.166  constdefs
  31.167    "SN" :: "lam \<Rightarrow> bool"
  31.168 -  "SN t \<equiv> t\<in>termi Beta"
  31.169 +  "SN t \<equiv> termi Beta t"
  31.170  
  31.171  lemma SN_preserved: "\<lbrakk>SN(t1);t1\<longrightarrow>\<^isub>\<beta> t2\<rbrakk>\<Longrightarrow>SN(t2)"
  31.172  apply(simp add: SN_def)
  31.173 @@ -561,30 +544,24 @@
  31.174    "NEUT t \<equiv> (\<exists>a. t=Var a)\<or>(\<exists>t1 t2. t=App t1 t2)" 
  31.175  
  31.176  (* a slight hack to get the first element of applications *)
  31.177 -consts
  31.178 -  FST :: "(lam\<times>lam) set"
  31.179 -syntax 
  31.180 -  "FST_judge"   :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<guillemotright> _" [80,80] 80)
  31.181 -translations 
  31.182 -  "t1 \<guillemotright> t2" \<rightleftharpoons> "(t1,t2) \<in> FST"
  31.183 -inductive FST
  31.184 -  intros
  31.185 +inductive2 FST :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<guillemotright> _" [80,80] 80)
  31.186 +where
  31.187  fst[intro!]:  "(App t s) \<guillemotright> t"
  31.188  
  31.189  lemma fst_elim[elim!]: 
  31.190    shows "(App t s) \<guillemotright> t' \<Longrightarrow> t=t'"
  31.191 -apply(ind_cases "App t s \<guillemotright> t'")
  31.192 +apply(ind_cases2 "App t s \<guillemotright> t'")
  31.193  apply(simp add: lam.inject)
  31.194  done
  31.195  
  31.196  lemma qq3: "SN(App t s)\<Longrightarrow>SN(t)"
  31.197  apply(simp add: SN_def)
  31.198 -apply(subgoal_tac "\<forall>z. (App t s \<guillemotright> z) \<longrightarrow> z\<in>termi Beta")(*A*)
  31.199 +apply(subgoal_tac "\<forall>z. (App t s \<guillemotright> z) \<longrightarrow> termi Beta z")(*A*)
  31.200  apply(force)
  31.201  (*A*)
  31.202  apply(erule acc_induct)
  31.203  apply(clarify)
  31.204 -apply(ind_cases "x \<guillemotright> z")
  31.205 +apply(ind_cases2 "x \<guillemotright> z" for x z)
  31.206  apply(clarify)
  31.207  apply(rule accI)
  31.208  apply(auto intro: b1)
  31.209 @@ -626,7 +603,7 @@
  31.210  apply(force simp only: NEUT_def)
  31.211  apply(simp (no_asm) add: CR3_RED_def)
  31.212  apply(clarify)
  31.213 -apply(ind_cases "App t x \<longrightarrow>\<^isub>\<beta> t'")
  31.214 +apply(ind_cases2 "App t x \<longrightarrow>\<^isub>\<beta> t'" for x t t')
  31.215  apply(simp_all add: lam.inject)
  31.216  apply(simp only:  CR3_RED_def)
  31.217  apply(drule_tac x="s2" in spec)
  31.218 @@ -701,21 +678,21 @@
  31.219  qed
  31.220      
  31.221  lemma double_acc_aux:
  31.222 -  assumes a_acc: "a \<in> acc r"
  31.223 -  and b_acc: "b \<in> acc r"
  31.224 +  assumes a_acc: "acc r a"
  31.225 +  and b_acc: "acc r b"
  31.226    and hyp: "\<And>x z.
  31.227 -    (\<And>y. (y, x) \<in> r \<Longrightarrow> y \<in> acc r) \<Longrightarrow>
  31.228 -    (\<And>y. (y, x) \<in> r \<Longrightarrow> P y z) \<Longrightarrow>
  31.229 -    (\<And>u. (u, z) \<in> r \<Longrightarrow> u \<in> acc r) \<Longrightarrow>
  31.230 -    (\<And>u. (u, z) \<in> r \<Longrightarrow> P x u) \<Longrightarrow> P x z"
  31.231 +    (\<And>y. r y x \<Longrightarrow> acc r y) \<Longrightarrow>
  31.232 +    (\<And>y. r y x \<Longrightarrow> P y z) \<Longrightarrow>
  31.233 +    (\<And>u. r u z \<Longrightarrow> acc r u) \<Longrightarrow>
  31.234 +    (\<And>u. r u z \<Longrightarrow> P x u) \<Longrightarrow> P x z"
  31.235    shows "P a b"
  31.236  proof -
  31.237    from a_acc
  31.238 -  have r: "\<And>b. b \<in> acc r \<Longrightarrow> P a b"
  31.239 +  have r: "\<And>b. acc r b \<Longrightarrow> P a b"
  31.240    proof (induct a rule: acc.induct)
  31.241      case (accI x)
  31.242      note accI' = accI
  31.243 -    have "b \<in> acc r" .
  31.244 +    have "acc r b" .
  31.245      thus ?case
  31.246      proof (induct b rule: acc.induct)
  31.247        case (accI y)
  31.248 @@ -734,7 +711,7 @@
  31.249  qed
  31.250  
  31.251  lemma double_acc:
  31.252 -  "\<lbrakk>a \<in> acc r; b \<in> acc r; \<forall>x z. ((\<forall>y. (y, x)\<in>r\<longrightarrow>P y z)\<and>(\<forall>u. (u, z)\<in>r\<longrightarrow>P x u))\<longrightarrow>P x z\<rbrakk>\<Longrightarrow>P a b"
  31.253 +  "\<lbrakk>acc r a; acc r b; \<forall>x z. ((\<forall>y. r y x \<longrightarrow> P y z) \<and> (\<forall>u. r u z \<longrightarrow> P x u)) \<longrightarrow> P x z\<rbrakk> \<Longrightarrow> P a b"
  31.254  apply(rule_tac r="r" in double_acc_aux)
  31.255  apply(assumption)+
  31.256  apply(blast)
  31.257 @@ -743,7 +720,7 @@
  31.258  lemma abs_RED: "(\<forall>s\<in>RED \<tau>. t[x::=s]\<in>RED \<sigma>)\<longrightarrow>Lam [x].t\<in>RED (\<tau>\<rightarrow>\<sigma>)"
  31.259  apply(simp)
  31.260  apply(clarify)
  31.261 -apply(subgoal_tac "t\<in>termi Beta")(*1*)
  31.262 +apply(subgoal_tac "termi Beta t")(*1*)
  31.263  apply(erule rev_mp)
  31.264  apply(subgoal_tac "u \<in> RED \<tau>")(*A*)
  31.265  apply(erule rev_mp)
  31.266 @@ -764,7 +741,7 @@
  31.267  apply(force simp add: NEUT_def)
  31.268  apply(simp add: CR3_RED_def)
  31.269  apply(clarify)
  31.270 -apply(ind_cases "App(Lam[x].xa) z \<longrightarrow>\<^isub>\<beta> t'")
  31.271 +apply(ind_cases2 "App(Lam[x].xa) z \<longrightarrow>\<^isub>\<beta> t'" for xa z t')
  31.272  apply(auto simp add: lam.inject lam.distinct)
  31.273  apply(drule beta_abs)
  31.274  apply(auto)
  31.275 @@ -813,7 +790,7 @@
  31.276  apply(force simp add: NEUT_def)
  31.277  apply(simp add: NORMAL_def)
  31.278  apply(clarify)
  31.279 -apply(ind_cases "Var x \<longrightarrow>\<^isub>\<beta> t'")
  31.280 +apply(ind_cases2 "Var x \<longrightarrow>\<^isub>\<beta> t'" for t')
  31.281  apply(auto simp add: lam.inject lam.distinct)
  31.282  apply(force simp add: RED_props)
  31.283  apply(simp add: id_subs)
    32.1 --- a/src/HOL/Tools/inductive_codegen.ML	Wed Feb 07 17:41:11 2007 +0100
    32.2 +++ b/src/HOL/Tools/inductive_codegen.ML	Wed Feb 07 17:44:07 2007 +0100
    32.3 @@ -7,7 +7,7 @@
    32.4  
    32.5  signature INDUCTIVE_CODEGEN =
    32.6  sig
    32.7 -  val add : string option -> attribute
    32.8 +  val add : string option -> int option -> attribute
    32.9    val setup : theory -> theory
   32.10  end;
   32.11  
   32.12 @@ -16,6 +16,17 @@
   32.13  
   32.14  open Codegen;
   32.15  
   32.16 +(* read off parameters of inductive predicate from raw induction rule *)
   32.17 +fun params_of induct =
   32.18 +  let
   32.19 +    val (_ $ t $ u :: _) =
   32.20 +      HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct));
   32.21 +    val (_, ts) = strip_comb t;
   32.22 +    val (_, us) = strip_comb u
   32.23 +  in
   32.24 +    List.take (ts, length ts - length us)
   32.25 +  end;
   32.26 +
   32.27  (**** theory data ****)
   32.28  
   32.29  fun merge_rules tabs =
   32.30 @@ -26,7 +37,7 @@
   32.31  (struct
   32.32    val name = "HOL/inductive_codegen";
   32.33    type T =
   32.34 -    {intros : (thm * string) list Symtab.table,
   32.35 +    {intros : (thm * (string * int)) list Symtab.table,
   32.36       graph : unit Graph.T,
   32.37       eqns : (thm * string) list Symtab.table};
   32.38    val empty =
   32.39 @@ -47,39 +58,46 @@
   32.40  
   32.41  fun add_node (g, x) = Graph.new_node (x, ()) g handle Graph.DUP _ => g;
   32.42  
   32.43 -fun add optmod = Thm.declaration_attribute (fn thm => Context.mapping (fn thy =>
   32.44 +fun add optmod optnparms = Thm.declaration_attribute (fn thm => Context.mapping (fn thy =>
   32.45    let
   32.46      val {intros, graph, eqns} = CodegenData.get thy;
   32.47      fun thyname_of s = (case optmod of
   32.48        NONE => thyname_of_const s thy | SOME s => s);
   32.49 -  in (case concl_of thm of
   32.50 -      _ $ (Const ("op :", _) $ _ $ t) => (case head_of t of
   32.51 -        Const (s, _) =>
   32.52 -          let val cs = foldr add_term_consts [] (prems_of thm)
   32.53 -          in CodegenData.put
   32.54 -            {intros = intros |>
   32.55 -             Symtab.update (s, Symtab.lookup_list intros s @ [(thm, thyname_of s)]),
   32.56 -             graph = foldr (uncurry (Graph.add_edge o pair s))
   32.57 -               (Library.foldl add_node (graph, s :: cs)) cs,
   32.58 -             eqns = eqns} thy
   32.59 -          end
   32.60 -      | _ => (warn thm; thy))
   32.61 -    | _ $ (Const ("op =", _) $ t $ _) => (case head_of t of
   32.62 +  in (case Option.map strip_comb (try HOLogic.dest_Trueprop (concl_of thm)) of
   32.63 +      SOME (Const ("op =", _), [t, _]) => (case head_of t of
   32.64          Const (s, _) =>
   32.65            CodegenData.put {intros = intros, graph = graph,
   32.66               eqns = eqns |> Symtab.update
   32.67                 (s, Symtab.lookup_list eqns s @ [(thm, thyname_of s)])} thy
   32.68        | _ => (warn thm; thy))
   32.69 +    | SOME (Const (s, _), _) =>
   32.70 +        let
   32.71 +          val cs = foldr add_term_consts [] (prems_of thm);
   32.72 +          val rules = Symtab.lookup_list intros s;
   32.73 +          val nparms = (case optnparms of
   32.74 +            SOME k => k
   32.75 +          | NONE => (case rules of
   32.76 +             [] => (case try (InductivePackage.the_inductive (ProofContext.init thy)) s of
   32.77 +                 SOME (_, {raw_induct, ...}) => length (params_of raw_induct)
   32.78 +               | NONE => 0)
   32.79 +            | xs => snd (snd (snd (split_last xs)))))
   32.80 +        in CodegenData.put
   32.81 +          {intros = intros |>
   32.82 +           Symtab.update (s, rules @ [(thm, (thyname_of s, nparms))]),
   32.83 +           graph = foldr (uncurry (Graph.add_edge o pair s))
   32.84 +             (Library.foldl add_node (graph, s :: cs)) cs,
   32.85 +           eqns = eqns} thy
   32.86 +        end
   32.87      | _ => (warn thm; thy))
   32.88    end) I);
   32.89  
   32.90  fun get_clauses thy s =
   32.91    let val {intros, graph, ...} = CodegenData.get thy
   32.92    in case Symtab.lookup intros s of
   32.93 -      NONE => (case OldInductivePackage.get_inductive thy s of
   32.94 +      NONE => (case try (InductivePackage.the_inductive (ProofContext.init thy)) s of
   32.95          NONE => NONE
   32.96 -      | SOME ({names, ...}, {intrs, ...}) =>
   32.97 -          SOME (names, thyname_of_const s thy,
   32.98 +      | SOME ({names, ...}, {intrs, raw_induct, ...}) =>
   32.99 +          SOME (names, thyname_of_const s thy, length (params_of raw_induct),
  32.100              preprocess thy intrs))
  32.101      | SOME _ =>
  32.102          let
  32.103 @@ -87,64 +105,11 @@
  32.104              (fn xs => s mem xs) (Graph.strong_conn graph);
  32.105            val intrs = List.concat (map
  32.106              (fn s => the (Symtab.lookup intros s)) names);
  32.107 -          val (_, (_, thyname)) = split_last intrs
  32.108 -        in SOME (names, thyname, preprocess thy (map fst intrs)) end
  32.109 +          val (_, (_, (thyname, nparms))) = split_last intrs
  32.110 +        in SOME (names, thyname, nparms, preprocess thy (map fst intrs)) end
  32.111    end;
  32.112  
  32.113  
  32.114 -(**** improper tuples ****)
  32.115 -
  32.116 -fun prod_factors p (Const ("Pair", _) $ t $ u) =
  32.117 -      p :: prod_factors (1::p) t @ prod_factors (2::p) u
  32.118 -  | prod_factors p _ = [];
  32.119 -
  32.120 -fun split_prod p ps t = if p mem ps then (case t of
  32.121 -       Const ("Pair", _) $ t $ u =>
  32.122 -         split_prod (1::p) ps t @ split_prod (2::p) ps u
  32.123 -     | _ => error "Inconsistent use of products") else [t];
  32.124 -
  32.125 -fun full_split_prod (Const ("Pair", _) $ t $ u) =
  32.126 -      full_split_prod t @ full_split_prod u
  32.127 -  | full_split_prod t = [t];
  32.128 -
  32.129 -datatype factors = FVar of int list list | FFix of int list list;
  32.130 -
  32.131 -exception Factors;
  32.132 -
  32.133 -fun mg_factor (FVar f) (FVar f') = FVar (f inter f')
  32.134 -  | mg_factor (FVar f) (FFix f') =
  32.135 -      if f' subset f then FFix f' else raise Factors
  32.136 -  | mg_factor (FFix f) (FVar f') =
  32.137 -      if f subset f' then FFix f else raise Factors
  32.138 -  | mg_factor (FFix f) (FFix f') =
  32.139 -      if f subset f' andalso f' subset f then FFix f else raise Factors;
  32.140 -
  32.141 -fun dest_factors (FVar f) = f
  32.142 -  | dest_factors (FFix f) = f;
  32.143 -
  32.144 -fun infer_factors sg extra_fs (fs, (optf, t)) =
  32.145 -  let fun err s = error (s ^ "\n" ^ Sign.string_of_term sg t)
  32.146 -  in (case (optf, strip_comb t) of
  32.147 -      (SOME f, (Const (name, _), args)) =>
  32.148 -        (case AList.lookup (op =) extra_fs name of
  32.149 -           NONE => AList.update (op =) (name, getOpt
  32.150 -             (Option.map (mg_factor f) (AList.lookup (op =) fs name), f)) fs
  32.151 -         | SOME (fs', f') => (mg_factor f (FFix f');
  32.152 -             Library.foldl (infer_factors sg extra_fs)
  32.153 -               (fs, map (Option.map FFix) fs' ~~ args)))
  32.154 -    | (SOME f, (Var ((name, _), _), [])) =>
  32.155 -        AList.update (op =) (name, getOpt
  32.156 -          (Option.map (mg_factor f) (AList.lookup (op =) fs name), f)) fs
  32.157 -    | (NONE, _) => fs
  32.158 -    | _ => err "Illegal term")
  32.159 -      handle Factors => err "Product factor mismatch in"
  32.160 -  end;
  32.161 -
  32.162 -fun string_of_factors p ps = if p mem ps then
  32.163 -    "(" ^ string_of_factors (1::p) ps ^ ", " ^ string_of_factors (2::p) ps ^ ")"
  32.164 -  else "_";
  32.165 -
  32.166 -
  32.167  (**** check if a term contains only constructor functions ****)
  32.168  
  32.169  fun is_constrt thy =
  32.170 @@ -202,31 +167,47 @@
  32.171  
  32.172  fun cprods xss = foldr (map op :: o cprod) [[]] xss;
  32.173  
  32.174 -datatype mode = Mode of (int list option list * int list) * mode option list;
  32.175 +datatype mode = Mode of (int list option list * int list) * int list * mode option list;
  32.176  
  32.177  fun modes_of modes t =
  32.178    let
  32.179 -    fun mk_modes name args = List.concat
  32.180 -      (map (fn (m as (iss, is)) => map (Mode o pair m) (cprods (map
  32.181 -        (fn (NONE, _) => [NONE]
  32.182 -          | (SOME js, arg) => map SOME
  32.183 -              (List.filter (fn Mode ((_, js'), _) => js=js') (modes_of modes arg)))
  32.184 -                (iss ~~ args)))) ((the o AList.lookup (op =) modes) name))
  32.185 +    val ks = 1 upto length (binder_types (fastype_of t));
  32.186 +    val default = [Mode (([], ks), ks, [])];
  32.187 +    fun mk_modes name args = Option.map (List.concat o
  32.188 +      map (fn (m as (iss, is)) =>
  32.189 +        let
  32.190 +          val (args1, args2) =
  32.191 +            if length args < length iss then
  32.192 +              error ("Too few arguments for inductive predicate " ^ name)
  32.193 +            else chop (length iss) args;
  32.194 +          val k = length args2;
  32.195 +          val prfx = 1 upto k
  32.196 +        in
  32.197 +          if not (is_prefix op = prfx is) then [] else
  32.198 +          let val is' = map (fn i => i - k) (List.drop (is, k))
  32.199 +          in map (fn x => Mode (m, is', x)) (cprods (map
  32.200 +            (fn (NONE, _) => [NONE]
  32.201 +              | (SOME js, arg) => map SOME (List.filter
  32.202 +                  (fn Mode (_, js', _) => js=js') (modes_of modes arg)))
  32.203 +                    (iss ~~ args1)))
  32.204 +          end
  32.205 +        end)) (AList.lookup op = modes name)
  32.206  
  32.207    in (case strip_comb t of
  32.208        (Const ("op =", Type (_, [T, _])), _) =>
  32.209 -        [Mode (([], [1]), []), Mode (([], [2]), [])] @
  32.210 -        (if is_eqT T then [Mode (([], [1, 2]), [])] else [])
  32.211 -    | (Const (name, _), args) => mk_modes name args
  32.212 -    | (Var ((name, _), _), args) => mk_modes name args
  32.213 -    | (Free (name, _), args) => mk_modes name args)
  32.214 +        [Mode (([], [1]), [1], []), Mode (([], [2]), [2], [])] @
  32.215 +        (if is_eqT T then [Mode (([], [1, 2]), [1, 2], [])] else [])
  32.216 +    | (Const (name, _), args) => the_default default (mk_modes name args)
  32.217 +    | (Var ((name, _), _), args) => the (mk_modes name args)
  32.218 +    | (Free (name, _), args) => the (mk_modes name args)
  32.219 +    | _ => default)
  32.220    end;
  32.221  
  32.222  datatype indprem = Prem of term list * term | Sidecond of term;
  32.223  
  32.224  fun select_mode_prem thy modes vs ps =
  32.225    find_first (is_some o snd) (ps ~~ map
  32.226 -    (fn Prem (us, t) => find_first (fn Mode ((_, is), _) =>
  32.227 +    (fn Prem (us, t) => find_first (fn Mode (_, is, _) =>
  32.228            let
  32.229              val (in_ts, out_ts) = get_args is 1 us;
  32.230              val (out_ts', in_ts') = List.partition (is_constrt thy) out_ts;
  32.231 @@ -239,8 +220,8 @@
  32.232              term_vs t subset vs andalso
  32.233              forall is_eqT dupTs
  32.234            end)
  32.235 -            (modes_of modes t handle Option => [Mode (([], []), [])])
  32.236 -      | Sidecond t => if term_vs t subset vs then SOME (Mode (([], []), []))
  32.237 +            (modes_of modes t handle Option => [Mode (([], []), [], [])])
  32.238 +      | Sidecond t => if term_vs t subset vs then SOME (Mode (([], []), [], []))
  32.239            else NONE) ps);
  32.240  
  32.241  fun check_mode_clause thy arg_vs modes (iss, is) (ts, ps) =
  32.242 @@ -278,12 +259,12 @@
  32.243    let val y = f x
  32.244    in if x = y then x else fixp f y end;
  32.245  
  32.246 -fun infer_modes thy extra_modes factors arg_vs preds = fixp (fn modes =>
  32.247 +fun infer_modes thy extra_modes arities arg_vs preds = fixp (fn modes =>
  32.248    map (check_modes_pred thy arg_vs preds (modes @ extra_modes)) modes)
  32.249 -    (map (fn (s, (fs, f)) => (s, cprod (cprods (map
  32.250 +    (map (fn (s, (ks, k)) => (s, cprod (cprods (map
  32.251        (fn NONE => [NONE]
  32.252 -        | SOME f' => map SOME (subsets 1 (length f' + 1))) fs),
  32.253 -      subsets 1 (length f + 1)))) factors);
  32.254 +        | SOME k' => map SOME (subsets 1 k')) ks),
  32.255 +      subsets 1 k))) arities);
  32.256  
  32.257  (**** code generation ****)
  32.258  
  32.259 @@ -296,51 +277,6 @@
  32.260    List.concat (separate [Pretty.str ",", Pretty.brk 1] (map single xs)) @
  32.261    [Pretty.str ")"]);
  32.262  
  32.263 -(* convert nested pairs to n-tuple *)
  32.264 -
  32.265 -fun conv_ntuple [_] t ps = ps
  32.266 -  | conv_ntuple [_, _] t ps = ps
  32.267 -  | conv_ntuple us t ps =
  32.268 -      let
  32.269 -        val xs = map (fn i => Pretty.str ("x" ^ string_of_int i))
  32.270 -          (1 upto length us);
  32.271 -        fun ntuple (ys as (x, T) :: xs) U =
  32.272 -          if T = U then (x, xs)
  32.273 -          else
  32.274 -            let
  32.275 -              val Type ("*", [U1, U2]) = U;
  32.276 -              val (p1, ys1) = ntuple ys U1;
  32.277 -              val (p2, ys2) = ntuple ys1 U2
  32.278 -            in (mk_tuple [p1, p2], ys2) end
  32.279 -      in
  32.280 -        [Pretty.str "Seq.map (fn", Pretty.brk 1,
  32.281 -         fst (ntuple (xs ~~ map fastype_of us) (HOLogic.dest_setT (fastype_of t))),
  32.282 -         Pretty.str " =>", Pretty.brk 1, mk_tuple xs, Pretty.str ")",
  32.283 -         Pretty.brk 1, parens (Pretty.block ps)]
  32.284 -      end;
  32.285 -
  32.286 -(* convert n-tuple to nested pairs *)
  32.287 -
  32.288 -fun conv_ntuple' fs T ps =
  32.289 -  let
  32.290 -    fun mk_x i = Pretty.str ("x" ^ string_of_int i);
  32.291 -    fun conv i js (Type ("*", [T, U])) =
  32.292 -          if js mem fs then
  32.293 -            let
  32.294 -              val (p, i') = conv i (1::js) T;
  32.295 -              val (q, i'') = conv i' (2::js) U
  32.296 -            in (mk_tuple [p, q], i'') end
  32.297 -          else (mk_x i, i+1)
  32.298 -      | conv i js _ = (mk_x i, i+1)
  32.299 -    val (p, i) = conv 1 [] T
  32.300 -  in
  32.301 -    if i > 3 then
  32.302 -      [Pretty.str "Seq.map (fn", Pretty.brk 1,
  32.303 -       mk_tuple (map mk_x (1 upto i-1)), Pretty.str " =>", Pretty.brk 1,
  32.304 -       p, Pretty.str ")", Pretty.brk 1, parens (Pretty.block ps)]
  32.305 -    else ps
  32.306 -  end;
  32.307 -
  32.308  fun mk_v ((names, vs), s) = (case AList.lookup (op =) vs s of
  32.309        NONE => ((names, (s, [s])::vs), s)
  32.310      | SOME xs => let val s' = Name.variant names s in
  32.311 @@ -383,23 +319,37 @@
  32.312        map (space_implode "_" o map string_of_int) (List.mapPartial I iss @ [is])))
  32.313    end;
  32.314  
  32.315 -fun compile_expr thy defs dep module brack (gr, (NONE, t)) =
  32.316 +fun mk_funcomp brack s k p = (if brack then parens else I)
  32.317 +  (Pretty.block [Pretty.block ((if k = 0 then [] else [Pretty.str "("]) @
  32.318 +    separate (Pretty.brk 1) (Pretty.str s :: replicate k (Pretty.str "|> ???")) @
  32.319 +    (if k = 0 then [] else [Pretty.str ")"])), Pretty.brk 1, p]);
  32.320 +
  32.321 +fun compile_expr thy defs dep module brack modes (gr, (NONE, t)) =
  32.322        apsnd single (invoke_codegen thy defs dep module brack (gr, t))
  32.323 -  | compile_expr _ _ _ _ _ (gr, (SOME _, Var ((name, _), _))) =
  32.324 +  | compile_expr _ _ _ _ _ _ (gr, (SOME _, Var ((name, _), _))) =
  32.325        (gr, [Pretty.str name])
  32.326 -  | compile_expr thy defs dep module brack (gr, (SOME (Mode (mode, ms)), t)) =
  32.327 -      let
  32.328 -        val (Const (name, _), args) = strip_comb t;
  32.329 -        val (gr', (ps, mode_id)) = foldl_map
  32.330 -            (compile_expr thy defs dep module true) (gr, ms ~~ args) |>>>
  32.331 -          modename module name mode;
  32.332 -      in (gr', (if brack andalso not (null ps) then
  32.333 -        single o parens o Pretty.block else I)
  32.334 -          (List.concat (separate [Pretty.brk 1]
  32.335 -            ([Pretty.str mode_id] :: ps))))
  32.336 -      end;
  32.337 +  | compile_expr thy defs dep module brack modes (gr, (SOME (Mode (mode, _, ms)), t)) =
  32.338 +      (case strip_comb t of
  32.339 +         (Const (name, _), args) =>
  32.340 +           if name = "op =" orelse AList.defined op = modes name then
  32.341 +             let
  32.342 +               val (args1, args2) = chop (length ms) args;
  32.343 +               val (gr', (ps, mode_id)) = foldl_map
  32.344 +                   (compile_expr thy defs dep module true modes) (gr, ms ~~ args1) |>>>
  32.345 +                 modename module name mode;
  32.346 +               val (gr'', ps') = foldl_map
  32.347 +                 (invoke_codegen thy defs dep module true) (gr', args2)
  32.348 +             in (gr', (if brack andalso not (null ps andalso null ps') then
  32.349 +               single o parens o Pretty.block else I)
  32.350 +                 (List.concat (separate [Pretty.brk 1]
  32.351 +                   ([Pretty.str mode_id] :: ps @ map single ps'))))
  32.352 +             end
  32.353 +           else apsnd (single o mk_funcomp brack "??" (length (binder_types (fastype_of t))))
  32.354 +             (invoke_codegen thy defs dep module true (gr, t))
  32.355 +       | _ => apsnd (single o mk_funcomp brack "??" (length (binder_types (fastype_of t))))
  32.356 +           (invoke_codegen thy defs dep module true (gr, t)));
  32.357  
  32.358 -fun compile_clause thy defs gr dep module all_vs arg_vs modes (iss, is) (ts, ps) =
  32.359 +fun compile_clause thy defs gr dep module all_vs arg_vs modes (iss, is) (ts, ps) inp =
  32.360    let
  32.361      val modes' = modes @ List.mapPartial
  32.362        (fn (_, NONE) => NONE | (v, SOME js) => SOME (v, [([], js)]))
  32.363 @@ -442,7 +392,7 @@
  32.364        | compile_prems out_ts vs names gr ps =
  32.365            let
  32.366              val vs' = distinct (op =) (List.concat (vs :: map term_vs out_ts));
  32.367 -            val SOME (p, mode as SOME (Mode ((_, js), _))) =
  32.368 +            val SOME (p, mode as SOME (Mode (_, js, _))) =
  32.369                select_mode_prem thy modes' vs' ps;
  32.370              val ps' = filter_out (equal p) ps;
  32.371              val ((names', eqs), out_ts') =
  32.372 @@ -458,14 +408,14 @@
  32.373                   let
  32.374                     val (in_ts, out_ts''') = get_args js 1 us;
  32.375                     val (gr2, in_ps) = foldl_map
  32.376 -                     (invoke_codegen thy defs dep module false) (gr1, in_ts);
  32.377 +                     (invoke_codegen thy defs dep module true) (gr1, in_ts);
  32.378                     val (gr3, ps) = if is_ind t then
  32.379 -                       apsnd (fn ps => ps @ [Pretty.brk 1, mk_tuple in_ps])
  32.380 -                         (compile_expr thy defs dep module false
  32.381 +                       apsnd (fn ps => ps @ Pretty.brk 1 ::
  32.382 +                           separate (Pretty.brk 1) in_ps)
  32.383 +                         (compile_expr thy defs dep module false modes
  32.384                             (gr2, (mode, t)))
  32.385                       else
  32.386 -                       apsnd (fn p => conv_ntuple us t
  32.387 -                         [Pretty.str "Seq.of_list", Pretty.brk 1, p])
  32.388 +                       apsnd (fn p => [Pretty.str "Seq.of_list", Pretty.brk 1, p])
  32.389                             (invoke_codegen thy defs dep module true (gr2, t));
  32.390                     val (gr4, rest) = compile_prems out_ts''' vs' (fst nvs) gr3 ps';
  32.391                   in
  32.392 @@ -488,20 +438,24 @@
  32.393  
  32.394      val (gr', prem_p) = compile_prems in_ts' arg_vs all_vs' gr ps;
  32.395    in
  32.396 -    (gr', Pretty.block [Pretty.str "Seq.single inp :->", Pretty.brk 1, prem_p])
  32.397 +    (gr', Pretty.block [Pretty.str "Seq.single", Pretty.brk 1, inp,
  32.398 +       Pretty.str " :->", Pretty.brk 1, prem_p])
  32.399    end;
  32.400  
  32.401  fun compile_pred thy defs gr dep module prfx all_vs arg_vs modes s cls mode =
  32.402 -  let val (gr', (cl_ps, mode_id)) =
  32.403 -    foldl_map (fn (gr, cl) => compile_clause thy defs
  32.404 -      gr dep module all_vs arg_vs modes mode cl) (gr, cls) |>>>
  32.405 -    modename module s mode
  32.406 +  let
  32.407 +    val xs = map Pretty.str (Name.variant_list arg_vs
  32.408 +      (map (fn i => "x" ^ string_of_int i) (snd mode)));
  32.409 +    val (gr', (cl_ps, mode_id)) =
  32.410 +      foldl_map (fn (gr, cl) => compile_clause thy defs
  32.411 +        gr dep module all_vs arg_vs modes mode cl (mk_tuple xs)) (gr, cls) |>>>
  32.412 +      modename module s mode
  32.413    in
  32.414      ((gr', "and "), Pretty.block
  32.415        ([Pretty.block (separate (Pretty.brk 1)
  32.416           (Pretty.str (prfx ^ mode_id) ::
  32.417 -           map Pretty.str arg_vs) @
  32.418 -         [Pretty.str " inp ="]),
  32.419 +           map Pretty.str arg_vs @ xs) @
  32.420 +         [Pretty.str " ="]),
  32.421          Pretty.brk 1] @
  32.422         List.concat (separate [Pretty.str " ++", Pretty.brk 1] (map single cl_ps))))
  32.423    end;
  32.424 @@ -519,17 +473,17 @@
  32.425  
  32.426  exception Modes of
  32.427    (string * (int list option list * int list) list) list *
  32.428 -  (string * (int list list option list * int list list)) list;
  32.429 +  (string * (int option list * int)) list;
  32.430  
  32.431  fun lookup_modes gr dep = apfst List.concat (apsnd List.concat (ListPair.unzip
  32.432    (map ((fn (SOME (Modes x), _, _) => x | _ => ([], [])) o get_node gr)
  32.433      (Graph.all_preds (fst gr) [dep]))));
  32.434  
  32.435 -fun print_factors factors = message ("Factors:\n" ^
  32.436 -  space_implode "\n" (map (fn (s, (fs, f)) => s ^ ": " ^
  32.437 +fun print_arities arities = message ("Arities:\n" ^
  32.438 +  space_implode "\n" (map (fn (s, (ks, k)) => s ^ ": " ^
  32.439      space_implode " -> " (map
  32.440 -      (fn NONE => "X" | SOME f' => string_of_factors [] f')
  32.441 -        (fs @ [SOME f]))) factors));
  32.442 +      (fn NONE => "X" | SOME k' => string_of_int k')
  32.443 +        (ks @ [SOME k]))) arities));
  32.444  
  32.445  fun prep_intrs intrs = map (rename_term o #prop o rep_thm o standard) intrs;
  32.446  
  32.447 @@ -543,133 +497,97 @@
  32.448      if name mem names then gr
  32.449      else (case get_clauses thy name of
  32.450          NONE => gr
  32.451 -      | SOME (names, thyname, intrs) =>
  32.452 +      | SOME (names, thyname, nparms, intrs) =>
  32.453            mk_ind_def thy defs gr dep names (if_library thyname module)
  32.454 -            [] [] (prep_intrs intrs)))
  32.455 +            [] (prep_intrs intrs) nparms))
  32.456              (gr, foldr add_term_consts [] ts)
  32.457  
  32.458 -and mk_ind_def thy defs gr dep names module modecs factorcs intrs =
  32.459 +and mk_ind_def thy defs gr dep names module modecs intrs nparms =
  32.460    add_edge (hd names, dep) gr handle Graph.UNDEF _ =>
  32.461      let
  32.462 -      val _ $ (_ $ _ $ u) = Logic.strip_imp_concl (hd intrs);
  32.463 -      val (_, args) = strip_comb u;
  32.464 +      val _ $ u = Logic.strip_imp_concl (hd intrs);
  32.465 +      val args = List.take (snd (strip_comb u), nparms);
  32.466        val arg_vs = List.concat (map term_vs args);
  32.467  
  32.468 -      fun dest_prem factors (_ $ (p as (Const ("op :", _) $ t $ u))) =
  32.469 -            (case AList.lookup (op =) factors (case head_of u of
  32.470 -                 Const (name, _) => name | Var ((name, _), _) => name) of
  32.471 -               NONE => Prem (full_split_prod t, u)
  32.472 -             | SOME f => Prem (split_prod [] f t, u))
  32.473 -        | dest_prem factors (_ $ ((eq as Const ("op =", _)) $ t $ u)) =
  32.474 -            Prem ([t, u], eq)
  32.475 -        | dest_prem factors (_ $ t) = Sidecond t;
  32.476 +      fun get_nparms s = if s mem names then SOME nparms else
  32.477 +        Option.map #3 (get_clauses thy s);
  32.478  
  32.479 -      fun add_clause factors (clauses, intr) =
  32.480 +      fun dest_prem (_ $ (Const ("op :", _) $ t $ u)) = Prem ([t], u)
  32.481 +        | dest_prem (_ $ ((eq as Const ("op =", _)) $ t $ u)) = Prem ([t, u], eq)
  32.482 +        | dest_prem (_ $ t) =
  32.483 +            (case strip_comb t of
  32.484 +               (v as Var _, ts) => Prem (ts, v)
  32.485 +             | (c as Const (s, _), ts) => (case get_nparms s of
  32.486 +                 NONE => Sidecond t
  32.487 +               | SOME k =>
  32.488 +                   let val (ts1, ts2) = chop k ts
  32.489 +                   in Prem (ts2, list_comb (c, ts1)) end)
  32.490 +             | _ => Sidecond t);
  32.491 +
  32.492 +      fun add_clause intr (clauses, arities) =
  32.493          let
  32.494 -          val _ $ (_ $ t $ u) = Logic.strip_imp_concl intr;
  32.495 -          val Const (name, _) = head_of u;
  32.496 -          val prems = map (dest_prem factors) (Logic.strip_imp_prems intr);
  32.497 +          val _ $ t = Logic.strip_imp_concl intr;
  32.498 +          val (Const (name, T), ts) = strip_comb t;
  32.499 +          val (ts1, ts2) = chop nparms ts;
  32.500 +          val prems = map dest_prem (Logic.strip_imp_prems intr);
  32.501 +          val (Ts, Us) = chop nparms (binder_types T)
  32.502          in
  32.503 -          AList.update (op =) (name, ((these o AList.lookup (op =) clauses) name) @
  32.504 -             [(split_prod [] ((the o AList.lookup (op =) factors) name) t, prems)]) clauses
  32.505 +          (AList.update op = (name, these (AList.lookup op = clauses name) @
  32.506 +             [(ts2, prems)]) clauses,
  32.507 +           AList.update op = (name, (map (fn U => (case strip_type U of
  32.508 +                 (Rs as _ :: _, Type ("bool", [])) => SOME (length Rs)
  32.509 +               | _ => NONE)) Ts,
  32.510 +             length Us)) arities)
  32.511          end;
  32.512  
  32.513 -      fun check_set (Const (s, _)) = s mem names orelse is_some (get_clauses thy s)
  32.514 -        | check_set (Var ((s, _), _)) = s mem arg_vs
  32.515 -        | check_set _ = false;
  32.516 -
  32.517 -      fun add_prod_factors extra_fs (fs, _ $ (Const ("op :", _) $ t $ u)) =
  32.518 -            if check_set (head_of u)
  32.519 -            then infer_factors (sign_of thy) extra_fs
  32.520 -              (fs, (SOME (FVar (prod_factors [] t)), u))
  32.521 -            else fs
  32.522 -        | add_prod_factors _ (fs, _) = fs;
  32.523 -
  32.524        val gr' = mk_extra_defs thy defs
  32.525          (add_edge (hd names, dep)
  32.526            (new_node (hd names, (NONE, "", "")) gr)) (hd names) names module intrs;
  32.527 -      val (extra_modes, extra_factors) = lookup_modes gr' (hd names);
  32.528 -      val fs = constrain factorcs (map (apsnd dest_factors)
  32.529 -        (Library.foldl (add_prod_factors extra_factors) ([], List.concat (map (fn t =>
  32.530 -          Logic.strip_imp_concl t :: Logic.strip_imp_prems t) intrs))));
  32.531 -      val factors = List.mapPartial (fn (name, f) =>
  32.532 -        if name mem arg_vs then NONE
  32.533 -        else SOME (name, (map (AList.lookup (op =) fs) arg_vs, f))) fs;
  32.534 -      val clauses =
  32.535 -        Library.foldl (add_clause (fs @ map (apsnd snd) extra_factors)) ([], intrs);
  32.536 +      val (extra_modes, extra_arities) = lookup_modes gr' (hd names);
  32.537 +      val (clauses, arities) = fold add_clause intrs ([], []);
  32.538        val modes = constrain modecs
  32.539 -        (infer_modes thy extra_modes factors arg_vs clauses);
  32.540 -      val _ = print_factors factors;
  32.541 +        (infer_modes thy extra_modes arities arg_vs clauses);
  32.542 +      val _ = print_arities arities;
  32.543        val _ = print_modes modes;
  32.544        val (gr'', s) = compile_preds thy defs gr' (hd names) module (terms_vs intrs)
  32.545          arg_vs (modes @ extra_modes) clauses;
  32.546      in
  32.547        (map_node (hd names)
  32.548 -        (K (SOME (Modes (modes, factors)), module, s)) gr'')
  32.549 +        (K (SOME (Modes (modes, arities)), module, s)) gr'')
  32.550      end;
  32.551  
  32.552 -fun find_mode gr dep s u modes is = (case find_first (fn Mode ((_, js), _) => is=js)
  32.553 +fun find_mode gr dep s u modes is = (case find_first (fn Mode (_, js, _) => is=js)
  32.554    (modes_of modes u handle Option => []) of
  32.555       NONE => codegen_error gr dep
  32.556         ("No such mode for " ^ s ^ ": " ^ string_of_mode ([], is))
  32.557     | mode => mode);
  32.558  
  32.559 -fun mk_ind_call thy defs gr dep module t u is_query = (case head_of u of
  32.560 -  Const (s, T) => (case (get_clauses thy s, get_assoc_code thy s T) of
  32.561 -       (NONE, _) => NONE
  32.562 -     | (SOME (names, thyname, intrs), NONE) =>
  32.563 -         let
  32.564 -          fun mk_mode (((ts, mode), i), Const ("dummy_pattern", _)) =
  32.565 -                ((ts, mode), i+1)
  32.566 -            | mk_mode (((ts, mode), i), t) = ((ts @ [t], mode @ [i]), i+1);
  32.567 +fun mk_ind_call thy defs gr dep module is_query s T ts names thyname k intrs =
  32.568 +  let
  32.569 +    val (ts1, ts2) = chop k ts;
  32.570 +    val u = list_comb (Const (s, T), ts1);
  32.571 +
  32.572 +    fun mk_mode (((ts, mode), i), Const ("dummy_pattern", _)) =
  32.573 +          ((ts, mode), i+1)
  32.574 +      | mk_mode (((ts, mode), i), t) = ((ts @ [t], mode @ [i]), i+1);
  32.575  
  32.576 -           val module' = if_library thyname module;
  32.577 -           val gr1 = mk_extra_defs thy defs
  32.578 -             (mk_ind_def thy defs gr dep names module'
  32.579 -             [] [] (prep_intrs intrs)) dep names module' [u];
  32.580 -           val (modes, factors) = lookup_modes gr1 dep;
  32.581 -           val ts = split_prod [] ((snd o the o AList.lookup (op =) factors) s) t;
  32.582 -           val (ts', is) = if is_query then
  32.583 -               fst (Library.foldl mk_mode ((([], []), 1), ts))
  32.584 -             else (ts, 1 upto length ts);
  32.585 -           val mode = find_mode gr1 dep s u modes is;
  32.586 -           val (gr2, in_ps) = foldl_map
  32.587 -             (invoke_codegen thy defs dep module false) (gr1, ts');
  32.588 -           val (gr3, ps) =
  32.589 -             compile_expr thy defs dep module false (gr2, (mode, u))
  32.590 -         in
  32.591 -           SOME (gr3, Pretty.block
  32.592 -             (ps @ [Pretty.brk 1, mk_tuple in_ps]))
  32.593 -         end
  32.594 -     | _ => NONE)
  32.595 -  | _ => NONE);
  32.596 -
  32.597 -fun list_of_indset thy defs gr dep module brack u = (case head_of u of
  32.598 -  Const (s, T) => (case (get_clauses thy s, get_assoc_code thy s T) of
  32.599 -       (NONE, _) => NONE
  32.600 -     | (SOME (names, thyname, intrs), NONE) =>
  32.601 -         let
  32.602 -           val module' = if_library thyname module;
  32.603 -           val gr1 = mk_extra_defs thy defs
  32.604 -             (mk_ind_def thy defs gr dep names module'
  32.605 -             [] [] (prep_intrs intrs)) dep names module' [u];
  32.606 -           val (modes, factors) = lookup_modes gr1 dep;
  32.607 -           val mode = find_mode gr1 dep s u modes [];
  32.608 -           val (gr2, ps) =
  32.609 -             compile_expr thy defs dep module false (gr1, (mode, u));
  32.610 -           val (gr3, _) =
  32.611 -             invoke_tycodegen thy defs dep module false (gr2, body_type T)
  32.612 -         in
  32.613 -           SOME (gr3, (if brack then parens else I)
  32.614 -             (Pretty.block ([Pretty.str "Seq.list_of", Pretty.brk 1,
  32.615 -               Pretty.str "("] @
  32.616 -                conv_ntuple' (snd (valOf (AList.lookup (op =) factors s)))
  32.617 -                 (HOLogic.dest_setT (fastype_of u))
  32.618 -                 (ps @ [Pretty.brk 1, Pretty.str "()"]) @
  32.619 -               [Pretty.str ")"])))
  32.620 -         end
  32.621 -     | _ => NONE)
  32.622 -  | _ => NONE);
  32.623 +    val module' = if_library thyname module;
  32.624 +    val gr1 = mk_extra_defs thy defs
  32.625 +      (mk_ind_def thy defs gr dep names module'
  32.626 +      [] (prep_intrs intrs) k) dep names module' [u];
  32.627 +    val (modes, _) = lookup_modes gr1 dep;
  32.628 +    val (ts', is) = if is_query then
  32.629 +        fst (Library.foldl mk_mode ((([], []), 1), ts2))
  32.630 +      else (ts2, 1 upto length (binder_types T) - k);
  32.631 +    val mode = find_mode gr1 dep s u modes is;
  32.632 +    val (gr2, in_ps) = foldl_map
  32.633 +      (invoke_codegen thy defs dep module true) (gr1, ts');
  32.634 +    val (gr3, ps) =
  32.635 +      compile_expr thy defs dep module false modes (gr2, (mode, u))
  32.636 +  in
  32.637 +    (gr3, Pretty.block (ps @ (if null in_ps then [] else [Pretty.brk 1]) @
  32.638 +       separate (Pretty.brk 1) in_ps))
  32.639 +  end;
  32.640  
  32.641  fun clause_of_eqn eqn =
  32.642    let
  32.643 @@ -677,10 +595,8 @@
  32.644      val (Const (s, T), ts) = strip_comb t;
  32.645      val (Ts, U) = strip_type T
  32.646    in
  32.647 -    rename_term
  32.648 -      (Logic.list_implies (prems_of eqn, HOLogic.mk_Trueprop (HOLogic.mk_mem
  32.649 -        (foldr1 HOLogic.mk_prod (ts @ [u]), Const (s ^ "_aux",
  32.650 -          HOLogic.mk_setT (foldr1 HOLogic.mk_prodT (Ts @ [U])))))))
  32.651 +    rename_term (Logic.list_implies (prems_of eqn, HOLogic.mk_Trueprop
  32.652 +      (list_comb (Const (s ^ "_aux", Ts @ [U] ---> HOLogic.boolT), ts @ [u]))))
  32.653    end;
  32.654  
  32.655  fun mk_fun thy defs name eqns dep module module' gr =
  32.656 @@ -699,44 +615,57 @@
  32.657        val s = Pretty.string_of (Pretty.block
  32.658          [mk_app false (Pretty.str ("fun " ^ snd fun_id)) vars, Pretty.str " =",
  32.659           Pretty.brk 1, Pretty.str "Seq.hd", Pretty.brk 1,
  32.660 -         parens (Pretty.block [Pretty.str mode_id,
  32.661 -           Pretty.brk 1, mk_tuple vars])]) ^ ";\n\n";
  32.662 +         parens (Pretty.block (separate (Pretty.brk 1) (Pretty.str mode_id ::
  32.663 +           vars)))]) ^ ";\n\n";
  32.664        val gr'' = mk_ind_def thy defs (add_edge (name, dep)
  32.665          (new_node (name, (NONE, module', s)) gr')) name [pname] module'
  32.666 -        [(pname, [([], mode)])]
  32.667 -        [(pname, map (fn i => replicate i 2) (0 upto arity-1))]
  32.668 -        clauses;
  32.669 +        [(pname, [([], mode)])] clauses 0;
  32.670        val (modes, _) = lookup_modes gr'' dep;
  32.671 -      val _ = find_mode gr'' dep pname (snd (HOLogic.dest_mem (HOLogic.dest_Trueprop
  32.672 -        (Logic.strip_imp_concl (hd clauses))))) modes mode
  32.673 +      val _ = find_mode gr'' dep pname (head_of (HOLogic.dest_Trueprop
  32.674 +        (Logic.strip_imp_concl (hd clauses)))) modes mode
  32.675      in (gr'', mk_qual_id module fun_id) end
  32.676    | SOME _ =>
  32.677        (add_edge (name, dep) gr, mk_qual_id module (get_const_id name gr));
  32.678  
  32.679 -fun inductive_codegen thy defs gr dep module brack (Const ("op :", _) $ t $ u) =
  32.680 -      ((case mk_ind_call thy defs gr dep module (Term.no_dummy_patterns t) u false of
  32.681 -         NONE => NONE
  32.682 -       | SOME (gr', call_p) => SOME (gr', (if brack then parens else I)
  32.683 -           (Pretty.block [Pretty.str "?! (", call_p, Pretty.str ")"])))
  32.684 -        handle TERM _ => mk_ind_call thy defs gr dep module t u true)
  32.685 -  | inductive_codegen thy defs gr dep module brack t = (case strip_comb t of
  32.686 -      (Const (s, _), ts) => (case Symtab.lookup (#eqns (CodegenData.get thy)) s of
  32.687 -        NONE => list_of_indset thy defs gr dep module brack t
  32.688 -      | SOME eqns =>
  32.689 -          let
  32.690 -            val (_, (_, thyname)) = split_last eqns;
  32.691 -            val (gr', id) = mk_fun thy defs s (preprocess thy (map fst eqns))
  32.692 -              dep module (if_library thyname module) gr;
  32.693 -            val (gr'', ps) = foldl_map
  32.694 -              (invoke_codegen thy defs dep module true) (gr', ts);
  32.695 -          in SOME (gr'', mk_app brack (Pretty.str id) ps)
  32.696 -          end)
  32.697 -    | _ => NONE);
  32.698 +fun inductive_codegen thy defs gr dep module brack t = (case strip_comb t of
  32.699 +    (Const ("Collect", Type (_, [_, Type (_, [U])])), [u]) => (case strip_comb u of
  32.700 +        (Const (s, T), ts) => (case (get_clauses thy s, get_assoc_code thy s T) of
  32.701 +          (SOME (names, thyname, k, intrs), NONE) =>
  32.702 +            let val (gr', call_p) = mk_ind_call thy defs gr dep module true
  32.703 +              s T (ts @ [Term.dummy_pattern U]) names thyname k intrs
  32.704 +            in SOME (gr', (if brack then parens else I) (Pretty.block
  32.705 +              [Pretty.str "Seq.list_of", Pretty.brk 1, Pretty.str "(",
  32.706 +               call_p, Pretty.str ")"]))
  32.707 +            end
  32.708 +        | _ => NONE)
  32.709 +      | _ => NONE)
  32.710 +  | (Const (s, T), ts) => (case Symtab.lookup (#eqns (CodegenData.get thy)) s of
  32.711 +      NONE => (case (get_clauses thy s, get_assoc_code thy s T) of
  32.712 +        (SOME (names, thyname, k, intrs), NONE) =>
  32.713 +          if length ts < k then NONE else SOME
  32.714 +            (let val (gr', call_p) = mk_ind_call thy defs gr dep module false
  32.715 +               s T (map Term.no_dummy_patterns ts) names thyname k intrs
  32.716 +             in (gr', mk_funcomp brack "?!"
  32.717 +               (length (binder_types T) - length ts) (parens call_p))
  32.718 +             end handle TERM _ => mk_ind_call thy defs gr dep module true
  32.719 +               s T ts names thyname k intrs)
  32.720 +      | _ => NONE)
  32.721 +    | SOME eqns =>
  32.722 +        let
  32.723 +          val (_, (_, thyname)) = split_last eqns;
  32.724 +          val (gr', id) = mk_fun thy defs s (preprocess thy (map fst eqns))
  32.725 +            dep module (if_library thyname module) gr;
  32.726 +          val (gr'', ps) = foldl_map
  32.727 +            (invoke_codegen thy defs dep module true) (gr', ts);
  32.728 +        in SOME (gr'', mk_app brack (Pretty.str id) ps)
  32.729 +        end)
  32.730 +  | _ => NONE);
  32.731  
  32.732  val setup =
  32.733    add_codegen "inductive" inductive_codegen #>
  32.734    CodegenData.init #>
  32.735 -  add_attribute "ind" (Scan.option (Args.$$$ "target" |-- Args.colon |-- Args.name) >> add);
  32.736 +  add_attribute "ind" (Scan.option (Args.$$$ "target" |-- Args.colon |-- Args.name) --
  32.737 +    Scan.option (Args.$$$ "params" |-- Args.colon |-- Args.nat) >> uncurry add);
  32.738  
  32.739  end;
  32.740  
  32.741 @@ -752,6 +681,8 @@
  32.742  
  32.743  fun ?? b = if b then Seq.single () else Seq.empty;
  32.744  
  32.745 +fun ??? f g = f o g;
  32.746 +
  32.747  fun ?! s = is_some (Seq.pull s);
  32.748  
  32.749  fun equal__1 x = Seq.single x;
    33.1 --- a/src/HOL/Tools/inductive_realizer.ML	Wed Feb 07 17:41:11 2007 +0100
    33.2 +++ b/src/HOL/Tools/inductive_realizer.ML	Wed Feb 07 17:44:07 2007 +0100
    33.3 @@ -15,51 +15,103 @@
    33.4  structure InductiveRealizer : INDUCTIVE_REALIZER =
    33.5  struct
    33.6  
    33.7 +(* FIXME: LocalTheory.note should return theorems with proper names! *)
    33.8 +fun name_of_thm thm = (case Proofterm.strip_combt (fst (Proofterm.strip_combP
    33.9 +    (Proofterm.rewrite_proof (theory_of_thm thm) ([], []) (proof_of thm)))) of
   33.10 +    (PThm (name, _, _, _), _) => name
   33.11 +  | _ => error "name_of_thm: bad proof");
   33.12 +
   33.13 +(* infer order of variables in intro rules from order of quantifiers in elim rule *)
   33.14 +fun infer_intro_vars elim arity intros =
   33.15 +  let
   33.16 +    val thy = theory_of_thm elim;
   33.17 +    val _ :: cases = prems_of elim;
   33.18 +    val used = map (fst o fst) (Term.add_vars (prop_of elim) []);
   33.19 +    fun mtch (t, u) =
   33.20 +      let
   33.21 +        val params = Logic.strip_params t;
   33.22 +        val vars = map (Var o apfst (rpair 0))
   33.23 +          (Name.variant_list used (map fst params) ~~ map snd params);
   33.24 +        val ts = map (curry subst_bounds (rev vars))
   33.25 +          (List.drop (Logic.strip_assums_hyp t, arity));
   33.26 +        val us = Logic.strip_imp_prems u;
   33.27 +        val tab = fold (Pattern.first_order_match thy) (ts ~~ us)
   33.28 +          (Vartab.empty, Vartab.empty);
   33.29 +      in
   33.30 +        map (Envir.subst_vars tab) vars
   33.31 +      end
   33.32 +  in
   33.33 +    map (mtch o apsnd prop_of) (cases ~~ intros)
   33.34 +  end;
   33.35 +
   33.36 +(* read off arities of inductive predicates from raw induction rule *)
   33.37 +fun arities_of induct =
   33.38 +  map (fn (_ $ t $ u) =>
   33.39 +      (fst (dest_Const (head_of t)), length (snd (strip_comb u))))
   33.40 +    (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)));
   33.41 +
   33.42 +(* read off parameters of inductive predicate from raw induction rule *)
   33.43 +fun params_of induct =
   33.44 +  let
   33.45 +    val (_ $ t $ u :: _) =
   33.46 +      HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct));
   33.47 +    val (_, ts) = strip_comb t;
   33.48 +    val (_, us) = strip_comb u
   33.49 +  in
   33.50 +    List.take (ts, length ts - length us)
   33.51 +  end;
   33.52 +
   33.53  val all_simps = map (symmetric o mk_meta_eq) (thms "HOL.all_simps");
   33.54  
   33.55  fun prf_of thm =
   33.56    let val {sign, prop, der = (_, prf), ...} = rep_thm thm
   33.57 -  in Reconstruct.reconstruct_proof sign prop prf end;
   33.58 +  in Reconstruct.expand_proof sign [("", NONE)] (Reconstruct.reconstruct_proof sign prop prf) end; (* FIXME *)
   33.59  
   33.60  fun forall_intr_prf (t, prf) =
   33.61    let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   33.62    in Abst (a, SOME T, Proofterm.prf_abstract_over t prf) end;
   33.63  
   33.64 +fun forall_intr_term (t, u) =
   33.65 +  let val (a, T) = (case t of Var ((a, _), T) => (a, T) | Free p => p)
   33.66 +  in all T $ Abs (a, T, abstract_over (t, u)) end;
   33.67 +
   33.68  fun subsets [] = [[]]
   33.69    | subsets (x::xs) =
   33.70        let val ys = subsets xs
   33.71        in ys @ map (cons x) ys end;
   33.72  
   33.73 -val set_of = fst o dest_Const o head_of o snd o HOLogic.dest_mem;
   33.74 +val pred_of = fst o dest_Const o head_of;
   33.75  
   33.76 -fun strip_all t =
   33.77 -  let
   33.78 -    fun strip used (Const ("all", _) $ Abs (s, T, t)) =
   33.79 -          let val s' = Name.variant used s
   33.80 -          in strip (s'::used) (subst_bound (Free (s', T), t)) end
   33.81 -      | strip used ((t as Const ("==>", _) $ P) $ Q) = t $ strip used Q
   33.82 -      | strip _ t = t;
   33.83 -  in strip (add_term_free_names (t, [])) t end;
   33.84 +fun strip_all' used names (Const ("all", _) $ Abs (s, T, t)) =
   33.85 +      let val (s', names') = (case names of
   33.86 +          [] => (Name.variant used s, [])
   33.87 +        | name :: names' => (name, names'))
   33.88 +      in strip_all' (s'::used) names' (subst_bound (Free (s', T), t)) end
   33.89 +  | strip_all' used names ((t as Const ("==>", _) $ P) $ Q) =
   33.90 +      t $ strip_all' used names Q
   33.91 +  | strip_all' _ _ t = t;
   33.92 +
   33.93 +fun strip_all t = strip_all' (add_term_free_names (t, [])) [] t;
   33.94 +
   33.95 +fun strip_one name (Const ("all", _) $ Abs (s, T, Const ("==>", _) $ P $ Q)) =
   33.96 +      (subst_bound (Free (name, T), P), subst_bound (Free (name, T), Q))
   33.97 +  | strip_one _ (Const ("==>", _) $ P $ Q) = (P, Q);
   33.98  
   33.99  fun relevant_vars prop = foldr (fn
  33.100        (Var ((a, i), T), vs) => (case strip_type T of
  33.101 -        (_, Type (s, _)) => if s mem ["bool", "set"] then (a, T) :: vs else vs
  33.102 +        (_, Type (s, _)) => if s mem ["bool"] then (a, T) :: vs else vs
  33.103        | _ => vs)
  33.104      | (_, vs) => vs) [] (term_vars prop);
  33.105  
  33.106 -fun params_of intr = map (fst o fst o dest_Var) (term_vars
  33.107 -  (snd (HOLogic.dest_mem (HOLogic.dest_Trueprop
  33.108 -    (Logic.strip_imp_concl intr)))));
  33.109 -
  33.110 -fun dt_of_intrs thy vs intrs =
  33.111 +fun dt_of_intrs thy vs nparms intrs =
  33.112    let
  33.113      val iTs = term_tvars (prop_of (hd intrs));
  33.114      val Tvs = map TVar iTs;
  33.115 -    val (_ $ (_ $ _ $ S)) = Logic.strip_imp_concl (prop_of (hd intrs));
  33.116 -    val (Const (s, _), ts) = strip_comb S;
  33.117 -    val params = map dest_Var ts;
  33.118 +    val (Const (s, _), ts) = strip_comb (HOLogic.dest_Trueprop
  33.119 +      (Logic.strip_imp_concl (prop_of (hd intrs))));
  33.120 +    val params = map dest_Var (Library.take (nparms, ts));
  33.121      val tname = space_implode "_" (Sign.base_name s ^ "T" :: vs);
  33.122 -    fun constr_of_intr intr = (Sign.base_name (Thm.get_name intr),
  33.123 +    fun constr_of_intr intr = (Sign.base_name (name_of_thm intr),
  33.124        map (Logic.unvarifyT o snd) (rev (Term.add_vars (prop_of intr) []) \\ params) @
  33.125          filter_out (equal Extraction.nullT) (map
  33.126            (Logic.unvarifyT o Extraction.etype_of thy vs []) (prems_of intr)),
  33.127 @@ -70,43 +122,40 @@
  33.128  
  33.129  fun mk_rlz T = Const ("realizes", [T, HOLogic.boolT] ---> HOLogic.boolT);
  33.130  
  33.131 -(** turn "P" into "%r x. realizes r (P x)" or "%r x. realizes r (x : P)" **)
  33.132 +(** turn "P" into "%r x. realizes r (P x)" **)
  33.133  
  33.134  fun gen_rvar vs (t as Var ((a, 0), T)) =
  33.135 -      let val U = TVar (("'" ^ a, 0), HOLogic.typeS)
  33.136 -      in case try HOLogic.dest_setT T of
  33.137 -          NONE => if body_type T <> HOLogic.boolT then t else
  33.138 -            let
  33.139 -              val Ts = binder_types T;
  33.140 -              val i = length Ts;
  33.141 -              val xs = map (pair "x") Ts;
  33.142 -              val u = list_comb (t, map Bound (i - 1 downto 0))
  33.143 -            in 
  33.144 -              if a mem vs then
  33.145 -                list_abs (("r", U) :: xs, mk_rlz U $ Bound i $ u)
  33.146 -              else list_abs (xs, mk_rlz Extraction.nullT $ Extraction.nullt $ u)
  33.147 -            end
  33.148 -        | SOME T' => if a mem vs then
  33.149 -              Abs ("r", U, Abs ("x", T', mk_rlz U $ Bound 1 $
  33.150 -                (HOLogic.mk_mem (Bound 0, t))))
  33.151 -            else Abs ("x", T', mk_rlz Extraction.nullT $ Extraction.nullt $
  33.152 -              (HOLogic.mk_mem (Bound 0, t)))
  33.153 -      end
  33.154 +      if body_type T <> HOLogic.boolT then t else
  33.155 +        let
  33.156 +          val U = TVar (("'" ^ a, 0), HOLogic.typeS)
  33.157 +          val Ts = binder_types T;
  33.158 +          val i = length Ts;
  33.159 +          val xs = map (pair "x") Ts;
  33.160 +          val u = list_comb (t, map Bound (i - 1 downto 0))
  33.161 +        in 
  33.162 +          if a mem vs then
  33.163 +            list_abs (("r", U) :: xs, mk_rlz U $ Bound i $ u)
  33.164 +          else list_abs (xs, mk_rlz Extraction.nullT $ Extraction.nullt $ u)
  33.165 +        end
  33.166    | gen_rvar _ t = t;
  33.167  
  33.168 -fun mk_realizes_eqn n vs intrs =
  33.169 +fun mk_realizes_eqn n vs nparms intrs =
  33.170    let
  33.171 -    val iTs = term_tvars (prop_of (hd intrs));
  33.172 +    val concl = HOLogic.dest_Trueprop (concl_of (hd intrs));
  33.173 +    val iTs = term_tvars concl;
  33.174      val Tvs = map TVar iTs;
  33.175 -    val _ $ (_ $ _ $ S) = concl_of (hd intrs);
  33.176 -    val (Const (s, T), ts') = strip_comb S;
  33.177 -    val setT = body_type T;
  33.178 -    val elT = HOLogic.dest_setT setT;
  33.179 -    val x = Var (("x", 0), elT);
  33.180 +    val (h as Const (s, T), us) = strip_comb concl;
  33.181 +    val params = List.take (us, nparms);
  33.182 +    val elTs = List.drop (binder_types T, nparms);
  33.183 +    val predT = elTs ---> HOLogic.boolT;
  33.184 +    val used = map (fst o fst o dest_Var) params;
  33.185 +    val xs = map (Var o apfst (rpair 0))
  33.186 +      (Name.variant_list used (replicate (length elTs) "x") ~~ elTs);
  33.187      val rT = if n then Extraction.nullT
  33.188        else Type (space_implode "_" (s ^ "T" :: vs),
  33.189          map (fn a => TVar (("'" ^ a, 0), HOLogic.typeS)) vs @ Tvs);
  33.190      val r = if n then Extraction.nullt else Var ((Sign.base_name s, 0), rT);
  33.191 +    val S = list_comb (h, params @ xs);
  33.192      val rvs = relevant_vars S;
  33.193      val vs' = map fst rvs \\ vs;
  33.194      val rname = space_implode "_" (s ^ "R" :: vs);
  33.195 @@ -119,23 +168,20 @@
  33.196        end;
  33.197  
  33.198      val prems = map (mk_Tprem true) vs' @ map (mk_Tprem false) vs;
  33.199 -    val ts = map (gen_rvar vs) ts';
  33.200 +    val ts = map (gen_rvar vs) params;
  33.201      val argTs = map fastype_of ts;
  33.202  
  33.203 -  in ((prems, (Const ("typeof", setT --> Type ("Type", [])) $ S,
  33.204 +  in ((prems, (Const ("typeof", HOLogic.boolT --> Type ("Type", [])) $ S,
  33.205         Extraction.mk_typ rT)),
  33.206 -    (prems, (mk_rlz rT $ r $ HOLogic.mk_mem (x, S),
  33.207 -       if n then
  33.208 -         HOLogic.mk_mem (x, list_comb (Const (rname, argTs ---> setT), ts))
  33.209 -       else HOLogic.mk_mem (HOLogic.mk_prod (r, x), list_comb (Const (rname,
  33.210 -         argTs ---> HOLogic.mk_setT (HOLogic.mk_prodT (rT, elT))), ts)))))
  33.211 +    (prems, (mk_rlz rT $ r $ S,
  33.212 +       if n then list_comb (Const (rname, argTs ---> predT), ts @ xs)
  33.213 +       else list_comb (Const (rname, argTs @ [rT] ---> predT), ts @ [r] @ xs))))
  33.214    end;
  33.215  
  33.216 -fun fun_of_prem thy rsets vs params rule intr =
  33.217 +fun fun_of_prem thy rsets vs params rule ivs intr =
  33.218    let
  33.219 -    (* add_term_vars and Term.add_vars may return variables in different order *)
  33.220 -    val args = map (Free o apfst fst o dest_Var)
  33.221 -      (add_term_vars (prop_of intr, []) \\ map Var params);
  33.222 +    val ctxt = ProofContext.init thy
  33.223 +    val args = map (Free o apfst fst o dest_Var) ivs;
  33.224      val args' = map (Free o apfst fst)
  33.225        (Term.add_vars (prop_of intr) [] \\ params);
  33.226      val rule' = strip_all rule;
  33.227 @@ -146,7 +192,9 @@
  33.228  
  33.229      fun is_meta (Const ("all", _) $ Abs (s, _, P)) = is_meta P
  33.230        | is_meta (Const ("==>", _) $ _ $ Q) = is_meta Q
  33.231 -      | is_meta (Const ("Trueprop", _) $ (Const ("op :", _) $ _ $ _)) = true
  33.232 +      | is_meta (Const ("Trueprop", _) $ t) = (case head_of t of
  33.233 +          Const (s, _) => can (InductivePackage.the_inductive ctxt) s
  33.234 +        | _ => true)
  33.235        | is_meta _ = false;
  33.236  
  33.237      fun fun_of ts rts args used (prem :: prems) =
  33.238 @@ -189,50 +237,42 @@
  33.239            in if conclT = Extraction.nullT
  33.240              then list_abs_free (map dest_Free xs, HOLogic.unit)
  33.241              else list_abs_free (map dest_Free xs, list_comb
  33.242 -              (Free ("r" ^ Sign.base_name (Thm.get_name intr),
  33.243 +              (Free ("r" ^ Sign.base_name (name_of_thm intr),
  33.244                  map fastype_of (rev args) ---> conclT), rev args))
  33.245            end
  33.246  
  33.247    in fun_of args' [] (rev args) used (Logic.strip_imp_prems rule') end;
  33.248  
  33.249 -fun find_first f = Library.find_first f;
  33.250 -
  33.251  fun indrule_realizer thy induct raw_induct rsets params vs rec_names rss intrs dummies =
  33.252    let
  33.253      val concls = HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of raw_induct));
  33.254      val premss = List.mapPartial (fn (s, rs) => if s mem rsets then
  33.255 -      SOME (map (fn r => List.nth (prems_of raw_induct,
  33.256 +      SOME (rs, map (fn (_, r) => List.nth (prems_of raw_induct,
  33.257          find_index_eq (prop_of r) (map prop_of intrs))) rs) else NONE) rss;
  33.258 -    val concls' = List.mapPartial (fn (s, _) => if s mem rsets then
  33.259 -        find_first (fn concl => s mem term_consts concl) concls
  33.260 -      else NONE) rss;
  33.261 -    val fs = List.concat (snd (foldl_map (fn (intrs, (prems, dummy)) =>
  33.262 +    val fs = maps (fn ((intrs, prems), dummy) =>
  33.263        let
  33.264 -        val (intrs1, intrs2) = chop (length prems) intrs;
  33.265 -        val fs = map (fn (rule, intr) =>
  33.266 -          fun_of_prem thy rsets vs params rule intr) (prems ~~ intrs1)
  33.267 -      in (intrs2, if dummy then Const ("arbitrary",
  33.268 +        val fs = map (fn (rule, (ivs, intr)) =>
  33.269 +          fun_of_prem thy rsets vs params rule ivs intr) (prems ~~ intrs)
  33.270 +      in if dummy then Const ("arbitrary",
  33.271            HOLogic.unitT --> body_type (fastype_of (hd fs))) :: fs
  33.272 -        else fs)
  33.273 -      end) (intrs, (premss ~~ dummies))));
  33.274 +        else fs
  33.275 +      end) (premss ~~ dummies);
  33.276      val frees = fold Term.add_frees fs [];
  33.277      val Ts = map fastype_of fs;
  33.278 -    val rlzs = List.mapPartial (fn (a, concl) =>
  33.279 +    fun name_of_fn intr = "r" ^ Sign.base_name (name_of_thm intr)
  33.280 +  in
  33.281 +    fst (fold_map (fn concl => fn names =>
  33.282        let val T = Extraction.etype_of thy vs [] concl
  33.283 -      in if T = Extraction.nullT then NONE
  33.284 -        else SOME (list_comb (Const (a, Ts ---> T), fs))
  33.285 -      end) (rec_names ~~ concls')
  33.286 -  in if null rlzs then Extraction.nullt else
  33.287 -    let
  33.288 -      val r = foldr1 HOLogic.mk_prod rlzs;
  33.289 -      val x = Free ("x", Extraction.etype_of thy vs [] (hd (prems_of induct)));
  33.290 -      fun name_of_fn intr = "r" ^ Sign.base_name (Thm.get_name intr);
  33.291 -      val r' = list_abs_free (List.mapPartial (fn intr =>
  33.292 -        Option.map (pair (name_of_fn intr)) (AList.lookup (op =) frees (name_of_fn intr))) intrs,
  33.293 -          if length concls = 1 then r $ x else r)
  33.294 -    in
  33.295 -      if length concls = 1 then lambda x r' else r'
  33.296 -    end
  33.297 +      in if T = Extraction.nullT then (Extraction.nullt, names) else
  33.298 +        let
  33.299 +          val Type ("fun", [U, _]) = T;
  33.300 +          val a :: names' = names
  33.301 +        in (list_abs_free (("x", U) :: List.mapPartial (fn intr =>
  33.302 +          Option.map (pair (name_of_fn intr))
  33.303 +            (AList.lookup (op =) frees (name_of_fn intr))) intrs,
  33.304 +          list_comb (Const (a, Ts ---> T), fs) $ Free ("x", U)), names')
  33.305 +        end
  33.306 +      end) concls rec_names)
  33.307    end;
  33.308  
  33.309  fun add_dummy name dname (x as (_, (vs, s, mfx, cs))) =
  33.310 @@ -254,48 +294,47 @@
  33.311          |> add_dummies f (map (add_dummy name dname) dts) (dname :: used)
  33.312        end;
  33.313  
  33.314 -fun mk_realizer thy vs params ((rule, rrule), rt) =
  33.315 +fun mk_realizer thy vs (name, rule, rrule, rlz, rt) =
  33.316    let
  33.317 -    val prems = prems_of rule ~~ prems_of rrule;
  33.318      val rvs = map fst (relevant_vars (prop_of rule));
  33.319      val xs = rev (Term.add_vars (prop_of rule) []);
  33.320      val vs1 = map Var (filter_out (fn ((a, _), _) => a mem rvs) xs);
  33.321      val rlzvs = rev (Term.add_vars (prop_of rrule) []);
  33.322      val vs2 = map (fn (ixn, _) => Var (ixn, (the o AList.lookup (op =) rlzvs) ixn)) xs;
  33.323 -    val rs = subtract (op = o pairself fst) xs rlzvs;
  33.324 -
  33.325 -    fun mk_prf _ [] prf = prf
  33.326 -      | mk_prf rs ((prem, rprem) :: prems) prf =
  33.327 -          if Extraction.etype_of thy vs [] prem = Extraction.nullT
  33.328 -          then AbsP ("H", SOME rprem, mk_prf rs prems prf)
  33.329 -          else forall_intr_prf (Var (hd rs), AbsP ("H", SOME rprem,
  33.330 -            mk_prf (tl rs) prems prf));
  33.331 -
  33.332 -  in (Thm.get_name rule, (vs,
  33.333 +    val rs = map Var (subtract (op = o pairself fst) xs rlzvs);
  33.334 +    val rlz' = foldr forall_intr_term (prop_of rrule) (vs2 @ rs);
  33.335 +    val rlz'' = foldr forall_intr_term rlz vs2
  33.336 +  in (name, (vs,
  33.337      if rt = Extraction.nullt then rt else
  33.338        foldr (uncurry lambda) rt vs1,
  33.339 -    foldr forall_intr_prf (mk_prf rs prems (Proofterm.proof_combP
  33.340 -      (prf_of rrule, map PBound (length prems - 1 downto 0)))) vs2))
  33.341 +    ProofRewriteRules.un_hhf_proof rlz' rlz''
  33.342 +      (foldr forall_intr_prf (prf_of rrule) (vs2 @ rs))))
  33.343    end;
  33.344  
  33.345 -fun add_rule r rss =
  33.346 +fun partition_rules induct intrs =
  33.347    let
  33.348 -    val _ $ (_ $ _ $ S) = concl_of r;
  33.349 -    val (Const (s, _), _) = strip_comb S;
  33.350 +    fun name_of t = fst (dest_Const (head_of t));
  33.351 +    val ts = HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct));
  33.352 +    val sets = map (name_of o fst o HOLogic.dest_imp) ts;
  33.353    in
  33.354 -    rss
  33.355 -    |> AList.default (op =) (s, [])
  33.356 -    |> AList.map_entry (op =) s (fn rs => rs @ [r])
  33.357 +    map (fn s => (s, filter
  33.358 +      (equal s o name_of o HOLogic.dest_Trueprop o concl_of) intrs)) sets
  33.359    end;
  33.360  
  33.361  fun add_ind_realizer rsets intrs induct raw_induct elims (thy, vs) =
  33.362    let
  33.363 +    val qualifier = NameSpace.qualifier (name_of_thm induct);
  33.364 +    val inducts = PureThy.get_thms thy (Name
  33.365 +      (NameSpace.qualified qualifier "inducts"));
  33.366      val iTs = term_tvars (prop_of (hd intrs));
  33.367      val ar = length vs + length iTs;
  33.368 -    val (_ $ (_ $ _ $ S)) = Logic.strip_imp_concl (prop_of (hd intrs));
  33.369 -    val (_, params) = strip_comb S;
  33.370 +    val params = params_of raw_induct;
  33.371 +    val arities = arities_of raw_induct;
  33.372 +    val nparms = length params;
  33.373      val params' = map dest_Var params;
  33.374 -    val rss = [] |> fold add_rule intrs;
  33.375 +    val rss = partition_rules raw_induct intrs;
  33.376 +    val rss' = map (fn (((s, rs), (_, arity)), elim) =>
  33.377 +      (s, (infer_intro_vars elim arity rs ~~ rs))) (rss ~~ arities ~~ elims);
  33.378      val (prfx, _) = split_last (NameSpace.explode (fst (hd rss)));
  33.379      val tnames = map (fn s => space_implode "_" (s ^ "T" :: vs)) rsets;
  33.380  
  33.381 @@ -303,7 +342,7 @@
  33.382        Theory.root_path |>
  33.383        Theory.add_path (NameSpace.implode prfx);
  33.384      val (ty_eqs, rlz_eqs) = split_list
  33.385 -      (map (fn (s, rs) => mk_realizes_eqn (not (s mem rsets)) vs rs) rss);
  33.386 +      (map (fn (s, rs) => mk_realizes_eqn (not (s mem rsets)) vs nparms rs) rss);
  33.387  
  33.388      val thy1' = thy1 |>
  33.389        Theory.copy |>
  33.390 @@ -312,7 +351,7 @@
  33.391          (s, replicate ar HOLogic.typeS, HOLogic.typeS)) tnames |>
  33.392          Extraction.add_typeof_eqns_i ty_eqs;
  33.393      val dts = List.mapPartial (fn (s, rs) => if s mem rsets then
  33.394 -      SOME (dt_of_intrs thy1' vs rs) else NONE) rss;
  33.395 +      SOME (dt_of_intrs thy1' vs nparms rs) else NONE) rss;
  33.396  
  33.397      (** datatype representing computational content of inductive set **)
  33.398  
  33.399 @@ -338,51 +377,89 @@
  33.400          ((get #rec_thms dt_info, dummies), rss);
  33.401      val rintrs = map (fn (intr, c) => Envir.eta_contract
  33.402        (Extraction.realizes_of thy2 vs
  33.403 -        c (prop_of (forall_intr_list (map (cterm_of (sign_of thy2) o Var)
  33.404 -          (rev (Term.add_vars (prop_of intr) []) \\ params')) intr))))
  33.405 -            (intrs ~~ List.concat constrss);
  33.406 -    val rlzsets = distinct (op =) (map (fn rintr => snd (HOLogic.dest_mem
  33.407 -      (HOLogic.dest_Trueprop (Logic.strip_assums_concl rintr)))) rintrs);
  33.408 +        (if c = Extraction.nullt then c else list_comb (c, map Var (rev
  33.409 +          (Term.add_vars (prop_of intr) []) \\ params'))) (prop_of intr)))
  33.410 +            (maps snd rss ~~ List.concat constrss);
  33.411 +    val (rlzpreds, rlzpreds') = split_list
  33.412 +      (distinct (op = o pairself (#1 o #1)) (map (fn rintr =>
  33.413 +        let
  33.414 +          val Const (s, T) = head_of (HOLogic.dest_Trueprop
  33.415 +            (Logic.strip_assums_concl rintr));
  33.416 +          val s' = Sign.base_name s;
  33.417 +          val T' = Logic.unvarifyT T
  33.418 +        in ((s', SOME T', NoSyn),
  33.419 +          (Const (s, T'), Free (s', T')))
  33.420 +        end) rintrs));
  33.421 +    val rlzparams = map (fn Var ((s, _), T) => (s, SOME (Logic.unvarifyT T)))
  33.422 +      (List.take (snd (strip_comb
  33.423 +        (HOLogic.dest_Trueprop (Logic.strip_assums_concl (hd rintrs)))), nparms));
  33.424  
  33.425      (** realizability predicate **)
  33.426  
  33.427 -    val (thy3', ind_info) = thy2 |>
  33.428 -      OldInductivePackage.add_inductive_i false true "" false false false
  33.429 -        (map Logic.unvarify rlzsets) (map (fn (rintr, intr) =>
  33.430 -          ((Sign.base_name (Thm.get_name intr), strip_all
  33.431 -            (Logic.unvarify rintr)), [])) (rintrs ~~ intrs)) [] |>>
  33.432 +    val (ind_info, thy3') = thy2 |>
  33.433 +      TheoryTarget.init NONE |>
  33.434 +      InductivePackage.add_inductive_i false "" false false false
  33.435 +        rlzpreds rlzparams (map (fn (rintr, intr) =>
  33.436 +          ((Sign.base_name (name_of_thm intr), []),
  33.437 +           subst_atomic rlzpreds' (Logic.unvarify rintr)))
  33.438 +             (rintrs ~~ maps snd rss)) [] ||>
  33.439 +      ProofContext.theory_of o LocalTheory.exit ||>
  33.440        Theory.absolute_path;
  33.441      val thy3 = PureThy.hide_thms false
  33.442 -      (map Thm.get_name (#intrs ind_info)) thy3';
  33.443 +      (map name_of_thm (#intrs ind_info)) thy3';
  33.444  
  33.445      (** realizer for induction rule **)
  33.446  
  33.447 -    val Ps = List.mapPartial (fn _ $ M $ P => if set_of M mem rsets then
  33.448 +    val Ps = List.mapPartial (fn _ $ M $ P => if pred_of M mem rsets then
  33.449        SOME (fst (fst (dest_Var (head_of P)))) else NONE)
  33.450          (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of raw_induct)));
  33.451  
  33.452      fun add_ind_realizer (thy, Ps) =
  33.453        let
  33.454 -        val r = indrule_realizer thy induct raw_induct rsets params'
  33.455 -          (vs @ Ps) rec_names rss intrs dummies;
  33.456 -        val rlz = strip_all (Logic.unvarify
  33.457 -          (Extraction.realizes_of thy (vs @ Ps) r (prop_of induct)));
  33.458 +        val rs = indrule_realizer thy induct raw_induct rsets params'
  33.459 +          (vs @ Ps) rec_names rss' intrs dummies;
  33.460 +        val rlzs = map (fn (r, ind) => Extraction.realizes_of thy (vs @ Ps) r
  33.461 +          (prop_of ind)) (rs ~~ inducts);
  33.462 +        val used = foldr add_term_free_names [] rlzs;
  33.463 +        val rnames = Name.variant_list used (replicate (length inducts) "r");
  33.464 +        val rnames' = Name.variant_list
  33.465 +          (used @ rnames) (replicate (length intrs) "s");
  33.466 +        val rlzs' as (prems, _, _) :: _ = map (fn (rlz, name) =>
  33.467 +          let
  33.468 +            val (P, Q) = strip_one name (Logic.unvarify rlz);
  33.469 +            val Q' = strip_all' [] rnames' Q
  33.470 +          in
  33.471 +            (Logic.strip_imp_prems Q', P, Logic.strip_imp_concl Q')
  33.472 +          end) (rlzs ~~ rnames);
  33.473 +        val concl = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map
  33.474 +          (fn (_, _ $ P, _ $ Q) => HOLogic.mk_imp (P, Q)) rlzs'));
  33.475          val rews = map mk_meta_eq
  33.476            (fst_conv :: snd_conv :: get #rec_thms dt_info);
  33.477 -        val thm = OldGoals.simple_prove_goal_cterm (cterm_of (sign_of thy) rlz) (fn prems =>
  33.478 -          [if length rss = 1 then
  33.479 -             cut_facts_tac [hd prems] 1 THEN etac (#induct ind_info) 1
  33.480 -           else EVERY [rewrite_goals_tac (rews @ all_simps),
  33.481 -             REPEAT (rtac allI 1), rtac (#induct ind_info) 1],
  33.482 +        val thm = Goal.prove_global thy [] prems concl (fn prems => EVERY
  33.483 +          [rtac (#raw_induct ind_info) 1,
  33.484             rewrite_goals_tac rews,
  33.485             REPEAT ((resolve_tac prems THEN_ALL_NEW EVERY'
  33.486               [K (rewrite_goals_tac rews), ObjectLogic.atomize_tac,
  33.487                DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE]]) 1)]);
  33.488          val (thm', thy') = PureThy.store_thm ((space_implode "_"
  33.489 -          (Thm.get_name induct :: vs @ Ps @ ["correctness"]), thm), []) thy
  33.490 +          (NameSpace.qualified qualifier "induct" :: vs @ Ps @
  33.491 +             ["correctness"]), thm), []) thy;
  33.492 +        val thms = map (fn th => zero_var_indexes (rotate_prems ~1 (th RS mp)))
  33.493 +          (DatatypeAux.split_conj_thm thm');
  33.494 +        val ([thms'], thy'') = PureThy.add_thmss
  33.495 +          [((space_implode "_"
  33.496 +             (NameSpace.qualified qualifier "inducts" :: vs @ Ps @
  33.497 +               ["correctness"]), thms), [])] thy';
  33.498 +        val realizers = inducts ~~ thms' ~~ rlzs ~~ rs;
  33.499        in
  33.500          Extraction.add_realizers_i
  33.501 -          [mk_realizer thy' (vs @ Ps) params' ((induct, thm'), r)] thy'
  33.502 +          (map (fn (((ind, corr), rlz), r) =>
  33.503 +              mk_realizer thy' (vs @ Ps) (Thm.get_name ind, ind, corr, rlz, r))
  33.504 +            realizers @ (case realizers of
  33.505 +             [(((ind, corr), rlz), r)] =>
  33.506 +               [mk_realizer thy' (vs @ Ps) (NameSpace.qualified qualifier "induct",
  33.507 +                  ind, corr, rlz, r)]
  33.508 +           | _ => [])) thy''
  33.509        end;
  33.510  
  33.511      (** realizer for elimination rules **)
  33.512 @@ -394,15 +471,13 @@
  33.513        (((((elim, elimR), intrs), case_thms), case_name), dummy) thy =
  33.514        let
  33.515          val (prem :: prems) = prems_of elim;
  33.516 -        fun reorder1 (p, intr) =
  33.517 +        fun reorder1 (p, (_, intr)) =
  33.518            Library.foldl (fn (t, ((s, _), T)) => all T $ lambda (Free (s, T)) t)
  33.519              (strip_all p, Term.add_vars (prop_of intr) [] \\ params');
  33.520 -        fun reorder2 (intr, i) =
  33.521 -          let
  33.522 -            val fs1 = term_vars (prop_of intr) \\ params;
  33.523 -            val fs2 = Term.add_vars (prop_of intr) [] \\ params'
  33.524 +        fun reorder2 ((ivs, intr), i) =
  33.525 +          let val fs = Term.add_vars (prop_of intr) [] \\ params'
  33.526            in Library.foldl (fn (t, x) => lambda (Var x) t)
  33.527 -            (list_comb (Bound (i + length fs1), fs1), fs2)
  33.528 +            (list_comb (Bound (i + length ivs), ivs), fs)
  33.529            end;
  33.530          val p = Logic.list_implies
  33.531            (map reorder1 (prems ~~ intrs) @ [prem], concl_of elim);
  33.532 @@ -416,37 +491,36 @@
  33.533               else []) @
  33.534              map reorder2 (intrs ~~ (length prems - 1 downto 0)) @
  33.535              [Bound (length prems)]));
  33.536 -        val rlz = strip_all (Logic.unvarify
  33.537 -          (Extraction.realizes_of thy (vs @ Ps) r (prop_of elim)));
  33.538 +        val rlz = Extraction.realizes_of thy (vs @ Ps) r (prop_of elim);
  33.539 +        val rlz' = strip_all (Logic.unvarify rlz);
  33.540          val rews = map mk_meta_eq case_thms;
  33.541 -        val thm = OldGoals.simple_prove_goal_cterm (cterm_of (sign_of thy) rlz) (fn prems =>
  33.542 +        val thm = Goal.prove_global thy []
  33.543 +          (Logic.strip_imp_prems rlz') (Logic.strip_imp_concl rlz') (fn prems => EVERY
  33.544            [cut_facts_tac [hd prems] 1,
  33.545             etac elimR 1,
  33.546 -           ALLGOALS (EVERY' [etac Pair_inject, asm_simp_tac HOL_basic_ss]),
  33.547 +           ALLGOALS (asm_simp_tac HOL_basic_ss),
  33.548             rewrite_goals_tac rews,
  33.549             REPEAT ((resolve_tac prems THEN_ALL_NEW (ObjectLogic.atomize_tac THEN'
  33.550               DEPTH_SOLVE_1 o FIRST' [atac, etac allE, etac impE])) 1)]);
  33.551          val (thm', thy') = PureThy.store_thm ((space_implode "_"
  33.552 -          (Thm.get_name elim :: vs @ Ps @ ["correctness"]), thm), []) thy
  33.553 +          (name_of_thm elim :: vs @ Ps @ ["correctness"]), thm), []) thy
  33.554        in
  33.555          Extraction.add_realizers_i
  33.556 -          [mk_realizer thy' (vs @ Ps) params' ((elim, thm'), r)] thy'
  33.557 +          [mk_realizer thy' (vs @ Ps) (name_of_thm elim, elim, thm', rlz, r)] thy'
  33.558        end;
  33.559  
  33.560      (** add realizers to theory **)
  33.561  
  33.562 -    val rintr_thms = List.concat (map (fn (_, rs) => map (fn r => List.nth
  33.563 -      (#intrs ind_info, find_index (fn th => eq_thm (th, r)) intrs)) rs) rss);
  33.564      val thy4 = Library.foldl add_ind_realizer (thy3, subsets Ps);
  33.565      val thy5 = Extraction.add_realizers_i
  33.566 -      (map (mk_realizer thy4 vs params')
  33.567 -         (map (fn ((rule, rrule), c) => ((rule, rrule), list_comb (c,
  33.568 -            map Var (rev (Term.add_vars (prop_of rule) []) \\ params')))) 
  33.569 -              (List.concat (map snd rss) ~~ rintr_thms ~~ List.concat constrss))) thy4;
  33.570 -    val elimps = List.mapPartial (fn (s, intrs) => if s mem rsets then
  33.571 -        Option.map (rpair intrs) (find_first (fn (thm, _) =>
  33.572 -          s mem term_consts (hd (prems_of thm))) (elims ~~ #elims ind_info))
  33.573 -      else NONE) rss;
  33.574 +      (map (mk_realizer thy4 vs) (map (fn (((rule, rrule), rlz), c) =>
  33.575 +         (name_of_thm rule, rule, rrule, rlz,
  33.576 +            list_comb (c, map Var (rev (Term.add_vars (prop_of rule) []) \\ params'))))
  33.577 +              (List.concat (map snd rss) ~~ #intrs ind_info ~~ rintrs ~~
  33.578 +                 List.concat constrss))) thy4;
  33.579 +    val elimps = List.mapPartial (fn ((s, intrs), p) =>
  33.580 +      if s mem rsets then SOME (p, intrs) else NONE)
  33.581 +        (rss' ~~ (elims ~~ #elims ind_info));
  33.582      val thy6 = Library.foldl (fn (thy, p as (((((elim, _), _), _), _), _)) => thy |>
  33.583        add_elim_realizer [] p |> add_elim_realizer [fst (fst (dest_Var
  33.584          (HOLogic.dest_Trueprop (concl_of elim))))] p) (thy5,
  33.585 @@ -457,12 +531,9 @@
  33.586  fun add_ind_realizers name rsets thy =
  33.587    let
  33.588      val (_, {intrs, induct, raw_induct, elims, ...}) =
  33.589 -      (case OldInductivePackage.get_inductive thy name of
  33.590 -         NONE => error ("Unknown inductive set " ^ quote name)
  33.591 -       | SOME info => info);
  33.592 -    val _ $ (_ $ _ $ S) = concl_of (hd intrs);
  33.593 +      InductivePackage.the_inductive (ProofContext.init thy) name;
  33.594      val vss = sort (int_ord o pairself length)
  33.595 -      (subsets (map fst (relevant_vars S)))
  33.596 +      (subsets (map fst (relevant_vars (concl_of (hd intrs)))))
  33.597    in
  33.598      Library.foldl (add_ind_realizer rsets intrs induct raw_induct elims) (thy, vss)
  33.599    end
  33.600 @@ -472,8 +543,8 @@
  33.601      fun err () = error "ind_realizer: bad rule";
  33.602      val sets =
  33.603        (case HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of thm)) of
  33.604 -           [_] => [set_of (HOLogic.dest_Trueprop (hd (prems_of thm)))]
  33.605 -         | xs => map (set_of o fst o HOLogic.dest_imp) xs)
  33.606 +           [_] => [pred_of (HOLogic.dest_Trueprop (hd (prems_of thm)))]
  33.607 +         | xs => map (pred_of o fst o HOLogic.dest_imp) xs)
  33.608           handle TERM _ => err () | Empty => err ();
  33.609    in 
  33.610      add_ind_realizers (hd sets)