theory Context_Free_Grammar_Example
imports "~~/src/HOL/Library/Code_Prolog"
begin
(*
declare mem_def[code_pred_inline]
*)

subsection \<open>Alternative rules for length\<close>

definition size_list :: "'a list => nat"
where "size_list = size"

lemma size_list_simps:
  "size_list [] = 0"
  "size_list (x # xs) = Suc (size_list xs)"
by (auto simp add: size_list_def)

declare size_list_simps[code_pred_def]
declare size_list_def[symmetric, code_pred_inline]

setup \<open>
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
\<close>

datatype alphabet = a | b

inductive_set S\<^sub>1 and A\<^sub>1 and B\<^sub>1 where
  "[] \<in> S\<^sub>1"
| "w \<in> A\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "w \<in> B\<^sub>1 \<Longrightarrow> a # w \<in> S\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> a # w \<in> A\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "\<lbrakk>v \<in> B\<^sub>1; v \<in> B\<^sub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>1"

lemma
  "S\<^sub>1p w \<Longrightarrow> w = []"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

definition "filter_a = filter (\<lambda>x. x = a)"

lemma [code_pred_def]: "filter_a [] = []"
unfolding filter_a_def by simp

lemma [code_pred_def]: "filter_a (x#xs) = (if x = a then x # filter_a xs else filter_a xs)"
unfolding filter_a_def by simp

declare filter_a_def[symmetric, code_pred_inline]

definition "filter_b = filter (\<lambda>x. x = b)"

lemma [code_pred_def]: "filter_b [] = []"
unfolding filter_b_def by simp

lemma [code_pred_def]: "filter_b (x#xs) = (if x = b then x # filter_b xs else filter_b xs)"
unfolding filter_b_def by simp

