(* Title:     HOL/MiniML/W.thy
   Author:    Dieter Nazareth, Wolfgang Naraschewski and Tobias Nipkow
   Copyright  1996 TU Muenchen
*)

section "Correctness and completeness of type inference algorithm W"

theory W
imports MiniML
begin

type_synonym result_W = "(subst * typ * nat) option"

\<comment> \<open>type inference algorithm W\<close>
primrec W :: "[expr, ctxt, nat] => result_W" where
  "W (Var i) A n =
     (if i < length A then Some( id_subst,
                                 bound_typ_inst (\<lambda>b. TVar(b+n)) (A!i),
                                 n + (min_new_bound_tv (A!i)) )
                      else None)"

| "W (Abs e) A n = ( (S,t,m) := W e ((FVar n)#A) (Suc n);
                     Some( S, (S n) -> t, m) )"

| "W (App e1 e2) A n = ( (S1,t1,m1) := W e1 A n;
                         (S2,t2,m2) := W e2 ($S1 A) m1;
                         U := mgu ($S2 t1) (t2 -> (TVar m2));
                         Some( $U \<circ> $S2 \<circ> S1, U m2, Suc m2) )"

| "W (LET e1 e2) A n = ( (S1,t1,m1) := W e1 A n;
                         (S2,t2,m2) := W e2 ((gen ($S1 A) t1)#($S1 A)) m1;
                         Some( $S2 \<circ> S1, t2, m2) )"

declare Suc_le_lessD [simp]

inductive_cases has_type_casesE:
"A |- Var n :: t"
"A |- Abs e :: t"
"A |- App e1 e2 ::t"
"A |- LET e1 e2 ::t"

\<comment> \<open>the resulting type variable is always greater or equal than the given one\<close>
lemma W_var_ge [rule_format (no_asm)]:
  "\<forall>A n S t m. W e A n  = Some (S,t,m) \<longrightarrow> n\<le>m"
apply (induct_tac "e")
(* case Var(n) *)
apply (simp (no_asm) split: split_option_bind)
(* case Abs e *)
apply (simp (no_asm) split: split_option_bind)
apply (fast dest: Suc_leD)
(* case App e1 e2 *)
apply (simp (no_asm) split: split_option_bind)
apply (blast intro: le_SucI le_trans)
(* case LET e1 e2 *)
apply (simp (no_asm) split: split_option_bind)
apply (blast intro: le_trans)
done

declare W_var_ge [simp]

lemma W_var_geD:
  "Some (S,t,m) = W e A n \<Longrightarrow> n\<le>m"
apply (simp add: eq_sym_conv)
done

lemma new_tv_compatible_W:
  "new_tv n A \<Longrightarrow> Some (S,t,m) = W e A n \<Longrightarrow> new_tv m A"
apply (drule W_var_geD)
apply (rule new_scheme_list_le)
apply assumption
apply assumption
done

lemma new_tv_bound_typ_inst_sch [rule_format (no_asm)]:
  "new_tv n sch \<longrightarrow> new_tv (n + (min_new_bound_tv sch)) (bound_typ_inst (\<lambda>b. TVar (b + n)) sch)"
apply (induct_tac "sch")
  apply simp
 apply (simp add: add.commute)
apply (intro strip)
apply simp
apply (erule conjE)
apply (rule conjI)
 apply (rule new_tv_le)
  prefer 2 apply (assumption)
 apply (rule add_le_mono)
  apply (simp (no_asm))
 apply (simp (no_asm) add: max_def)
apply (rule new_tv_le)
 prefer 2 apply (assumption)
apply (rule add_le_mono)
 apply (simp (no_asm))
apply (simp (no_asm) add: max_def)
done

declare new_tv_bound_typ_inst_sch [simp]

\<comment> \<open>resulting type variable is new\<close>
lemma new_tv_W [rule_format (no_asm)]:
  "\<forall>n A S t m. new_tv n A \<longrightarrow> W e A n = Some (S,t,m) \<longrightarrow>
               new_tv m S \<and> new_tv m t"
proof (induct e)
  case Var then show ?case
    apply (simp (no_asm) split: split_option_bind)
    apply (intro strip)
    apply (drule new_tv_nth_nat_A)
    apply assumption
    apply (simp (no_asm_simp))
    done
next
  case Abs then show ?case
    apply (simp (no_asm) add: new_tv_subst new_tv_Suc_list split: split_option_bind)
    apply (intro strip)
    apply (erule_tac x = "Suc n" in allE)
    apply (erule_tac x = " (FVar n) #A" in allE)
    apply (fastforce simp add: new_tv_subst new_tv_Suc_list)
    done
