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

theory Internalize imports L_axioms Datatype_absolute begin

subsection\<open>Internalized Forms of Data Structuring Operators\<close>

subsubsection\<open>The Formula \<^term>\<open>is_Inl\<close>, Internalized\<close>

(*  is_Inl(M,a,z) \<equiv> \<exists>zero[M]. empty(M,zero) \<and> pair(M,zero,a,z) *)
definition
  Inl_fm :: "[i,i]\<Rightarrow>i" where
    "Inl_fm(a,z) \<equiv> Exists(And(empty_fm(0), pair_fm(0,succ(a),succ(z))))"

lemma Inl_type [TC]:
     "\<lbrakk>x \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> Inl_fm(x,z) \<in> formula"
by (simp add: Inl_fm_def)

lemma sats_Inl_fm [simp]:
   "\<lbrakk>x \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, Inl_fm(x,z), env) \<longleftrightarrow> is_Inl(##A, nth(x,env), nth(z,env))"
by (simp add: Inl_fm_def is_Inl_def)

lemma Inl_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(k,env) = z;
          i \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_Inl(##A, x, z) \<longleftrightarrow> sats(A, Inl_fm(i,k), env)"
by simp

theorem Inl_reflection:
     "REFLECTS[\<lambda>x. is_Inl(L,f(x),h(x)),
               \<lambda>i x. is_Inl(##Lset(i),f(x),h(x))]"
apply (simp only: is_Inl_def)
apply (intro FOL_reflections function_reflections)
done

subsubsection\<open>The Formula \<^term>\<open>is_Inr\<close>, Internalized\<close>

(*  is_Inr(M,a,z) \<equiv> \<exists>n1[M]. number1(M,n1) \<and> pair(M,n1,a,z) *)
definition
  Inr_fm :: "[i,i]\<Rightarrow>i" where
    "Inr_fm(a,z) \<equiv> Exists(And(number1_fm(0), pair_fm(0,succ(a),succ(z))))"

lemma Inr_type [TC]:
     "\<lbrakk>x \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> Inr_fm(x,z) \<in> formula"
by (simp add: Inr_fm_def)

lemma sats_Inr_fm [simp]:
   "\<lbrakk>x \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, Inr_fm(x,z), env) \<longleftrightarrow> is_Inr(##A, nth(x,env), nth(z,env))"
by (simp add: Inr_fm_def is_Inr_def)

lemma Inr_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(k,env) = z;
          i \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_Inr(##A, x, z) \<longleftrightarrow> sats(A, Inr_fm(i,k), env)"
by simp

theorem Inr_reflection:
     "REFLECTS[\<lambda>x. is_Inr(L,f(x),h(x)),
               \<lambda>i x. is_Inr(##Lset(i),f(x),h(x))]"
apply (simp only: is_Inr_def)
apply (intro FOL_reflections function_reflections)
done

subsubsection\<open>The Formula \<^term>\<open>is_Nil\<close>, Internalized\<close>

(* is_Nil(M,xs) \<equiv> \<exists>zero[M]. empty(M,zero) \<and> is_Inl(M,zero,xs) *)

definition
  Nil_fm :: "i\<Rightarrow>i" where
    "Nil_fm(x) \<equiv> Exists(And(empty_fm(0), Inl_fm(0,succ(x))))"

lemma Nil_type [TC]: "x \<in> nat \<Longrightarrow> Nil_fm(x) \<in> formula"
by (simp add: Nil_fm_def)

lemma sats_Nil_fm [simp]:
   "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, Nil_fm(x), env) \<longleftrightarrow> is_Nil(##A, nth(x,env))"
by (simp add: Nil_fm_def is_Nil_def)

lemma Nil_iff_sats:
      "\<lbrakk>nth(i,env) = x; i \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_Nil(##A, x) \<longleftrightarrow> sats(A, Nil_fm(i), env)"
by simp

theorem Nil_reflection:
     "REFLECTS[\<lambda>x. is_Nil(L,f(x)),
               \<lambda>i x. is_Nil(##Lset(i),f(x))]"
apply (simp only: is_Nil_def)
apply (intro FOL_reflections function_reflections Inl_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_Cons\<close>, Internalized\<close>

(*  "is_Cons(M,a,l,Z) \<equiv> \<exists>p[M]. pair(M,a,l,p) \<and> is_Inr(M,p,Z)" *)
definition
  Cons_fm :: "[i,i,i]\<Rightarrow>i" where
    "Cons_fm(a,l,Z) \<equiv>
       Exists(And(pair_fm(succ(a),succ(l),0), Inr_fm(0,succ(Z))))"

lemma Cons_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> Cons_fm(x,y,z) \<in> formula"
by (simp add: Cons_fm_def)

lemma sats_Cons_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, Cons_fm(x,y,z), env) \<longleftrightarrow>
       is_Cons(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: Cons_fm_def is_Cons_def)

lemma Cons_iff_sats:
      "\<lbrakk>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)\<rbrakk>
       \<Longrightarrow>is_Cons(##A, x, y, z) \<longleftrightarrow> sats(A, Cons_fm(i,j,k), env)"
by simp

theorem Cons_reflection:
     "REFLECTS[\<lambda>x. is_Cons(L,f(x),g(x),h(x)),
               \<lambda>i x. is_Cons(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_Cons_def)
apply (intro FOL_reflections pair_reflection Inr_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_quasilist\<close>, Internalized\<close>

(* is_quasilist(M,xs) \<equiv> is_Nil(M,z) | (\<exists>x[M]. \<exists>l[M]. is_Cons(M,x,l,z))" *)

definition
  quasilist_fm :: "i\<Rightarrow>i" where
    "quasilist_fm(x) \<equiv>
       Or(Nil_fm(x), Exists(Exists(Cons_fm(1,0,succ(succ(x))))))"

lemma quasilist_type [TC]: "x \<in> nat \<Longrightarrow> quasilist_fm(x) \<in> formula"
by (simp add: quasilist_fm_def)

lemma sats_quasilist_fm [simp]:
   "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, quasilist_fm(x), env) \<longleftrightarrow> is_quasilist(##A, nth(x,env))"
by (simp add: quasilist_fm_def is_quasilist_def)

lemma quasilist_iff_sats:
      "\<lbrakk>nth(i,env) = x; i \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_quasilist(##A, x) \<longleftrightarrow> sats(A, quasilist_fm(i), env)"
by simp

theorem quasilist_reflection:
     "REFLECTS[\<lambda>x. is_quasilist(L,f(x)),
               \<lambda>i x. is_quasilist(##Lset(i),f(x))]"
apply (simp only: is_quasilist_def)
apply (intro FOL_reflections Nil_reflection Cons_reflection)
done

subsection\<open>Absoluteness for the Function \<^term>\<open>nth\<close>\<close>

subsubsection\<open>The Formula \<^term>\<open>is_hd\<close>, Internalized\<close>

(*   "is_hd(M,xs,H) \<equiv>
       (is_Nil(M,xs) \<longrightarrow> empty(M,H)) \<and>
       (\<forall>x[M]. \<forall>l[M]. \<not> is_Cons(M,x,l,xs) | H=x) \<and>
       (is_quasilist(M,xs) | empty(M,H))" *)
definition
  hd_fm :: "[i,i]\<Rightarrow>i" where
    "hd_fm(xs,H) \<equiv>
       And(Implies(Nil_fm(xs), empty_fm(H)),
           And(Forall(Forall(Or(Neg(Cons_fm(1,0,xs#+2)), Equal(H#+2,1)))),
               Or(quasilist_fm(xs), empty_fm(H))))"

lemma hd_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> hd_fm(x,y) \<in> formula"
by (simp add: hd_fm_def)

lemma sats_hd_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, hd_fm(x,y), env) \<longleftrightarrow> is_hd(##A, nth(x,env), nth(y,env))"
by (simp add: hd_fm_def is_hd_def)

lemma hd_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_hd(##A, x, y) \<longleftrightarrow> sats(A, hd_fm(i,j), env)"
by simp

theorem hd_reflection:
     "REFLECTS[\<lambda>x. is_hd(L,f(x),g(x)),
               \<lambda>i x. is_hd(##Lset(i),f(x),g(x))]"
apply (simp only: is_hd_def)
apply (intro FOL_reflections Nil_reflection Cons_reflection
             quasilist_reflection empty_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_tl\<close>, Internalized\<close>

(*     "is_tl(M,xs,T) \<equiv>
       (is_Nil(M,xs) \<longrightarrow> T=xs) \<and>
       (\<forall>x[M]. \<forall>l[M]. \<not> is_Cons(M,x,l,xs) | T=l) \<and>
       (is_quasilist(M,xs) | empty(M,T))" *)
definition
  tl_fm :: "[i,i]\<Rightarrow>i" where
    "tl_fm(xs,T) \<equiv>
       And(Implies(Nil_fm(xs), Equal(T,xs)),
           And(Forall(Forall(Or(Neg(Cons_fm(1,0,xs#+2)), Equal(T#+2,0)))),
               Or(quasilist_fm(xs), empty_fm(T))))"

lemma tl_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> tl_fm(x,y) \<in> formula"
by (simp add: tl_fm_def)

lemma sats_tl_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, tl_fm(x,y), env) \<longleftrightarrow> is_tl(##A, nth(x,env), nth(y,env))"
by (simp add: tl_fm_def is_tl_def)

lemma tl_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_tl(##A, x, y) \<longleftrightarrow> sats(A, tl_fm(i,j), env)"
by simp

theorem tl_reflection:
     "REFLECTS[\<lambda>x. is_tl(L,f(x),g(x)),
               \<lambda>i x. is_tl(##Lset(i),f(x),g(x))]"
apply (simp only: is_tl_def)
apply (intro FOL_reflections Nil_reflection Cons_reflection
             quasilist_reflection empty_reflection)
done

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

(*   is_bool_of_o :: "[i\<Rightarrow>o, o, i] \<Rightarrow> o"
   "is_bool_of_o(M,P,z) \<equiv> (P \<and> number1(M,z)) | (\<not>P \<and> empty(M,z))" *)

text\<open>The formula \<^term>\<open>p\<close> has no free variables.\<close>
definition
  bool_of_o_fm :: "[i, i]\<Rightarrow>i" where
  "bool_of_o_fm(p,z) \<equiv>
    Or(And(p,number1_fm(z)),
       And(Neg(p),empty_fm(z)))"

lemma is_bool_of_o_type [TC]:
     "\<lbrakk>p \<in> formula; z \<in> nat\<rbrakk> \<Longrightarrow> bool_of_o_fm(p,z) \<in> formula"
by (simp add: bool_of_o_fm_def)

lemma sats_bool_of_o_fm:
  assumes p_iff_sats: "P \<longleftrightarrow> sats(A, p, env)"
  shows
      "\<lbrakk>z \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> sats(A, bool_of_o_fm(p,z), env) \<longleftrightarrow>
           is_bool_of_o(##A, P, nth(z,env))"
by (simp add: bool_of_o_fm_def is_bool_of_o_def p_iff_sats [THEN iff_sym])

lemma is_bool_of_o_iff_sats:
  "\<lbrakk>P \<longleftrightarrow> sats(A, p, env); nth(k,env) = z; k \<in> nat; env \<in> list(A)\<rbrakk>
   \<Longrightarrow> is_bool_of_o(##A, P, z) \<longleftrightarrow> sats(A, bool_of_o_fm(p,k), env)"
by (simp add: sats_bool_of_o_fm)

theorem bool_of_o_reflection:
     "REFLECTS [P(L), \<lambda>i. P(##Lset(i))] \<Longrightarrow>
      REFLECTS[\<lambda>x. is_bool_of_o(L, P(L,x), f(x)),
               \<lambda>i x. is_bool_of_o(##Lset(i), P(##Lset(i),x), f(x))]"
apply (simp (no_asm) only: is_bool_of_o_def)
apply (intro FOL_reflections function_reflections, assumption+)
done

subsection\<open>More Internalizations\<close>

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

text\<open>The two arguments of \<^term>\<open>p\<close> are always 1, 0. Remember that
 \<^term>\<open>p\<close> will be enclosed by three quantifiers.\<close>

(* is_lambda :: "[i\<Rightarrow>o, i, [i,i]\<Rightarrow>o, i] \<Rightarrow> o"
    "is_lambda(M, A, is_b, z) \<equiv>
       \<forall>p[M]. p \<in> z \<longleftrightarrow>
        (\<exists>u[M]. \<exists>v[M]. u\<in>A \<and> pair(M,u,v,p) \<and> is_b(u,v))" *)
definition
  lambda_fm :: "[i, i, i]\<Rightarrow>i" where
  "lambda_fm(p,A,z) \<equiv>
    Forall(Iff(Member(0,succ(z)),
            Exists(Exists(And(Member(1,A#+3),
                           And(pair_fm(1,0,2), p))))))"

text\<open>We call \<^term>\<open>p\<close> with arguments x, y by equating them with
  the corresponding quantified variables with de Bruijn indices 1, 0.\<close>

lemma is_lambda_type [TC]:
     "\<lbrakk>p \<in> formula; x \<in> nat; y \<in> nat\<rbrakk>
      \<Longrightarrow> lambda_fm(p,x,y) \<in> formula"
by (simp add: lambda_fm_def)

lemma sats_lambda_fm:
  assumes is_b_iff_sats:
      "\<And>a0 a1 a2.
        \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A\<rbrakk>
        \<Longrightarrow> is_b(a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,env))))"
  shows
      "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> sats(A, lambda_fm(p,x,y), env) \<longleftrightarrow>
           is_lambda(##A, nth(x,env), is_b, nth(y,env))"
by (simp add: lambda_fm_def is_lambda_def is_b_iff_sats [THEN iff_sym])

theorem is_lambda_reflection:
  assumes is_b_reflection:
    "\<And>f g h. REFLECTS[\<lambda>x. is_b(L, f(x), g(x), h(x)),
                     \<lambda>i x. is_b(##Lset(i), f(x), g(x), h(x))]"
  shows "REFLECTS[\<lambda>x. is_lambda(L, A(x), is_b(L,x), f(x)),
               \<lambda>i x. is_lambda(##Lset(i), A(x), is_b(##Lset(i),x), f(x))]"
apply (simp (no_asm_use) only: is_lambda_def)
apply (intro FOL_reflections is_b_reflection pair_reflection)
done

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

(*    "is_Member(M,x,y,Z) \<equiv>
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) \<and> is_Inl(M,p,u) \<and> is_Inl(M,u,Z)" *)
definition
  Member_fm :: "[i,i,i]\<Rightarrow>i" where
    "Member_fm(x,y,Z) \<equiv>
       Exists(Exists(And(pair_fm(x#+2,y#+2,1),
                      And(Inl_fm(1,0), Inl_fm(0,Z#+2)))))"

lemma is_Member_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> Member_fm(x,y,z) \<in> formula"
by (simp add: Member_fm_def)

lemma sats_Member_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, Member_fm(x,y,z), env) \<longleftrightarrow>
        is_Member(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: Member_fm_def is_Member_def)

lemma Member_iff_sats:
      "\<lbrakk>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)\<rbrakk>
       \<Longrightarrow> is_Member(##A, x, y, z) \<longleftrightarrow> sats(A, Member_fm(i,j,k), env)"
by (simp)

theorem Member_reflection:
     "REFLECTS[\<lambda>x. is_Member(L,f(x),g(x),h(x)),
               \<lambda>i x. is_Member(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_Member_def)
apply (intro FOL_reflections pair_reflection Inl_reflection)
done

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

(*    "is_Equal(M,x,y,Z) \<equiv>
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) \<and> is_Inr(M,p,u) \<and> is_Inl(M,u,Z)" *)
definition
  Equal_fm :: "[i,i,i]\<Rightarrow>i" where
    "Equal_fm(x,y,Z) \<equiv>
       Exists(Exists(And(pair_fm(x#+2,y#+2,1),
                      And(Inr_fm(1,0), Inl_fm(0,Z#+2)))))"

lemma is_Equal_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> Equal_fm(x,y,z) \<in> formula"
by (simp add: Equal_fm_def)

lemma sats_Equal_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, Equal_fm(x,y,z), env) \<longleftrightarrow>
        is_Equal(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: Equal_fm_def is_Equal_def)

lemma Equal_iff_sats:
      "\<lbrakk>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)\<rbrakk>
       \<Longrightarrow> is_Equal(##A, x, y, z) \<longleftrightarrow> sats(A, Equal_fm(i,j,k), env)"
by (simp)

theorem Equal_reflection:
     "REFLECTS[\<lambda>x. is_Equal(L,f(x),g(x),h(x)),
               \<lambda>i x. is_Equal(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_Equal_def)
apply (intro FOL_reflections pair_reflection Inl_reflection Inr_reflection)
done

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

(*    "is_Nand(M,x,y,Z) \<equiv>
        \<exists>p[M]. \<exists>u[M]. pair(M,x,y,p) \<and> is_Inl(M,p,u) \<and> is_Inr(M,u,Z)" *)
definition
  Nand_fm :: "[i,i,i]\<Rightarrow>i" where
    "Nand_fm(x,y,Z) \<equiv>
       Exists(Exists(And(pair_fm(x#+2,y#+2,1),
                      And(Inl_fm(1,0), Inr_fm(0,Z#+2)))))"

lemma is_Nand_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> Nand_fm(x,y,z) \<in> formula"
by (simp add: Nand_fm_def)

lemma sats_Nand_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, Nand_fm(x,y,z), env) \<longleftrightarrow>
        is_Nand(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: Nand_fm_def is_Nand_def)

lemma Nand_iff_sats:
      "\<lbrakk>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)\<rbrakk>
       \<Longrightarrow> is_Nand(##A, x, y, z) \<longleftrightarrow> sats(A, Nand_fm(i,j,k), env)"
by (simp)

theorem Nand_reflection:
     "REFLECTS[\<lambda>x. is_Nand(L,f(x),g(x),h(x)),
               \<lambda>i x. is_Nand(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_Nand_def)
apply (intro FOL_reflections pair_reflection Inl_reflection Inr_reflection)
done

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

(* "is_Forall(M,p,Z) \<equiv> \<exists>u[M]. is_Inr(M,p,u) \<and> is_Inr(M,u,Z)" *)
definition
  Forall_fm :: "[i,i]\<Rightarrow>i" where
    "Forall_fm(x,Z) \<equiv>
       Exists(And(Inr_fm(succ(x),0), Inr_fm(0,succ(Z))))"

lemma is_Forall_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> Forall_fm(x,y) \<in> formula"
by (simp add: Forall_fm_def)

lemma sats_Forall_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, Forall_fm(x,y), env) \<longleftrightarrow>
        is_Forall(##A, nth(x,env), nth(y,env))"
by (simp add: Forall_fm_def is_Forall_def)

lemma Forall_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_Forall(##A, x, y) \<longleftrightarrow> sats(A, Forall_fm(i,j), env)"
by (simp)

theorem Forall_reflection:
     "REFLECTS[\<lambda>x. is_Forall(L,f(x),g(x)),
               \<lambda>i x. is_Forall(##Lset(i),f(x),g(x))]"
apply (simp only: is_Forall_def)
apply (intro FOL_reflections pair_reflection Inr_reflection)
done

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

(* is_and(M,a,b,z) \<equiv> (number1(M,a)  \<and> z=b) |
                       (\<not>number1(M,a) \<and> empty(M,z)) *)
definition
  and_fm :: "[i,i,i]\<Rightarrow>i" where
    "and_fm(a,b,z) \<equiv>
       Or(And(number1_fm(a), Equal(z,b)),
          And(Neg(number1_fm(a)),empty_fm(z)))"

lemma is_and_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> and_fm(x,y,z) \<in> formula"
by (simp add: and_fm_def)

lemma sats_and_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, and_fm(x,y,z), env) \<longleftrightarrow>
        is_and(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: and_fm_def is_and_def)

lemma is_and_iff_sats:
      "\<lbrakk>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)\<rbrakk>
       \<Longrightarrow> is_and(##A, x, y, z) \<longleftrightarrow> sats(A, and_fm(i,j,k), env)"
by simp

theorem is_and_reflection:
     "REFLECTS[\<lambda>x. is_and(L,f(x),g(x),h(x)),
               \<lambda>i x. is_and(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_and_def)
apply (intro FOL_reflections function_reflections)
done

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

(* is_or(M,a,b,z) \<equiv> (number1(M,a)  \<and> number1(M,z)) |
                     (\<not>number1(M,a) \<and> z=b) *)

definition
  or_fm :: "[i,i,i]\<Rightarrow>i" where
    "or_fm(a,b,z) \<equiv>
       Or(And(number1_fm(a), number1_fm(z)),
          And(Neg(number1_fm(a)), Equal(z,b)))"

lemma is_or_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> or_fm(x,y,z) \<in> formula"
by (simp add: or_fm_def)

lemma sats_or_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, or_fm(x,y,z), env) \<longleftrightarrow>
        is_or(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: or_fm_def is_or_def)

lemma is_or_iff_sats:
      "\<lbrakk>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)\<rbrakk>
       \<Longrightarrow> is_or(##A, x, y, z) \<longleftrightarrow> sats(A, or_fm(i,j,k), env)"
by simp

theorem is_or_reflection:
     "REFLECTS[\<lambda>x. is_or(L,f(x),g(x),h(x)),
               \<lambda>i x. is_or(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_or_def)
apply (intro FOL_reflections function_reflections)
done

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

(* is_not(M,a,z) \<equiv> (number1(M,a)  \<and> empty(M,z)) |
                     (\<not>number1(M,a) \<and> number1(M,z)) *)
definition
  not_fm :: "[i,i]\<Rightarrow>i" where
    "not_fm(a,z) \<equiv>
       Or(And(number1_fm(a), empty_fm(z)),
          And(Neg(number1_fm(a)), number1_fm(z)))"

lemma is_not_type [TC]:
     "\<lbrakk>x \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> not_fm(x,z) \<in> formula"
by (simp add: not_fm_def)

lemma sats_is_not_fm [simp]:
   "\<lbrakk>x \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, not_fm(x,z), env) \<longleftrightarrow> is_not(##A, nth(x,env), nth(z,env))"
by (simp add: not_fm_def is_not_def)

lemma is_not_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(k,env) = z;
          i \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_not(##A, x, z) \<longleftrightarrow> sats(A, not_fm(i,k), env)"
by simp

theorem is_not_reflection:
     "REFLECTS[\<lambda>x. is_not(L,f(x),g(x)),
               \<lambda>i x. is_not(##Lset(i),f(x),g(x))]"
apply (simp only: is_not_def)
apply (intro FOL_reflections function_reflections)
done

lemmas extra_reflections =
    Inl_reflection Inr_reflection Nil_reflection Cons_reflection
    quasilist_reflection hd_reflection tl_reflection bool_of_o_reflection
    is_lambda_reflection Member_reflection Equal_reflection Nand_reflection
    Forall_reflection is_and_reflection is_or_reflection is_not_reflection

subsection\<open>Well-Founded Recursion!\<close>

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

text\<open>Alternative definition, minimizing nesting of quantifiers around MH\<close>
lemma M_is_recfun_iff:
   "M_is_recfun(M,MH,r,a,f) \<longleftrightarrow>
    (\<forall>z[M]. z \<in> f \<longleftrightarrow>
     (\<exists>x[M]. \<exists>f_r_sx[M]. \<exists>y[M].
             MH(x, f_r_sx, y) \<and> pair(M,x,y,z) \<and>
             (\<exists>xa[M]. \<exists>sx[M]. \<exists>r_sx[M].
                pair(M,x,a,xa) \<and> upair(M,x,x,sx) \<and>
               pre_image(M,r,sx,r_sx) \<and> restriction(M,f,r_sx,f_r_sx) \<and>
               xa \<in> r)))"
apply (simp add: M_is_recfun_def)
apply (rule rall_cong, blast)
done

(* M_is_recfun :: "[i\<Rightarrow>o, [i,i,i]\<Rightarrow>o, i, i, i] \<Rightarrow> o"
   "M_is_recfun(M,MH,r,a,f) \<equiv>
     \<forall>z[M]. z \<in> f \<longleftrightarrow>
               2      1           0
new def     (\<exists>x[M]. \<exists>f_r_sx[M]. \<exists>y[M].
             MH(x, f_r_sx, y) \<and> pair(M,x,y,z) \<and>
             (\<exists>xa[M]. \<exists>sx[M]. \<exists>r_sx[M].
                pair(M,x,a,xa) \<and> upair(M,x,x,sx) \<and>
               pre_image(M,r,sx,r_sx) \<and> restriction(M,f,r_sx,f_r_sx) \<and>
               xa \<in> r)"
*)

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0 and z\<close>
definition
  is_recfun_fm :: "[i, i, i, i]\<Rightarrow>i" where
  "is_recfun_fm(p,r,a,f) \<equiv>
   Forall(Iff(Member(0,succ(f)),
    Exists(Exists(Exists(
     And(p,
      And(pair_fm(2,0,3),
       Exists(Exists(Exists(
        And(pair_fm(5,a#+7,2),
         And(upair_fm(5,5,1),
          And(pre_image_fm(r#+7,1,0),
           And(restriction_fm(f#+7,0,4), Member(2,r#+7)))))))))))))))"

lemma is_recfun_type [TC]:
     "\<lbrakk>p \<in> formula; x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
      \<Longrightarrow> is_recfun_fm(p,x,y,z) \<in> formula"
by (simp add: is_recfun_fm_def)

lemma sats_is_recfun_fm:
  assumes MH_iff_sats:
      "\<And>a0 a1 a2 a3.
        \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A\<rbrakk>
        \<Longrightarrow> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,env)))))"
  shows
      "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> sats(A, is_recfun_fm(p,x,y,z), env) \<longleftrightarrow>
           M_is_recfun(##A, MH, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: is_recfun_fm_def M_is_recfun_iff MH_iff_sats [THEN iff_sym])

lemma is_recfun_iff_sats:
  assumes MH_iff_sats:
      "\<And>a0 a1 a2 a3.
        \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A\<rbrakk>
        \<Longrightarrow> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,env)))))"
  shows
  "\<lbrakk>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)\<rbrakk>
   \<Longrightarrow> M_is_recfun(##A, MH, x, y, z) \<longleftrightarrow> sats(A, is_recfun_fm(p,i,j,k), env)"
by (simp add: sats_is_recfun_fm [OF MH_iff_sats])

text\<open>The additional variable in the premise, namely \<^term>\<open>f'\<close>, is essential.
It lets \<^term>\<open>MH\<close> depend upon \<^term>\<open>x\<close>, which seems often necessary.
The same thing occurs in \<open>is_wfrec_reflection\<close>.\<close>
theorem is_recfun_reflection:
  assumes MH_reflection:
    "\<And>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. M_is_recfun(L, MH(L,x), f(x), g(x), h(x)),
             \<lambda>i x. M_is_recfun(##Lset(i), MH(##Lset(i),x), f(x), g(x), h(x))]"
apply (simp (no_asm_use) only: M_is_recfun_def)
apply (intro FOL_reflections function_reflections
             restriction_reflection MH_reflection)
done

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

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0;
      \<^term>\<open>p\<close> is enclosed by 5 quantifiers.\<close>

(* is_wfrec :: "[i\<Rightarrow>o, i, [i,i,i]\<Rightarrow>o, i, i] \<Rightarrow> o"
    "is_wfrec(M,MH,r,a,z) \<equiv>
      \<exists>f[M]. M_is_recfun(M,MH,r,a,f) \<and> MH(a,f,z)" *)
definition
  is_wfrec_fm :: "[i, i, i, i]\<Rightarrow>i" where
  "is_wfrec_fm(p,r,a,z) \<equiv>
    Exists(And(is_recfun_fm(p, succ(r), succ(a), 0),
           Exists(Exists(Exists(Exists(
             And(Equal(2,a#+5), And(Equal(1,4), And(Equal(0,z#+5), p)))))))))"

text\<open>We call \<^term>\<open>p\<close> with arguments a, f, z by equating them with
  the corresponding quantified variables with de Bruijn indices 2, 1, 0.\<close>

text\<open>There's an additional existential quantifier to ensure that the
      environments in both calls to MH have the same length.\<close>

lemma is_wfrec_type [TC]:
     "\<lbrakk>p \<in> formula; x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
      \<Longrightarrow> is_wfrec_fm(p,x,y,z) \<in> formula"
by (simp add: is_wfrec_fm_def)

lemma sats_is_wfrec_fm:
  assumes MH_iff_sats:
      "\<And>a0 a1 a2 a3 a4.
        \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A\<rbrakk>
        \<Longrightarrow> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
  shows
      "\<lbrakk>x \<in> nat; y < length(env); z < length(env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> sats(A, is_wfrec_fm(p,x,y,z), env) \<longleftrightarrow>
           is_wfrec(##A, MH, nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule lt_length_in_nat, assumption)
apply (simp add: is_wfrec_fm_def sats_is_recfun_fm is_wfrec_def MH_iff_sats [THEN iff_sym], blast)
done

lemma is_wfrec_iff_sats:
  assumes MH_iff_sats:
      "\<And>a0 a1 a2 a3 a4.
        \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A\<rbrakk>
        \<Longrightarrow> MH(a2, a1, a0) \<longleftrightarrow> sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,Cons(a4,env))))))"
  shows
  "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i \<in> nat; j < length(env); k < length(env); env \<in> list(A)\<rbrakk>
   \<Longrightarrow> is_wfrec(##A, MH, x, y, z) \<longleftrightarrow> sats(A, is_wfrec_fm(p,i,j,k), env)"
by (simp add: sats_is_wfrec_fm [OF MH_iff_sats])

theorem is_wfrec_reflection:
  assumes MH_reflection:
    "\<And>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_wfrec(L, MH(L,x), f(x), g(x), h(x)),
               \<lambda>i x. is_wfrec(##Lset(i), MH(##Lset(i),x), f(x), g(x), h(x))]"
apply (simp (no_asm_use) only: is_wfrec_def)
apply (intro FOL_reflections MH_reflection is_recfun_reflection)
done

subsection\<open>For Datatypes\<close>

subsubsection\<open>Binary Products, Internalized\<close>

definition
  cartprod_fm :: "[i,i,i]\<Rightarrow>i" where
(* "cartprod(M,A,B,z) \<equiv>
        \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A \<and> (\<exists>y[M]. y\<in>B \<and> pair(M,x,y,u)))" *)
    "cartprod_fm(A,B,z) \<equiv>
       Forall(Iff(Member(0,succ(z)),
                  Exists(And(Member(0,succ(succ(A))),
                         Exists(And(Member(0,succ(succ(succ(B)))),
                                    pair_fm(1,0,2)))))))"

lemma cartprod_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> cartprod_fm(x,y,z) \<in> formula"
by (simp add: cartprod_fm_def)

lemma sats_cartprod_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, cartprod_fm(x,y,z), env) \<longleftrightarrow>
        cartprod(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: cartprod_fm_def cartprod_def)

lemma cartprod_iff_sats:
      "\<lbrakk>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)\<rbrakk>
       \<Longrightarrow> cartprod(##A, x, y, z) \<longleftrightarrow> sats(A, cartprod_fm(i,j,k), env)"
by (simp)

theorem cartprod_reflection:
     "REFLECTS[\<lambda>x. cartprod(L,f(x),g(x),h(x)),
               \<lambda>i x. cartprod(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: cartprod_def)
apply (intro FOL_reflections pair_reflection)
done

subsubsection\<open>Binary Sums, Internalized\<close>

(* "is_sum(M,A,B,Z) \<equiv>
       \<exists>A0[M]. \<exists>n1[M]. \<exists>s1[M]. \<exists>B1[M].
         3      2       1        0
       number1(M,n1) \<and> cartprod(M,n1,A,A0) \<and> upair(M,n1,n1,s1) \<and>
       cartprod(M,s1,B,B1) \<and> union(M,A0,B1,Z)"  *)
definition
  sum_fm :: "[i,i,i]\<Rightarrow>i" where
    "sum_fm(A,B,Z) \<equiv>
       Exists(Exists(Exists(Exists(
        And(number1_fm(2),
            And(cartprod_fm(2,A#+4,3),
                And(upair_fm(2,2,1),
                    And(cartprod_fm(1,B#+4,0), union_fm(3,0,Z#+4)))))))))"

lemma sum_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> sum_fm(x,y,z) \<in> formula"
by (simp add: sum_fm_def)

lemma sats_sum_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, sum_fm(x,y,z), env) \<longleftrightarrow>
        is_sum(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: sum_fm_def is_sum_def)

lemma sum_iff_sats:
      "\<lbrakk>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)\<rbrakk>
       \<Longrightarrow> is_sum(##A, x, y, z) \<longleftrightarrow> sats(A, sum_fm(i,j,k), env)"
by simp

theorem sum_reflection:
     "REFLECTS[\<lambda>x. is_sum(L,f(x),g(x),h(x)),
               \<lambda>i x. is_sum(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_sum_def)
apply (intro FOL_reflections function_reflections cartprod_reflection)
done

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

(* "is_quasinat(M,z) \<equiv> empty(M,z) | (\<exists>m[M]. successor(M,m,z))" *)
definition
  quasinat_fm :: "i\<Rightarrow>i" where
    "quasinat_fm(z) \<equiv> Or(empty_fm(z), Exists(succ_fm(0,succ(z))))"

lemma quasinat_type [TC]:
     "x \<in> nat \<Longrightarrow> quasinat_fm(x) \<in> formula"
by (simp add: quasinat_fm_def)

lemma sats_quasinat_fm [simp]:
   "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, quasinat_fm(x), env) \<longleftrightarrow> is_quasinat(##A, nth(x,env))"
by (simp add: quasinat_fm_def is_quasinat_def)

lemma quasinat_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_quasinat(##A, x) \<longleftrightarrow> sats(A, quasinat_fm(i), env)"
by simp

theorem quasinat_reflection:
     "REFLECTS[\<lambda>x. is_quasinat(L,f(x)),
               \<lambda>i x. is_quasinat(##Lset(i),f(x))]"
apply (simp only: is_quasinat_def)
apply (intro FOL_reflections function_reflections)
done

subsubsection\<open>The Operator \<^term>\<open>is_nat_case\<close>\<close>
text\<open>I could not get it to work with the more natural assumption that
 \<^term>\<open>is_b\<close> takes two arguments.  Instead it must be a formula where 1 and 0
 stand for \<^term>\<open>m\<close> and \<^term>\<open>b\<close>, respectively.\<close>

(* is_nat_case :: "[i\<Rightarrow>o, i, [i,i]\<Rightarrow>o, i, i] \<Rightarrow> o"
    "is_nat_case(M, a, is_b, k, z) \<equiv>
       (empty(M,k) \<longrightarrow> z=a) \<and>
       (\<forall>m[M]. successor(M,m,k) \<longrightarrow> is_b(m,z)) \<and>
       (is_quasinat(M,k) | empty(M,z))" *)
text\<open>The formula \<^term>\<open>is_b\<close> has free variables 1 and 0.\<close>
definition
  is_nat_case_fm :: "[i, i, i, i]\<Rightarrow>i" where
 "is_nat_case_fm(a,is_b,k,z) \<equiv>
    And(Implies(empty_fm(k), Equal(z,a)),
        And(Forall(Implies(succ_fm(0,succ(k)),
                   Forall(Implies(Equal(0,succ(succ(z))), is_b)))),
            Or(quasinat_fm(k), empty_fm(z))))"

lemma is_nat_case_type [TC]:
     "\<lbrakk>is_b \<in> formula;
         x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
      \<Longrightarrow> is_nat_case_fm(x,is_b,y,z) \<in> formula"
by (simp add: is_nat_case_fm_def)

lemma sats_is_nat_case_fm:
  assumes is_b_iff_sats:
      "\<And>a. a \<in> A \<Longrightarrow> is_b(a,nth(z, env)) \<longleftrightarrow>
                      sats(A, p, Cons(nth(z,env), Cons(a, env)))"
  shows
      "\<lbrakk>x \<in> nat; y \<in> nat; z < length(env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> sats(A, is_nat_case_fm(x,p,y,z), env) \<longleftrightarrow>
           is_nat_case(##A, nth(x,env), is_b, nth(y,env), nth(z,env))"
apply (frule lt_length_in_nat, assumption)
apply (simp add: is_nat_case_fm_def is_nat_case_def is_b_iff_sats [THEN iff_sym])
done

lemma is_nat_case_iff_sats:
  "\<lbrakk>(\<And>a. a \<in> A \<Longrightarrow> is_b(a,z) \<longleftrightarrow>
                      sats(A, p, Cons(z, Cons(a,env))));
      nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i \<in> nat; j \<in> nat; k < length(env); env \<in> list(A)\<rbrakk>
   \<Longrightarrow> is_nat_case(##A, x, is_b, y, z) \<longleftrightarrow> sats(A, is_nat_case_fm(i,p,j,k), env)"
by (simp add: sats_is_nat_case_fm [of A is_b])

text\<open>The second argument of \<^term>\<open>is_b\<close> gives it direct access to \<^term>\<open>x\<close>,
  which is essential for handling free variable references.  Without this
  argument, we cannot prove reflection for \<^term>\<open>iterates_MH\<close>.\<close>
theorem is_nat_case_reflection:
  assumes is_b_reflection:
    "\<And>h f g. REFLECTS[\<lambda>x. is_b(L, h(x), f(x), g(x)),
                     \<lambda>i x. is_b(##Lset(i), h(x), f(x), g(x))]"
  shows "REFLECTS[\<lambda>x. is_nat_case(L, f(x), is_b(L,x), g(x), h(x)),
               \<lambda>i x. is_nat_case(##Lset(i), f(x), is_b(##Lset(i), x), g(x), h(x))]"
apply (simp (no_asm_use) only: is_nat_case_def)
apply (intro FOL_reflections function_reflections
             restriction_reflection is_b_reflection quasinat_reflection)
done

subsection\<open>The Operator \<^term>\<open>iterates_MH\<close>, Needed for Iteration\<close>

(*  iterates_MH :: "[i\<Rightarrow>o, [i,i]\<Rightarrow>o, i, i, i, i] \<Rightarrow> o"
   "iterates_MH(M,isF,v,n,g,z) \<equiv>
        is_nat_case(M, v, \<lambda>m u. \<exists>gm[M]. fun_apply(M,g,m,gm) \<and> isF(gm,u),
                    n, z)" *)
definition
  iterates_MH_fm :: "[i, i, i, i, i]\<Rightarrow>i" where
 "iterates_MH_fm(isF,v,n,g,z) \<equiv>
    is_nat_case_fm(v,
      Exists(And(fun_apply_fm(succ(succ(succ(g))),2,0),
                     Forall(Implies(Equal(0,2), isF)))),
      n, z)"

lemma iterates_MH_type [TC]:
     "\<lbrakk>p \<in> formula;
         v \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
      \<Longrightarrow> iterates_MH_fm(p,v,x,y,z) \<in> formula"
by (simp add: iterates_MH_fm_def)

lemma sats_iterates_MH_fm:
  assumes is_F_iff_sats:
      "\<And>a b c d. \<lbrakk>a \<in> A; b \<in> A; c \<in> A; d \<in> A\<rbrakk>
              \<Longrightarrow> is_F(a,b) \<longleftrightarrow>
                  sats(A, p, Cons(b, Cons(a, Cons(c, Cons(d,env)))))"
  shows
      "\<lbrakk>v \<in> nat; x \<in> nat; y \<in> nat; z < length(env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> sats(A, iterates_MH_fm(p,v,x,y,z), env) \<longleftrightarrow>
           iterates_MH(##A, is_F, nth(v,env), nth(x,env), nth(y,env), nth(z,env))"
apply (frule lt_length_in_nat, assumption)
apply (simp add: iterates_MH_fm_def iterates_MH_def sats_is_nat_case_fm
              is_F_iff_sats [symmetric])
apply (rule is_nat_case_cong)
apply (simp_all add: setclass_def)
done

lemma iterates_MH_iff_sats:
  assumes is_F_iff_sats:
      "\<And>a b c d. \<lbrakk>a \<in> A; b \<in> A; c \<in> A; d \<in> A\<rbrakk>
              \<Longrightarrow> is_F(a,b) \<longleftrightarrow>
                  sats(A, p, Cons(b, Cons(a, Cons(c, Cons(d,env)))))"
  shows
  "\<lbrakk>nth(i',env) = v; nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i' \<in> nat; i \<in> nat; j \<in> nat; k < length(env); env \<in> list(A)\<rbrakk>
   \<Longrightarrow> iterates_MH(##A, is_F, v, x, y, z) \<longleftrightarrow>
       sats(A, iterates_MH_fm(p,i',i,j,k), env)"
by (simp add: sats_iterates_MH_fm [OF is_F_iff_sats])

text\<open>The second argument of \<^term>\<open>p\<close> gives it direct access to \<^term>\<open>x\<close>,
  which is essential for handling free variable references.  Without this
  argument, we cannot prove reflection for \<^term>\<open>list_N\<close>.\<close>
theorem iterates_MH_reflection:
  assumes p_reflection:
    "\<And>f g h. REFLECTS[\<lambda>x. p(L, h(x), f(x), g(x)),
                     \<lambda>i x. p(##Lset(i), h(x), f(x), g(x))]"
 shows "REFLECTS[\<lambda>x. iterates_MH(L, p(L,x), e(x), f(x), g(x), h(x)),
               \<lambda>i x. iterates_MH(##Lset(i), p(##Lset(i),x), e(x), f(x), g(x), h(x))]"
apply (simp (no_asm_use) only: iterates_MH_def)
apply (intro FOL_reflections function_reflections is_nat_case_reflection
             restriction_reflection p_reflection)
done

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

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0;
      \<^term>\<open>p\<close> is enclosed by 9 (??) quantifiers.\<close>

(*    "is_iterates(M,isF,v,n,Z) \<equiv>
      \<exists>sn[M]. \<exists>msn[M]. successor(M,n,sn) \<and> membership(M,sn,msn) \<and>
       1       0       is_wfrec(M, iterates_MH(M,isF,v), msn, n, Z)"*)

definition
  is_iterates_fm :: "[i, i, i, i]\<Rightarrow>i" where
  "is_iterates_fm(p,v,n,Z) \<equiv>
     Exists(Exists(
      And(succ_fm(n#+2,1),
       And(Memrel_fm(1,0),
              is_wfrec_fm(iterates_MH_fm(p, v#+7, 2, 1, 0),
                          0, n#+2, Z#+2)))))"

text\<open>We call \<^term>\<open>p\<close> with arguments a, f, z by equating them with
  the corresponding quantified variables with de Bruijn indices 2, 1, 0.\<close>

lemma is_iterates_type [TC]:
     "\<lbrakk>p \<in> formula; x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
      \<Longrightarrow> is_iterates_fm(p,x,y,z) \<in> formula"
by (simp add: is_iterates_fm_def)

lemma sats_is_iterates_fm:
  assumes is_F_iff_sats:
      "\<And>a b c d e f g h i j k.
              \<lbrakk>a \<in> A; b \<in> A; c \<in> A; d \<in> A; e \<in> A; f \<in> A;
                 g \<in> A; h \<in> A; i \<in> A; j \<in> A; k \<in> A\<rbrakk>
              \<Longrightarrow> is_F(a,b) \<longleftrightarrow>
                  sats(A, p, Cons(b, Cons(a, Cons(c, Cons(d, Cons(e, Cons(f,
                      Cons(g, Cons(h, Cons(i, Cons(j, Cons(k, env))))))))))))"
  shows
      "\<lbrakk>x \<in> nat; y < length(env); z < length(env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> sats(A, is_iterates_fm(p,x,y,z), env) \<longleftrightarrow>
           is_iterates(##A, is_F, nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule lt_length_in_nat, assumption)
apply (simp add: is_iterates_fm_def is_iterates_def sats_is_nat_case_fm
              is_F_iff_sats [symmetric] sats_is_wfrec_fm sats_iterates_MH_fm)
done

lemma is_iterates_iff_sats:
  assumes is_F_iff_sats:
      "\<And>a b c d e f g h i j k.
              \<lbrakk>a \<in> A; b \<in> A; c \<in> A; d \<in> A; e \<in> A; f \<in> A;
                 g \<in> A; h \<in> A; i \<in> A; j \<in> A; k \<in> A\<rbrakk>
              \<Longrightarrow> is_F(a,b) \<longleftrightarrow>
                  sats(A, p, Cons(b, Cons(a, Cons(c, Cons(d, Cons(e, Cons(f,
                      Cons(g, Cons(h, Cons(i, Cons(j, Cons(k, env))))))))))))"
  shows
  "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
      i \<in> nat; j < length(env); k < length(env); env \<in> list(A)\<rbrakk>
   \<Longrightarrow> is_iterates(##A, is_F, x, y, z) \<longleftrightarrow>
       sats(A, is_iterates_fm(p,i,j,k), env)"
by (simp add: sats_is_iterates_fm [OF is_F_iff_sats])

text\<open>The second argument of \<^term>\<open>p\<close> gives it direct access to \<^term>\<open>x\<close>,
  which is essential for handling free variable references.  Without this
  argument, we cannot prove reflection for \<^term>\<open>list_N\<close>.\<close>
theorem is_iterates_reflection:
  assumes p_reflection:
    "\<And>f g h. REFLECTS[\<lambda>x. p(L, h(x), f(x), g(x)),
                     \<lambda>i x. p(##Lset(i), h(x), f(x), g(x))]"
 shows "REFLECTS[\<lambda>x. is_iterates(L, p(L,x), f(x), g(x), h(x)),
               \<lambda>i x. is_iterates(##Lset(i), p(##Lset(i),x), f(x), g(x), h(x))]"
apply (simp (no_asm_use) only: is_iterates_def)
apply (intro FOL_reflections function_reflections p_reflection
             is_wfrec_reflection iterates_MH_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_eclose_n\<close>, Internalized\<close>

(* is_eclose_n(M,A,n,Z) \<equiv> is_iterates(M, big_union(M), A, n, Z) *)

definition
  eclose_n_fm :: "[i,i,i]\<Rightarrow>i" where
  "eclose_n_fm(A,n,Z) \<equiv> is_iterates_fm(big_union_fm(1,0), A, n, Z)"

lemma eclose_n_fm_type [TC]:
 "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> eclose_n_fm(x,y,z) \<in> formula"
by (simp add: eclose_n_fm_def)

lemma sats_eclose_n_fm [simp]:
   "\<lbrakk>x \<in> nat; y < length(env); z < length(env); env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, eclose_n_fm(x,y,z), env) \<longleftrightarrow>
        is_eclose_n(##A, nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (simp add: eclose_n_fm_def is_eclose_n_def
                 sats_is_iterates_fm)
done

lemma eclose_n_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j < length(env); k < length(env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_eclose_n(##A, x, y, z) \<longleftrightarrow> sats(A, eclose_n_fm(i,j,k), env)"
by (simp)

theorem eclose_n_reflection:
     "REFLECTS[\<lambda>x. is_eclose_n(L, f(x), g(x), h(x)),
               \<lambda>i x. is_eclose_n(##Lset(i), f(x), g(x), h(x))]"
apply (simp only: is_eclose_n_def)
apply (intro FOL_reflections function_reflections is_iterates_reflection)
done

subsubsection\<open>Membership in \<^term>\<open>eclose(A)\<close>\<close>

(* mem_eclose(M,A,l) \<equiv>
      \<exists>n[M]. \<exists>eclosen[M].
       finite_ordinal(M,n) \<and> is_eclose_n(M,A,n,eclosen) \<and> l \<in> eclosen *)
definition
  mem_eclose_fm :: "[i,i]\<Rightarrow>i" where
    "mem_eclose_fm(x,y) \<equiv>
       Exists(Exists(
         And(finite_ordinal_fm(1),
           And(eclose_n_fm(x#+2,1,0), Member(y#+2,0)))))"

lemma mem_eclose_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> mem_eclose_fm(x,y) \<in> formula"
by (simp add: mem_eclose_fm_def)

lemma sats_mem_eclose_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, mem_eclose_fm(x,y), env) \<longleftrightarrow> mem_eclose(##A, nth(x,env), nth(y,env))"
by (simp add: mem_eclose_fm_def mem_eclose_def)

lemma mem_eclose_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> mem_eclose(##A, x, y) \<longleftrightarrow> sats(A, mem_eclose_fm(i,j), env)"
by simp

theorem mem_eclose_reflection:
     "REFLECTS[\<lambda>x. mem_eclose(L,f(x),g(x)),
               \<lambda>i x. mem_eclose(##Lset(i),f(x),g(x))]"
apply (simp only: mem_eclose_def)
apply (intro FOL_reflections finite_ordinal_reflection eclose_n_reflection)
done

subsubsection\<open>The Predicate ``Is \<^term>\<open>eclose(A)\<close>''\<close>

(* is_eclose(M,A,Z) \<equiv> \<forall>l[M]. l \<in> Z \<longleftrightarrow> mem_eclose(M,A,l) *)
definition
  is_eclose_fm :: "[i,i]\<Rightarrow>i" where
    "is_eclose_fm(A,Z) \<equiv>
       Forall(Iff(Member(0,succ(Z)), mem_eclose_fm(succ(A),0)))"

lemma is_eclose_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> is_eclose_fm(x,y) \<in> formula"
by (simp add: is_eclose_fm_def)

lemma sats_is_eclose_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, is_eclose_fm(x,y), env) \<longleftrightarrow> is_eclose(##A, nth(x,env), nth(y,env))"
by (simp add: is_eclose_fm_def is_eclose_def)

lemma is_eclose_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_eclose(##A, x, y) \<longleftrightarrow> sats(A, is_eclose_fm(i,j), env)"
by simp

theorem is_eclose_reflection:
     "REFLECTS[\<lambda>x. is_eclose(L,f(x),g(x)),
               \<lambda>i x. is_eclose(##Lset(i),f(x),g(x))]"
apply (simp only: is_eclose_def)
apply (intro FOL_reflections mem_eclose_reflection)
done

subsubsection\<open>The List Functor, Internalized\<close>

definition
  list_functor_fm :: "[i,i,i]\<Rightarrow>i" where
(* "is_list_functor(M,A,X,Z) \<equiv>
        \<exists>n1[M]. \<exists>AX[M].
         number1(M,n1) \<and> cartprod(M,A,X,AX) \<and> is_sum(M,n1,AX,Z)" *)
    "list_functor_fm(A,X,Z) \<equiv>
       Exists(Exists(
        And(number1_fm(1),
            And(cartprod_fm(A#+2,X#+2,0), sum_fm(1,0,Z#+2)))))"

lemma list_functor_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> list_functor_fm(x,y,z) \<in> formula"
by (simp add: list_functor_fm_def)

lemma sats_list_functor_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, list_functor_fm(x,y,z), env) \<longleftrightarrow>
        is_list_functor(##A, nth(x,env), nth(y,env), nth(z,env))"
by (simp add: list_functor_fm_def is_list_functor_def)

lemma list_functor_iff_sats:
  "\<lbrakk>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)\<rbrakk>
   \<Longrightarrow> is_list_functor(##A, x, y, z) \<longleftrightarrow> sats(A, list_functor_fm(i,j,k), env)"
by simp

theorem list_functor_reflection:
     "REFLECTS[\<lambda>x. is_list_functor(L,f(x),g(x),h(x)),
               \<lambda>i x. is_list_functor(##Lset(i),f(x),g(x),h(x))]"
apply (simp only: is_list_functor_def)
apply (intro FOL_reflections number1_reflection
             cartprod_reflection sum_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_list_N\<close>, Internalized\<close>

(* "is_list_N(M,A,n,Z) \<equiv>
      \<exists>zero[M]. empty(M,zero) \<and>
                is_iterates(M, is_list_functor(M,A), zero, n, Z)" *)

definition
  list_N_fm :: "[i,i,i]\<Rightarrow>i" where
  "list_N_fm(A,n,Z) \<equiv>
     Exists(
       And(empty_fm(0),
           is_iterates_fm(list_functor_fm(A#+9#+3,1,0), 0, n#+1, Z#+1)))"

lemma list_N_fm_type [TC]:
 "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk> \<Longrightarrow> list_N_fm(x,y,z) \<in> formula"
by (simp add: list_N_fm_def)

lemma sats_list_N_fm [simp]:
   "\<lbrakk>x \<in> nat; y < length(env); z < length(env); env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, list_N_fm(x,y,z), env) \<longleftrightarrow>
        is_list_N(##A, nth(x,env), nth(y,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (simp add: list_N_fm_def is_list_N_def sats_is_iterates_fm)
done

lemma list_N_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y; nth(k,env) = z;
          i \<in> nat; j < length(env); k < length(env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_list_N(##A, x, y, z) \<longleftrightarrow> sats(A, list_N_fm(i,j,k), env)"
by (simp)

theorem list_N_reflection:
     "REFLECTS[\<lambda>x. is_list_N(L, f(x), g(x), h(x)),
               \<lambda>i x. is_list_N(##Lset(i), f(x), g(x), h(x))]"
apply (simp only: is_list_N_def)
apply (intro FOL_reflections function_reflections
             is_iterates_reflection list_functor_reflection)
done

subsubsection\<open>The Predicate ``Is A List''\<close>

(* mem_list(M,A,l) \<equiv>
      \<exists>n[M]. \<exists>listn[M].
       finite_ordinal(M,n) \<and> is_list_N(M,A,n,listn) \<and> l \<in> listn *)
definition
  mem_list_fm :: "[i,i]\<Rightarrow>i" where
    "mem_list_fm(x,y) \<equiv>
       Exists(Exists(
         And(finite_ordinal_fm(1),
           And(list_N_fm(x#+2,1,0), Member(y#+2,0)))))"

lemma mem_list_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> mem_list_fm(x,y) \<in> formula"
by (simp add: mem_list_fm_def)

lemma sats_mem_list_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, mem_list_fm(x,y), env) \<longleftrightarrow> mem_list(##A, nth(x,env), nth(y,env))"
by (simp add: mem_list_fm_def mem_list_def)

lemma mem_list_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> mem_list(##A, x, y) \<longleftrightarrow> sats(A, mem_list_fm(i,j), env)"
by simp

theorem mem_list_reflection:
     "REFLECTS[\<lambda>x. mem_list(L,f(x),g(x)),
               \<lambda>i x. mem_list(##Lset(i),f(x),g(x))]"
apply (simp only: mem_list_def)
apply (intro FOL_reflections finite_ordinal_reflection list_N_reflection)
done

subsubsection\<open>The Predicate ``Is \<^term>\<open>list(A)\<close>''\<close>

(* is_list(M,A,Z) \<equiv> \<forall>l[M]. l \<in> Z \<longleftrightarrow> mem_list(M,A,l) *)
definition
  is_list_fm :: "[i,i]\<Rightarrow>i" where
    "is_list_fm(A,Z) \<equiv>
       Forall(Iff(Member(0,succ(Z)), mem_list_fm(succ(A),0)))"

lemma is_list_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> is_list_fm(x,y) \<in> formula"
by (simp add: is_list_fm_def)

lemma sats_is_list_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, is_list_fm(x,y), env) \<longleftrightarrow> is_list(##A, nth(x,env), nth(y,env))"
by (simp add: is_list_fm_def is_list_def)

lemma is_list_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_list(##A, x, y) \<longleftrightarrow> sats(A, is_list_fm(i,j), env)"
by simp

theorem is_list_reflection:
     "REFLECTS[\<lambda>x. is_list(L,f(x),g(x)),
               \<lambda>i x. is_list(##Lset(i),f(x),g(x))]"
apply (simp only: is_list_def)
apply (intro FOL_reflections mem_list_reflection)
done

subsubsection\<open>The Formula Functor, Internalized\<close>

definition formula_functor_fm :: "[i,i]\<Rightarrow>i" where
(*     "is_formula_functor(M,X,Z) \<equiv>
        \<exists>nat'[M]. \<exists>natnat[M]. \<exists>natnatsum[M]. \<exists>XX[M]. \<exists>X3[M].
           4           3               2       1       0
          omega(M,nat') \<and> cartprod(M,nat',nat',natnat) \<and>
          is_sum(M,natnat,natnat,natnatsum) \<and>
          cartprod(M,X,X,XX) \<and> is_sum(M,XX,X,X3) \<and>
          is_sum(M,natnatsum,X3,Z)" *)
    "formula_functor_fm(X,Z) \<equiv>
       Exists(Exists(Exists(Exists(Exists(
        And(omega_fm(4),
         And(cartprod_fm(4,4,3),
          And(sum_fm(3,3,2),
           And(cartprod_fm(X#+5,X#+5,1),
            And(sum_fm(1,X#+5,0), sum_fm(2,0,Z#+5)))))))))))"

lemma formula_functor_type [TC]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> formula_functor_fm(x,y) \<in> formula"
by (simp add: formula_functor_fm_def)

lemma sats_formula_functor_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, formula_functor_fm(x,y), env) \<longleftrightarrow>
        is_formula_functor(##A, nth(x,env), nth(y,env))"
by (simp add: formula_functor_fm_def is_formula_functor_def)

lemma formula_functor_iff_sats:
  "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
   \<Longrightarrow> is_formula_functor(##A, x, y) \<longleftrightarrow> sats(A, formula_functor_fm(i,j), env)"
by simp

theorem formula_functor_reflection:
     "REFLECTS[\<lambda>x. is_formula_functor(L,f(x),g(x)),
               \<lambda>i x. is_formula_functor(##Lset(i),f(x),g(x))]"
apply (simp only: is_formula_functor_def)
apply (intro FOL_reflections omega_reflection
             cartprod_reflection sum_reflection)
done

subsubsection\<open>The Formula \<^term>\<open>is_formula_N\<close>, Internalized\<close>

(*  "is_formula_N(M,n,Z) \<equiv>
      \<exists>zero[M]. empty(M,zero) \<and>
                is_iterates(M, is_formula_functor(M), zero, n, Z)" *)
definition
  formula_N_fm :: "[i,i]\<Rightarrow>i" where
  "formula_N_fm(n,Z) \<equiv>
     Exists(
       And(empty_fm(0),
           is_iterates_fm(formula_functor_fm(1,0), 0, n#+1, Z#+1)))"

lemma formula_N_fm_type [TC]:
 "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> formula_N_fm(x,y) \<in> formula"
by (simp add: formula_N_fm_def)

lemma sats_formula_N_fm [simp]:
   "\<lbrakk>x < length(env); y < length(env); env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, formula_N_fm(x,y), env) \<longleftrightarrow>
        is_formula_N(##A, nth(x,env), nth(y,env))"
apply (frule_tac x=y in lt_length_in_nat, assumption)
apply (frule lt_length_in_nat, assumption)
apply (simp add: formula_N_fm_def is_formula_N_def sats_is_iterates_fm)
done

lemma formula_N_iff_sats:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i < length(env); j < length(env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_formula_N(##A, x, y) \<longleftrightarrow> sats(A, formula_N_fm(i,j), env)"
by (simp)

theorem formula_N_reflection:
     "REFLECTS[\<lambda>x. is_formula_N(L, f(x), g(x)),
               \<lambda>i x. is_formula_N(##Lset(i), f(x), g(x))]"
apply (simp only: is_formula_N_def)
apply (intro FOL_reflections function_reflections
             is_iterates_reflection formula_functor_reflection)
done

subsubsection\<open>The Predicate ``Is A Formula''\<close>

(*  mem_formula(M,p) \<equiv>
      \<exists>n[M]. \<exists>formn[M].
       finite_ordinal(M,n) \<and> is_formula_N(M,n,formn) \<and> p \<in> formn *)
definition
  mem_formula_fm :: "i\<Rightarrow>i" where
    "mem_formula_fm(x) \<equiv>
       Exists(Exists(
         And(finite_ordinal_fm(1),
           And(formula_N_fm(1,0), Member(x#+2,0)))))"

lemma mem_formula_type [TC]:
     "x \<in> nat \<Longrightarrow> mem_formula_fm(x) \<in> formula"
by (simp add: mem_formula_fm_def)

lemma sats_mem_formula_fm [simp]:
   "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, mem_formula_fm(x), env) \<longleftrightarrow> mem_formula(##A, nth(x,env))"
by (simp add: mem_formula_fm_def mem_formula_def)

lemma mem_formula_iff_sats:
      "\<lbrakk>nth(i,env) = x; i \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> mem_formula(##A, x) \<longleftrightarrow> sats(A, mem_formula_fm(i), env)"
by simp

theorem mem_formula_reflection:
     "REFLECTS[\<lambda>x. mem_formula(L,f(x)),
               \<lambda>i x. mem_formula(##Lset(i),f(x))]"
apply (simp only: mem_formula_def)
apply (intro FOL_reflections finite_ordinal_reflection formula_N_reflection)
done

subsubsection\<open>The Predicate ``Is \<^term>\<open>formula\<close>''\<close>

(* is_formula(M,Z) \<equiv> \<forall>p[M]. p \<in> Z \<longleftrightarrow> mem_formula(M,p) *)
definition
  is_formula_fm :: "i\<Rightarrow>i" where
    "is_formula_fm(Z) \<equiv> Forall(Iff(Member(0,succ(Z)), mem_formula_fm(0)))"

lemma is_formula_type [TC]:
     "x \<in> nat \<Longrightarrow> is_formula_fm(x) \<in> formula"
by (simp add: is_formula_fm_def)

lemma sats_is_formula_fm [simp]:
   "\<lbrakk>x \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> sats(A, is_formula_fm(x), env) \<longleftrightarrow> is_formula(##A, nth(x,env))"
by (simp add: is_formula_fm_def is_formula_def)

lemma is_formula_iff_sats:
      "\<lbrakk>nth(i,env) = x; i \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> is_formula(##A, x) \<longleftrightarrow> sats(A, is_formula_fm(i), env)"
by simp

theorem is_formula_reflection:
     "REFLECTS[\<lambda>x. is_formula(L,f(x)),
               \<lambda>i x. is_formula(##Lset(i),f(x))]"
apply (simp only: is_formula_def)
apply (intro FOL_reflections mem_formula_reflection)
done

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

text\<open>The three arguments of \<^term>\<open>p\<close> are always 2, 1, 0.  It is buried
   within eight quantifiers!
   We call \<^term>\<open>p\<close> with arguments a, f, z by equating them with
  the corresponding quantified variables with de Bruijn indices 2, 1, 0.\<close>

(* is_transrec :: "[i\<Rightarrow>o, [i,i,i]\<Rightarrow>o, i, i] \<Rightarrow> o"
   "is_transrec(M,MH,a,z) \<equiv>
      \<exists>sa[M]. \<exists>esa[M]. \<exists>mesa[M].
       2       1         0
       upair(M,a,a,sa) \<and> is_eclose(M,sa,esa) \<and> membership(M,esa,mesa) \<and>
       is_wfrec(M,MH,mesa,a,z)" *)
definition
  is_transrec_fm :: "[i, i, i]\<Rightarrow>i" where
 "is_transrec_fm(p,a,z) \<equiv>
    Exists(Exists(Exists(
      And(upair_fm(a#+3,a#+3,2),
       And(is_eclose_fm(2,1),
        And(Memrel_fm(1,0), is_wfrec_fm(p,0,a#+3,z#+3)))))))"

lemma is_transrec_type [TC]:
     "\<lbrakk>p \<in> formula; x \<in> nat; z \<in> nat\<rbrakk>
      \<Longrightarrow> is_transrec_fm(p,x,z) \<in> formula"
by (simp add: is_transrec_fm_def)

lemma sats_is_transrec_fm:
  assumes MH_iff_sats:
      "\<And>a0 a1 a2 a3 a4 a5 a6 a7.
        \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A; a5\<in>A; a6\<in>A; a7\<in>A\<rbrakk>
        \<Longrightarrow> MH(a2, a1, a0) \<longleftrightarrow>
            sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,
                          Cons(a4,Cons(a5,Cons(a6,Cons(a7,env)))))))))"
  shows
      "\<lbrakk>x < length(env); z < length(env); env \<in> list(A)\<rbrakk>
       \<Longrightarrow> sats(A, is_transrec_fm(p,x,z), env) \<longleftrightarrow>
           is_transrec(##A, MH, nth(x,env), nth(z,env))"
apply (frule_tac x=z in lt_length_in_nat, assumption)
apply (frule_tac x=x in lt_length_in_nat, assumption)
apply (simp add: is_transrec_fm_def sats_is_wfrec_fm is_transrec_def MH_iff_sats [THEN iff_sym])
done

lemma is_transrec_iff_sats:
  assumes MH_iff_sats:
      "\<And>a0 a1 a2 a3 a4 a5 a6 a7.
        \<lbrakk>a0\<in>A; a1\<in>A; a2\<in>A; a3\<in>A; a4\<in>A; a5\<in>A; a6\<in>A; a7\<in>A\<rbrakk>
        \<Longrightarrow> MH(a2, a1, a0) \<longleftrightarrow>
            sats(A, p, Cons(a0,Cons(a1,Cons(a2,Cons(a3,
                          Cons(a4,Cons(a5,Cons(a6,Cons(a7,env)))))))))"
  shows
  "\<lbrakk>nth(i,env) = x; nth(k,env) = z;
      i < length(env); k < length(env); env \<in> list(A)\<rbrakk>
   \<Longrightarrow> is_transrec(##A, MH, x, z) \<longleftrightarrow> sats(A, is_transrec_fm(p,i,k), env)"
by (simp add: sats_is_transrec_fm [OF MH_iff_sats])

theorem is_transrec_reflection:
  assumes MH_reflection:
    "\<And>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_transrec(L, MH(L,x), f(x), h(x)),
               \<lambda>i x. is_transrec(##Lset(i), MH(##Lset(i),x), f(x), h(x))]"
apply (simp (no_asm_use) only: is_transrec_def)
apply (intro FOL_reflections function_reflections MH_reflection
             is_wfrec_reflection is_eclose_reflection)
done

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Backtracking
imports
  HOLCF
  Nats
  WorkerWrapperNew
begin

(*>*)
section{* Backtracking using lazy lists and continuations *}

text{*
\label{sec:ww-backtracking}

To illustrate the utility of worker/wrapper fusion to programming
language semantics, we consider here the first-order part of a
higher-order backtracking language by \citet{DBLP:conf/icfp/WandV04};
see also \citet{DBLP:journals/ngc/DanvyGR01}. We refer the reader to
these papers for a broader motivation for these languages.

As syntax is typically considered to be inductively generated, with
each syntactic object taken to be finite and completely defined, we
define the syntax for our language using a HOL datatype:

*}

datatype expr = const nat | add expr expr | disj expr expr | fail
(*<*)

lemma case_expr_cont[cont2cont]:
  assumes f1: "\<And>y. cont (\<lambda>x. f1 x y)"
  assumes f2: "\<And>y z. cont (\<lambda>x. f2 x y z)"
  assumes f3: "\<And>y z. cont (\<lambda>x. f3 x y z)"
  assumes f4: "cont (\<lambda>x. f4 x)"
  shows "cont (\<lambda>x. case_expr (f1 x) (f2 x) (f3 x) (f4 x) expr)"
  using assms by (cases expr) simp_all

(* Presumably obsolete in the HG version, not so in Isabelle2011. *)

fun
  expr_encode :: "expr \<Rightarrow> nat"
where
  "expr_encode (const n) = prod_encode (0, n)"
| "expr_encode (add e1 e2) = prod_encode (1, (prod_encode (expr_encode e1, expr_encode e2)))"
| "expr_encode (disj e1 e2) = prod_encode (2, (prod_encode (expr_encode e1, expr_encode e2)))"
| "expr_encode fail = prod_encode (3, 0)"

lemma expr_encode_inj:
  "expr_encode x = expr_encode y \<Longrightarrow> x = y"
  by (induct x arbitrary: y) ((case_tac y, auto dest!: inj_onD[OF inj_prod_encode, where A=UNIV])[1])+

instance expr :: countable
  by (rule countable_classI[OF expr_encode_inj])

(*>*)
text{*

The language consists of constants, an addition function, a
disjunctive choice between expressions, and failure. We give it a
direct semantics using the monad of lazy lists of natural numbers,
with the goal of deriving an an extensionally-equivalent evaluator
that uses double-barrelled continuations.

Our theory of lazy lists is entirely standard.

*}

default_sort predomain

domain 'a llist =
    lnil
  | lcons (lazy "'a") (lazy "'a llist")

text{*

By relaxing the default sort of type variables to @{text "predomain"},
our polymorphic definitions can be used at concrete types that do not
contain @{term "\<bottom>"}. These include those constructed from HOL types
using the discrete ordering type constructor @{typ "'a discr"}, and in
particular our interpretation @{typ "nat discr"} of the natural
numbers.

The following standard list functions underpin the monadic
infrastructure:

*}

fixrec lappend :: "'a llist \<rightarrow> 'a llist \<rightarrow> 'a llist" where
  "lappend\<cdot>lnil\<cdot>ys = ys"
| "lappend\<cdot>(lcons\<cdot>x\<cdot>xs)\<cdot>ys = lcons\<cdot>x\<cdot>(lappend\<cdot>xs\<cdot>ys)"

fixrec lconcat :: "'a llist llist \<rightarrow> 'a llist" where
  "lconcat\<cdot>lnil = lnil"
| "lconcat\<cdot>(lcons\<cdot>x\<cdot>xs) = lappend\<cdot>x\<cdot>(lconcat\<cdot>xs)"

fixrec lmap :: "('a \<rightarrow> 'b) \<rightarrow> 'a llist \<rightarrow> 'b llist" where
  "lmap\<cdot>f\<cdot>lnil = lnil"
| "lmap\<cdot>f\<cdot>(lcons\<cdot>x\<cdot>xs) = lcons\<cdot>(f\<cdot>x)\<cdot>(lmap\<cdot>f\<cdot>xs)"
(*<*)

lemma lappend_strict'[simp]: "lappend\<cdot>\<bottom> = (\<Lambda> a. \<bottom>)"
  by fixrec_simp

lemma lconcat_strict[simp]: "lconcat\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

lemma lmap_strict[simp]: "lmap\<cdot>f\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

(*>*)
text{*

We define the lazy list monad @{text "S"} in the traditional fashion:

*}

type_synonym S = "nat discr llist"

definition returnS :: "nat discr \<rightarrow> S" where
  "returnS = (\<Lambda> x. lcons\<cdot>x\<cdot>lnil)"

definition bindS :: "S \<rightarrow> (nat discr \<rightarrow> S) \<rightarrow> S" where
  "bindS = (\<Lambda> x g. lconcat\<cdot>(lmap\<cdot>g\<cdot>x))"

text{*

Unfortunately the lack of higher-order polymorphism in HOL prevents us
from providing the general typing one would expect a monad to have in
Haskell.

The evaluator uses the following extra constants:

*}

definition addS :: "S \<rightarrow> S \<rightarrow> S" where
  "addS \<equiv> (\<Lambda> x y. bindS\<cdot>x\<cdot>(\<Lambda> xv. bindS\<cdot>y\<cdot>(\<Lambda> yv. returnS\<cdot>(xv + yv))))"

definition disjS :: "S \<rightarrow> S \<rightarrow> S" where
  "disjS \<equiv> lappend"

definition failS :: "S" where
  "failS \<equiv> lnil"

text{*

We interpret our language using these combinators in the obvious
way. The only complication is that, even though our evaluator is
primitive recursive, we must explicitly use the fixed point operator
as the worker/wrapper technique requires us to talk about the body of
the recursive definition.

*}

definition
  evalS_body :: "(expr discr \<rightarrow> nat discr llist)
              \<rightarrow> (expr discr \<rightarrow> nat discr llist)"
where
  "evalS_body \<equiv> \<Lambda> r e. case undiscr e of
     const n \<Rightarrow> returnS\<cdot>(Discr n)
   | add e1 e2 \<Rightarrow> addS\<cdot>(r\<cdot>(Discr e1))\<cdot>(r\<cdot>(Discr e2))
   | disj e1 e2 \<Rightarrow> disjS\<cdot>(r\<cdot>(Discr e1))\<cdot>(r\<cdot>(Discr e2))
   | fail \<Rightarrow> failS"

abbreviation evalS :: "expr discr \<rightarrow> nat discr llist" where
  "evalS \<equiv> fix\<cdot>evalS_body"

text{*

We aim to transform this evaluator into one using double-barrelled
continuations; one will serve as a "success" context, taking a natural
number into "the rest of the computation", and the other outright
failure.

In general we could work with an arbitrary observation type ala
\citet{DBLP:conf/icalp/Reynolds74}, but for convenience we use the
clearly adequate concrete type @{typ "nat discr llist"}.

*}

type_synonym Obs = "nat discr llist"
type_synonym Failure = "Obs"
type_synonym Success = "nat discr \<rightarrow> Failure \<rightarrow> Obs"
type_synonym K = "Success \<rightarrow> Failure \<rightarrow> Obs"

text{*

To ease our development we adopt what
\citet[\S5]{DBLP:conf/icfp/WandV04} call a "failure computation"
instead of a failure continuation, which would have the type @{typ
"unit \<rightarrow> Obs"}.

The monad over the continuation type @{typ "K"} is as follows:

*}

definition returnK :: "nat discr \<rightarrow> K" where
  "returnK \<equiv> (\<Lambda> x. \<Lambda> s f. s\<cdot>x\<cdot>f)"

definition bindK :: "K \<rightarrow> (nat discr \<rightarrow> K) \<rightarrow> K" where
  "bindK \<equiv> \<Lambda> x g. \<Lambda> s f. x\<cdot>(\<Lambda> xv f'. g\<cdot>xv\<cdot>s\<cdot>f')\<cdot>f"

text{*

Our extra constants are defined as follows:

*}

definition addK :: "K \<rightarrow> K \<rightarrow> K" where
  "addK \<equiv> (\<Lambda> x y. bindK\<cdot>x\<cdot>(\<Lambda> xv. bindK\<cdot>y\<cdot>(\<Lambda> yv. returnK\<cdot>(xv + yv))))"

definition disjK :: "K \<rightarrow> K \<rightarrow> K" where
  "disjK \<equiv> (\<Lambda> g h. \<Lambda> s f. g\<cdot>s\<cdot>(h\<cdot>s\<cdot>f))"

definition failK :: "K" where
  "failK \<equiv> \<Lambda> s f. f"

text{*

The continuation semantics is again straightforward:

*}

definition
  evalK_body :: "(expr discr \<rightarrow> K) \<rightarrow> (expr discr \<rightarrow> K)"
where
  "evalK_body \<equiv> \<Lambda> r e. case undiscr e of
     const n \<Rightarrow> returnK\<cdot>(Discr n)
   | add e1 e2 \<Rightarrow> addK\<cdot>(r\<cdot>(Discr e1))\<cdot>(r\<cdot>(Discr e2))
   | disj e1 e2 \<Rightarrow> disjK\<cdot>(r\<cdot>(Discr e1))\<cdot>(r\<cdot>(Discr e2))
   | fail \<Rightarrow> failK"

abbreviation evalK :: "expr discr \<rightarrow> K" where
  "evalK \<equiv> fix\<cdot>evalK_body"

text{*

We now set up a worker/wrapper relation between these two semantics.

The kernel of @{term "unwrap"} is the following function that converts
a lazy list into an equivalent continuation representation.

*}

fixrec SK :: "S \<rightarrow> K" where
  "SK\<cdot>lnil = failK"
| "SK\<cdot>(lcons\<cdot>x\<cdot>xs) = (\<Lambda> s f. s\<cdot>x\<cdot>(SK\<cdot>xs\<cdot>s\<cdot>f))"

definition
  unwrap :: "(expr discr \<rightarrow> nat discr llist) \<rightarrow> (expr discr \<rightarrow> K)"
where
  "unwrap \<equiv> \<Lambda> r e. SK\<cdot>(r\<cdot>e)"
(*<*)

lemma SK_strict[simp]: "SK\<cdot>\<bottom> = \<bottom>"
  by fixrec_simp

lemma unwrap_strict[simp]: "unwrap\<cdot>\<bottom> = \<bottom>"
  unfolding unwrap_def by simp

(*>*)
text{*

Symmetrically @{term "wrap"} converts an evaluator using continuations
into one generating lazy lists by passing it the right continuations.

*}

definition KS :: "K \<rightarrow> S" where
  "KS \<equiv> (\<Lambda> k. k\<cdot>lcons\<cdot>lnil)"

definition wrap :: "(expr discr \<rightarrow> K) \<rightarrow> (expr discr \<rightarrow> nat discr llist)" where
  "wrap \<equiv> \<Lambda> r e. KS\<cdot>(r\<cdot>e)"
(*<*)

lemma KS_strict[simp]: "KS\<cdot>\<bottom> = \<bottom>"
  unfolding KS_def by simp

lemma wrap_strict[simp]: "wrap\<cdot>\<bottom> = \<bottom>"
  unfolding wrap_def by simp

(*>*)
text{*

The worker/wrapper condition follows directly from these definitions.

*}

lemma KS_SK_id:
  "KS\<cdot>(SK\<cdot>xs) = xs"
  by (induct xs) (simp_all add: KS_def failK_def)

lemma wrap_unwrap_id:
  "wrap oo unwrap = ID"
  unfolding wrap_def unwrap_def
  by (simp add: KS_SK_id cfun_eq_iff)

text{*

The worker/wrapper transformation is only non-trivial if @{term
"wrap"} and @{term "unwrap"} do not witness an isomorphism. In this
case we can show that we do not even have a Galois connection.

*}

lemma cfun_not_below:
  "f\<cdot>x \<notsqsubseteq> g\<cdot>x \<Longrightarrow> f \<notsqsubseteq> g"
  by (auto simp: cfun_below_iff)

lemma unwrap_wrap_not_under_id:
  "unwrap oo wrap \<notsqsubseteq> ID"
proof -
  let ?witness = "\<Lambda> e. (\<Lambda> s f. lnil :: K)"
  have "(unwrap oo wrap)\<cdot>?witness\<cdot>(Discr fail)\<cdot>\<bottom>\<cdot>(lcons\<cdot>0\<cdot>lnil)
       \<notsqsubseteq> ?witness\<cdot>(Discr fail)\<cdot>\<bottom>\<cdot>(lcons\<cdot>0\<cdot>lnil)"
    by (simp add: failK_def wrap_def unwrap_def KS_def)
  hence "(unwrap oo wrap)\<cdot>?witness \<notsqsubseteq> ?witness"
    by (fastforce intro!: cfun_not_below)
  thus ?thesis by (simp add: cfun_not_below)
qed

text{*

We now apply \texttt{worker\_wrapper\_id}:

*}

definition eval_work :: "expr discr \<rightarrow> K" where
  "eval_work \<equiv> fix\<cdot>(unwrap oo evalS_body oo wrap)"

definition eval_ww :: "expr discr \<rightarrow> nat discr llist" where
  "eval_ww \<equiv> wrap\<cdot>eval_work"

lemma "evalS = eval_ww"
  unfolding eval_ww_def eval_work_def
  using worker_wrapper_id[OF wrap_unwrap_id]
  by simp

text{*

We now show how the monadic operations correspond by showing that
@{term "SK"} witnesses a \emph{monad morphism}
\citep[\S6]{wadler92:_comprehending_monads}. As required by
\citet[Definition~2.1]{DBLP:journals/ngc/DanvyGR01}, the mapping needs
to hold for our specific operations in addition to the common monadic
scaffolding.

*}

lemma SK_returnS_returnK:
  "SK\<cdot>(returnS\<cdot>x) = returnK\<cdot>x"
  by (simp add: returnS_def returnK_def failK_def)

lemma SK_lappend_distrib:
 "SK\<cdot>(lappend\<cdot>xs\<cdot>ys)\<cdot>s\<cdot>f = SK\<cdot>xs\<cdot>s\<cdot>(SK\<cdot>ys\<cdot>s\<cdot>f)"
  by (induct xs) (simp_all add: failK_def)

lemma SK_bindS_bindK:
  "SK\<cdot>(bindS\<cdot>x\<cdot>g) = bindK\<cdot>(SK\<cdot>x)\<cdot>(SK oo g)"
  by (induct x)
     (simp_all add: cfun_eq_iff
                    bindS_def bindK_def failK_def
                    SK_lappend_distrib)

lemma SK_addS_distrib:
  "SK\<cdot>(addS\<cdot>x\<cdot>y) = addK\<cdot>(SK\<cdot>x)\<cdot>(SK\<cdot>y)"
  by (clarsimp simp: cfcomp1
                     addS_def addK_def failK_def
                     SK_bindS_bindK SK_returnS_returnK)

lemma SK_disjS_disjK:
 "SK\<cdot>(disjS\<cdot>xs\<cdot>ys) = disjK\<cdot>(SK\<cdot>xs)\<cdot>(SK\<cdot>ys)"
  by (simp add: cfun_eq_iff disjS_def disjK_def SK_lappend_distrib)

lemma SK_failS_failK:
  "SK\<cdot>failS = failK"
  unfolding failS_def by simp

text{*

These lemmas directly establish the precondition for our all-in-one
worker/wrapper and fusion rule:

*}

lemma evalS_body_evalK_body:
  "unwrap oo evalS_body oo wrap = evalK_body oo unwrap oo wrap"
proof(intro cfun_eqI)
  fix r e' s f
  obtain e :: "expr"
    where ee': "e' = Discr e" by (cases e')
  have "(unwrap oo evalS_body oo wrap)\<cdot>r\<cdot>(Discr e)\<cdot>s\<cdot>f
      = (evalK_body oo unwrap oo wrap)\<cdot>r\<cdot>(Discr e)\<cdot>s\<cdot>f"
    by (cases e)
       (simp_all add: evalS_body_def evalK_body_def unwrap_def
                      SK_returnS_returnK SK_addS_distrib
                      SK_disjS_disjK SK_failS_failK)
  with ee' show "(unwrap oo evalS_body oo wrap)\<cdot>r\<cdot>e'\<cdot>s\<cdot>f
                = (evalK_body oo unwrap oo wrap)\<cdot>r\<cdot>e'\<cdot>s\<cdot>f"
    by simp
qed

theorem evalS_evalK:
  "evalS = wrap\<cdot>evalK"
  using worker_wrapper_fusion_new[OF wrap_unwrap_id unwrap_strict]
        evalS_body_evalK_body
  by simp

text{*

This proof can be considered an instance of the approach of
\citet{DBLP:journals/jfp/HuttonJG10}, which uses the worker/wrapper
machinery to relate two algebras.

This result could be obtained by a structural induction over the
syntax of the language. However our goal here is to show how such a
transformation can be achieved by purely equational means; this has
the advantange that our proof can be locally extended, e.g. to the
full language of \citet{DBLP:journals/ngc/DanvyGR01} simply by proving
extra equations. In contrast the higher-order language of
\citet{DBLP:conf/icfp/WandV04} is beyond the reach of this approach.

*}
(*<*)

end
(*>*)


theory Confluence imports
  "MainRLT"
begin

section \<open>Confluence\<close>

definition semiconfluentp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "semiconfluentp r \<longleftrightarrow> r\<inverse>\<inverse> OO r\<^sup>*\<^sup>* \<le> r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>*"

definition confluentp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "confluentp r \<longleftrightarrow> r\<inverse>\<inverse>\<^sup>*\<^sup>* OO r\<^sup>*\<^sup>* \<le> r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>*"

definition strong_confluentp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "strong_confluentp r \<longleftrightarrow> r\<inverse>\<inverse> OO r \<le> r\<^sup>*\<^sup>* OO (r\<inverse>\<inverse>)\<^sup>=\<^sup>="

lemma semiconfluentpI [intro?]:
  "semiconfluentp r" if "\<And>x y z. \<lbrakk> r x y; r\<^sup>*\<^sup>* x z \<rbrakk> \<Longrightarrow> \<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u"
  using that unfolding semiconfluentp_def rtranclp_conversep by blast

lemma semiconfluentpD: "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u" if "semiconfluentp r" "r x y" "r\<^sup>*\<^sup>* x z"
  using that unfolding semiconfluentp_def rtranclp_conversep by blast

lemma confluentpI:
  "confluentp r" if "\<And>x y z. \<lbrakk> r\<^sup>*\<^sup>* x y; r\<^sup>*\<^sup>* x z \<rbrakk> \<Longrightarrow> \<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u"
  using that unfolding confluentp_def rtranclp_conversep by blast

lemma confluentpD: "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u" if "confluentp r" "r\<^sup>*\<^sup>* x y" "r\<^sup>*\<^sup>* x z"
  using that unfolding confluentp_def rtranclp_conversep by blast

lemma strong_confluentpI [intro?]:
  "strong_confluentp r" if "\<And>x y z. \<lbrakk> r x y; r x z \<rbrakk> \<Longrightarrow> \<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>=\<^sup>= z u"
  using that unfolding strong_confluentp_def by blast

lemma strong_confluentpD: "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>=\<^sup>= z u" if "strong_confluentp r" "r x y" "r x z"
  using that unfolding strong_confluentp_def by blast

lemma semiconfluentp_imp_confluentp: "confluentp r" if r: "semiconfluentp r"
proof(rule confluentpI)
  show "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u" if "r\<^sup>*\<^sup>* x y" "r\<^sup>*\<^sup>* x z" for x y z
    using that(2,1)
    by(induction arbitrary: y rule: converse_rtranclp_induct)
      (blast intro: rtranclp_trans dest:  r[THEN semiconfluentpD])+
qed

lemma confluentp_imp_semiconfluentp: "semiconfluentp r" if "confluentp r"
  using that by(auto intro!: semiconfluentpI dest: confluentpD[OF that])

lemma confluentp_eq_semiconfluentp: "confluentp r \<longleftrightarrow> semiconfluentp r"
  by(blast intro: semiconfluentp_imp_confluentp confluentp_imp_semiconfluentp)

lemma confluentp_conv_strong_confluentp_rtranclp:
  "confluentp r \<longleftrightarrow> strong_confluentp (r\<^sup>*\<^sup>*)"
  by(auto simp add: confluentp_def strong_confluentp_def rtranclp_conversep)

lemma strong_confluentp_into_semiconfluentp:
  "semiconfluentp r" if r: "strong_confluentp r"
proof
  show "\<exists>u. r\<^sup>*\<^sup>* y u \<and> r\<^sup>*\<^sup>* z u" if "r x y" "r\<^sup>*\<^sup>* x z" for x y z
    using that(2,1)
    apply(induction arbitrary: y rule: converse_rtranclp_induct)
    subgoal by blast
    subgoal for a b c
      by (drule (1) strong_confluentpD[OF r, of a c])(auto 10 0 intro: rtranclp_trans)
    done
qed

lemma strong_confluentp_imp_confluentp: "confluentp r" if "strong_confluentp r"
  unfolding confluentp_eq_semiconfluentp using that by(rule strong_confluentp_into_semiconfluentp)

lemma semiconfluentp_equivclp: "equivclp r = r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>*" if r: "semiconfluentp r"
proof(rule antisym[rotated] r_OO_conversep_into_equivclp predicate2I)+
  show "(r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>*) x y" if "equivclp r x y" for x y using that unfolding equivclp_def rtranclp_conversep
    by(induction rule: converse_rtranclp_induct)
      (blast elim!: symclpE intro: converse_rtranclp_into_rtranclp rtranclp_trans dest: semiconfluentpD[OF r])+
qed

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory Quotient_Sets

imports
  Order_Locale

begin

text {*

A quotient space is constructed by taking the collection of equivalence
classes modulo an equivalence relation @{text "BS_sim"}.

*}

definition
  equiv_class :: "['a, 'a orderT] \<rightarrow> 'a set"
where
  equiv_class_def: "equiv_class x BS_sim \<defs> {y | \<^infopa>{:x:}{:BS_sim:}{:y:}}"

notation (xsymbols output)
  equiv_class (infixl "\<up>" 90)

notation (zed)
  equiv_class ("\<^eclass>{:_:}{:_:}")

lemma equiv_class_mem: "y \<in> \<^eclass>{:x:}{:BS_sim:} \<Leftrightarrow> \<^infopa>{:x:}{:BS_sim:}{:y:}"
  by (simp add: equiv_class_def)

lemma (in equivalence) equiv_class_eq:
  assumes a1: "x \<in> X"
  shows "\<^eclass>{:x:}{:BS_sim:} = \<^eclass>{:y:}{:BS_sim:} \<Leftrightarrow> \<^infopa>{:x:}{:BS_sim:}{:y:}"
  apply (simp add: equiv_class_def)
  apply (rule iffI)
proof -
  assume b1: "{z | \<^infopa>{:x:}{:BS_sim:}{:z:}} = {z | \<^infopa>{:y:}{:BS_sim:}{:z:}}"
  from a1 have "\<^infopa>{:x:}{:BS_sim:}{:x:}"
    by (rule reflD)
  then have "{z | \<^infopa>{:y:}{:BS_sim:}{:z:}} \<noteq> \<emptyset>"
    by (auto simp add: b1 [THEN HOL.sym])
  then have "y \<in> X"
    by (auto dest: relD1)
  then have "\<^infopa>{:y:}{:BS_sim:}{:y:}"
    by (rule reflD)
  also from b1 have "\<^infopa>{:y:}{:BS_sim:}{:y:}
  \<Leftrightarrow> \<^infopa>{:x:}{:BS_sim:}{:y:}"
    by (simp add: set_eq_def)
  finally show "\<^infopa>{:x:}{:BS_sim:}{:y:}" by (this)
next
  assume b1: "\<^infopa>{:x:}{:BS_sim:}{:y:}"
  show "{z | \<^infopa>{:x:}{:BS_sim:}{:z:}} = {z | \<^infopa>{:y:}{:BS_sim:}{:z:}}"
  proof (auto)
    fix z assume c1: "\<^infopa>{:x:}{:BS_sim:}{:z:}"
    from b1 have "\<^infopa>{:y:}{:BS_sim:}{:x:}"
      by (rule symD)
    also have "\<^infopa>{:x:}{:BS_sim:}{:z:}"
      by (rule c1)
    finally show "\<^infopa>{:y:}{:BS_sim:}{:z:}"
      by (this)
  next
    fix z assume c1: "\<^infopa>{:y:}{:BS_sim:}{:z:}"
    have "\<^infopa>{:x:}{:BS_sim:}{:y:}"
      by (rule b1)
    also have "\<^infopa>{:y:}{:BS_sim:}{:z:}"
      by (rule c1)
    finally show "\<^infopa>{:x:}{:BS_sim:}{:z:}"
      by (this)
  qed
qed

lemma (in equivalence) equiv_class_eq':
  assumes a1: "y \<in> X"
  shows "\<^eclass>{:x:}{:BS_sim:} = \<^eclass>{:y:}{:BS_sim:} \<Leftrightarrow> \<^infopa>{:x:}{:BS_sim:}{:y:}"
proof -
  have "\<^eclass>{:x:}{:BS_sim:} = \<^eclass>{:y:}{:BS_sim:}
  \<Leftrightarrow> \<^eclass>{:y:}{:BS_sim:} = \<^eclass>{:x:}{:BS_sim:}"
    by (auto)
  also have "\<dots>
  \<Leftrightarrow> \<^infopa>{:y:}{:BS_sim:}{:x:}"
    by (simp add: equiv_class_eq [OF a1])
  also have "\<dots>
  \<Leftrightarrow> \<^infopa>{:x:}{:BS_sim:}{:y:}"
    by (auto dest: symD)
  finally show ?thesis by (this)
qed

lemma (in equivalence) equiv_class_eqI:
  assumes
    a1: "\<^infopa>{:x:}{:BS_sim:}{:y:}"
  shows
    "\<^eclass>{:x:}{:BS_sim:} = \<^eclass>{:y:}{:BS_sim:}"
  using relD1 [OF a1] a1
  by (simp add: equiv_class_eq)

definition
  quot_set :: "['a set, 'a orderT] \<rightarrow> 'a set set"
where
  quot_set_def: "quot_set X BS_sim \<defs> {x | x \<in> X \<bullet> \<^eclass>{:x:}{:BS_sim:}}"

notation ("" output)
  quot_set (infixl "'/'/" 90)

notation (zed)
  quot_set ("\<^qspace>{:_:}{:_:}")

lemma quot_setI: "x \<in> X \<turnstile> \<^eclass>{:x:}{:BS_sim:} \<in> \<^qspace>{:X:}{:BS_sim:}"
  by (auto simp add: quot_set_def equiv_class_def)

lemma (in equivalence) ec_range:
  "A \<in> \<^qspace>{:X:}{:BS_sim:} \<turnstile> A \<subseteq> X"
  by (auto simp add: quot_set_def equiv_class_def set_eq_def relD2)

lemma quot_set_mem: "A \<in> \<^qspace>{:X:}{:BS_sim:} \<Leftrightarrow> (\<exists> x \<bullet> x \<in> X \<and> A = \<^eclass>{:x:}{:BS_sim:})"
  by (auto simp add: quot_set_def equiv_class_def)

lemma (in equivalence) quot_set_mem_ec:
  "\<^eclass>{:x:}{:BS_sim:} \<in> \<^qspace>{:X:}{:BS_sim:} \<Leftrightarrow> x \<in> X"
  by (auto simp add: quot_set_mem reflD relD1 equiv_class_eq')

lemma (in equivalence) quot_set_mem_ec':
  assumes a1: "A \<subseteq> X"
  shows "\<^eclass>{:x:}{:BS_sim:} \<in> \<^qspace>{:A:}{:BS_sim:} \<Leftrightarrow> (\<exists> y \<bullet> y \<in> A \<and> \<^infopa>{:x:}{:BS_sim:}{:y:})"
proof -
  have "\<^eclass>{:x:}{:BS_sim:} \<in> \<^qspace>{:A:}{:BS_sim:}
  \<Leftrightarrow> (\<exists> y \<bullet> y \<in> A \<and> \<^eclass>{:x:}{:BS_sim:} = \<^eclass>{:y:}{:BS_sim:})"
    by (simp add: quot_set_mem)
  also have "\<dots>
  \<Leftrightarrow> (\<exists> y \<bullet> y \<in> A \<and> \<^infopa>{:x:}{:BS_sim:}{:y:})"
  proof (mauto(wind))
    fix y assume c1: "y \<in> A"
    with a1 have "y \<in> X" by (auto)
    then show "\<^eclass>{:x:}{:BS_sim:} = \<^eclass>{:y:}{:BS_sim:} \<Leftrightarrow> \<^infopa>{:x:}{:BS_sim:}{:y:}"
      by (simp add: equiv_class_eq')
  qed
  finally show ?thesis by (this)
qed

lemma quot_class_cases:
  assumes a1: "A \<in> \<^qspace>{:X:}{:BS_sim:}" and
    a2: "\<And> x \<bullet> \<lbrakk> x \<in> X; A = \<^eclass>{:x:}{:BS_sim:} \<rbrakk> \<turnstile> R"
  shows R
proof -
  from a1 obtain x where "x \<in> X" "A = \<^eclass>{:x:}{:BS_sim:}"
    by (auto simp add: quot_set_mem)
  then show R
    by (rule a2)
qed

lemma (in equivalence) quotient_space_eq:
  assumes
    a1: "A \<in> \<^qspace>{:X:}{:BS_sim:}" and
    a2: "B \<in> \<^qspace>{:X:}{:BS_sim:}"
  shows
    "A = B \<Leftrightarrow> (\<forall> x y | x \<in> A \<and> y \<in> B \<bullet> \<^infopa>{:x:}{:BS_sim:}{:y:})"
  apply (rule quot_class_cases [OF a1])
  apply (rule quot_class_cases [OF a2])
  apply (rule iffI)
  apply (simp add: set_eq_def)
  apply (simp add: equiv_class_mem)
  apply (mauto(inference) mintro: transD [OF symD])
  apply (rule set_eqI)
  apply (subst (asm) equiv_class_mem)+
  apply (subst equiv_class_mem)+
proof -
  fix
    x xa xb
  assume
    b1 [rule_format]: "\<forall> xb y \<bullet> x \<sim> xb \<and> xa \<sim> y \<Rightarrow> xb \<sim> y"  and
    b2: "x \<in> X" and
    b3: "xa \<in> X"
  from b1 [OF _ reflD [OF b3], THEN symD] b1 [OF reflD [OF b2]] show
    "x \<sim> xb \<Leftrightarrow> xa \<sim> xb"
    by (auto)
qed

definition
  quot_char :: "['a set, 'a orderT] \<rightarrow> 'a"
where
  quot_char_def: "quot_char A BS_sim \<defs> (\<some> x | x \<in> A \<and> A = \<^eclass>{:x:}{:BS_sim:})"

notation (xsymbols output)
  quot_char (infixl "\<down>" 90)

notation (zed)
  quot_char ("\<^qchar>{:_:}{:_:}")

lemma (in equivalence) quot_char_class:
  assumes a1: "A \<in> \<^qspace>{:X:}{:BS_sim:}"
  shows "\<^eclass>{:\<^qchar>{:A:}{:BS_sim:}:}{:BS_sim:} = A"
proof -
  let "?P x" = "x \<in> A \<and> A = \<^eclass>{:x:}{:BS_sim:}"
  from a1 reflD have b1: "\<exists> x \<bullet> ?P x"
    apply (simp add: quot_set_mem total_rel equiv_class_def)
    apply (blast)
    done
  from b1 [THEN someI_ex [of ?P]]
  have "?P (\<^qchar>{:A:}{:BS_sim:})"
    by (simp add: quot_char_def)
  then have "A = \<^eclass>{:\<^qchar>{:A:}{:BS_sim:}:}{:BS_sim:}"
    by (msafe(inference))
  then show ?thesis
    by (rule HOL.sym)
qed

lemma (in equivalence) quot_class_char:
  assumes
    a1: "x \<in> X"
  shows
    "\<^infopa>{:\<^qchar>{:\<^eclass>{:x:}{:BS_sim:}:}{:BS_sim:}:}{:BS_sim:}{:x:}"
proof (rule symD)
  let
    ?P = "(\<olambda> y \<bullet> y \<in> \<^eclass>{:x:}{:BS_sim:} \<and> \<^eclass>{:x:}{:BS_sim:} = \<^eclass>{:y:}{:BS_sim:})"
  have
    b1: "?P x"
    by (simp add: equiv_class_mem reflD [OF a1])
  from someI [of ?P, OF b1] show
    "\<^infopa>{:x:}{:BS_sim:}{:\<^qchar>{:\<^eclass>{:x:}{:BS_sim:}:}{:BS_sim:}:}"
    by (simp add: quot_char_def equiv_class_eq [OF a1])
qed

lemma (in equivalence) quot_char_mem:
  assumes a1: "A \<in> \<^qspace>{:X:}{:BS_sim:}"
  shows "\<^qchar>{:A:}{:BS_sim:} \<in> A"
proof -
  let "?P x" = "x \<in> A \<and> A = \<^eclass>{:x:}{:BS_sim:}"
  from a1 reflD have b1: "\<exists> x \<bullet> ?P x"
    apply (simp add: quot_set_mem total_rel equiv_class_def)
    apply (blast)
    done
  from b1 someI_ex [of ?P]
  have "?P (\<^qchar>{:A:}{:BS_sim:})"
    by (simp add: quot_char_def)
  then show ?thesis
    by (msafe(inference))
qed

lemma (in equivalence) quot_class_mem:
  "A \<in> \<^qspace>{:X:}{:BS_sim:} \<turnstile> x \<in> A \<Leftrightarrow> x \<in> X \<and> A = \<^eclass>{:x:}{:BS_sim:}"
  apply (simp add: quot_set_mem equiv_class_mem set_eq_def)
  apply (elim exE conjE)
  apply (simp)
proof -
  fix y
  show "\<^infopa>{:y:}{:BS_sim:}{:x:} \<Leftrightarrow> x \<in> X \<and> (\<forall> z \<bullet> \<^infopa>{:y:}{:BS_sim:}{:z:} \<Leftrightarrow> \<^infopa>{:x:}{:BS_sim:}{:z:})"
  proof (msafe(inference))
    assume c1: "\<^infopa>{:y:}{:BS_sim:}{:x:}"
    from c1 show "x \<in> X" by (simp add: relD2)
    {fix z assume c2: "\<^infopa>{:y:}{:BS_sim:}{:z:}"
    from c1 have "\<^infopa>{:x:}{:BS_sim:}{:y:}"
      by (rule symD)
    also have "\<^infopa>{:y:}{:BS_sim:}{:z:}"
      by (rule c2)
    finally show "\<^infopa>{:x:}{:BS_sim:}{:z:}"
      by (this)}
    {fix z assume c2: "\<^infopa>{:x:}{:BS_sim:}{:z:}"
    have "\<^infopa>{:y:}{:BS_sim:}{:x:}"
      by (rule c1)
    also have "\<^infopa>{:x:}{:BS_sim:}{:z:}"
      by (rule c2)
    finally show "\<^infopa>{:y:}{:BS_sim:}{:z:}"
      by (this)}
  next
    assume "x \<in> X" "\<forall> z \<bullet> \<^infopa>{:y:}{:BS_sim:}{:z:} \<Leftrightarrow> \<^infopa>{:x:}{:BS_sim:}{:z:}"
    then show "\<^infopa>{:y:}{:BS_sim:}{:x:}"
      by (simp add: reflD)
  qed
qed

lemma (in equivalence) quot_set_subset:
   "CL_A \<subseteq> \<^qspace>{:X:}{:BS_sim:} \<Leftrightarrow> (\<exists> A \<bullet> CL_A = \<^qspace>{:A:}{:BS_sim:} \<and> A \<subseteq> X)"
   (is "?LHS \<Leftrightarrow> ?RHS")
proof (rule iffI)
  assume "?RHS"
  then show "?LHS"
    by (auto simp add: quot_set_def equiv_class_def subset_def)+
next
  let ?A = "{A | A \<in> CL_A \<bullet> \<^qchar>{:A:}{:BS_sim:}}"
  assume b1: "?LHS"
  have "CL_A = \<^qspace>{:?A:}{:BS_sim:}"
  proof (rule subset_antisym)
    from b1 show "\<^qspace>{:?A:}{:BS_sim:} \<subseteq> CL_A"
      by (auto simp add: quot_set_def quot_char_class subset_def)
    show "CL_A \<subseteq> \<^qspace>{:?A:}{:BS_sim:}"
      apply (auto simp add: quot_set_def quot_char_class subset_def)
      apply (subst ex_simps')
      apply (simp del: ex_simps)
    proof -
      fix A assume d1: "A \<in> CL_A"
      from b1 d1 have "A = \<^eclass>{:\<^qchar>{:A:}{:BS_sim:}:}{:BS_sim:}"
        by (auto simp add: quot_char_class)
      with d1 show "\<exists> A' \<bullet> A = \<^eclass>{:\<^qchar>{:A':}{:BS_sim:}:}{:BS_sim:} \<and> A' \<in> CL_A"
        by (blast)
    qed
  qed
  moreover have "?A \<subseteq> X"
    apply (auto)
    using quot_char_mem ec_range
    apply (auto dest!: b1 [THEN subsetD])
    done
  ultimately show "?RHS"
    by (auto)
qed

lemma (in equivalence) quot_class_set_cases:
  assumes a1: "CL_A \<subseteq> \<^qspace>{:X:}{:BS_sim:}" and
    a2: "\<And> A \<bullet> \<lbrakk> A \<subseteq> X; CL_A = \<^qspace>{:A:}{:BS_sim:} \<rbrakk> \<turnstile> R"
  shows "R"
proof -
  from a1 obtain A where "A \<subseteq> X" "CL_A = \<^qspace>{:A:}{:BS_sim:}"
    by (auto simp add: quot_set_subset)
  then show R by (rule a2)
qed

end