declare filter_b_def[symmetric, code_pred_inline]

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s1p", "a1p", "b1p"], 2)],
  replacing = [(("s1p", "limited_s1p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]})\<close>

theorem S\<^sub>1_sound:
"S\<^sub>1p w \<Longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

inductive_set S\<^sub>2 and A\<^sub>2 and B\<^sub>2 where
  "[] \<in> S\<^sub>2"
| "w \<in> A\<^sub>2 \<Longrightarrow> b # w \<in> S\<^sub>2"
| "w \<in> B\<^sub>2 \<Longrightarrow> a # w \<in> S\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> a # w \<in> A\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> b # w \<in> B\<^sub>2"
| "\<lbrakk>v \<in> B\<^sub>2; v \<in> B\<^sub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>2"

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s2p", "a2p", "b2p"], 3)],
  replacing = [(("s2p", "limited_s2p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]})\<close>

theorem S\<^sub>2_sound:
  "S\<^sub>2p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, expect = counterexample]
oops

inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where
  "[] \<in> S\<^sub>3"
| "w \<in> A\<^sub>3 \<Longrightarrow> b # w \<in> S\<^sub>3"
| "w \<in> B\<^sub>3 \<Longrightarrow> a # w \<in> S\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> a # w \<in> A\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> b # w \<in> B\<^sub>3"
| "\<lbrakk>v \<in> B\<^sub>3; w \<in> B\<^sub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>3"

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s3p", "a3p", "b3p"], 6)],
  replacing = [(("s3p", "limited_s3p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]})\<close>

lemma S\<^sub>3_sound:
  "S\<^sub>3p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, iterations=1, size=1, expect = no_counterexample]
oops

(*
setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = [],
  timeout = seconds 10.0,
  prolog_system = Code_Prolog.SWI_PROLOG}) *}

theorem S\<^sub>3_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>3"
quickcheck[tester = prolog, size=1, iterations=1]
oops
*)

inductive_set S\<^sub>4 and A\<^sub>4 and B\<^sub>4 where
  "[] \<in> S\<^sub>4"
| "w \<in> A\<^sub>4 \<Longrightarrow> b # w \<in> S\<^sub>4"
| "w \<in> B\<^sub>4 \<Longrightarrow> a # w \<in> S\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> a # w \<in> A\<^sub>4"
| "\<lbrakk>v \<in> A\<^sub>4; w \<in> A\<^sub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> b # w \<in> B\<^sub>4"
| "\<lbrakk>v \<in> B\<^sub>4; w \<in> B\<^sub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>4"

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [(["s4p", "a4p", "b4p"], 6)],
  replacing = [(("s4p", "limited_s4p"), "quickcheck")],
  manual_reorder = [(("quickcheck", 1), [0,2,1,4,3,5])]})\<close>

theorem S\<^sub>4_sound:
  "S\<^sub>4p w \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
quickcheck[tester = prolog, size=1, iterations=1, expect = no_counterexample]
oops

(*
theorem S\<^sub>4_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>4"
oops
*)

hide_const a b

end


(*  Title:      ZF/Constructible/DPow_absolute.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Absoluteness for the Definable Powerset Function\<close>

theory DPow_absolute imports Satisfies_absolute begin

subsection\<open>Preliminary Internalizations\<close>

subsubsection\<open>The Operator \<^term>\<open>is_formula_rec\<close>\<close>

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0.  It is buried
   within 11 quantifiers!!\<close>

(* is_formula_rec :: "[i=>o, [i,i,i]=>o, i, i] => o"
   "is_formula_rec(M,MH,p,z)  ==
      \<exists>dp[M]. \<exists>i[M]. \<exists>f[M]. finite_ordinal(M,dp) & is_depth(M,p,dp) &
       2       1      0
             successor(M,dp,i) & fun_apply(M,f,p,z) & is_transrec(M,MH,i,f)"
*)

definition
  formula_rec_fm :: "[i, i, i]=>i" where
 "formula_rec_fm(mh,p,z) ==
    Exists(Exists(Exists(
      And(finite_ordinal_fm(2),
       And(depth_fm(p#+3,2),
        And(succ_fm(2,1),
          And(fun_apply_fm(0,p#+3,z#+3), is_transrec_fm(mh,1,0))))))))"

lemma is_formula_rec_type [TC]:
     "[| p \<in> formula; x \<in> nat; z \<in> nat |]
      ==> formula_rec_fm(p,x,z) \<in> formula"
by (simp add: formula_rec_fm_def)

lemma sats_formula_rec_fm:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A; a5\<in>A; a6\<in>A; a7\<in>A; a8\<in>A; a9\<in>A; a10\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow>
            sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,
                          Cons(a4,Cons(a5,Cons(a6,Cons(a7,
                                  Cons(a8,Cons(a9,Cons(a10,env))))))))))))"
  shows
      "[|x \<in> nat; z \<in> nat; env \<in> list(A)|]
       ==> sats(A, formula_rec_fm(p,x,z), env) \<longleftrightarrow>
           is_formula_rec(##A, MH, nth(x,env), nth(z,env))"
by (simp add: formula_rec_fm_def sats_is_transrec_fm is_formula_rec_def
              MH_iff_sats [THEN iff_sym])

lemma formula_rec_iff_sats:
  assumes MH_iff_sats:
      "!!a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
        [|a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A; a5\<in>A; a6\<in>A; a7\<in>A; a8\<in>A; a9\<in>A; a10\<in>A|]
        ==> MH(a2, a1, a0) \<longleftrightarrow>
            sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,
                          Cons(a4,Cons(a5,Cons(a6,Cons(a7,
                                  Cons(a8,Cons(a9,Cons(a10,env))))))))))))"
  shows
  "[|nth(i,env) = x; nth(k,env) = z;
      i \<in> nat; k \<in> nat; env \<in> list(A)|]
   ==> is_formula_rec(##A, MH, x, z) \<longleftrightarrow> sats(A, formula_rec_fm(p,i,k), env)"
by (simp add: sats_formula_rec_fm [OF MH_iff_sats])

theorem formula_rec_reflection:
  assumes MH_reflection:
    "!!f' f g h. REFLECTS[\<lambda>x. MH(L, f'(x), f(x), g(x), h(x)),
                     \<lambda>i x. MH(##Lset(i), f'(x), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. is_formula_rec(L, MH(L,x), f(x), h(x)),
               \<lambda>i x. is_formula_rec(##Lset(i), MH(##Lset(i),x), f(x), h(x))]"
apply (simp (no_asm_use) only: is_formula_rec_def)
apply (intro FOL_reflections function_reflections fun_plus_reflections
             depth_reflection is_transrec_reflection MH_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_satisfies\<close>\<close>

(* is_satisfies(M,A,p,z) == is_formula_rec (M, satisfies_MH(M,A), p, z) *)
definition
  satisfies_fm :: "[i,i,i]=>i" where
    "satisfies_fm(x) == formula_rec_fm (satisfies_MH_fm(x#+5#+6, 2, 1, 0))"

lemma is_satisfies_type [TC]:
     "[| x \<in> nat; y \<in> nat; z \<in> nat |] ==> satisfies_fm(x,y,z) \<in> formula"
by (simp add: satisfies_fm_def)

lemma sats_satisfies_fm [simp]:
   "[| x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, satisfies_fm(x,y,z), env) \<longleftrightarrow>
        is_satisfies(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: satisfies_fm_def is_satisfies_def sats_formula_rec_fm)

lemma satisfies_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j \<in> nat; k \<in> nat; env \<in> list(A)|]
       ==> is_satisfies(##A, x, y, z) \<longleftrightarrow> sats(A, satisfies_fm(i,j,k), env)"
by (simp)

theorem satisfies_reflection:
     "REFLECTS[\<lambda>x. is_satisfies(L,f(x),g(x),h(x)),
               \<lambda>i x. is_satisfies(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_satisfies_def)
apply (intro formula_rec_reflection satisfies_MH_reflection)
done

subsection \<open>Relativization of the Operator \<^term>\<open>DPow'\<close>\<close>

lemma DPow'_eq:
  "DPow'(A) = {z . ep \<in> list(A) * formula,
                    \<exists>env \<in> list(A). \<exists>p \<in> formula.
                       ep = <env,p> & z = {x\<in>A. sats(A, p, Cons(x,env))}}"
by (simp add: DPow'_def, blast)

text\<open>Relativize the use of \<^term>\<open>sats\<close> within \<^term>\<open>DPow'\<close>
(the comprehension).\<close>
definition
  is_DPow_sats :: "[i=>o,i,i,i,i] => o" where
   "is_DPow_sats(M,A,env,p,x) ==
      \<forall>n1[M]. \<forall>e[M]. \<forall>sp[M].
             is_satisfies(M,A,p,sp) \<longrightarrow> is_Cons(M,x,env,e) \<longrightarrow>
             fun_apply(M, sp, e, n1) \<longrightarrow> number1(M, n1)"

lemma (in M_satisfies) DPow_sats_abs:
    "[| M(A); env \<in> list(A); p \<in> formula; M(x) |]
    ==> is_DPow_sats(M,A,env,p,x) \<longleftrightarrow> sats(A, p, Cons(x,env))"
apply (subgoal_tac "M(env)")
 apply (simp add: is_DPow_sats_def satisfies_closed satisfies_abs)
apply (blast dest: transM)
done

lemma (in M_satisfies) Collect_DPow_sats_abs:
    "[| M(A); env \<in> list(A); p \<in> formula |]
    ==> Collect(A, is_DPow_sats(M,A,env,p)) =
        {x \<in> A. sats(A, p, Cons(x,env))}"
by (simp add: DPow_sats_abs transM [of _ A])

subsubsection\<open>The Operator \<^term>\<open>is_DPow_sats\<close>, Internalized\<close>

(* is_DPow_sats(M,A,env,p,x) ==
      \<forall>n1[M]. \<forall>e[M]. \<forall>sp[M].
             is_satisfies(M,A,p,sp) \<longrightarrow> is_Cons(M,x,env,e) \<longrightarrow>
             fun_apply(M, sp, e, n1) \<longrightarrow> number1(M, n1) *)

definition
  DPow_sats_fm :: "[i,i,i,i]=>i" where
  "DPow_sats_fm(A,env,p,x) ==
   Forall(Forall(Forall(
     Implies(satisfies_fm(A#+3,p#+3,0),
       Implies(Cons_fm(x#+3,env#+3,1),
         Implies(fun_apply_fm(0,1,2), number1_fm(2)))))))"

lemma is_DPow_sats_type [TC]:
     "[| A \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat |]
      ==> DPow_sats_fm(A,x,y,z) \<in> formula"
by (simp add: DPow_sats_fm_def)

lemma sats_DPow_sats_fm [simp]:
   "[| u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
    ==> sats(A, DPow_sats_fm(u,x,y,z), env) \<longleftrightarrow>
        is_DPow_sats(##A, nth(u,env), nth(x,env), nth(y,env), nth(z,env))"
by (simp add: DPow_sats_fm_def is_DPow_sats_def)

lemma DPow_sats_iff_sats:
  "[| nth(u,env) = nu; nth(x,env) = nx; nth(y,env) = ny; nth(z,env) = nz;
      u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)|]
   ==> is_DPow_sats(##A,nu,nx,ny,nz) \<longleftrightarrow>
       sats(A, DPow_sats_fm(u,x,y,z), env)"
by simp

theorem DPow_sats_reflection:
     "REFLECTS[\<lambda>x. is_DPow_sats(L,f(x),g(x),h(x),g'(x)),
               \<lambda>i x. is_DPow_sats(##Lset(i),f(x),g(x),h(x),g'(x))]"
apply (unfold is_DPow_sats_def)
apply (intro FOL_reflections function_reflections extra_reflections
             satisfies_reflection)
done

subsection\<open>A Locale for Relativizing the Operator \<^term>\<open>DPow'\<close>\<close>

locale M_DPow = M_satisfies +
 assumes sep:
   "[| M(A); env \<in> list(A); p \<in> formula |]
    ==> separation(M, \<lambda>x. is_DPow_sats(M,A,env,p,x))"
 and rep:
    "M(A)
    ==> strong_replacement (M,
         \<lambda>ep z. \<exists>env[M]. \<exists>p[M]. mem_formula(M,p) & mem_list(M,A,env) &
                  pair(M,env,p,ep) &
                  is_Collect(M, A, \<lambda>x. is_DPow_sats(M,A,env,p,x), z))"

lemma (in M_DPow) sep':
   "[| M(A); env \<in> list(A); p \<in> formula |]
    ==> separation(M, \<lambda>x. sats(A, p, Cons(x,env)))"
by (insert sep [of A env p], simp add: DPow_sats_abs)

lemma (in M_DPow) rep':
   "M(A)
    ==> strong_replacement (M,
         \<lambda>ep z. \<exists>env\<in>list(A). \<exists>p\<in>formula.
                  ep = <env,p> & z = {x \<in> A . sats(A, p, Cons(x, env))})"
by (insert rep [of A], simp add: Collect_DPow_sats_abs)

lemma univalent_pair_eq:
     "univalent (M, A, \<lambda>xy z. \<exists>x\<in>B. \<exists>y\<in>C. xy = \<langle>x,y\<rangle> \<and> z = f(x,y))"
by (simp add: univalent_def, blast)

lemma (in M_DPow) DPow'_closed: "M(A) ==> M(DPow'(A))"
apply (simp add: DPow'_eq)
apply (fast intro: rep' sep' univalent_pair_eq)
done

text\<open>Relativization of the Operator \<^term>\<open>DPow'\<close>\<close>
definition
  is_DPow' :: "[i=>o,i,i] => o" where
    "is_DPow'(M,A,Z) ==
       \<forall>X[M]. X \<in> Z \<longleftrightarrow>
         subset(M,X,A) &
           (\<exists>env[M]. \<exists>p[M]. mem_formula(M,p) & mem_list(M,A,env) &
                    is_Collect(M, A, is_DPow_sats(M,A,env,p), X))"

lemma (in M_DPow) DPow'_abs:
    "[|M(A); M(Z)|] ==> is_DPow'(M,A,Z) \<longleftrightarrow> Z = DPow'(A)"
apply (rule iffI)
 prefer 2 apply (simp add: is_DPow'_def DPow'_def Collect_DPow_sats_abs)
apply (rule M_equalityI)
apply (simp add: is_DPow'_def DPow'_def Collect_DPow_sats_abs, assumption)
apply (erule DPow'_closed)
done

subsection\<open>Instantiating the Locale \<open>M_DPow\<close>\<close>

subsubsection\<open>The Instance of Separation\<close>

lemma DPow_separation:
    "[| L(A); env \<in> list(A); p \<in> formula |]
     ==> separation(L, \<lambda>x. is_DPow_sats(L,A,env,p,x))"
apply (rule gen_separation_multi [OF DPow_sats_reflection, of "{A,env,p}"],
       auto intro: transL)
apply (rule_tac env="[A,env,p]" in DPow_LsetI)
apply (rule DPow_sats_iff_sats sep_rules | simp)+
done

subsubsection\<open>The Instance of Replacement\<close>

lemma DPow_replacement_Reflects:
 "REFLECTS [\<lambda>x. \<exists>u[L]. u \<in> B &
             (\<exists>env[L]. \<exists>p[L].
               mem_formula(L,p) & mem_list(L,A,env) & pair(L,env,p,u) &
               is_Collect (L, A, is_DPow_sats(L,A,env,p), x)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B &
             (\<exists>env \<in> Lset(i). \<exists>p \<in> Lset(i).
               mem_formula(##Lset(i),p) & mem_list(##Lset(i),A,env) &
               pair(##Lset(i),env,p,u) &
               is_Collect (##Lset(i), A, is_DPow_sats(##Lset(i),A,env,p), x))]"
apply (unfold is_Collect_def)
apply (intro FOL_reflections function_reflections mem_formula_reflection
          mem_list_reflection DPow_sats_reflection)
done

lemma DPow_replacement:
    "L(A)
    ==> strong_replacement (L,
         \<lambda>ep z. \<exists>env[L]. \<exists>p[L]. mem_formula(L,p) & mem_list(L,A,env) &
                  pair(L,env,p,ep) &
                  is_Collect(L, A, \<lambda>x. is_DPow_sats(L,A,env,p,x), z))"
apply (rule strong_replacementI)
apply (rule_tac u="{A,B}"
         in gen_separation_multi [OF DPow_replacement_Reflects],
       auto)
apply (unfold is_Collect_def)
apply (rule_tac env="[A,B]" in DPow_LsetI)
apply (rule sep_rules mem_formula_iff_sats mem_list_iff_sats
            DPow_sats_iff_sats | simp)+
done

subsubsection\<open>Actually Instantiating the Locale\<close>

lemma M_DPow_axioms_L: "M_DPow_axioms(L)"
  apply (rule M_DPow_axioms.intro)
   apply (assumption | rule DPow_separation DPow_replacement)+
  done

theorem M_DPow_L: "M_DPow(L)"
  apply (rule M_DPow.intro)
   apply (rule M_satisfies_L)
  apply (rule M_DPow_axioms_L)
  done

lemmas DPow'_closed [intro, simp] = M_DPow.DPow'_closed [OF M_DPow_L]
  and DPow'_abs [intro, simp] = M_DPow.DPow'_abs [OF M_DPow_L]

subsubsection\<open>The Operator \<^term>\<open>is_Collect\<close>\<close>

text\<open>The formula \<^term>\<open>is_P\<close> has one free variable, 0, and it is
enclosed within a single quantifier.\<close>

(* is_Collect :: "[i=>o,i,i=>o,i] => o"
    "is_Collect(M,A,P,z) == \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> A & P(x)" *)

definition
  Collect_fm :: "[i, i, i]=>i" where
 "Collect_fm(A,is_P,z) ==
        Forall(Iff(Member(0,succ(z)),
                   And(Member(0,succ(A)), is_P)))"

lemma is_Collect_type [TC]:
     "[| is_P \<in> formula; x \<in> nat; y \<in> nat |]
      ==> Collect_fm(x,is_P,y) \<in> formula"
by (simp add: Collect_fm_def)

lemma sats_Collect_fm:
  assumes is_P_iff_sats:
      "!!a. a \<in> A ==> is_P(a) \<longleftrightarrow> sats(A, p, Cons(a, env))"
  shows
      "[|x \<in> nat; y \<in> nat; env \<in> list(A)|]
       ==> sats(A, Collect_fm(x,p,y), env) \<longleftrightarrow>
           is_Collect(##A, nth(x,env), is_P, nth(y,env))"
by (simp add: Collect_fm_def is_Collect_def is_P_iff_sats [THEN iff_sym])

lemma Collect_iff_sats:
  assumes is_P_iff_sats:
      "!!a. a \<in> A ==> is_P(a) \<longleftrightarrow> sats(A, p, Cons(a, env))"
  shows
  "[| nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j \<in> nat; env \<in> list(A)|]
   ==> is_Collect(##A, x, is_P, y) \<longleftrightarrow> sats(A, Collect_fm(i,p,j), env)"
by (simp add: sats_Collect_fm [OF is_P_iff_sats])

text\<open>The second argument of \<^term>\<open>is_P\<close> gives it direct access to \<^term>\<open>x\<close>,
  which is essential for handling free variable references.\<close>
theorem Collect_reflection:
  assumes is_P_reflection:
    "!!h f g. REFLECTS[\<lambda>x. is_P(L, f(x), g(x)),
                     \<lambda>i x. is_P(##Lset(i), f(x), g(x))]"
  shows "REFLECTS[\<lambda>x. is_Collect(L, f(x), is_P(L,x), g(x)),
               \<lambda>i x. is_Collect(##Lset(i), f(x), is_P(##Lset(i), x), g(x))]"
apply (simp (no_asm_use) only: is_Collect_def)
apply (intro FOL_reflections is_P_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_Replace\<close>\<close>

text\<open>BEWARE!  The formula \<^term>\<open>is_P\<close> has free variables 0, 1
 and not the usual 1, 0!  It is enclosed within two quantifiers.\<close>

(*  is_Replace :: "[i=>o,i,[i,i]=>o,i] => o"
    "is_Replace(M,A,P,z) == \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A & P(x,u))" *)

definition
  Replace_fm :: "[i, i, i]=>i" where
  "Replace_fm(A,is_P,z) ==
        Forall(Iff(Member(0,succ(z)),
                   Exists(And(Member(0,A#+2), is_P))))"

lemma is_Replace_type [TC]:
     "[| is_P \<in> formula; x \<in> nat; y \<in> nat |]
      ==> Replace_fm(x,is_P,y) \<in> formula"
by (simp add: Replace_fm_def)

lemma sats_Replace_fm:
  assumes is_P_iff_sats:
      "!!a b. [|a \<in> A; b \<in> A|]
              ==> is_P(a,b) \<longleftrightarrow> sats(A, p, Cons(a,Cons(b,env)))"
  shows
      "[|x \<in> nat; y \<in> nat; env \<in> list(A)|]
       ==> sats(A, Replace_fm(x,p,y), env) \<longleftrightarrow>
           is_Replace(##A, nth(x,env), is_P, nth(y,env))"
by (simp add: Replace_fm_def is_Replace_def is_P_iff_sats [THEN iff_sym])

lemma Replace_iff_sats:
  assumes is_P_iff_sats:
      "!!a b. [|a \<in> A; b \<in> A|]
              ==> is_P(a,b) \<longleftrightarrow> sats(A, p, Cons(a,Cons(b,env)))"
  shows
  "[| nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j \<in> nat; env \<in> list(A)|]
   ==> is_Replace(##A, x, is_P, y) \<longleftrightarrow> sats(A, Replace_fm(i,p,j), env)"
by (simp add: sats_Replace_fm [OF is_P_iff_sats])

text\<open>The second argument of \<^term>\<open>is_P\<close> gives it direct access to \<^term>\<open>x\<close>,
  which is essential for handling free variable references.\<close>
theorem Replace_reflection:
  assumes is_P_reflection:
    "!!h f g. REFLECTS[\<lambda>x. is_P(L, f(x), g(x), h(x)),
                     \<lambda>i x. is_P(##Lset(i), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. is_Replace(L, f(x), is_P(L,x), g(x)),
               \<lambda>i x. is_Replace(##Lset(i), f(x), is_P(##Lset(i), x), g(x))]"
apply (simp (no_asm_use) only: is_Replace_def)
apply (intro FOL_reflections is_P_reflection)
done

subsubsection\<open>The Operator \<^term>\<open>is_DPow'\<close>, Internalized\<close>

(*  "is_DPow'(M,A,Z) ==
       \<forall>X[M]. X \<in> Z \<longleftrightarrow>
         subset(M,X,A) &
           (\<exists>env[M]. \<exists>p[M]. mem_formula(M,p) & mem_list(M,A,env) &
                    is_Collect(M, A, is_DPow_sats(M,A,env,p), X))" *)

definition
  DPow'_fm :: "[i,i]=>i" where
    "DPow'_fm(A,Z) ==
      Forall(
       Iff(Member(0,succ(Z)),
        And(subset_fm(0,succ(A)),
         Exists(Exists(
          And(mem_formula_fm(0),
           And(mem_list_fm(A#+3,1),
            Collect_fm(A#+3,
                       DPow_sats_fm(A#+4, 2, 1, 0), 2))))))))"

lemma is_DPow'_type [TC]:
     "[| x \<in> nat; y \<in> nat |] ==> DPow'_fm(x,y) \<in> formula"
by (simp add: DPow'_fm_def)

lemma sats_DPow'_fm [simp]:
   "[| x \<in> nat; y \<in> nat; env \<in> list(A)|]
    ==> sats(A, DPow'_fm(x,y), env) \<longleftrightarrow>
        is_DPow'(##A, nth(x,env), nth(y,env))"
by (simp add: DPow'_fm_def is_DPow'_def sats_subset_fm' sats_Collect_fm)

lemma DPow'_iff_sats:
      "[| nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)|]
       ==> is_DPow'(##A, x, y) \<longleftrightarrow> sats(A, DPow'_fm(i,j), env)"
by (simp)

theorem DPow'_reflection:
     "REFLECTS[\<lambda>x. is_DPow'(L,f(x),g(x)),
               \<lambda>i x. is_DPow'(##Lset(i),f(x),g(x))]"
apply (simp only: is_DPow'_def)
apply (intro FOL_reflections function_reflections mem_formula_reflection
             mem_list_reflection Collect_reflection DPow_sats_reflection)
done

subsection\<open>A Locale for Relativizing the Operator \<^term>\<open>Lset\<close>\<close>

definition
  transrec_body :: "[i=>o,i,i,i,i] => o" where
    "transrec_body(M,g,x) ==
      \<lambda>y z. \<exists>gy[M]. y \<in> x & fun_apply(M,g,y,gy) & is_DPow'(M,gy,z)"

lemma (in M_DPow) transrec_body_abs:
     "[|M(x); M(g); M(z)|]
    ==> transrec_body(M,g,x,y,z) \<longleftrightarrow> y \<in> x & z = DPow'(g`y)"
by (simp add: transrec_body_def DPow'_abs transM [of _ x])

locale M_Lset = M_DPow +
 assumes strong_rep:
   "[|M(x); M(g)|] ==> strong_replacement(M, \<lambda>y z. transrec_body(M,g,x,y,z))"
 and transrec_rep:
    "M(i) ==> transrec_replacement(M, \<lambda>x f u.
              \<exists>r[M]. is_Replace(M, x, transrec_body(M,f,x), r) &
                     big_union(M, r, u), i)"

lemma (in M_Lset) strong_rep':
   "[|M(x); M(g)|]
    ==> strong_replacement(M, \<lambda>y z. y \<in> x & z = DPow'(g`y))"
by (insert strong_rep [of x g], simp add: transrec_body_abs)

lemma (in M_Lset) DPow_apply_closed:
   "[|M(f); M(x); y\<in>x|] ==> M(DPow'(f`y))"
by (blast intro: DPow'_closed dest: transM)

lemma (in M_Lset) RepFun_DPow_apply_closed:
   "[|M(f); M(x)|] ==> M({DPow'(f`y). y\<in>x})"
by (blast intro: DPow_apply_closed RepFun_closed2 strong_rep')

lemma (in M_Lset) RepFun_DPow_abs:
     "[|M(x); M(f); M(r) |]
      ==> is_Replace(M, x, \<lambda>y z. transrec_body(M,f,x,y,z), r) \<longleftrightarrow>
          r =  {DPow'(f`y). y\<in>x}"
apply (simp add: transrec_body_abs RepFun_def)
apply (rule iff_trans)
apply (rule Replace_abs)
apply (simp_all add: DPow_apply_closed strong_rep')
done

lemma (in M_Lset) transrec_rep':
   "M(i) ==> transrec_replacement(M, \<lambda>x f u. u = (\<Union>y\<in>x. DPow'(f ` y)), i)"
apply (insert transrec_rep [of i])
apply (simp add: RepFun_DPow_apply_closed RepFun_DPow_abs
       transrec_replacement_def)
done

text\<open>Relativization of the Operator \<^term>\<open>Lset\<close>\<close>

definition
  is_Lset :: "[i=>o, i, i] => o" where
   \<comment> \<open>We can use the term language below because \<^term>\<open>is_Lset\<close> will
       not have to be internalized: it isn't used in any instance of
       separation.\<close>
   "is_Lset(M,a,z) == is_transrec(M, %x f u. u = (\<Union>y\<in>x. DPow'(f`y)), a, z)"

lemma (in M_Lset) Lset_abs:
  "[|Ord(i);  M(i);  M(z)|]
   ==> is_Lset(M,i,z) \<longleftrightarrow> z = Lset(i)"
apply (simp add: is_Lset_def Lset_eq_transrec_DPow')
apply (rule transrec_abs)
apply (simp_all add: transrec_rep' relation2_def RepFun_DPow_apply_closed)
done

lemma (in M_Lset) Lset_closed:
  "[|Ord(i);  M(i)|] ==> M(Lset(i))"
apply (simp add: Lset_eq_transrec_DPow')
apply (rule transrec_closed [OF transrec_rep'])
apply (simp_all add: relation2_def RepFun_DPow_apply_closed)
done

subsection\<open>Instantiating the Locale \<open>M_Lset\<close>\<close>

subsubsection\<open>The First Instance of Replacement\<close>

lemma strong_rep_Reflects:
 "REFLECTS [\<lambda>u. \<exists>v[L]. v \<in> B & (\<exists>gy[L].
                          v \<in> x & fun_apply(L,g,v,gy) & is_DPow'(L,gy,u)),
   \<lambda>i u. \<exists>v \<in> Lset(i). v \<in> B & (\<exists>gy \<in> Lset(i).
            v \<in> x & fun_apply(##Lset(i),g,v,gy) & is_DPow'(##Lset(i),gy,u))]"
by (intro FOL_reflections function_reflections DPow'_reflection)

lemma strong_rep:
   "[|L(x); L(g)|] ==> strong_replacement(L, \<lambda>y z. transrec_body(L,g,x,y,z))"
apply (unfold transrec_body_def)
apply (rule strong_replacementI)
apply (rule_tac u="{x,g,B}"
         in gen_separation_multi [OF strong_rep_Reflects], auto)
apply (rule_tac env="[x,g,B]" in DPow_LsetI)
apply (rule sep_rules DPow'_iff_sats | simp)+
done

subsubsection\<open>The Second Instance of Replacement\<close>

lemma transrec_rep_Reflects:
 "REFLECTS [\<lambda>x. \<exists>v[L]. v \<in> B &
              (\<exists>y[L]. pair(L,v,y,x) &
             is_wfrec (L, \<lambda>x f u. \<exists>r[L].
                is_Replace (L, x, \<lambda>y z.
                     \<exists>gy[L]. y \<in> x & fun_apply(L,f,y,gy) &
                      is_DPow'(L,gy,z), r) & big_union(L,r,u), mr, v, y)),
    \<lambda>i x. \<exists>v \<in> Lset(i). v \<in> B &
              (\<exists>y \<in> Lset(i). pair(##Lset(i),v,y,x) &
             is_wfrec (##Lset(i), \<lambda>x f u. \<exists>r \<in> Lset(i).
                is_Replace (##Lset(i), x, \<lambda>y z.
                     \<exists>gy \<in> Lset(i). y \<in> x & fun_apply(##Lset(i),f,y,gy) &
                      is_DPow'(##Lset(i),gy,z), r) &
                      big_union(##Lset(i),r,u), mr, v, y))]"
apply (simp only: rex_setclass_is_bex [symmetric])
  \<comment> \<open>Convert \<open>\<exists>y\<in>Lset(i)\<close> to \<open>\<exists>y[##Lset(i)]\<close> within the body
       of the \<^term>\<open>is_wfrec\<close> application.\<close>
apply (intro FOL_reflections function_reflections
          is_wfrec_reflection Replace_reflection DPow'_reflection)
done

lemma transrec_rep:
    "[|L(j)|]
    ==> transrec_replacement(L, \<lambda>x f u.
              \<exists>r[L]. is_Replace(L, x, transrec_body(L,f,x), r) &
                     big_union(L, r, u), j)"
apply (rule L.transrec_replacementI, assumption)
apply (unfold transrec_body_def)
apply (rule strong_replacementI)
apply (rule_tac u="{j,B,Memrel(eclose({j}))}"
         in gen_separation_multi [OF transrec_rep_Reflects], auto)
apply (rule_tac env="[j,B,Memrel(eclose({j}))]" in DPow_LsetI)
apply (rule sep_rules is_wfrec_iff_sats Replace_iff_sats DPow'_iff_sats |
       simp)+
done

subsubsection\<open>Actually Instantiating \<open>M_Lset\<close>\<close>

lemma M_Lset_axioms_L: "M_Lset_axioms(L)"
  apply (rule M_Lset_axioms.intro)
       apply (assumption | rule strong_rep transrec_rep)+
  done

theorem M_Lset_L: "M_Lset(L)"
  apply (rule M_Lset.intro)
   apply (rule M_DPow_L)
  apply (rule M_Lset_axioms_L)
  done

text\<open>Finally: the point of the whole theory!\<close>
lemmas Lset_closed = M_Lset.Lset_closed [OF M_Lset_L]
   and Lset_abs = M_Lset.Lset_abs [OF M_Lset_L]

subsection\<open>The Notion of Constructible Set\<close>

definition
  constructible :: "[i=>o,i] => o" where
    "constructible(M,x) ==
       \<exists>i[M]. \<exists>Li[M]. ordinal(M,i) & is_Lset(M,i,Li) & x \<in> Li"

theorem V_equals_L_in_L:
  "L(x) \<longleftrightarrow> constructible(L,x)"
apply (simp add: constructible_def Lset_abs Lset_closed)
apply (simp add: L_def)
apply (blast intro: Ord_in_L)
done

end


(* TODO Move. *)
(* TODO Rename. *)
theory Tbd
  imports
    Directed_Walk
begin

(* TODO: Rename. *)
definition edges_from_map :: "('b \<rightharpoonup> 'a \<times> 'b) \<Rightarrow> ('a, 'b) multigraph" where
  "edges_from_map m \<equiv> {(\<epsilon>, u, v). m v = Some (\<epsilon>, u)}"

lemma mem_edges_from_mapI:
  assumes "m v = Some (\<epsilon>, u)"
  shows "(\<epsilon>, u, v) \<in> edges_from_map m"
  using assms
  by (simp add: edges_from_map_def)

lemma mem_edges_from_mapD:
  assumes "e \<in> edges_from_map m"
  shows "m (head e) = Some (fst e, tail e)"
  using assms
  by (auto simp add: edges_from_map_def head_def tail_def endpoints_def)

lemma mem_edges_from_mapD_2:
  assumes "(\<epsilon>, u, v) \<in> edges_from_map m"
  shows "m v = Some (\<epsilon>, u)"
  using assms
  by (auto simp add: head_def tail_def endpoints_def dest: mem_edges_from_mapD)

lemma edges_from_map_subset_if_map_le:
  assumes "m1 \<subseteq>\<^sub>m m2"
  shows "edges_from_map m1 \<subseteq> edges_from_map m2"
proof (standard, goal_cases)
  case (1 e)
  let ?\<epsilon> = "fst e"
  let ?u = "tail e"
  let ?v = "head e"
  have "m1 ?v = Some (?\<epsilon>, ?u)"
    using 1
    by (blast dest: mem_edges_from_mapD)
  hence "m2 ?v = Some (?\<epsilon>, ?u)"
    using assms
    by (simp add: map_le_def dom_def)
  thus ?case
    by (auto simp add: head_def tail_def endpoints_def dest: mem_edges_from_mapI)
qed

locale tbd =
  fixes m :: "'b \<rightharpoonup> 'a \<times> 'b"
  assumes wf: "wf {(u, v). \<exists>\<epsilon>. m v = Some (\<epsilon>, u)}"
begin

function (domintros) follow :: "'b \<Rightarrow> ('a, 'b) edge list" where
  "follow v = (case m v of None \<Rightarrow> [] | Some (\<epsilon>, u) \<Rightarrow> (\<epsilon>, u, v) # follow u)"
  by simp+

lemma follow_dom:
  shows "follow_dom v"
  using wf
  by (auto simp add: wfP_def follow_rel.simps intro: accp_wfPD)

lemma follow_simps:
  shows "follow v = (case m v of None \<Rightarrow> [] | Some (\<epsilon>, u) \<Rightarrow> (\<epsilon>, u, v) # follow u)"
  using follow_dom
  by (intro follow.psimps)

lemma follow_induct:
  assumes "\<And>v. (\<And>\<epsilon> u. m v = Some (\<epsilon>, u) \<Longrightarrow> P u) \<Longrightarrow> P v"
  shows "P v"
  using follow_dom assms
  by (rule follow.pinduct) simp

lemma follow_induct_2:
  assumes "\<And>v. (\<And>p. m v = Some p \<Longrightarrow> P (snd p)) \<Longrightarrow> P v"
  shows "P v"
  using assms
  by (rule follow_induct) force

definition rev_follow :: "'b \<Rightarrow> ('a, 'b) walk" where
  "rev_follow v = rev (follow v)"

lemma rev_follow_simps:
  shows "rev_follow v = (case m v of None \<Rightarrow> [] | Some (\<epsilon>, u) \<Rightarrow> rev_follow u @ [(\<epsilon>, u, v)])"
  by (simp add: rev_follow_def follow_simps split: option.split)

lemma
  shows "V (edges_from_map m) = dom m \<union> snd ` ran m"
  sorry

(* TODO: Move. *)
lemma rev_follow_non_emptyI:
  assumes "m v \<noteq> None"
  shows "rev_follow v \<noteq> []"
  using assms
  by (auto simp add: rev_follow_simps)

lemma cases_m [case_names None Some]:
  assumes "m v = None \<Longrightarrow> P v"
  assumes "\<And>\<epsilon> u. m v = Some (\<epsilon>, u) \<Longrightarrow> P v"
  shows "P v"
  using assms
  by fast

lemma walk_rev_follow:
  assumes "m v \<noteq> None"
  shows "walk (edges_from_map m) (rev_follow v) (tail (hd (rev_follow v))) v"
  using assms
proof (induct rule: follow_induct)
  case (1 v)
  show ?case
  proof (induct rule: cases_m)
    case None
    thus ?case
      using 1(2)
      by simp
  next
    case m_v_eq_Some: (Some \<epsilon> u)
    show ?case
    proof (induct rule: cases_m[of u])
      case None
      hence "rev_follow v = [(\<epsilon>, u, v)]"
        using m_v_eq_Some
        by (auto simp add: rev_follow_simps)
      thus ?case
        using m_v_eq_Some
        by (simp add: walk_singleton_iff edges_from_map_def endpoints_def tail_def)
    next
      case Some
      hence "rev_follow v = rev_follow u @ [(\<epsilon>, u, v)]"
        using m_v_eq_Some
        by (auto simp add: rev_follow_simps)
      moreover hence "hd (rev_follow v) = hd (rev_follow u)"
        using Some
        by (auto simp add: hd_append rev_follow_simps)
      ultimately show ?case
        using m_v_eq_Some Some
        by (auto simp add: walk_snoc_iff tail_def endpoints_def edges_from_map_def head_def dest: "1.hyps")
    qed
  qed
qed

lemma
  assumes "walk_vertices (rev_follow v) v = vs @ u # vs'"
  shows "walk_vertices (rev_follow u) u = vs @ [u]"
  using assms
proof (induct vs' arbitrary: v rule: rev_induct)
  case Nil
  then show ?case sorry
next
  case (snoc x xs)
  then show ?case sorry
qed

lemma m_eq_SomeD:
  assumes "m v = Some (\<epsilon>, u)"
  shows "v \<notin> set (walk_vertices (rev_follow u) u)"
proof
  assume "v \<in> set (walk_vertices (rev_follow u) u)"
  then obtain vs vs' where
    "walk_vertices (rev_follow u) u = vs @ v # vs'"
    by (fast dest: split_list)
  hence
    "walk_vertices (rev_follow v) v = vs @ v # vs @ [v]"
    "walk_vertices (rev_follow v) v = vs @ [v]"
    sorry
  thus False
    by force
qed

lemma distinct_walk_vertices_rev_follow:
  shows "distinct (walk_vertices (rev_follow v) v)"
proof (induct v rule: follow_induct)
  case (1 v)
  show ?case
  proof (cases rule: cases_m[of v])
    case None
    thus ?thesis
      by (simp add: rev_follow_simps)
  next
    case (Some \<epsilon> u)
    hence "walk_vertices (rev_follow v) v = walk_vertices (rev_follow u) u @ [v]"
      using walk_rev_follow
      by (fastforce simp add: rev_follow_simps walk_vertices_snoc tail_def head_def endpoints_def)
    thus ?thesis
      using Some
      by (fastforce dest: m_eq_SomeD intro: "1.hyps")
  qed
qed

lemma distinct_rev_follow:
  shows "distinct (rev_follow v)"
  using distinct_walk_vertices_rev_follow
  by (intro dinstinct_walk_vertices_imp_distinct)

lemma unique_walk_2:
  assumes "walk (edges_from_map m) p u v"
  shows "rev_follow u @ p = rev_follow v"
  using assms
proof (induct p arbitrary: v rule: rev_induct)
  case Nil
  thus ?case
    by (simp add: walk_Nil_iff)
next
  case (snoc e es)
  thus ?case
    by
      (auto
        simp add: walk_snoc_iff head_def tail_def endpoints_def rev_follow_simps
        dest: mem_edges_from_mapD)
qed

lemma unique_walk_3:
  assumes "walk (edges_from_map m) p1 u v"
  assumes "walk (edges_from_map m) p2 v w"
  assumes "walk (edges_from_map m) p u w"
  shows "p1 @ p2 = p"
proof -
  have "rev_follow w = rev_follow u @ p1 @ p2"
    using assms(1, 2)
    by (simp add: unique_walk_2[symmetric])
  thus ?thesis
    using assms(3)
    by (simp add: unique_walk_2[symmetric])
qed

end

locale tree = tbd
  where m = T
  for T :: "'b \<rightharpoonup> 'a \<times> 'b" +
  fixes r :: 'b
  assumes T_r_eq_None: "T r = None"
  assumes tail_last_follow_eq_r: "T v \<noteq> None \<Longrightarrow> tail (last (follow v)) = r"
begin

lemma tail_hd_rev_follow_eq_r:
  assumes "T v \<noteq> None"
  shows "tail (hd (rev_follow v)) = r"
  using assms
  by (auto simp add: rev_follow_def hd_rev intro: tail_last_follow_eq_r)

lemma walk_rev_follow:
  assumes "T v \<noteq> None"
  shows "walk (edges_from_map T) (rev_follow v) r v"
  using assms
  by (auto simp add: tail_hd_rev_follow_eq_r[symmetric] intro: walk_rev_follow)

lemma unique_walk:
  assumes "walk (edges_from_map T) p r v"
  shows "p = rev_follow v"
  using assms
proof (induct arbitrary: v rule: rev_induct)
  case Nil
  thus ?case
    by (simp add: walk_Nil_iff T_r_eq_None rev_follow_simps)
next
  case (snoc e es)
  thus ?case
    by
      (auto
        simp add: walk_snoc_iff head_def tail_def endpoints_def rev_follow_simps
        dest: mem_edges_from_mapD)
qed

end

end


theory SN
imports Lam_Funs
begin

text \<open>Strong Normalisation proof from the Proofs and Types book\<close>

section \<open>Beta Reduction\<close>

lemma subst_rename:
  assumes a: "c\<sharp>t1"
  shows "t1[a::=t2] = ([(c,a)]\<bullet>t1)[c::=t2]"
using a
by (nominal_induct t1 avoiding: a c t2 rule: lam.strong_induct)
   (auto simp add: calc_atm fresh_atm abs_fresh)

lemma forget:
  assumes a: "a\<sharp>t1"
  shows "t1[a::=t2] = t1"
  using a
by (nominal_induct t1 avoiding: a t2 rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact:
  fixes a::"name"
  assumes a: "a\<sharp>t1" "a\<sharp>t2"
  shows "a\<sharp>t1[b::=t2]"
using a
by (nominal_induct t1 avoiding: a b t2 rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact':
  fixes a::"name"
  assumes a: "a\<sharp>t2"
  shows "a\<sharp>t1[a::=t2]"
using a
by (nominal_induct t1 avoiding: a t2 rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma subst_lemma:
  assumes a: "x\<noteq>y"
  and     b: "x\<sharp>L"
  shows "M[x::=N][y::=L] = M[y::=L][x::=N[y::=L]]"
using a b
by (nominal_induct M avoiding: x y N L rule: lam.strong_induct)
   (auto simp add: fresh_fact forget)

lemma id_subs:
  shows "t[x::=Var x] = t"
  by (nominal_induct t avoiding: x rule: lam.strong_induct)
     (simp_all add: fresh_atm)

lemma lookup_fresh:
  fixes z::"name"
  assumes "z\<sharp>\<theta>" "z\<sharp>x"
  shows "z\<sharp> lookup \<theta> x"
using assms
by (induct rule: lookup.induct) (auto simp add: fresh_list_cons)

lemma lookup_fresh':
  assumes "z\<sharp>\<theta>"
  shows "lookup \<theta> z = Var z"
using assms
by (induct rule: lookup.induct)
   (auto simp add: fresh_list_cons fresh_prod fresh_atm)

lemma psubst_subst:
  assumes h:"c\<sharp>\<theta>"
  shows "(\<theta><t>)[c::=s] = ((c,s)#\<theta>)<t>"
  using h
by (nominal_induct t avoiding: \<theta> c s rule: lam.strong_induct)
   (auto simp add: fresh_list_cons fresh_atm forget lookup_fresh lookup_fresh')

inductive
  Beta :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta> _" [80,80] 80)
where
  b1[intro!]: "s1 \<longrightarrow>\<^sub>\<beta> s2 \<Longrightarrow> App s1 t \<longrightarrow>\<^sub>\<beta> App s2 t"
| b2[intro!]: "s1\<longrightarrow>\<^sub>\<beta>s2 \<Longrightarrow> App t s1 \<longrightarrow>\<^sub>\<beta> App t s2"
| b3[intro!]: "s1\<longrightarrow>\<^sub>\<beta>s2 \<Longrightarrow> Lam [a].s1 \<longrightarrow>\<^sub>\<beta> Lam [a].s2"
| b4[intro!]: "a\<sharp>s2 \<Longrightarrow> App (Lam [a].s1) s2\<longrightarrow>\<^sub>\<beta> (s1[a::=s2])"

equivariance Beta

nominal_inductive Beta
  by (simp_all add: abs_fresh fresh_fact')

lemma beta_preserves_fresh:
  fixes a::"name"
  assumes a: "t\<longrightarrow>\<^sub>\<beta> s"
  shows "a\<sharp>t \<Longrightarrow> a\<sharp>s"
using a
apply(nominal_induct t s avoiding: a rule: Beta.strong_induct)
apply(auto simp add: abs_fresh fresh_fact fresh_atm)
done

lemma beta_abs:
  assumes a: "Lam [a].t\<longrightarrow>\<^sub>\<beta> t'"
  shows "\<exists>t''. t'=Lam [a].t'' \<and> t\<longrightarrow>\<^sub>\<beta> t''"
proof -
  have "a\<sharp>Lam [a].t" by (simp add: abs_fresh)
  with a have "a\<sharp>t'" by (simp add: beta_preserves_fresh)
  with a show ?thesis
    by (cases rule: Beta.strong_cases[where a="a" and aa="a"])
       (auto simp add: lam.inject abs_fresh alpha)
qed

lemma beta_subst:
  assumes a: "M \<longrightarrow>\<^sub>\<beta> M'"
  shows "M[x::=N]\<longrightarrow>\<^sub>\<beta> M'[x::=N]"
using a
by (nominal_induct M M' avoiding: x N rule: Beta.strong_induct)
   (auto simp add: fresh_atm subst_lemma fresh_fact)

section \<open>types\<close>

nominal_datatype ty =
    TVar "nat"
  | TArr "ty" "ty" (infix "\<rightarrow>" 200)

lemma fresh_ty:
  fixes a ::"name"
  and   \<tau>  ::"ty"
  shows "a\<sharp>\<tau>"
by (nominal_induct \<tau> rule: ty.strong_induct)
   (auto simp add: fresh_nat)

(* valid contexts *)

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)"

equivariance valid

(* typing judgements *)

lemma fresh_context:
  fixes  \<Gamma> :: "(name\<times>ty)list"
  and    a :: "name"
  assumes a: "a\<sharp>\<Gamma>"
  shows "\<not>(\<exists>\<tau>::ty. (a,\<tau>)\<in>set \<Gamma>)"
using a
by (induct \<Gamma>)
   (auto simp add: fresh_prod fresh_list_cons fresh_atm)

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>lam\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
where
  t1[intro]: "\<lbrakk>valid \<Gamma>; (a,\<tau>)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var a : \<tau>"
| t2[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : \<tau>\<rightarrow>\<sigma>; \<Gamma> \<turnstile> t2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App t1 t2 : \<sigma>"
| t3[intro]: "\<lbrakk>a\<sharp>\<Gamma>;((a,\<tau>)#\<Gamma>) \<turnstile> t : \<sigma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [a].t : \<tau>\<rightarrow>\<sigma>"

equivariance typing

nominal_inductive typing
  by (simp_all add: abs_fresh fresh_ty)

subsection \<open>a fact about beta\<close>

definition "NORMAL" :: "lam \<Rightarrow> bool" where
  "NORMAL t \<equiv> \<not>(\<exists>t'. t\<longrightarrow>\<^sub>\<beta> t')"

lemma NORMAL_Var:
  shows "NORMAL (Var a)"
proof -
  { assume "\<exists>t'. (Var a) \<longrightarrow>\<^sub>\<beta> t'"
    then obtain t' where "(Var a) \<longrightarrow>\<^sub>\<beta> t'" by blast
    hence False by (cases) (auto)
  }
  thus "NORMAL (Var a)" by (auto simp add: NORMAL_def)
qed

text \<open>Inductive version of Strong Normalisation\<close>
inductive
  SN :: "lam \<Rightarrow> bool"
where
  SN_intro: "(\<And>t'. t \<longrightarrow>\<^sub>\<beta> t' \<Longrightarrow> SN t') \<Longrightarrow> SN t"

lemma SN_preserved:
  assumes a: "SN t1" "t1\<longrightarrow>\<^sub>\<beta> t2"
  shows "SN t2"
using a
by (cases) (auto)

lemma double_SN_aux:
  assumes a: "SN a"
  and b: "SN b"
  and hyp: "\<And>x z.
    \<lbrakk>\<And>y. x \<longrightarrow>\<^sub>\<beta> y \<Longrightarrow> SN y; \<And>y. x \<longrightarrow>\<^sub>\<beta> y \<Longrightarrow> P y z;
     \<And>u. z \<longrightarrow>\<^sub>\<beta> u \<Longrightarrow> SN u; \<And>u. z \<longrightarrow>\<^sub>\<beta> u \<Longrightarrow> P x u\<rbrakk> \<Longrightarrow> P x z"
  shows "P a b"
proof -
  from a
  have r: "\<And>b. SN b \<Longrightarrow> P a b"
  proof (induct a rule: SN.SN.induct)
    case (SN_intro x)
    note SNI' = SN_intro
    have "SN b" by fact
    thus ?case
    proof (induct b rule: SN.SN.induct)
      case (SN_intro y)
      show ?case
        apply (rule hyp)
        apply (erule SNI')
        apply (erule SNI')
        apply (rule SN.SN_intro)
        apply (erule SN_intro)+
        done
    qed
  qed
  from b show ?thesis by (rule r)
qed

lemma double_SN[consumes 2]:
  assumes a: "SN a"
  and     b: "SN b"
  and     c: "\<And>x z. \<lbrakk>\<And>y. x \<longrightarrow>\<^sub>\<beta> y \<Longrightarrow> P y z; \<And>u. z \<longrightarrow>\<^sub>\<beta> u \<Longrightarrow> P x u\<rbrakk> \<Longrightarrow> P x z"
  shows "P a b"
using a b c
apply(rule_tac double_SN_aux)
apply(assumption)+
apply(blast)
done

section \<open>Candidates\<close>

nominal_primrec
  RED :: "ty \<Rightarrow> lam set"
where
  "RED (TVar X) = {t. SN(t)}"
| "RED (\<tau>\<rightarrow>\<sigma>) =   {t. \<forall>u. (u\<in>RED \<tau> \<longrightarrow> (App t u)\<in>RED \<sigma>)}"
by (rule TrueI)+

text \<open>neutral terms\<close>
definition NEUT :: "lam \<Rightarrow> bool" where
  "NEUT t \<equiv> (\<exists>a. t = Var a) \<or> (\<exists>t1 t2. t = App t1 t2)"

(* a slight hack to get the first element of applications *)
(* this is needed to get (SN t) from SN (App t s)         *)
inductive
  FST :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<guillemotright> _" [80,80] 80)
where
  fst[intro!]:  "(App t s) \<guillemotright> t"

nominal_primrec
  fst_app_aux::"lam\<Rightarrow>lam option"
where
  "fst_app_aux (Var a)     = None"
| "fst_app_aux (App t1 t2) = Some t1"
| "fst_app_aux (Lam [x].t) = None"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: fresh_none)
apply(fresh_guess)+
done

definition
  fst_app_def[simp]: "fst_app t = the (fst_app_aux t)"

lemma SN_of_FST_of_App:
  assumes a: "SN (App t s)"
  shows "SN (fst_app (App t s))"
using a
proof -
  from a have "\<forall>z. (App t s \<guillemotright> z) \<longrightarrow> SN z"
    by (induct rule: SN.SN.induct)
       (blast elim: FST.cases intro: SN_intro)
  then have "SN t" by blast
  then show "SN (fst_app (App t s))" by simp
qed

section \<open>Candidates\<close>

definition "CR1" :: "ty \<Rightarrow> bool" where
  "CR1 \<tau> \<equiv> \<forall>t. (t\<in>RED \<tau> \<longrightarrow> SN t)"

definition "CR2" :: "ty \<Rightarrow> bool" where
  "CR2 \<tau> \<equiv> \<forall>t t'. (t\<in>RED \<tau> \<and> t \<longrightarrow>\<^sub>\<beta> t') \<longrightarrow> t'\<in>RED \<tau>"

definition "CR3_RED" :: "lam \<Rightarrow> ty \<Rightarrow> bool" where
  "CR3_RED t \<tau> \<equiv> \<forall>t'. t\<longrightarrow>\<^sub>\<beta> t' \<longrightarrow>  t'\<in>RED \<tau>"

definition "CR3" :: "ty \<Rightarrow> bool" where
  "CR3 \<tau> \<equiv> \<forall>t. (NEUT t \<and> CR3_RED t \<tau>) \<longrightarrow> t\<in>RED \<tau>"

definition "CR4" :: "ty \<Rightarrow> bool" where
  "CR4 \<tau> \<equiv> \<forall>t. (NEUT t \<and> NORMAL t) \<longrightarrow>t\<in>RED \<tau>"

lemma CR3_implies_CR4:
  assumes a: "CR3 \<tau>"
  shows "CR4 \<tau>"
using a by (auto simp add: CR3_def CR3_RED_def CR4_def NORMAL_def)

(* sub_induction in the arrow-type case for the next proof *)
lemma sub_induction:
  assumes a: "SN(u)"
  and     b: "u\<in>RED \<tau>"
  and     c1: "NEUT t"
  and     c2: "CR2 \<tau>"
  and     c3: "CR3 \<sigma>"
  and     c4: "CR3_RED t (\<tau>\<rightarrow>\<sigma>)"
  shows "(App t u)\<in>RED \<sigma>"
using a b
proof (induct)
  fix u
  assume as: "u\<in>RED \<tau>"
  assume ih: " \<And>u'. \<lbrakk>u \<longrightarrow>\<^sub>\<beta> u'; u' \<in> RED \<tau>\<rbrakk> \<Longrightarrow> App t u' \<in> RED \<sigma>"
  have "NEUT (App t u)" using c1 by (auto simp add: NEUT_def)
  moreover
  have "CR3_RED (App t u) \<sigma>" unfolding CR3_RED_def
  proof (intro strip)
    fix r
    assume red: "App t u \<longrightarrow>\<^sub>\<beta> r"
    moreover
    { assume "\<exists>t'. t \<longrightarrow>\<^sub>\<beta> t' \<and> r = App t' u"
      then obtain t' where a1: "t \<longrightarrow>\<^sub>\<beta> t'" and a2: "r = App t' u" by blast
      have "t'\<in>RED (\<tau>\<rightarrow>\<sigma>)" using c4 a1 by (simp add: CR3_RED_def)
      then have "App t' u\<in>RED \<sigma>" using as by simp
      then have "r\<in>RED \<sigma>" using a2 by simp
    }
    moreover
    { assume "\<exists>u'. u \<longrightarrow>\<^sub>\<beta> u' \<and> r = App t u'"
      then obtain u' where b1: "u \<longrightarrow>\<^sub>\<beta> u'" and b2: "r = App t u'" by blast
      have "u'\<in>RED \<tau>" using as b1 c2 by (auto simp add: CR2_def)
      with ih have "App t u' \<in> RED \<sigma>" using b1 by simp
      then have "r\<in>RED \<sigma>" using b2 by simp
    }
    moreover
    { assume "\<exists>x t'. t = Lam [x].t'"
      then obtain x t' where "t = Lam [x].t'" by blast
      then have "NEUT (Lam [x].t')" using c1 by simp
      then have "False" by (simp add: NEUT_def)
      then have "r\<in>RED \<sigma>" by simp
    }
    ultimately show "r \<in> RED \<sigma>" by (cases) (auto simp add: lam.inject)
  qed
  ultimately show "App t u \<in> RED \<sigma>" using c3 by (simp add: CR3_def)
qed

text \<open>properties of the candiadates\<close>
lemma RED_props:
  shows "CR1 \<tau>" and "CR2 \<tau>" and "CR3 \<tau>"
proof (nominal_induct \<tau> rule: ty.strong_induct)
  case (TVar a)
  { case 1 show "CR1 (TVar a)" by (simp add: CR1_def)
  next
    case 2 show "CR2 (TVar a)" by (auto intro: SN_preserved simp add: CR2_def)
  next
    case 3 show "CR3 (TVar a)" by (auto intro: SN_intro simp add: CR3_def CR3_RED_def)
  }
next
  case (TArr \<tau>1 \<tau>2)
  { case 1
    have ih_CR3_\<tau>1: "CR3 \<tau>1" by fact
    have ih_CR1_\<tau>2: "CR1 \<tau>2" by fact
    have "\<And>t. t \<in> RED (\<tau>1 \<rightarrow> \<tau>2) \<Longrightarrow> SN t"
    proof -
      fix t
      assume "t \<in> RED (\<tau>1 \<rightarrow> \<tau>2)"
      then have a: "\<forall>u. u \<in> RED \<tau>1 \<longrightarrow> App t u \<in> RED \<tau>2" by simp
      from ih_CR3_\<tau>1 have "CR4 \<tau>1" by (simp add: CR3_implies_CR4)
      moreover
      fix a have "NEUT (Var a)" by (force simp add: NEUT_def)
      moreover
      have "NORMAL (Var a)" by (rule NORMAL_Var)
      ultimately have "(Var a)\<in> RED \<tau>1" by (simp add: CR4_def)
      with a have "App t (Var a) \<in> RED \<tau>2" by simp
      hence "SN (App t (Var a))" using ih_CR1_\<tau>2 by (simp add: CR1_def)
      thus "SN t" by (auto dest: SN_of_FST_of_App)
    qed
    then show "CR1 (\<tau>1 \<rightarrow> \<tau>2)" unfolding CR1_def by simp
  next
    case 2
    have ih_CR2_\<tau>2: "CR2 \<tau>2" by fact
    then show "CR2 (\<tau>1 \<rightarrow> \<tau>2)" unfolding CR2_def by auto
  next
    case 3
    have ih_CR1_\<tau>1: "CR1 \<tau>1" by fact
    have ih_CR2_\<tau>1: "CR2 \<tau>1" by fact
    have ih_CR3_\<tau>2: "CR3 \<tau>2" by fact
    show "CR3 (\<tau>1 \<rightarrow> \<tau>2)" unfolding CR3_def
    proof (simp, intro strip)
      fix t u
      assume a1: "u \<in> RED \<tau>1"
      assume a2: "NEUT t \<and> CR3_RED t (\<tau>1 \<rightarrow> \<tau>2)"
      have "SN(u)" using a1 ih_CR1_\<tau>1 by (simp add: CR1_def)
      then show "(App t u)\<in>RED \<tau>2" using ih_CR2_\<tau>1 ih_CR3_\<tau>2 a1 a2 by (blast intro: sub_induction)
    qed
  }
qed

text \<open>
  the next lemma not as simple as on paper, probably because of
  the stronger double_SN induction
\<close>
lemma abs_RED:
  assumes asm: "\<forall>s\<in>RED \<tau>. t[x::=s]\<in>RED \<sigma>"
  shows "Lam [x].t\<in>RED (\<tau>\<rightarrow>\<sigma>)"
proof -
  have b1: "SN t"
  proof -
    have "Var x\<in>RED \<tau>"
    proof -
      have "CR4 \<tau>" by (simp add: RED_props CR3_implies_CR4)
      moreover
      have "NEUT (Var x)" by (auto simp add: NEUT_def)
      moreover
      have "NORMAL (Var x)" by (auto elim: Beta.cases simp add: NORMAL_def)
      ultimately show "Var x\<in>RED \<tau>" by (simp add: CR4_def)
    qed
    then have "t[x::=Var x]\<in>RED \<sigma>" using asm by simp
    then have "t\<in>RED \<sigma>" by (simp add: id_subs)
    moreover
    have "CR1 \<sigma>" by (simp add: RED_props)
    ultimately show "SN t" by (simp add: CR1_def)
  qed
  show "Lam [x].t\<in>RED (\<tau>\<rightarrow>\<sigma>)"
  proof (simp, intro strip)
    fix u
    assume b2: "u\<in>RED \<tau>"
    then have b3: "SN u" using RED_props by (auto simp add: CR1_def)
    show "App (Lam [x].t) u \<in> RED \<sigma>" using b1 b3 b2 asm
    proof(induct t u rule: double_SN)
      fix t u
      assume ih1: "\<And>t'.  \<lbrakk>t \<longrightarrow>\<^sub>\<beta> t'; u\<in>RED \<tau>; \<forall>s\<in>RED \<tau>. t'[x::=s]\<in>RED \<sigma>\<rbrakk> \<Longrightarrow> App (Lam [x].t') u \<in> RED \<sigma>"
      assume ih2: "\<And>u'.  \<lbrakk>u \<longrightarrow>\<^sub>\<beta> u'; u'\<in>RED \<tau>; \<forall>s\<in>RED \<tau>. t[x::=s]\<in>RED \<sigma>\<rbrakk> \<Longrightarrow> App (Lam [x].t) u' \<in> RED \<sigma>"
      assume as1: "u \<in> RED \<tau>"
      assume as2: "\<forall>s\<in>RED \<tau>. t[x::=s]\<in>RED \<sigma>"
      have "CR3_RED (App (Lam [x].t) u) \<sigma>" unfolding CR3_RED_def
      proof(intro strip)
        fix r
        assume red: "App (Lam [x].t) u \<longrightarrow>\<^sub>\<beta> r"
        moreover
        { assume "\<exists>t'. t \<longrightarrow>\<^sub>\<beta> t' \<and> r = App (Lam [x].t') u"
          then obtain t' where a1: "t \<longrightarrow>\<^sub>\<beta> t'" and a2: "r = App (Lam [x].t') u" by blast
          have "App (Lam [x].t') u\<in>RED \<sigma>" using ih1 a1 as1 as2
            apply(auto)
            apply(drule_tac x="t'" in meta_spec)
            apply(simp)
            apply(drule meta_mp)
            prefer 2
            apply(auto)[1]
            apply(rule ballI)
            apply(drule_tac x="s" in bspec)
            apply(simp)
            apply(subgoal_tac "CR2 \<sigma>")(*A*)
            apply(unfold CR2_def)[1]
            apply(drule_tac x="t[x::=s]" in spec)
            apply(drule_tac x="t'[x::=s]" in spec)
            apply(simp add: beta_subst)
            (*A*)
            apply(simp add: RED_props)
            done
          then have "r\<in>RED \<sigma>" using a2 by simp
        }
        moreover
        { assume "\<exists>u'. u \<longrightarrow>\<^sub>\<beta> u' \<and> r = App (Lam [x].t) u'"
          then obtain u' where b1: "u \<longrightarrow>\<^sub>\<beta> u'" and b2: "r = App (Lam [x].t) u'" by blast
          have "App (Lam [x].t) u'\<in>RED \<sigma>" using ih2 b1 as1 as2
            apply(auto)
            apply(drule_tac x="u'" in meta_spec)
            apply(simp)
            apply(drule meta_mp)
            apply(subgoal_tac "CR2 \<tau>")
            apply(unfold CR2_def)[1]
            apply(drule_tac x="u" in spec)
            apply(drule_tac x="u'" in spec)
            apply(simp)
            apply(simp add: RED_props)
            apply(simp)
            done
          then have "r\<in>RED \<sigma>" using b2 by simp
        }
        moreover
        { assume "r = t[x::=u]"
          then have "r\<in>RED \<sigma>" using as1 as2 by auto
        }
        ultimately show "r \<in> RED \<sigma>"
          (* one wants to use the strong elimination principle; for this one
             has to know that x\<sharp>u *)
        apply(cases)
        apply(auto simp add: lam.inject)
        apply(drule beta_abs)
        apply(auto)[1]
        apply(auto simp add: alpha subst_rename)
        done
    qed
    moreover
    have "NEUT (App (Lam [x].t) u)" unfolding NEUT_def by (auto)
    ultimately show "App (Lam [x].t) u \<in> RED \<sigma>"  using RED_props by (simp add: CR3_def)
  qed
qed
qed

abbreviation
 mapsto :: "(name\<times>lam) list \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> bool" ("_ maps _ to _" [55,55,55] 55)
where
 "\<theta> maps x to e \<equiv> (lookup \<theta> x) = e"

abbreviation
  closes :: "(name\<times>lam) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ closes _" [55,55] 55)
where
  "\<theta> closes \<Gamma> \<equiv> \<forall>x T. ((x,T) \<in> set \<Gamma> \<longrightarrow> (\<exists>t. \<theta> maps x to t \<and> t \<in> RED T))"

lemma all_RED:
  assumes a: "\<Gamma> \<turnstile> t : \<tau>"
  and     b: "\<theta> closes \<Gamma>"
  shows "\<theta><t> \<in> RED \<tau>"
using a b
proof(nominal_induct  avoiding: \<theta> rule: typing.strong_induct)
  case (t3 a \<Gamma> \<sigma> t \<tau> \<theta>) \<comment> \<open>lambda case\<close>
  have ih: "\<And>\<theta>. \<theta> closes ((a,\<sigma>)#\<Gamma>) \<Longrightarrow> \<theta><t> \<in> RED \<tau>" by fact
  have \<theta>_cond: "\<theta> closes \<Gamma>" by fact
  have fresh: "a\<sharp>\<Gamma>" "a\<sharp>\<theta>" by fact+
  from ih have "\<forall>s\<in>RED \<sigma>. ((a,s)#\<theta>)<t> \<in> RED \<tau>" using fresh \<theta>_cond fresh_context by simp
  then have "\<forall>s\<in>RED \<sigma>. \<theta><t>[a::=s] \<in> RED \<tau>" using fresh by (simp add: psubst_subst)
  then have "Lam [a].(\<theta><t>) \<in> RED (\<sigma> \<rightarrow> \<tau>)" by (simp only: abs_RED)
  then show "\<theta><(Lam [a].t)> \<in> RED (\<sigma> \<rightarrow> \<tau>)" using fresh by simp
qed auto

section \<open>identity substitution generated from a context \<Gamma>\<close>
fun
  "id" :: "(name\<times>ty) list \<Rightarrow> (name\<times>lam) list"
where
  "id []    = []"
| "id ((x,\<tau>)#\<Gamma>) = (x,Var x)#(id \<Gamma>)"

lemma id_maps:
  shows "(id \<Gamma>) maps a to (Var a)"
by (induct \<Gamma>) (auto)

lemma id_fresh:
  fixes a::"name"
  assumes a: "a\<sharp>\<Gamma>"
  shows "a\<sharp>(id \<Gamma>)"
using a
by (induct \<Gamma>)
   (auto simp add: fresh_list_nil fresh_list_cons)

lemma id_apply:
  shows "(id \<Gamma>)<t> = t"
by (nominal_induct t avoiding: \<Gamma> rule: lam.strong_induct)
   (auto simp add: id_maps id_fresh)

lemma id_closes:
  shows "(id \<Gamma>) closes \<Gamma>"
apply(auto)
apply(simp add: id_maps)
apply(subgoal_tac "CR3 T") \<comment> \<open>A\<close>
apply(drule CR3_implies_CR4)
apply(simp add: CR4_def)
apply(drule_tac x="Var x" in spec)
apply(force simp add: NEUT_def NORMAL_Var)
\<comment> \<open>A\<close>
apply(rule RED_props)
done

lemma typing_implies_RED:
  assumes a: "\<Gamma> \<turnstile> t : \<tau>"
  shows "t \<in> RED \<tau>"
proof -
  have "(id \<Gamma>)<t>\<in>RED \<tau>"
  proof -
    have "(id \<Gamma>) closes \<Gamma>" by (rule id_closes)
    with a show ?thesis by (rule all_RED)
  qed
  thus"t \<in> RED \<tau>" by (simp add: id_apply)
qed

lemma typing_implies_SN:
  assumes a: "\<Gamma> \<turnstile> t : \<tau>"
  shows "SN(t)"
proof -
  from a have "t \<in> RED \<tau>" by (rule typing_implies_RED)
  moreover
  have "CR1 \<tau>" by (rule RED_props)
  ultimately show "SN(t)" by (simp add: CR1_def)
qed

end


text \<open>Authors: Anthony Bordg and Lawrence Paulson\<close>

theory Group_Extras
  imports Main
          "Jacobson_Basic_Algebra.Group_Theory"
          "Set_Extras"

begin

section \<open>Fold operator with a subdomain\<close>

inductive_set
  foldSetD :: "['a set, 'b \<Rightarrow> 'a \<Rightarrow> 'a, 'a] \<Rightarrow> ('b set * 'a) set"
  for D :: "'a set" and f :: "'b \<Rightarrow> 'a \<Rightarrow> 'a" and e :: 'a
  where
    emptyI [intro]: "e \<in> D \<Longrightarrow> ({}, e) \<in> foldSetD D f e"
  | insertI [intro]: "\<lbrakk>x \<notin> A; f x y \<in> D; (A, y) \<in> foldSetD D f e\<rbrakk> \<Longrightarrow>
                      (insert x A, f x y) \<in> foldSetD D f e"

inductive_cases empty_foldSetDE [elim!]: "({}, x) \<in> foldSetD D f e"

definition
  foldD :: "['a set, 'b \<Rightarrow> 'a \<Rightarrow> 'a, 'a, 'b set] \<Rightarrow> 'a"
  where "foldD D f e A = (THE x. (A, x) \<in> foldSetD D f e)"

lemma foldSetD_closed: "(A, z) \<in> foldSetD D f e \<Longrightarrow> z \<in> D"
  by (erule foldSetD.cases) auto

lemma Diff1_foldSetD:
  "\<lbrakk>(A - {x}, y) \<in> foldSetD D f e; x \<in> A; f x y \<in> D\<rbrakk> \<Longrightarrow>
   (A, f x y) \<in> foldSetD D f e"
  by (metis Diff_insert_absorb foldSetD.insertI mk_disjoint_insert)

lemma foldSetD_imp_finite [simp]: "(A, x) \<in> foldSetD D f e \<Longrightarrow> finite A"
  by (induct set: foldSetD) auto

lemma finite_imp_foldSetD:
  "\<lbrakk>finite A; e \<in> D; \<And>x y. \<lbrakk>x \<in> A; y \<in> D\<rbrakk> \<Longrightarrow> f x y \<in> D\<rbrakk>
    \<Longrightarrow> \<exists>x. (A, x) \<in> foldSetD D f e"
proof (induct set: finite)
  case empty then show ?case by auto
next
  case (insert x F)
  then obtain y where y: "(F, y) \<in> foldSetD D f e" by auto
  with insert have "y \<in> D" by (auto dest: foldSetD_closed)
  with y and insert have "(insert x F, f x y) \<in> foldSetD D f e"
    by (intro foldSetD.intros) auto
  then show ?case ..
qed

lemma foldSetD_backwards:
  assumes "A \<noteq> {}" "(A, z) \<in> foldSetD D f e"
  shows "\<exists>x y. x \<in> A \<and> (A - { x }, y) \<in> foldSetD D f e \<and> z = f x y"
  using assms(2) by (cases) (simp add: assms(1), metis Diff_insert_absorb insertI1)

subsection \<open>Left-Commutative Operations\<close>

locale LCD =
  fixes B :: "'b set"
  and D :: "'a set"
  and f :: "'b \<Rightarrow> 'a \<Rightarrow> 'a"    (infixl "\<cdot>" 70)
  assumes left_commute:
    "\<lbrakk>x \<in> B; y \<in> B; z \<in> D\<rbrakk> \<Longrightarrow> x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
  and f_closed [simp, intro!]: "!!x y. \<lbrakk>x \<in> B; y \<in> D\<rbrakk> \<Longrightarrow> f x y \<in> D"

lemma (in LCD) foldSetD_closed [dest]: "(A, z) \<in> foldSetD D f e \<Longrightarrow> z \<in> D"
  by (erule foldSetD.cases) auto

lemma (in LCD) Diff1_foldSetD:
  "\<lbrakk>(A - {x}, y) \<in> foldSetD D f e; x \<in> A; A \<subseteq> B\<rbrakk> \<Longrightarrow>
  (A, f x y) \<in> foldSetD D f e"
  by (meson Diff1_foldSetD f_closed local.foldSetD_closed subsetCE)

lemma (in LCD) finite_imp_foldSetD:
  "\<lbrakk>finite A; A \<subseteq> B; e \<in> D\<rbrakk> \<Longrightarrow> \<exists>x. (A, x) \<in> foldSetD D f e"
proof (induct set: finite)
  case empty then show ?case by auto
next
  case (insert x F)
  then obtain y where y: "(F, y) \<in> foldSetD D f e" by auto
  with insert have "y \<in> D" by auto
  with y and insert have "(insert x F, f x y) \<in> foldSetD D f e"
    by (intro foldSetD.intros) auto
  then show ?case ..
qed

lemma (in LCD) foldSetD_determ_aux:
  assumes "e \<in> D" and A: "card A < n" "A \<subseteq> B" "(A, x) \<in> foldSetD D f e" "(A, y) \<in> foldSetD D f e"
  shows "y = x"
  using A
proof (induction n arbitrary: A x y)
  case 0
  then show ?case
    by auto
next
  case (Suc n)
  then consider "card A = n" | "card A < n"
    by linarith
  then show ?case
  proof cases
    case 1
    show ?thesis
      using foldSetD.cases [OF \<open>(A,x) \<in> foldSetD D (\<cdot>) e\<close>]
    proof cases
      case 1
      then show ?thesis
        using \<open>(A,y) \<in> foldSetD D (\<cdot>) e\<close> by auto
    next
      case (2 x' A' y')
      note A' = this
      show ?thesis
        using foldSetD.cases [OF \<open>(A,y) \<in> foldSetD D (\<cdot>) e\<close>]
      proof cases
        case 1
        then show ?thesis
          using \<open>(A,x) \<in> foldSetD D (\<cdot>) e\<close> by auto
      next
        case (2 x'' A'' y'')
        note A'' = this
        show ?thesis
        proof (cases "x' = x''")
          case True
          show ?thesis
          proof (cases "y' = y''")
            case True
            then show ?thesis
              using A' A'' \<open>x' = x''\<close> by (blast elim!: equalityE)
          next
            case False
            then show ?thesis
              using A' A'' \<open>x' = x''\<close>
              by (metis \<open>card A = n\<close> Suc.IH Suc.prems(2) card_insert_disjoint foldSetD_imp_finite insert_eq_iff insert_subset lessI)
          qed
        next
          case False
          then have *: "A' - {x''} = A'' - {x'}" "x'' \<in> A'" "x' \<in> A''"
            using A' A'' by fastforce+
          then have "A' = insert x'' A'' - {x'}"
            using \<open>x' \<notin> A'\<close> by blast
          then have card: "card A' \<le> card A''"
            using A' A'' * by (metis card_Suc_Diff1 eq_refl foldSetD_imp_finite)
          obtain u where u: "(A' - {x''}, u) \<in> foldSetD D (\<cdot>) e"
            using finite_imp_foldSetD [of "A' - {x''}"] A' Diff_insert \<open>A \<subseteq> B\<close> \<open>e \<in> D\<close> by fastforce
          have "y' = f x'' u"
            using Diff1_foldSetD [OF u] \<open>x'' \<in> A'\<close> \<open>card A = n\<close> A' Suc.IH \<open>A \<subseteq> B\<close> by auto
          then have "(A'' - {x'}, u) \<in> foldSetD D f e"
            using "*"(1) u by auto
          then have "y'' = f x' u"
            using A'' by (metis * \<open>card A = n\<close> A'(1) Diff1_foldSetD Suc.IH \<open>A \<subseteq> B\<close>
                card card_Suc_Diff1 card_insert_disjoint foldSetD_imp_finite insert_subset le_imp_less_Suc)
          then show ?thesis
            using A' A''
            by (metis \<open>A \<subseteq> B\<close> \<open>y' = x'' \<cdot> u\<close> insert_subset left_commute local.foldSetD_closed u)
        qed
      qed
    qed
  next
    case 2 with Suc show ?thesis by blast
  qed
qed

lemma (in LCD) foldSetD_determ:
  "\<lbrakk>(A, x) \<in> foldSetD D f e; (A, y) \<in> foldSetD D f e; e \<in> D; A \<subseteq> B\<rbrakk>
  \<Longrightarrow> y = x"
  by (blast intro: foldSetD_determ_aux [rule_format])

lemma (in LCD) foldD_equality:
  "\<lbrakk>(A, y) \<in> foldSetD D f e; e \<in> D; A \<subseteq> B\<rbrakk> \<Longrightarrow> foldD D f e A = y"
  by (unfold foldD_def) (blast intro: foldSetD_determ)

lemma foldD_empty [simp]:
  "e \<in> D \<Longrightarrow> foldD D f e {} = e"
  by (unfold foldD_def) blast

lemma (in LCD) foldD_insert_aux:
  "\<lbrakk>x \<notin> A; x \<in> B; e \<in> D; A \<subseteq> B\<rbrakk>
    \<Longrightarrow> ((insert x A, v) \<in> foldSetD D f e) \<longleftrightarrow> (\<exists>y. (A, y) \<in> foldSetD D f e \<and> v = f x y)"
  apply auto
  by (metis Diff_insert_absorb f_closed finite_Diff foldSetD.insertI foldSetD_determ foldSetD_imp_finite insert_subset local.finite_imp_foldSetD local.foldSetD_closed)

lemma (in LCD) foldD_insert:
  assumes "finite A" "x \<notin> A" "x \<in> B" "e \<in> D" "A \<subseteq> B"
  shows "foldD D f e (insert x A) = f x (foldD D f e A)"
proof -
  have "(THE v. \<exists>y. (A, y) \<in> foldSetD D (\<cdot>) e \<and> v = x \<cdot> y) = x \<cdot> (THE y. (A, y) \<in> foldSetD D (\<cdot>) e)"
    by (rule the_equality) (use assms foldD_def foldD_equality foldD_def finite_imp_foldSetD in \<open>metis+\<close>)
  then show ?thesis
    unfolding foldD_def using assms by (simp add: foldD_insert_aux)
qed

lemma (in LCD) foldD_closed [simp]:
  "\<lbrakk>finite A; e \<in> D; A \<subseteq> B\<rbrakk> \<Longrightarrow> foldD D f e A \<in> D"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case by (simp add: foldD_insert)
qed

lemma (in LCD) foldD_commute:
  "\<lbrakk>finite A; x \<in> B; e \<in> D; A \<subseteq> B\<rbrakk> \<Longrightarrow>
   f x (foldD D f e A) = foldD D f (f x e) A"
  by (induct set: finite) (auto simp add: left_commute foldD_insert)

lemma Int_mono2:
  "\<lbrakk>A \<subseteq> C; B \<subseteq> C\<rbrakk> \<Longrightarrow> A Int B \<subseteq> C"
  by blast

lemma (in LCD) foldD_nest_Un_Int:
  "\<lbrakk>finite A; finite C; e \<in> D; A \<subseteq> B; C \<subseteq> B\<rbrakk> \<Longrightarrow>
   foldD D f (foldD D f e C) A = foldD D f (foldD D f e (A Int C)) (A Un C)"
proof (induction set: finite)
  case (insert x F)
  then show ?case
    by (simp add: foldD_insert foldD_commute Int_insert_left insert_absorb Int_mono2)
qed simp

lemma (in LCD) foldD_nest_Un_disjoint:
  "\<lbrakk>finite A; finite B; A Int B = {}; e \<in> D; A \<subseteq> B; C \<subseteq> B\<rbrakk>
    \<Longrightarrow> foldD D f e (A Un B) = foldD D f (foldD D f e B) A"
  by (simp add: foldD_nest_Un_Int)

\<comment> \<open>Delete rules to do with \<open>foldSetD\<close> relation.\<close>

declare foldSetD_imp_finite [simp del]
  empty_foldSetDE [rule del]
  foldSetD.intros [rule del]
declare (in LCD)
  foldSetD_closed [rule del]

section \<open>Monoids\<close>

lemma comp_monoid_morphisms:
  assumes "monoid_homomorphism \<eta> A multA oneA B multB oneB" and
          "monoid_homomorphism \<theta> B multB oneB C multC oneC"
shows "monoid_homomorphism (\<theta> \<circ> \<eta> \<down> A) A multA oneA C multC oneC"
proof-
  have "map (\<theta> \<circ> \<eta> \<down> A) A C" using assms comp_maps by (metis monoid_homomorphism.axioms(1))
  moreover have "(\<theta> \<circ> \<eta> \<down> A) oneA = oneC"
    using assms
    by (metis compose_eq monoid.unit_closed monoid_homomorphism.axioms(2) monoid_homomorphism.commutes_with_unit)
  moreover have "(\<theta> \<circ> \<eta> \<down> A) (multA x y) = multC ((\<theta> \<circ> \<eta> \<down> A) x) ((\<theta> \<circ> \<eta> \<down> A) y)"
      if "x \<in> A" "y \<in> A" for x y
    using that assms monoid_homomorphism.commutes_with_composition
    by (smt compose_eq map.map_closed monoid.composition_closed monoid_homomorphism.axioms)
  ultimately show ?thesis
    using monoid_homomorphism_def assms comp_maps by (smt monoid_homomorphism_axioms.intro)
qed

text \<open>Commutative Monoids\<close>

text \<open>
  We enter a more restrictive context, with \<open>f :: 'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  instead of \<open>'b \<Rightarrow> 'a \<Rightarrow> 'a\<close>.
\<close>

locale ACeD =
  fixes D :: "'a set"
    and f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"    (infixl "\<cdot>" 70)
    and e :: 'a
  assumes ident [simp]: "x \<in> D \<Longrightarrow> x \<cdot> e = x"
    and commute: "\<lbrakk>x \<in> D; y \<in> D\<rbrakk> \<Longrightarrow> x \<cdot> y = y \<cdot> x"
    and assoc: "\<lbrakk>x \<in> D; y \<in> D; z \<in> D\<rbrakk> \<Longrightarrow> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    and e_closed [simp]: "e \<in> D"
    and f_closed [simp]: "\<lbrakk>x \<in> D; y \<in> D\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> D"

lemma (in ACeD) left_commute:
  "\<lbrakk>x \<in> D; y \<in> D; z \<in> D\<rbrakk> \<Longrightarrow> x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
proof -
  assume D: "x \<in> D" "y \<in> D" "z \<in> D"
  then have "x \<cdot> (y \<cdot> z) = (y \<cdot> z) \<cdot> x" by (simp add: commute)
  also from D have "... = y \<cdot> (z \<cdot> x)" by (simp add: assoc)
  also from D have "z \<cdot> x = x \<cdot> z" by (simp add: commute)
  finally show ?thesis .
qed

lemmas (in ACeD) AC = assoc commute left_commute

lemma (in ACeD) left_ident [simp]: "x \<in> D \<Longrightarrow> e \<cdot> x = x"
proof -
  assume "x \<in> D"
  then have "x \<cdot> e = x" by (rule ident)
  with \<open>x \<in> D\<close> show ?thesis by (simp add: commute)
qed

lemma (in ACeD) foldD_Un_Int:
  "\<lbrakk>finite A; finite B; A \<subseteq> D; B \<subseteq> D\<rbrakk> \<Longrightarrow>
    foldD D f e A \<cdot> foldD D f e B =
    foldD D f e (A Un B) \<cdot> foldD D f e (A Int B)"
proof (induction set: finite)
  case empty
  then show ?case
    by(simp add: left_commute LCD.foldD_closed [OF LCD.intro [of D]])
next
  case (insert x F)
  then show ?case
    by(simp add: AC insert_absorb Int_insert_left Int_mono2
                 LCD.foldD_insert [OF LCD.intro [of D]]
                 LCD.foldD_closed [OF LCD.intro [of D]])
qed

lemma (in ACeD) foldD_Un_disjoint:
  "\<lbrakk>finite A; finite B; A Int B = {}; A \<subseteq> D; B \<subseteq> D\<rbrakk> \<Longrightarrow>
    foldD D f e (A Un B) = foldD D f e A \<cdot> foldD D f e B"
  by (simp add: foldD_Un_Int
    left_commute LCD.foldD_closed [OF LCD.intro [of D]])

subsection \<open>Finite Products\<close>

context monoid
begin

definition finprod:: "'b set => ('b => 'a) \<Rightarrow> 'a"
  where "finprod I f \<equiv> if finite I then foldD M (composition \<circ> f) \<one> I else \<one>"

end (* monoid *)

section \<open>Groups\<close>

lemma comp_group_morphisms:
  assumes "group_homomorphism \<eta> A multA oneA B multB oneB" and
"group_homomorphism \<theta> B multB oneB C multC oneC"
shows "group_homomorphism (\<theta> \<circ> \<eta> \<down> A) A multA oneA C multC oneC"
  using assms group_homomorphism_def comp_monoid_morphisms by metis

subsection \<open>Subgroup Generated by a Subset\<close>

context group
begin

inductive_set generate :: "'a set \<Rightarrow> 'a set"
  for H where
    unit:  "\<one> \<in> generate H"
  | incl: "a \<in> H \<Longrightarrow> a \<in> generate H"
  | inv:  "a \<in> H \<Longrightarrow> inverse a \<in> generate H"
  | mult:  "a \<in> generate H \<Longrightarrow> b \<in> generate H \<Longrightarrow> a \<cdot> b \<in> generate H"

lemma generate_into_G: "a \<in> generate (G \<inter> H) \<Longrightarrow> a \<in> G"
  by (induction rule: generate.induct) auto

definition subgroup_generated :: "'a set \<Rightarrow> 'a set"
  where "subgroup_generated S = generate (G \<inter> S)"

lemma inverse_in_subgroup_generated: "a \<in> subgroup_generated H \<Longrightarrow> inverse a \<in> subgroup_generated H"
  unfolding subgroup_generated_def
proof (induction rule: generate.induct)
  case (mult a b)
  then show ?case
    by (simp add: generate.mult generate_into_G inverse_composition_commute)
qed (auto simp add: generate.unit generate.incl generate.inv)

lemma subgroup_generated_is_monoid:
  fixes H
  shows "Group_Theory.monoid (subgroup_generated H) (\<cdot>) \<one>"
  unfolding subgroup_generated_def
proof qed (auto simp: generate.unit generate.mult associative generate_into_G)

lemma subgroup_generated_is_subset:
  fixes H
  shows "subgroup_generated H \<subseteq> G"
    using generate_into_G subgroup_generated_def by blast

lemma subgroup_generated_is_subgroup:
  fixes H
  shows "subgroup (subgroup_generated H) G (\<cdot>) \<one>"
proof
  show "subgroup_generated H \<subseteq> G"
    by (simp add: subgroup_generated_is_subset)
  show "a \<cdot> b \<in> subgroup_generated H"
    if "a \<in> subgroup_generated H" "b \<in> subgroup_generated H" for a b
    using that by (meson monoid.composition_closed subgroup_generated_is_monoid)
  show "a \<cdot> b \<cdot> c = a \<cdot> (b \<cdot> c)"
    if "a \<in> subgroup_generated H" "b \<in> subgroup_generated H" "c \<in> subgroup_generated H"
    for a b c
    using that by (meson monoid.associative subgroup_generated_is_monoid)
  show "monoid.invertible (subgroup_generated H) (\<cdot>) \<one> u"
    if "u \<in> subgroup_generated H" for u
  proof (rule monoid.invertibleI )
    show "Group_Theory.monoid (subgroup_generated H) (\<cdot>) \<one>"
      by (simp add: subgroup_generated_is_monoid)
    show "u \<cdot> local.inverse u = \<one>" "local.inverse u \<cdot> u = \<one>" "u \<in> subgroup_generated H"
      using \<open>subgroup_generated H \<subseteq> G\<close> that by auto
    show "local.inverse u \<in> subgroup_generated H"
      using inverse_in_subgroup_generated that by blast
  qed
qed (auto simp: generate_into_G generate.unit subgroup_generated_def)

end (* group *)

section \<open>Abelian Groups\<close>

context abelian_group
begin

definition minus:: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<hyphen>" 70)
  where "x \<hyphen> y \<equiv> x \<cdot> inverse y "

definition finsum:: "'b set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "finsum I f \<equiv> finprod I f"

(* A notation "\<Sum>i\<in>I. f i" should be introduced for a sum of a family of elements of an abelian group *)

end (* abelian_group*)

end