next
  case App then show ?case
    apply (simp (no_asm) split: split_option_bind)
    apply (intro strip)
    apply (rename_tac S1 t1 n1 S2 t2 n2 S3)
    apply (erule_tac x = "n" in allE)
    apply (erule_tac x = "A" in allE)
    apply (erule_tac x = "S1" in allE)
    apply (erule_tac x = "t1" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (simp add: eq_sym_conv del: all_simps)
    apply (erule_tac x = "$S1 A" in allE)
    apply (erule_tac x = "S2" in allE)
    apply (erule_tac x = "t2" in allE)
    apply (erule_tac x = "n2" in allE)
    apply ( simp add: o_def rotate_Some)
    apply (rule conjI)
    apply (rule new_tv_subst_comp_2)
    apply (rule new_tv_subst_comp_2)
    apply (rule lessI [THEN less_imp_le, THEN new_tv_le])
    apply (rule_tac n = "n1" in new_tv_subst_le)
    apply (simp add: rotate_Some)
    apply (simp (no_asm_simp))
    apply (fast dest: W_var_geD intro: new_scheme_list_le new_tv_subst_scheme_list lessI [THEN less_imp_le [THEN new_tv_subst_le]])
    apply (erule sym [THEN mgu_new])
    apply (blast dest!: W_var_geD
      intro: lessI [THEN less_imp_le, THEN new_tv_le] new_tv_subst_te
      new_tv_subst_scheme_list new_scheme_list_le new_tv_le)

    apply (erule impE)
    apply (blast dest: W_var_geD intro: new_tv_subst_scheme_list new_scheme_list_le new_tv_le)
    apply clarsimp

    apply (rule lessI [THEN new_tv_subst_var])
    apply (erule sym [THEN mgu_new])
    apply (blast dest!: W_var_geD
      intro: lessI [THEN less_imp_le, THEN new_tv_le] new_tv_subst_te
      new_tv_subst_scheme_list new_scheme_list_le new_tv_le)

    apply (erule impE)
    apply (blast dest: W_var_geD intro: new_tv_subst_scheme_list new_scheme_list_le new_tv_le)
    apply clarsimp
    done
next
  case LET then show ?case
    apply (simp (no_asm) split: split_option_bind)
    apply (intro strip)
    apply (erule allE,erule allE,erule allE,erule allE,erule allE, erule impE, assumption, erule impE, assumption)
    apply (erule conjE)
    apply (erule allE,erule allE,erule allE,erule allE,erule allE, erule impE, erule_tac [2] notE impE,
      tactic "assume_tac @{context} 2")
    apply (simp only: new_tv_def)
    apply (simp (no_asm_simp))
    apply (drule W_var_ge)+
    apply (rule allI)
    apply (intro strip)
    apply (simp only: free_tv_subst)
    apply (drule free_tv_app_subst_scheme_list [THEN subsetD])
    apply (best elim: less_le_trans)
    apply (erule conjE)
    apply (rule conjI)
    apply (simp only: o_def)
    apply (rule new_tv_subst_comp_2)
    apply (erule W_var_ge [THEN new_tv_subst_le])
    apply assumption
    apply assumption
    apply assumption
    done
qed

lemma free_tv_bound_typ_inst1 [rule_format (no_asm)]:
  "(v \<notin> free_tv sch) \<longrightarrow> (v \<in> free_tv (bound_typ_inst (TVar \<circ> S) sch)) \<longrightarrow> (\<exists>x. v = S x)"
apply (induct_tac "sch")
apply simp
apply simp
apply (intro strip)
apply (rule exI)
apply (rule refl)
apply simp
done

declare free_tv_bound_typ_inst1 [simp]

lemma free_tv_W [rule_format (no_asm)]:
  "\<forall>n A S t m v. W e A n = Some (S,t,m) \<longrightarrow>
          (v\<in>free_tv S \<or> v\<in>free_tv t) \<longrightarrow> v<n \<longrightarrow> v\<in>free_tv A"
proof (induct e)
  case (Var n) then show ?case
    apply (simp (no_asm) add: free_tv_subst split: split_option_bind)
    apply (intro strip)
    apply (case_tac "v : free_tv (A!n)")
    apply simp
    apply (drule free_tv_bound_typ_inst1)
    apply (simp (no_asm) add: o_def)
    apply (erule exE)
    apply simp
    done
  case Abs then show ?case
    apply (simp add: free_tv_subst split: split_option_bind del: all_simps)
    apply (intro strip)
    apply (rename_tac S t n1 v)
    apply (erule_tac x = "Suc n" in allE)
    apply (erule_tac x = "FVar n # A" in allE)
    apply (erule_tac x = "S" in allE)
    apply (erule_tac x = "t" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (erule_tac x = "v" in allE)
    apply (bestsimp intro: cod_app_subst simp add: less_Suc_eq)
    done
  case App then show ?case
    apply (simp (no_asm) split: split_option_bind del: all_simps)
    apply (intro strip)
    apply (rename_tac S t n1 S1 t1 n2 S2 v)
    apply (erule_tac x = "n" in allE)
    apply (erule_tac x = "A" in allE)
    apply (erule_tac x = "S" in allE)
    apply (erule_tac x = "t" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (erule_tac x = "n1" in allE)
    apply (erule_tac x = "v" in allE)
    (* second case *)
    apply (erule_tac x = "$ S A" in allE)
    apply (erule_tac x = "S1" in allE)
    apply (erule_tac x = "t1" in allE)
    apply (erule_tac x = "n2" in allE)
    apply (erule_tac x = "v" in allE)
    apply (intro conjI impI | elim conjE)+
    apply (simp add: rotate_Some o_def)
    apply (drule W_var_geD)
    apply (drule W_var_geD)
    apply ( (frule less_le_trans) , (assumption))
    apply clarsimp
    apply (drule free_tv_comp_subst [THEN subsetD])
    apply (drule sym [THEN mgu_free])
    apply clarsimp
    apply (fastforce dest: free_tv_comp_subst [THEN subsetD] sym [THEN mgu_free] codD free_tv_app_subst_te [THEN subsetD] free_tv_app_subst_scheme_list [THEN subsetD] less_le_trans less_not_refl2 subsetD)
    apply simp
    apply (drule sym [THEN W_var_geD])
    apply (drule sym [THEN W_var_geD])
    apply ( (frule less_le_trans) , (assumption))
    apply clarsimp
    apply (drule mgu_free)
    apply (fastforce dest: mgu_free codD free_tv_subst_var [THEN subsetD] free_tv_app_subst_te [THEN subsetD] free_tv_app_subst_scheme_list [THEN subsetD] less_le_trans subsetD)
    done
next
  case LET then show ?case
    apply (simp (no_asm) split: split_option_bind del: all_simps)
    apply (intro strip)
    apply (rename_tac S1 t1 n2 S2 t2 n3 v)
    apply (erule_tac x = "n" in allE)
    apply (erule_tac x = "A" in allE)
    apply (erule_tac x = "S1" in allE)
    apply (erule_tac x = "t1" in allE)
    apply (rotate_tac -1)
    apply (erule_tac x = "n2" in allE)
    apply (rotate_tac -1)
    apply (erule_tac x = "v" in allE)
    apply (erule (1) notE impE)
    apply (erule allE,erule allE,erule allE,erule allE,erule allE,erule_tac  x = "v" in allE)
    apply (erule (1) notE impE)
    apply simp
    apply (rule conjI)
    apply (fast dest!: codD free_tv_app_subst_scheme_list [THEN subsetD] free_tv_o_subst [THEN subsetD] W_var_ge dest: less_le_trans)
    apply (fast dest!: codD free_tv_app_subst_scheme_list [THEN subsetD] W_var_ge dest: less_le_trans)
    done
qed

lemma weaken_A_Int_B_eq_empty: "(\<forall>x. x \<in> A \<longrightarrow> x \<notin> B) \<Longrightarrow> A \<inter> B = {}"
apply fast
done

lemma weaken_not_elem_A_minus_B: "x \<notin> A \<or> x \<in> B \<Longrightarrow> x \<notin> A - B"
apply fast
done

\<comment> \<open>correctness of W with respect to @{text has_type}\<close>
lemma W_correct_lemma [rule_format (no_asm)]: "\<forall>A S t m n . new_tv n A \<longrightarrow> Some (S,t,m) = W e A n \<longrightarrow> $S A |- e :: t"
apply (induct_tac "e")
(* case Var n *)
apply simp
apply (intro strip)
apply (rule has_type.VarI)
apply (simp (no_asm))
apply (simp (no_asm) add: is_bound_typ_instance)
apply (rule exI)
apply (rule refl)
(* case Abs e *)
apply (simp add: app_subst_list split: split_option_bind)
apply (intro strip)
apply (erule_tac x = " (mk_scheme (TVar n)) # A" in allE)
apply simp
apply (rule has_type.AbsI)
apply (drule le_refl [THEN le_SucI, THEN new_scheme_list_le])
apply (drule sym)
apply (erule allE)+
apply (erule impE)
apply (erule_tac [2] notE impE, tactic "assume_tac @{context} 2")
apply (simp (no_asm_simp))
apply assumption
(* case App e1 e2 *)
apply (simp (no_asm) split: split_option_bind)
apply (intro strip)
apply (rename_tac S1 t1 n1 S2 t2 n2 S3)
apply (rule_tac ?t2.0 = "$ S3 t2" in has_type.AppI)
apply (rule_tac S1 = "S3" in app_subst_TVar [THEN subst])
apply (rule app_subst_Fun [THEN subst])
apply (rule_tac t = "$S3 (t2 -> (TVar n2))" and s = "$S3 ($S2 t1) " in subst)
apply simp
apply (simp only: subst_comp_scheme_list [symmetric] o_def)
apply ((rule has_type_cl_sub [THEN spec]) , (rule has_type_cl_sub [THEN spec]))
apply (simp add: eq_sym_conv)
apply (simp add: subst_comp_scheme_list [symmetric] o_def has_type_cl_sub eq_sym_conv)
apply (rule has_type_cl_sub [THEN spec])
apply (frule new_tv_W)
apply assumption
apply (drule conjunct1)
apply (frule new_tv_subst_scheme_list)
apply (rule new_scheme_list_le)
apply (rule W_var_ge)
apply assumption
apply assumption
apply (erule thin_rl)
apply (erule allE)+
apply (drule sym)
apply (drule sym)
apply (erule thin_rl)
apply (erule thin_rl)
apply (erule (1) notE impE)
apply (erule (1) notE impE)
apply assumption
(* case Let e1 e2 *)
apply (simp (no_asm) split: split_option_bind)
apply (intro strip)
(*by (rename_tac "w q m1 S1 t1 m2 S2 t n2" 1); *)
apply (rename_tac S1 t1 m1 S2)
apply (rule_tac ?t1.0 = "$ S2 t1" in has_type.LETI)
 apply (simp (no_asm) add: o_def)
 apply (simp only: subst_comp_scheme_list [symmetric])
 apply (rule has_type_cl_sub [THEN spec])
 apply (drule_tac x = "A" in spec)
 apply (drule_tac x = "S1" in spec)
 apply (drule_tac x = "t1" in spec)
 apply (drule_tac x = "m1" in spec)
 apply (drule_tac x = "n" in spec)
 apply (erule (1) notE impE)
 apply (simp add: eq_sym_conv)
apply (simp (no_asm) add: o_def)
apply (simp only: subst_comp_scheme_list [symmetric])
apply (rule gen_subst_commutes [symmetric, THEN subst])
 apply (rule_tac [2] app_subst_Cons [THEN subst])
 apply (erule_tac [2] thin_rl)
 apply (drule_tac [2] x = "gen ($S1 A) t1 # $ S1 A" in spec)
 apply (drule_tac [2] x = "S2" in spec)
 apply (drule_tac [2] x = "t" in spec)
 apply (drule_tac [2] x = "m" in spec)
 apply (drule_tac [2] x = "m1" in spec)
 apply (frule_tac [2] new_tv_W)
  prefer 2 apply (assumption)
 apply (drule_tac [2] conjunct1)
 apply (frule_tac [2] new_tv_subst_scheme_list)
  apply (rule_tac [2] new_scheme_list_le)
   apply (rule_tac [2] W_var_ge)
   prefer 2 apply (assumption)
  prefer 2 apply (assumption)
 apply (erule_tac [2] impE)
  apply (rule_tac [2] A = "$ S1 A" in new_tv_only_depends_on_free_tv_scheme_list)
   prefer 2 apply simp
   apply (fast)
  prefer 2 apply (assumption)
 prefer 2 apply simp
apply (rule weaken_A_Int_B_eq_empty)
apply (rule allI)
apply (intro strip)
apply (rule weaken_not_elem_A_minus_B)
apply (case_tac "x < m1")
 apply (rule disjI2)
 apply (rule free_tv_gen_cons [THEN subst])
 apply (rule free_tv_W)
   apply assumption
  apply simp
 apply assumption
apply (rule disjI1)
apply (drule new_tv_W)
apply assumption
apply (drule conjunct2)
apply (rule new_tv_not_free_tv)
apply (rule new_tv_le)
 prefer 2 apply (assumption)
apply (simp add: linorder_not_less)
done

\<comment> \<open>Completeness of W w.r.t. @{text has_type}\<close>
lemma W_complete_lemma [rule_format (no_asm)]:
  "\<forall>S' A t' n. $S' A |- e :: t' \<longrightarrow> new_tv n A \<longrightarrow>
               (\<exists>S t. (\<exists>m. W e A n = Some (S,t,m)) \<and>
                       (\<exists>R. $S' A = $R ($S A) \<and> t' = $R t))"
apply (induct e)
   (* case Var n *)
   apply (intro strip)
   apply (simp (no_asm) cong add: conj_cong)
   apply (erule has_type_casesE)
   apply (simp add: is_bound_typ_instance)
   apply (erule exE)
   apply (hypsubst)
   apply (rename_tac "S")
   apply (rule_tac x = "\<lambda>x. (if x < n then S' x else S (x - n))" in exI)
   apply (rule conjI)
   apply (simp (no_asm_simp))
   apply (simp (no_asm_simp) add: bound_typ_inst_composed_subst [symmetric] new_tv_nth_nat_A o_def nth_subst
                             del: bound_typ_inst_composed_subst)

  (* case Abs e *)
  apply (intro strip)
  apply (erule has_type_casesE)
  apply (erule_tac x = "\<lambda>x. if x=n then t1 else (S' x) " in allE)
  apply (erule_tac x = " (FVar n) #A" in allE)
  apply (erule_tac x = "t2" in allE)
  apply (erule_tac x = "Suc n" in allE)
  apply (bestsimp dest!: mk_scheme_injective cong: conj_cong split: split_option_bind)

 (* case App e1 e2 *)
 apply (intro strip)
 apply (erule has_type_casesE)
 apply (erule_tac x = "S'" in allE)
 apply (erule_tac x = "A" in allE)
 apply (erule_tac x = "t2 -> t'" in allE)
 apply (erule_tac x = "n" in allE)
 apply safe
 apply (erule_tac x = "R" in allE)
 apply (erule_tac x = "$ S A" in allE)
 apply (erule_tac x = "t2" in allE)
 apply (erule_tac x = "m" in allE)
 apply simp
 apply safe
  apply (blast intro: sym [THEN W_var_geD] new_tv_W [THEN conjunct1] new_scheme_list_le new_tv_subst_scheme_list)

 (** LEVEL 33 **)
apply (subgoal_tac "$ (\<lambda>x. if x=ma then t' else (if x: (free_tv t - free_tv Sa) then R x else Ra x)) ($ Sa t) = $ (\<lambda>x. if x=ma then t' else (if x: (free_tv t - free_tv Sa) then R x else Ra x)) (ta -> (TVar ma))")
apply (rule_tac [2] t = "$ (\<lambda>x. if x = ma then t' else (if x: (free_tv t - free_tv Sa) then R x else Ra x)) ($ Sa t) " and s = " ($ Ra ta) -> t'" in ssubst)
prefer 2 apply (simp (no_asm_simp) add: subst_comp_te) prefer 2
apply (rule_tac [2] eq_free_eq_subst_te)
prefer 2 apply (intro strip) prefer 2
apply (subgoal_tac [2] "na \<noteq>ma")
 prefer 3 apply (best dest: new_tv_W sym [THEN W_var_geD] new_tv_not_free_tv new_tv_le)
apply (case_tac [2] "na:free_tv Sa")
(* n1 \<notin> free_tv S1 *)
apply (frule_tac [3] not_free_impl_id)
 prefer 3 apply (simp)
(* na : free_tv Sa *)
apply (drule_tac [2] A1 = "$ S A" in trans [OF _ subst_comp_scheme_list])
apply (drule_tac [2] eq_subst_scheme_list_eq_free)
 prefer 2 apply (fast intro: free_tv_W free_tv_le_new_tv dest: new_tv_W)
prefer 2 apply (simp (no_asm_simp)) prefer 2
apply (case_tac [2] "na:dom Sa")
(* na \<notin> dom Sa *)
 prefer 3 apply (simp add: dom_def)
(* na : dom Sa *)
apply (rule_tac [2] eq_free_eq_subst_te)
prefer 2 apply (intro strip) prefer 2
apply (subgoal_tac [2] "nb \<noteq> ma")
apply (frule_tac [3] new_tv_W) prefer 3 apply assumption
apply (erule_tac [3] conjE)
apply (drule_tac [3] new_tv_subst_scheme_list)
   prefer 3 apply (fast intro: new_scheme_list_le dest: sym [THEN W_var_geD])
  prefer 3 apply (fastforce dest: new_tv_W new_tv_not_free_tv simp add: cod_def free_tv_subst)
 prefer 2 apply (fastforce simp add: cod_def free_tv_subst)
prefer 2 apply (simp (no_asm)) prefer 2
apply (rule_tac [2] eq_free_eq_subst_te)
prefer 2 apply (intro strip) prefer 2
apply (subgoal_tac [2] "na \<noteq> ma")
apply (frule_tac [3] new_tv_W) prefer 3 apply assumption
apply (erule_tac [3] conjE)
apply (drule_tac [3] sym [THEN W_var_geD])
 prefer 3 apply (fast dest: new_scheme_list_le new_tv_subst_scheme_list new_tv_W new_tv_not_free_tv)
apply (case_tac [2] "na: free_tv t - free_tv Sa")
(* case na \<notin> free_tv t - free_tv Sa *)
 prefer 3
 apply simp
 apply fast
(* case na : free_tv t - free_tv Sa *)
prefer 2 apply simp prefer 2
apply (drule_tac [2] A1 = "$ S A" and r = "$ R ($ S A)" in trans [OF _ subst_comp_scheme_list])
apply (drule_tac [2] eq_subst_scheme_list_eq_free)
 prefer 2
 apply (fast intro: free_tv_W free_tv_le_new_tv dest: new_tv_W)
(** LEVEL 73 **)
 prefer 2 apply (simp add: free_tv_subst dom_def)
apply (simp (no_asm_simp) split: split_option_bind)
apply safe
apply (drule mgu_Some)
 apply fastforce
(** LEVEL 78 *)
apply (drule mgu_mg, assumption)
apply (erule exE)
apply (rule_tac x = "Rb" in exI)
apply (rule conjI)
apply (drule_tac [2] x = "ma" in fun_cong)
 prefer 2 apply (simp add: eq_sym_conv)
apply (simp (no_asm) add: subst_comp_scheme_list)
apply (simp (no_asm) add: subst_comp_scheme_list [symmetric])
apply (rule_tac A1 = "($ Sa ($ S A))" in trans [OF _ subst_comp_scheme_list [symmetric]])
apply (simp add: o_def eq_sym_conv)
apply (drule_tac s = "Some _" in sym)
apply (rule eq_free_eq_subst_scheme_list)
apply safe
apply (subgoal_tac "ma \<noteq> na")
apply (frule_tac [2] new_tv_W) prefer 2 apply assumption
apply (erule_tac [2] conjE)
apply (drule_tac [2] new_tv_subst_scheme_list)
 prefer 2 apply (fast intro: new_scheme_list_le dest: sym [THEN W_var_geD])
apply (frule_tac [2] n = "m" in new_tv_W) prefer 2 apply assumption
apply (erule_tac [2] conjE)
apply (drule_tac [2] free_tv_app_subst_scheme_list [THEN subsetD])
 apply (tactic \<open>
    (fast_tac (put_claset (claset_of @{theory_context Fun}) @{context}
      addDs [sym RS @{thm W_var_geD}, @{thm new_scheme_list_le}, @{thm codD},
        @{thm new_tv_not_free_tv}]) 2)\<close>)
apply (case_tac "na: free_tv t - free_tv Sa")
(* case na \<notin> free_tv t - free_tv Sa *)
 prefer 2 apply simp apply blast
(* case na : free_tv t - free_tv Sa *)
apply simp
apply (drule free_tv_app_subst_scheme_list [THEN subsetD])
 apply (fastforce dest: codD trans [OF _ subst_comp_scheme_list]
                       eq_subst_scheme_list_eq_free
             simp add: free_tv_subst dom_def)
(* case Let e1 e2 *)
apply (erule has_type_casesE)
apply (erule_tac x = "S'" in allE)
apply (erule_tac x = "A" in allE)
apply (erule_tac x = "t1" in allE)
apply (erule_tac x = "n" in allE)
apply (erule (1) notE impE)
apply (erule (1) notE impE)
apply safe
apply (simp (no_asm_simp))
apply (erule_tac x = "R" in allE)
apply (erule_tac x = "gen ($ S A) t # $ S A" in allE)
apply (erule_tac x = "t'" in allE)
apply (erule_tac x = "m" in allE)
apply simp
apply (drule mp)
apply (rule has_type_le_env)
apply assumption
apply (simp (no_asm))
apply (rule gen_bound_typ_instance)
apply (drule mp)
apply (frule new_tv_compatible_W)
apply (rule sym)
apply assumption
apply (fast dest: new_tv_compatible_gen new_tv_subst_scheme_list new_tv_W)
apply safe
apply simp
apply (rule_tac x = "Ra" in exI)
apply (simp (no_asm) add: o_def subst_comp_scheme_list [symmetric])
done

lemma W_complete:
  "[] |- e :: t' \<Longrightarrow> (\<exists>S t. (\<exists>m. W e [] n = Some(S,t,m)) \<and>
                     (\<exists>R. t' = $ R t))"
apply (cut_tac A = "[]" and S' = "id_subst" and e = "e" and t' = "t'" in W_complete_lemma)
apply simp_all
done

end


theory Lens
imports Iso
begin

locale lens =
  fixes get :: "'s \<Rightarrow> 'a" and set :: "'a \<Rightarrow> 's \<Rightarrow> 's"
  assumes set_get[simp]: "get (set a s) = a"
  assumes get_set[simp]: "set (get s) s = s"
  assumes set_set[simp]: "set a (set a' s) = set a s"
begin

definition modify :: "('a \<Rightarrow> 'a) \<Rightarrow> 's \<Rightarrow> 's" where
[optics]: "modify f s = set (f (get s)) s"

lemma modify_id[simp]: "modify id = id"
unfolding modify_def[abs_def] id_def by auto

lemma modify_comp[simp]: "modify (f \<circ> g) = modify f \<circ> modify g"
unfolding modify_def[abs_def] comp_def by auto

end

context iso begin

definition set where [optics]: "set a _ = back a"

sublocale lens: lens get set
by unfold_locales (auto simp: set_def)

lemma lens_modify_eq[simp]: "lens.modify = modify"
unfolding lens.modify_def[abs_def] modify_def[abs_def] set_def
by auto

end

locale compose_lens_lens =
  one: lens f g + two: lens h i for f :: "'s \<Rightarrow> 'a" and g and h :: "'a \<Rightarrow> 'b" and i
begin

definition [optics]: "get = h \<circ> f"
definition set where [optics]: "set b s = g (i b (f s)) s"

sublocale lens get set
by unfold_locales (auto simp: get_def set_def)

end

context compose_iso_iso begin

sublocale lens_lens: compose_lens_lens f "iso.set g" h "iso.set i" ..

lemma get_eq[simp]: "lens_lens.get = get"
unfolding lens_lens.get_def get_def ..

lemma set_eq[simp]: "lens_lens.set = set"
unfolding lens_lens.set_def[abs_def] one.set_def two.set_def local.set_def[abs_def]
by (simp add: back_def)

end

end


section \<open>Graphs defined by Successor Functions\<close>
theory Succ_Graph
imports
  "../../Refine_Dflt"
begin

text \<open>
  This code is used in various examples
\<close>

type_synonym 'a slg = "'a \<Rightarrow> 'a list"
definition slg_rel_def_internal: "slg_rel R \<equiv>
  {(succs,G). \<forall>v. (succs v, G``{v}) \<in> \<langle>R\<rangle>list_set_rel}"

lemma slg_rel_def: "\<langle>R\<rangle>slg_rel \<equiv>
  {(succs,G). \<forall>v. (succs v, G``{v}) \<in> \<langle>R\<rangle>list_set_rel}"
  by (auto simp: slg_rel_def_internal relAPP_def)

lemma [relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>slg_rel)"
  unfolding slg_rel_def
  apply (rule single_valuedI)
  apply (auto dest: single_valuedD[OF list_set_rel_sv])
  done

consts i_slg :: "interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] =
  REL_INTFI[of slg_rel i_slg]

definition [simp]: "slg_succs E v \<equiv> E``{v}"

lemma [autoref_itype]: "slg_succs ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_slg \<rightarrow>\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set" by simp

context begin interpretation autoref_syn .

definition [code_unfold, simp]: "slg_succs_impl succs v \<equiv> succs v"

lemma refine_slg_succs[autoref_rules_raw]:
  "(slg_succs_impl,slg_succs)\<in>\<langle>Id\<rangle>slg_rel\<rightarrow>Id\<rightarrow>\<langle>Id\<rangle>list_set_rel"
  apply (intro fun_relI)
  apply (simp add: slg_succs_def slg_rel_def)
  done

subsection "Graph Representations"
(* TODO: Correctness proofs *)

definition succ_of_list :: "(nat\<times>nat) list \<Rightarrow> nat \<Rightarrow> nat set"
  where
  "succ_of_list l \<equiv> let
    m = fold (\<lambda>(u,v) g.
          case g u of
            None \<Rightarrow> g(u\<mapsto>{v})
          | Some s \<Rightarrow> g(u\<mapsto>insert v s)
        ) l Map.empty
  in
    (\<lambda>u. case m u of None \<Rightarrow> {} | Some s \<Rightarrow> s)

"

schematic_goal succ_of_list_impl:
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat\<rightharpoonup>nat set" and R="\<langle>nat_rel,R\<rangle>iam_map_rel" for R]
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>list_set_rel"]

  shows "(?f::?'c,succ_of_list) \<in> ?R"
  unfolding succ_of_list_def[abs_def]
  apply (autoref (keep_goal))
  done

concrete_definition succ_of_list_impl uses succ_of_list_impl
export_code succ_of_list_impl checking SML

definition acc_of_list :: "nat list \<Rightarrow> nat set"
  where "acc_of_list l \<equiv> fold insert l {}"

schematic_goal acc_of_list_impl:
  notes [autoref_tyrel] =
    ty_REL[where 'a="nat set" and R="\<langle>nat_rel\<rangle>iam_set_rel" for R]

  shows "(?f::?'c,acc_of_list) \<in> ?R"
  unfolding acc_of_list_def[abs_def]
  apply (autoref (keep_goal))
  done

concrete_definition acc_of_list_impl uses acc_of_list_impl
export_code acc_of_list_impl checking SML

end


(* ********************************************************************************

    Theory DaC_synthesis.thy is part of a package providing supplementary material
    to 'Synthesis of Implementations for Divide-and-conquer Specifications'.
    Copyright (c) 2023  M. Bortin

    The package is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    For more details see the license agreement (LICENSE) you should have
    received along with the package.

   ******************************************************************************* *)

theory DaC_synthesis
  imports Preliminaries
begin

section "Modelling a particular relator"

text "Endorelators are in general modelled by means of
       -- an algebraic data type and
       -- a function that lifts each relation to the respective relation
          between the images of the source and the target.
      The extra parameter 'u below allows us to abstract over the type of
      the underlying values and corresponds to the set E in the publication."

datatype ('u, 'a) Relt = Empty | Dcmp 'u 'a

definition Relt :: "'a \<rightarrow> 'b \<Rightarrow> ('u, 'a) Relt \<rightarrow> ('u, 'b) Relt"
  where  "Relt r = {(Empty, Empty)} \<union> {(Dcmp x A, Dcmp x B) |x A B. (A, B) \<in> r}"

subsection "The relator axioms"

lemma Relt_mono:
  "mono Relt"
  unfolding Relt_def
  by(rule monoI, fast)

lemma Relt_comp:
  "Relt r \<diamondop> Relt s = Relt (r \<diamondop> s)"
  unfolding Relt_def
  by(rule equalityI, blast+)

lemma Relt_Id:
  "Relt Id = Id"
  unfolding Relt_def
  by (clarsimp, rule set_eqI, smt (verit, best) IdE IdI Relt.exhaust insert_iff mem_Collect_eq)

lemma Relt_conv:
"(Relt r)\<^sup>\<circ> \<subseteq> Relt (r\<^sup>\<circ>)"
  unfolding Relt_def
  by blast

subsection "Derived properties"

lemma Relt_conv_eq :
"(Relt r)\<^sup>\<circ> = Relt (r\<^sup>\<circ>)"
  by (metis Relt_conv converse_converse converse_subset_swap subset_antisym)

lemma Relt_simple :
"simple r \<Longrightarrow> simple(Relt r)"
  by (metis (no_types, opaque_lifting) Relt_Id Relt_comp Relt_conv_eq Relt_mono monoD simple_def)

lemma Relt_entire :
"entire r \<Longrightarrow> entire(Relt r)"
  by (metis Relt_Id Relt_comp Relt_conv_eq Relt_mono entire_def monoE)

lemma Relt_graph_of :
"\<exists>g. Relt(graph_of f) = graph_of g"
  apply(subgoal_tac "simple (graph_of f)")
  apply(subgoal_tac "entire (graph_of f)")
  apply (simp add: Relt_entire Relt_simple mapping)
  by(simp add: graph_of_def simple_def entire_def, fast)+

subsubsection "The induced endofunctor"

definition
  "ReltF f = funct_of(Relt(graph_of f))"

lemma ReltF_eqs :
"ReltF f Empty = Empty"
"ReltF f (Dcmp x u) = Dcmp x (f u)"
  by(simp add: ReltF_def Relt_def funct_of_def graph_of_def)+

lemma ReltF :
"Relt(graph_of f) = graph_of(ReltF f)"
  by (metis ReltF_def Relt_graph_of graph_of_funct_of)

text "the functor axioms:"

lemma ReltF1 :
"ReltF id = id"
  by (metis ReltF_def Relt_Id graph_of_funct_of graph_of_id)

lemma ReltF2 :
  "ReltF (g \<circ> f) = ReltF g \<circ> ReltF f"
  by (metis ReltF Relt_comp graph_of_comp graph_of_funct_of)

section "The divide-and-conquer synthesis for the above relator"

definition
"DaC_scheme decompose compose = (\<lambda>r. decompose \<diamondop> Relt r \<diamondop> compose)"

lemma DaC_mono :
"decompose \<subseteq> decompose' \<Longrightarrow> compose \<subseteq> compose' \<Longrightarrow> r \<subseteq> r' \<Longrightarrow>
 DaC_scheme decompose compose r \<subseteq> DaC_scheme decompose' compose' r'"
  apply(simp add: DaC_scheme_def, erule relcomp_mono, erule relcomp_mono[rotated 1])
  by(rule monoD[OF Relt_mono])

text "The synthesis rule will be captured by means of a 'locale' which is
      the central device supporting abstract developments in Isabelle:"
locale DaC_synthesis =
  fixes \<alpha>\<^sub>1 :: "'a \<rightarrow> 'b"
    and \<alpha>\<^sub>2 :: "'c \<rightarrow> 'd"
  and spec :: "'b \<rightarrow> 'd"
  and abs_dcmp :: "'b \<rightarrow> ('x, 'b) Relt"
  and abs_cmp  :: "('x, 'd) Relt \<rightarrow> 'd"
  and dcmp     :: "'a \<Rightarrow> ('x, 'a) Relt"
  and cmp      :: "('x, 'c) Relt \<Rightarrow> 'c"
assumes
  DaC : "DaC_scheme abs_dcmp abs_cmp spec \<subseteq> spec"
and
  decomp : "\<alpha>\<^sub>1\<^sup>\<circ> \<diamondop> (graph_of dcmp) \<subseteq> abs_dcmp \<diamondop> Relt (\<alpha>\<^sub>1\<^sup>\<circ>)"
and
  comp   : "(graph_of cmp) \<diamondop> \<alpha>\<^sub>2 \<subseteq> Relt \<alpha>\<^sub>2 \<diamondop> abs_cmp"
and
  reduct : "Id \<subseteq> lfp(\<lambda>x. monotypeF (graph_of dcmp) (Relt x))"
begin

lemma DaC_simple :
"simple d \<Longrightarrow> simple c \<Longrightarrow> simple (lfp (DaC_scheme d c))"
  apply(simp add: simple_def)
  apply(subst rdiv_univ)
  apply(rule lfp_lowerbound)
  apply(subst rdiv_univ[THEN sym])
  apply(subst lfp_unfold)
   apply(rule monoI, rule DaC_mono, rule subset_refl, rule subset_refl, assumption)
  apply(simp add: DaC_scheme_def)
  apply(fold DaC_scheme_def)
  apply(subst converse_relcomp)+
  apply(subst Relt_conv_eq)
  apply(subst O_assoc)+
  apply(rule subset_trans)
   apply(rule relcomp_mono[rotated 1])
    apply(rule relcomp_mono[rotated 1])
     apply(subst O_assoc[THEN sym])+
     apply(rule relcomp_mono)
      apply(erule relcomp_mono)
      apply(rule subset_refl)+
  apply simp
  apply(rule subset_trans)
   apply(rule relcomp_mono[rotated 1])
    apply(subst O_assoc[THEN sym])
    apply(rule relcomp_mono)
     apply(subst Relt_comp)
     apply(rule monoD[OF Relt_mono])
     apply(rule rdiv_univ[THEN iffD2])
     apply(rule subset_refl)+
  apply(subst Relt_Id)
  by simp

lemma DaC_entire :
"entire c \<Longrightarrow> entire(lfp(DaC_scheme (graph_of dcmp) c))"
  apply(simp add: entire_def)
  apply(rule subset_trans, rule reduct)
  apply(rule_tac H="\<lambda>x. x \<diamondop> x\<^sup>\<circ>" in lfp_fusion)
  apply(rule monoI, rule DaC_mono, simp+)
  apply(rule allI)
  apply(subgoal_tac "monotypeF (graph_of dcmp) (Relt (x \<diamondop> x\<^sup>\<circ>)) \<subseteq>
                    (monotypeF (graph_of dcmp) (Relt (x \<diamondop> x\<^sup>\<circ>)) \<diamondop> (graph_of dcmp)) \<diamondop> (graph_of dcmp)\<^sup>\<circ>")
   apply(erule subset_trans)
   apply(rule subset_trans)
    apply(rule relcomp_mono)
     apply(rule monotypeF1)
    apply(rule subset_refl)
   apply(subst Relt_comp[THEN sym])
   apply(simp add: DaC_scheme_def)
   apply(subst converse_relcomp)+
   apply(subst Relt_conv_eq)
   apply(subst O_assoc)+
   apply(rule relcomp_mono, rule subset_refl)+
   apply(rule subset_trans[rotated 1])
    apply(subst O_assoc[THEN sym])+
    apply(rule relcomp_mono)
     apply(erule relcomp_mono)
     apply(rule subset_refl)+
   apply simp
  apply(subst O_assoc)+
  apply(rule subset_trans[rotated 1])
   apply(rule_tac s'=Id in relcomp_mono)
    apply(rule subset_refl)
   apply(clarsimp simp: graph_of_def, fast)
  by simp

lemma DaC_impl :
"\<alpha>\<^sub>1\<^sup>\<circ> \<diamondop> lfp(DaC_scheme (graph_of dcmp) (graph_of cmp)) \<diamondop> \<alpha>\<^sub>2 \<subseteq> spec"
  apply(subst O_assoc[THEN sym])
  apply(subst ldiv_univ)
  apply(subst rdiv_univ)
  apply(rule lfp_lowerbound)
  apply(subst rdiv_univ[THEN sym])
  apply(subst ldiv_univ[THEN sym])
  apply(simp add: DaC_scheme_def)
  apply(rule subset_trans[rotated 1])
   apply(rule DaC)
  apply(subst O_assoc[THEN sym])+
  apply(rule subset_trans)
   apply(rule relcomp_mono)
    apply(rule relcomp_mono)
     apply(rule relcomp_mono)
      apply(rule decomp)
     apply(rule subset_refl)+
  apply(subst O_assoc)+
  apply(rule subset_trans)
   apply(rule relcomp_mono[rotated 1])
    apply(rule relcomp_mono[rotated 1])
     apply(rule relcomp_mono[rotated 1])
      apply(rule comp)
     apply(rule subset_refl)+
  apply(simp add: DaC_scheme_def)
  apply(rule relcomp_mono, rule subset_refl)
  apply(subst O_assoc[THEN sym])+
  apply(subst Relt_comp)+
  apply(rule relcomp_mono[rotated 1], rule subset_refl)
  apply(rule monoD[OF Relt_mono])
  apply(rule subset_trans)
   apply(rule relcomp_mono)
    apply(rule rdiv_univ[THEN iffD2])
    apply(rule subset_refl)+
  apply(rule ldiv_univ[THEN iffD2])
  by(rule subset_refl)

theorem DaC_synthesis :
"\<exists>\<phi>. lfp(DaC_scheme (graph_of dcmp) (graph_of cmp)) = graph_of \<phi> \<and>
     \<alpha>\<^sub>1\<^sup>\<circ> \<diamondop> graph_of \<phi> \<diamondop> \<alpha>\<^sub>2 \<subseteq> spec"
  apply(subgoal_tac "\<exists>\<phi>. lfp(DaC_scheme (graph_of dcmp) (graph_of cmp)) = graph_of \<phi>")
   apply clarify
   apply(rule exI, rule conjI, assumption)
   apply(erule subst)
   apply(rule DaC_impl)
  apply(rule mapping)
   apply(rule DaC_simple)
    apply(clarsimp simp: simple_def graph_of_def)
   apply(clarsimp simp: simple_def graph_of_def)
  apply(rule DaC_entire)
  apply(clarsimp simp: entire_def graph_of_def)
  by fast

text "We can thus define the synthesised function and derive relevant properties:"

definition "dac = (THE \<phi>. lfp(DaC_scheme (graph_of dcmp) (graph_of cmp)) = graph_of \<phi>)"

lemma dac_unq :
"lfp (DaC_scheme (graph_of dcmp) (graph_of cmp)) = graph_of f \<Longrightarrow> f = dac"
  by (smt (verit, ccfv_threshold) dac_def graph_of_funct_of the_equality)

lemma dac_lfp :
"graph_of dac = lfp(DaC_scheme (graph_of dcmp) (graph_of cmp))"
  using DaC_synthesis dac_unq by fastforce

lemma dac_unfold' :
"graph_of dac = (graph_of dcmp) \<diamondop> Relt(graph_of dac) \<diamondop> (graph_of cmp)"
proof -
  have "graph_of dac = lfp (DaC_scheme (graph_of dcmp) (graph_of cmp))" (is "?l = ?r")
    by (simp add: dac_lfp)
  also have "... = DaC_scheme (graph_of dcmp) (graph_of cmp) ?r"
    by(rule lfp_unfold, rule monoI, rule DaC_mono, simp+)
  also have "... = DaC_scheme (graph_of dcmp) (graph_of cmp) ?l"
    by (simp add: dac_lfp)
  finally show ?thesis by(simp add: DaC_scheme_def)
qed

lemma dac_unq_function' :
"(graph_of dcmp) \<diamondop> Relt(graph_of f) \<diamondop> (graph_of cmp) \<subseteq> graph_of f \<Longrightarrow> dac = f"
  by (simp add: DaC_scheme_def dac_lfp graph_of_sub lfp_lowerbound)

lemma dac_unfold :
"dac = cmp \<circ> ReltF dac \<circ> dcmp"
  by (metis ReltF dac_lfp dac_unfold' dac_unq graph_of_comp)

lemma dac_unq_function :
"f = cmp \<circ> ReltF f \<circ> dcmp \<Longrightarrow> f = dac"
  by (metis ReltF dac_unq_function' graph_of_comp subset_refl)

lemma dac_impl :
"\<alpha>\<^sub>1\<^sup>\<circ> \<diamondop> (graph_of dac) \<diamondop> \<alpha>\<^sub>2 \<subseteq> spec"
  by (simp add: DaC_impl dac_lfp)

end  (* the synthesis tactic *)

end


(*  Title:      Cube/Cube.thy
    Author:     Tobias Nipkow
*)

section \<open>Barendregt's Lambda-Cube\<close>

theory Cube
imports Pure
begin

setup Pure_Thy.old_appl_syntax_setup

named_theorems rules "Cube inference rules"

typedecl "term"
typedecl "context"
typedecl typing

axiomatization
  Abs :: "[term, term \<Rightarrow> term] \<Rightarrow> term" and
  Prod :: "[term, term \<Rightarrow> term] \<Rightarrow> term" and
  Trueprop :: "[context, typing] \<Rightarrow> prop" and
  MT_context :: "context" and
  Context :: "[typing, context] \<Rightarrow> context" and
  star :: "term"  ("*") and
  box :: "term"  ("\<box>") and
  app :: "[term, term] \<Rightarrow> term"  (infixl "\<cdot>" 20) and
  Has_type :: "[term, term] \<Rightarrow> typing"

nonterminal context' and typing'
syntax
  "_Trueprop" :: "[context', typing'] \<Rightarrow> prop"  ("(_/ \<turnstile> _)")
  "_Trueprop1" :: "typing' \<Rightarrow> prop"  ("(_)")
  "" :: "id \<Rightarrow> context'"  ("_")
  "" :: "var \<Rightarrow> context'"  ("_")
  "_MT_context" :: "context'"  ("")
  "_Context" :: "[typing', context'] \<Rightarrow> context'"  ("_ _")
  "_Has_type" :: "[term, term] \<Rightarrow> typing'"  ("(_:/ _)" [0, 0] 5)
  "_Lam" :: "[idt, term, term] \<Rightarrow> term"  ("(3\<^bold>\<lambda>_:_./ _)" [0, 0, 0] 10)
  "_Pi" :: "[idt, term, term] \<Rightarrow> term"  ("(3\<Prod>_:_./ _)" [0, 0] 10)
  "_arrow" :: "[term, term] \<Rightarrow> term"  (infixr "\<rightarrow>" 10)
translations
  "_Trueprop(G, t)" \<rightleftharpoons> "CONST Trueprop(G, t)"
  ("prop") "x:X" \<rightleftharpoons> ("prop") "\<turnstile> x:X"
  "_MT_context" \<rightleftharpoons> "CONST MT_context"
  "_Context" \<rightleftharpoons> "CONST Context"
  "_Has_type" \<rightleftharpoons> "CONST Has_type"
  "\<^bold>\<lambda>x:A. B" \<rightleftharpoons> "CONST Abs(A, \<lambda>x. B)"
  "\<Prod>x:A. B" \<rightharpoonup> "CONST Prod(A, \<lambda>x. B)"
  "A \<rightarrow> B" \<rightharpoonup> "CONST Prod(A, \<lambda>_. B)"
print_translation \<open>
  [(@{const_syntax Prod},
    fn _ => Syntax_Trans.dependent_tr' (@{syntax_const "_Pi"}, @{syntax_const "_arrow"}))]
\<close>

axiomatization where
  s_b: "*: \<box>"  and

  strip_s: "\<lbrakk>A:*; a:A \<Longrightarrow> G \<turnstile> x:X\<rbrakk> \<Longrightarrow> a:A G \<turnstile> x:X" and
  strip_b: "\<lbrakk>A:\<box>; a:A \<Longrightarrow> G \<turnstile> x:X\<rbrakk> \<Longrightarrow> a:A G \<turnstile> x:X" and

  app: "\<lbrakk>F:Prod(A, B); C:A\<rbrakk> \<Longrightarrow> F\<cdot>C: B(C)" and

  pi_ss: "\<lbrakk>A:*; \<And>x. x:A \<Longrightarrow> B(x):*\<rbrakk> \<Longrightarrow> Prod(A, B):*" and

  lam_ss: "\<lbrakk>A:*; \<And>x. x:A \<Longrightarrow> f(x):B(x); \<And>x. x:A \<Longrightarrow> B(x):* \<rbrakk>
            \<Longrightarrow> Abs(A, f) : Prod(A, B)" and

  beta: "Abs(A, f)\<cdot>a \<equiv> f(a)"

lemmas [rules] = s_b strip_s strip_b app lam_ss pi_ss

lemma imp_elim:
  assumes "f:A\<rightarrow>B" and "a:A" and "f\<cdot>a:B \<Longrightarrow> PROP P"
  shows "PROP P" by (rule app assms)+

lemma pi_elim:
  assumes "F:Prod(A,B)" and "a:A" and "F\<cdot>a:B(a) \<Longrightarrow> PROP P"
  shows "PROP P" by (rule app assms)+

locale L2 =
  assumes pi_bs: "\<lbrakk>A:\<box>; \<And>x. x:A \<Longrightarrow> B(x):*\<rbrakk> \<Longrightarrow> Prod(A,B):*"
    and lam_bs: "\<lbrakk>A:\<box>; \<And>x. x:A \<Longrightarrow> f(x):B(x); \<And>x. x:A \<Longrightarrow> B(x):*\<rbrakk>
                   \<Longrightarrow> Abs(A,f) : Prod(A,B)"
begin

lemmas [rules] = lam_bs pi_bs

end

locale Lomega =
  assumes
    pi_bb: "\<lbrakk>A:\<box>; \<And>x. x:A \<Longrightarrow> B(x):\<box>\<rbrakk> \<Longrightarrow> Prod(A,B):\<box>"
    and lam_bb: "\<lbrakk>A:\<box>; \<And>x. x:A \<Longrightarrow> f(x):B(x); \<And>x. x:A \<Longrightarrow> B(x):\<box>\<rbrakk>
                   \<Longrightarrow> Abs(A,f) : Prod(A,B)"
begin

lemmas [rules] = lam_bb pi_bb

end

locale LP =
  assumes pi_sb: "\<lbrakk>A:*; \<And>x. x:A \<Longrightarrow> B(x):\<box>\<rbrakk> \<Longrightarrow> Prod(A,B):\<box>"
    and lam_sb: "\<lbrakk>A:*; \<And>x. x:A \<Longrightarrow> f(x):B(x); \<And>x. x:A \<Longrightarrow> B(x):\<box>\<rbrakk>
                   \<Longrightarrow> Abs(A,f) : Prod(A,B)"
begin

lemmas [rules] = lam_sb pi_sb

end

locale LP2 = LP + L2
begin

lemmas [rules] = lam_bs pi_bs lam_sb pi_sb

end

locale Lomega2 = L2 + Lomega
begin

lemmas [rules] = lam_bs pi_bs lam_bb pi_bb

end

locale LPomega = LP + Lomega
begin

lemmas [rules] = lam_bb pi_bb lam_sb pi_sb

end

locale CC = L2 + LP + Lomega
begin

lemmas [rules] = lam_bs pi_bs lam_bb pi_bb lam_sb pi_sb

end

end


(*  Title:      ZF/Epsilon.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section\<open>Epsilon Induction and Recursion\<close>

theory Epsilon imports Nat_ZF begin

definition
  eclose    :: "i=>i"  where
    "eclose(A) == \<Union>n\<in>nat. nat_rec(n, A, %m r. \<Union>(r))"

definition
  transrec  :: "[i, [i,i]=>i] =>i"  where
    "transrec(a,H) == wfrec(Memrel(eclose({a})), a, H)"

definition
  rank      :: "i=>i"  where
    "rank(a) == transrec(a, %x f. \<Union>y\<in>x. succ(f`y))"

definition
  transrec2 :: "[i, i, [i,i]=>i] =>i"  where
    "transrec2(k, a, b) ==
       transrec(k,
                %i r. if(i=0, a,
                        if(\<exists>j. i=succ(j),
                           b(THE j. i=succ(j), r`(THE j. i=succ(j))),
                           \<Union>j<i. r`j)))"

definition
  recursor  :: "[i, [i,i]=>i, i]=>i"  where
    "recursor(a,b,k) ==  transrec(k, %n f. nat_case(a, %m. b(m, f`m), n))"

definition
  rec  :: "[i, i, [i,i]=>i]=>i"  where
    "rec(k,a,b) == recursor(a,b,k)"

subsection\<open>Basic Closure Properties\<close>

lemma arg_subset_eclose: "A \<subseteq> eclose(A)"
apply (unfold eclose_def)
apply (rule nat_rec_0 [THEN equalityD2, THEN subset_trans])
apply (rule nat_0I [THEN UN_upper])
done

lemmas arg_into_eclose = arg_subset_eclose [THEN subsetD]

lemma Transset_eclose: "Transset(eclose(A))"
apply (unfold eclose_def Transset_def)
apply (rule subsetI [THEN ballI])
apply (erule UN_E)
apply (rule nat_succI [THEN UN_I], assumption)
apply (erule nat_rec_succ [THEN ssubst])
apply (erule UnionI, assumption)
done

(* @{term"x \<in> eclose(A) ==> x \<subseteq> eclose(A)"} *)
lemmas eclose_subset =
       Transset_eclose [unfolded Transset_def, THEN bspec]

(* @{term"[| A \<in> eclose(B); c \<in> A |] ==> c \<in> eclose(B)"} *)
lemmas ecloseD = eclose_subset [THEN subsetD]

lemmas arg_in_eclose_sing = arg_subset_eclose [THEN singleton_subsetD]
lemmas arg_into_eclose_sing = arg_in_eclose_sing [THEN ecloseD]

(* This is epsilon-induction for eclose(A); see also eclose_induct_down...
   [| a \<in> eclose(A);  !!x. [| x \<in> eclose(A); \<forall>y\<in>x. P(y) |] ==> P(x)
   |] ==> P(a)
*)
lemmas eclose_induct =
     Transset_induct [OF _ Transset_eclose, induct set: eclose]

(*Epsilon induction*)
lemma eps_induct:
    "[| !!x. \<forall>y\<in>x. P(y) ==> P(x) |]  ==>  P(a)"
by (rule arg_in_eclose_sing [THEN eclose_induct], blast)

subsection\<open>Leastness of @{term eclose}\<close>

(** eclose(A) is the least transitive set including A as a subset. **)

lemma eclose_least_lemma:
    "[| Transset(X);  A<=X;  n \<in> nat |] ==> nat_rec(n, A, %m r. \<Union>(r)) \<subseteq> X"
apply (unfold Transset_def)
apply (erule nat_induct)
apply (simp add: nat_rec_0)
apply (simp add: nat_rec_succ, blast)
done

lemma eclose_least:
     "[| Transset(X);  A<=X |] ==> eclose(A) \<subseteq> X"
apply (unfold eclose_def)
apply (rule eclose_least_lemma [THEN UN_least], assumption+)
done

(*COMPLETELY DIFFERENT induction principle from eclose_induct!!*)
lemma eclose_induct_down [consumes 1]:
    "[| a \<in> eclose(b);
        !!y.   [| y \<in> b |] ==> P(y);
        !!y z. [| y \<in> eclose(b);  P(y);  z \<in> y |] ==> P(z)
     |] ==> P(a)"
apply (rule eclose_least [THEN subsetD, THEN CollectD2, of "eclose(b)"])
  prefer 3 apply assumption
 apply (unfold Transset_def)
 apply (blast intro: ecloseD)
apply (blast intro: arg_subset_eclose [THEN subsetD])
done

lemma Transset_eclose_eq_arg: "Transset(X) ==> eclose(X) = X"
apply (erule equalityI [OF eclose_least arg_subset_eclose])
apply (rule subset_refl)
done

text\<open>A transitive set either is empty or contains the empty set.\<close>
lemma Transset_0_lemma [rule_format]: "Transset(A) ==> x\<in>A \<longrightarrow> 0\<in>A"
apply (simp add: Transset_def)
apply (rule_tac a=x in eps_induct, clarify)
apply (drule bspec, assumption)
apply (case_tac "x=0", auto)
done

lemma Transset_0_disj: "Transset(A) ==> A=0 | 0\<in>A"
by (blast dest: Transset_0_lemma)

subsection\<open>Epsilon Recursion\<close>

(*Unused...*)
lemma mem_eclose_trans: "[| A \<in> eclose(B);  B \<in> eclose(C) |] ==> A \<in> eclose(C)"
by (rule eclose_least [OF Transset_eclose eclose_subset, THEN subsetD],
    assumption+)

(*Variant of the previous lemma in a useable form for the sequel*)
lemma mem_eclose_sing_trans:
     "[| A \<in> eclose({B});  B \<in> eclose({C}) |] ==> A \<in> eclose({C})"
by (rule eclose_least [OF Transset_eclose singleton_subsetI, THEN subsetD],
    assumption+)

lemma under_Memrel: "[| Transset(i);  j \<in> i |] ==> Memrel(i)-``{j} = j"
by (unfold Transset_def, blast)

lemma lt_Memrel: "j < i ==> Memrel(i) -`` {j} = j"
by (simp add: lt_def Ord_def under_Memrel)

(* @{term"j \<in> eclose(A) ==> Memrel(eclose(A)) -`` j = j"} *)
lemmas under_Memrel_eclose = Transset_eclose [THEN under_Memrel]

lemmas wfrec_ssubst = wf_Memrel [THEN wfrec, THEN ssubst]

lemma wfrec_eclose_eq:
    "[| k \<in> eclose({j});  j \<in> eclose({i}) |] ==>
     wfrec(Memrel(eclose({i})), k, H) = wfrec(Memrel(eclose({j})), k, H)"
apply (erule eclose_induct)
apply (rule wfrec_ssubst)
apply (rule wfrec_ssubst)
apply (simp add: under_Memrel_eclose mem_eclose_sing_trans [of _ j i])
done

lemma wfrec_eclose_eq2:
    "k \<in> i ==> wfrec(Memrel(eclose({i})),k,H) = wfrec(Memrel(eclose({k})),k,H)"
apply (rule arg_in_eclose_sing [THEN wfrec_eclose_eq])
apply (erule arg_into_eclose_sing)
done

lemma transrec: "transrec(a,H) = H(a, \<lambda>x\<in>a. transrec(x,H))"
apply (unfold transrec_def)
apply (rule wfrec_ssubst)
apply (simp add: wfrec_eclose_eq2 arg_in_eclose_sing under_Memrel_eclose)
done

(*Avoids explosions in proofs; resolve it with a meta-level definition.*)
lemma def_transrec:
    "[| !!x. f(x)==transrec(x,H) |] ==> f(a) = H(a, \<lambda>x\<in>a. f(x))"
apply simp
apply (rule transrec)
done

lemma transrec_type:
    "[| !!x u. [| x \<in> eclose({a});  u \<in> Pi(x,B) |] ==> H(x,u) \<in> B(x) |]
     ==> transrec(a,H) \<in> B(a)"
apply (rule_tac i = a in arg_in_eclose_sing [THEN eclose_induct])
apply (subst transrec)
apply (simp add: lam_type)
done

lemma eclose_sing_Ord: "Ord(i) ==> eclose({i}) \<subseteq> succ(i)"
apply (erule Ord_is_Transset [THEN Transset_succ, THEN eclose_least])
apply (rule succI1 [THEN singleton_subsetI])
done

lemma succ_subset_eclose_sing: "succ(i) \<subseteq> eclose({i})"
apply (insert arg_subset_eclose [of "{i}"], simp)
apply (frule eclose_subset, blast)
done

lemma eclose_sing_Ord_eq: "Ord(i) ==> eclose({i}) = succ(i)"
apply (rule equalityI)
apply (erule eclose_sing_Ord)
apply (rule succ_subset_eclose_sing)
done

lemma Ord_transrec_type:
  assumes jini: "j \<in> i"
      and ordi: "Ord(i)"
      and minor: " !!x u. [| x \<in> i;  u \<in> Pi(x,B) |] ==> H(x,u) \<in> B(x)"
  shows "transrec(j,H) \<in> B(j)"
apply (rule transrec_type)
apply (insert jini ordi)
apply (blast intro!: minor
             intro: Ord_trans
             dest: Ord_in_Ord [THEN eclose_sing_Ord, THEN subsetD])
done

subsection\<open>Rank\<close>

(*NOT SUITABLE FOR REWRITING -- RECURSIVE!*)
lemma rank: "rank(a) = (\<Union>y\<in>a. succ(rank(y)))"
by (subst rank_def [THEN def_transrec], simp)

lemma Ord_rank [simp]: "Ord(rank(a))"
apply (rule_tac a=a in eps_induct)
apply (subst rank)
apply (rule Ord_succ [THEN Ord_UN])
apply (erule bspec, assumption)
done

lemma rank_of_Ord: "Ord(i) ==> rank(i) = i"
apply (erule trans_induct)
apply (subst rank)
apply (simp add: Ord_equality)
done

lemma rank_lt: "a \<in> b ==> rank(a) < rank(b)"
apply (rule_tac a1 = b in rank [THEN ssubst])
apply (erule UN_I [THEN ltI])
apply (rule_tac [2] Ord_UN, auto)
done

lemma eclose_rank_lt: "a \<in> eclose(b) ==> rank(a) < rank(b)"
apply (erule eclose_induct_down)
apply (erule rank_lt)
apply (erule rank_lt [THEN lt_trans], assumption)
done

lemma rank_mono: "a<=b ==> rank(a) \<le> rank(b)"
apply (rule subset_imp_le)
apply (auto simp add: rank [of a] rank [of b])
done

lemma rank_Pow: "rank(Pow(a)) = succ(rank(a))"
apply (rule rank [THEN trans])
apply (rule le_anti_sym)
apply (rule_tac [2] UN_upper_le)
apply (rule UN_least_le)
apply (auto intro: rank_mono simp add: Ord_UN)
done

lemma rank_0 [simp]: "rank(0) = 0"
by (rule rank [THEN trans], blast)

lemma rank_succ [simp]: "rank(succ(x)) = succ(rank(x))"
apply (rule rank [THEN trans])
apply (rule equalityI [OF UN_least succI1 [THEN UN_upper]])
apply (erule succE, blast)
apply (erule rank_lt [THEN leI, THEN succ_leI, THEN le_imp_subset])
done

lemma rank_Union: "rank(\<Union>(A)) = (\<Union>x\<in>A. rank(x))"
apply (rule equalityI)
apply (rule_tac [2] rank_mono [THEN le_imp_subset, THEN UN_least])
apply (erule_tac [2] Union_upper)
apply (subst rank)
apply (rule UN_least)
apply (erule UnionE)
apply (rule subset_trans)
apply (erule_tac [2] RepFunI [THEN Union_upper])
apply (erule rank_lt [THEN succ_leI, THEN le_imp_subset])
done

lemma rank_eclose: "rank(eclose(a)) = rank(a)"
apply (rule le_anti_sym)
apply (rule_tac [2] arg_subset_eclose [THEN rank_mono])
apply (rule_tac a1 = "eclose (a) " in rank [THEN ssubst])
apply (rule Ord_rank [THEN UN_least_le])
apply (erule eclose_rank_lt [THEN succ_leI])
done

lemma rank_pair1: "rank(a) < rank(<a,b>)"
apply (unfold Pair_def)
apply (rule consI1 [THEN rank_lt, THEN lt_trans])
apply (rule consI1 [THEN consI2, THEN rank_lt])
done

lemma rank_pair2: "rank(b) < rank(<a,b>)"
apply (unfold Pair_def)
apply (rule consI1 [THEN consI2, THEN rank_lt, THEN lt_trans])
apply (rule consI1 [THEN consI2, THEN rank_lt])
done

(*Not clear how to remove the P(a) condition, since the "then" part
  must refer to "a"*)
lemma the_equality_if:
     "P(a) ==> (THE x. P(x)) = (if (\<exists>!x. P(x)) then a else 0)"
by (simp add: the_0 the_equality2)

(*The first premise not only fixs i but ensures @{term"f\<noteq>0"}.
  The second premise is now essential.  Consider otherwise the relation
  r = {<0,0>,<0,1>,<0,2>,...}.  Then f`0 = \<Union>(f``{0}) = \<Union>(nat) = nat,
  whose rank equals that of r.*)
lemma rank_apply: "[|i \<in> domain(f); function(f)|] ==> rank(f`i) < rank(f)"
apply clarify
apply (simp add: function_apply_equality)
apply (blast intro: lt_trans rank_lt rank_pair2)
done

subsection\<open>Corollaries of Leastness\<close>

lemma mem_eclose_subset: "A \<in> B ==> eclose(A)<=eclose(B)"
apply (rule Transset_eclose [THEN eclose_least])
apply (erule arg_into_eclose [THEN eclose_subset])
done

lemma eclose_mono: "A<=B ==> eclose(A) \<subseteq> eclose(B)"
apply (rule Transset_eclose [THEN eclose_least])
apply (erule subset_trans)
apply (rule arg_subset_eclose)
done

(** Idempotence of eclose **)

lemma eclose_idem: "eclose(eclose(A)) = eclose(A)"
apply (rule equalityI)
apply (rule eclose_least [OF Transset_eclose subset_refl])
apply (rule arg_subset_eclose)
done

(** Transfinite recursion for definitions based on the
    three cases of ordinals **)

lemma transrec2_0 [simp]: "transrec2(0,a,b) = a"
by (rule transrec2_def [THEN def_transrec, THEN trans], simp)

lemma transrec2_succ [simp]: "transrec2(succ(i),a,b) = b(i, transrec2(i,a,b))"
apply (rule transrec2_def [THEN def_transrec, THEN trans])
apply (simp add: the_equality if_P)
done

lemma transrec2_Limit:
     "Limit(i) ==> transrec2(i,a,b) = (\<Union>j<i. transrec2(j,a,b))"
apply (rule transrec2_def [THEN def_transrec, THEN trans])
apply (auto simp add: OUnion_def)
done

lemma def_transrec2:
     "(!!x. f(x)==transrec2(x,a,b))
      ==> f(0) = a &
          f(succ(i)) = b(i, f(i)) &
          (Limit(K) \<longrightarrow> f(K) = (\<Union>j<K. f(j)))"
by (simp add: transrec2_Limit)

(** recursor -- better than nat_rec; the succ case has no type requirement! **)

(*NOT suitable for rewriting*)
lemmas recursor_lemma = recursor_def [THEN def_transrec, THEN trans]

lemma recursor_0: "recursor(a,b,0) = a"
by (rule nat_case_0 [THEN recursor_lemma])

lemma recursor_succ: "recursor(a,b,succ(m)) = b(m, recursor(a,b,m))"
by (rule recursor_lemma, simp)

(** rec: old version for compatibility **)

lemma rec_0 [simp]: "rec(0,a,b) = a"
apply (unfold rec_def)
apply (rule recursor_0)
done

lemma rec_succ [simp]: "rec(succ(m),a,b) = b(m, rec(m,a,b))"
apply (unfold rec_def)
apply (rule recursor_succ)
done

lemma rec_type:
    "[| n \<in> nat;
        a \<in> C(0);
        !!m z. [| m \<in> nat;  z \<in> C(m) |] ==> b(m,z): C(succ(m)) |]
     ==> rec(n,a,b) \<in> C(n)"
by (erule nat_induct, auto)

end