(*  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\<Rightarrow>o, [i,i,i]\<Rightarrow>o, i, i] \<Rightarrow> o"
   "is_formula_rec(M,MH,p,z)  \<equiv>
      \<exists>dp[M]. \<exists>i[M]. \<exists>f[M]. finite_ordinal(M,dp) \<and> is_depth(M,p,dp) \<and>
       2       1      0
             successor(M,dp,i) \<and> fun_apply(M,f,p,z) \<and> is_transrec(M,MH,i,f)"
*)

definition
  formula_rec_fm :: "[i, i, i]\<Rightarrow>i" where
 "formula_rec_fm(mh,p,z) \<equiv>
    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]:
     "\<lbrakk>p \<in> formula; x \<in> nat; z \<in> nat\<rbrakk>
      \<Longrightarrow> formula_rec_fm(p,x,z) \<in> formula"
by (simp add: formula_rec_fm_def)

lemma sats_formula_rec_fm:
  assumes MH_iff_sats:
      "\<And>a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
        \<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; a8\<in>A; a9\<in>A; a10\<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,
                                  Cons(a8,Cons(a9,Cons(a10,env))))))))))))"
  shows
      "\<lbrakk>x \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> 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:
      "\<And>a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
        \<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; a8\<in>A; a9\<in>A; a10\<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,
                                  Cons(a8,Cons(a9,Cons(a10,env))))))))))))"
  shows
  "\<lbrakk>nth(i,env) = x; nth(k,env) = z;
      i \<in> nat; k \<in> nat; env \<in> list(A)\<rbrakk>
   \<Longrightarrow> 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:
    "\<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_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) \<equiv> is_formula_rec (M, satisfies_MH(M,A), p, z) *)
definition
  satisfies_fm :: "[i,i,i]\<Rightarrow>i" where
    "satisfies_fm(x) \<equiv> formula_rec_fm (satisfies_MH_fm(x#+5#+6, 2, 1, 0))"

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

lemma sats_satisfies_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> 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:
      "\<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_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 = \<langle>env,p\<rangle> \<and> 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\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
   "is_DPow_sats(M,A,env,p,x) \<equiv>
      \<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:
    "\<lbrakk>M(A); env \<in> list(A); p \<in> formula; M(x)\<rbrakk>
    \<Longrightarrow> 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:
    "\<lbrakk>M(A); env \<in> list(A); p \<in> formula\<rbrakk>
    \<Longrightarrow> 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) \<equiv>
      \<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]\<Rightarrow>i" where
  "DPow_sats_fm(A,env,p,x) \<equiv>
   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]:
     "\<lbrakk>A \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat\<rbrakk>
      \<Longrightarrow> DPow_sats_fm(A,x,y,z) \<in> formula"
by (simp add: DPow_sats_fm_def)

lemma sats_DPow_sats_fm [simp]:
   "\<lbrakk>u \<in> nat; x \<in> nat; y \<in> nat; z \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> 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:
  "\<lbrakk>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)\<rbrakk>
   \<Longrightarrow> 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))]"
  unfolding 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:
   "\<lbrakk>M(A); env \<in> list(A); p \<in> formula\<rbrakk>
    \<Longrightarrow> separation(M, \<lambda>x. is_DPow_sats(M,A,env,p,x))"
 and rep:
    "M(A)
    \<Longrightarrow> strong_replacement (M,
         \<lambda>ep z. \<exists>env[M]. \<exists>p[M]. mem_formula(M,p) \<and> mem_list(M,A,env) \<and>
                  pair(M,env,p,ep) \<and>
                  is_Collect(M, A, \<lambda>x. is_DPow_sats(M,A,env,p,x), z))"

lemma (in M_DPow) sep':
   "\<lbrakk>M(A); env \<in> list(A); p \<in> formula\<rbrakk>
    \<Longrightarrow> 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)
    \<Longrightarrow> strong_replacement (M,
         \<lambda>ep z. \<exists>env\<in>list(A). \<exists>p\<in>formula.
                  ep = \<langle>env,p\<rangle> \<and> 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) \<Longrightarrow> 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\<Rightarrow>o,i,i] \<Rightarrow> o" where
    "is_DPow'(M,A,Z) \<equiv>
       \<forall>X[M]. X \<in> Z \<longleftrightarrow>
         subset(M,X,A) \<and>
           (\<exists>env[M]. \<exists>p[M]. mem_formula(M,p) \<and> mem_list(M,A,env) \<and>
                    is_Collect(M, A, is_DPow_sats(M,A,env,p), X))"

lemma (in M_DPow) DPow'_abs:
    "\<lbrakk>M(A); M(Z)\<rbrakk> \<Longrightarrow> 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:
    "\<lbrakk>L(A); env \<in> list(A); p \<in> formula\<rbrakk>
     \<Longrightarrow> 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 \<and>
             (\<exists>env[L]. \<exists>p[L].
               mem_formula(L,p) \<and> mem_list(L,A,env) \<and> pair(L,env,p,u) \<and>
               is_Collect (L, A, is_DPow_sats(L,A,env,p), x)),
    \<lambda>i x. \<exists>u \<in> Lset(i). u \<in> B \<and>
             (\<exists>env \<in> Lset(i). \<exists>p \<in> Lset(i).
               mem_formula(##Lset(i),p) \<and> mem_list(##Lset(i),A,env) \<and>
               pair(##Lset(i),env,p,u) \<and>
               is_Collect (##Lset(i), A, is_DPow_sats(##Lset(i),A,env,p), x))]"
  unfolding is_Collect_def
apply (intro FOL_reflections function_reflections mem_formula_reflection
          mem_list_reflection DPow_sats_reflection)
done

lemma DPow_replacement:
    "L(A)
    \<Longrightarrow> strong_replacement (L,
         \<lambda>ep z. \<exists>env[L]. \<exists>p[L]. mem_formula(L,p) \<and> mem_list(L,A,env) \<and>
                  pair(L,env,p,ep) \<and>
                  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)
  unfolding 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\<Rightarrow>o,i,i\<Rightarrow>o,i] \<Rightarrow> o"
    "is_Collect(M,A,P,z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> x \<in> A \<and> P(x)" *)

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

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

lemma sats_Collect_fm:
  assumes is_P_iff_sats:
      "\<And>a. a \<in> A \<Longrightarrow> is_P(a) \<longleftrightarrow> sats(A, p, Cons(a, env))"
  shows
      "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> 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:
      "\<And>a. a \<in> A \<Longrightarrow> is_P(a) \<longleftrightarrow> sats(A, p, Cons(a, env))"
  shows
  "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
   \<Longrightarrow> 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:
    "\<And>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\<Rightarrow>o,i,[i,i]\<Rightarrow>o,i] \<Rightarrow> o"
    "is_Replace(M,A,P,z) \<equiv> \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A \<and> P(x,u))" *)

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

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

lemma sats_Replace_fm:
  assumes is_P_iff_sats:
      "\<And>a b. \<lbrakk>a \<in> A; b \<in> A\<rbrakk>
              \<Longrightarrow> is_P(a,b) \<longleftrightarrow> sats(A, p, Cons(a,Cons(b,env)))"
  shows
      "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> 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:
      "\<And>a b. \<lbrakk>a \<in> A; b \<in> A\<rbrakk>
              \<Longrightarrow> is_P(a,b) \<longleftrightarrow> sats(A, p, Cons(a,Cons(b,env)))"
  shows
  "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
      i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
   \<Longrightarrow> 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:
    "\<And>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) \<equiv>
       \<forall>X[M]. X \<in> Z \<longleftrightarrow>
         subset(M,X,A) \<and>
           (\<exists>env[M]. \<exists>p[M]. mem_formula(M,p) \<and> mem_list(M,A,env) \<and>
                    is_Collect(M, A, is_DPow_sats(M,A,env,p), X))" *)

definition
  DPow'_fm :: "[i,i]\<Rightarrow>i" where
    "DPow'_fm(A,Z) \<equiv>
      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]:
     "\<lbrakk>x \<in> nat; y \<in> nat\<rbrakk> \<Longrightarrow> DPow'_fm(x,y) \<in> formula"
by (simp add: DPow'_fm_def)

lemma sats_DPow'_fm [simp]:
   "\<lbrakk>x \<in> nat; y \<in> nat; env \<in> list(A)\<rbrakk>
    \<Longrightarrow> 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:
      "\<lbrakk>nth(i,env) = x; nth(j,env) = y;
          i \<in> nat; j \<in> nat; env \<in> list(A)\<rbrakk>
       \<Longrightarrow> 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\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
    "transrec_body(M,g,x) \<equiv>
      \<lambda>y z. \<exists>gy[M]. y \<in> x \<and> fun_apply(M,g,y,gy) \<and> is_DPow'(M,gy,z)"

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

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

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

lemma (in M_Lset) DPow_apply_closed:
   "\<lbrakk>M(f); M(x); y\<in>x\<rbrakk> \<Longrightarrow> M(DPow'(f`y))"
by (blast intro: DPow'_closed dest: transM)

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

lemma (in M_Lset) RepFun_DPow_abs:
     "\<lbrakk>M(x); M(f); M(r)\<rbrakk>
      \<Longrightarrow> 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) \<Longrightarrow> 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\<Rightarrow>o, i, i] \<Rightarrow> 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) \<equiv> is_transrec(M, \<lambda>x f u. u = (\<Union>y\<in>x. DPow'(f`y)), a, z)"

lemma (in M_Lset) Lset_abs:
  "\<lbrakk>Ord(i);  M(i);  M(z)\<rbrakk>
   \<Longrightarrow> 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:
  "\<lbrakk>Ord(i);  M(i)\<rbrakk> \<Longrightarrow> 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 \<and> (\<exists>gy[L].
                          v \<in> x \<and> fun_apply(L,g,v,gy) \<and> is_DPow'(L,gy,u)),
   \<lambda>i u. \<exists>v \<in> Lset(i). v \<in> B \<and> (\<exists>gy \<in> Lset(i).
            v \<in> x \<and> fun_apply(##Lset(i),g,v,gy) \<and> is_DPow'(##Lset(i),gy,u))]"
by (intro FOL_reflections function_reflections DPow'_reflection)

lemma strong_rep:
   "\<lbrakk>L(x); L(g)\<rbrakk> \<Longrightarrow> strong_replacement(L, \<lambda>y z. transrec_body(L,g,x,y,z))"
  unfolding 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 \<and>
              (\<exists>y[L]. pair(L,v,y,x) \<and>
             is_wfrec (L, \<lambda>x f u. \<exists>r[L].
                is_Replace (L, x, \<lambda>y z.
                     \<exists>gy[L]. y \<in> x \<and> fun_apply(L,f,y,gy) \<and>
                      is_DPow'(L,gy,z), r) \<and> big_union(L,r,u), mr, v, y)),
    \<lambda>i x. \<exists>v \<in> Lset(i). v \<in> B \<and>
              (\<exists>y \<in> Lset(i). pair(##Lset(i),v,y,x) \<and>
             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 \<and> fun_apply(##Lset(i),f,y,gy) \<and>
                      is_DPow'(##Lset(i),gy,z), r) \<and>
                      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:
    "\<lbrakk>L(j)\<rbrakk>
    \<Longrightarrow> transrec_replacement(L, \<lambda>x f u.
              \<exists>r[L]. is_Replace(L, x, transrec_body(L,f,x), r) \<and>
                     big_union(L, r, u), j)"
apply (rule L.transrec_replacementI, assumption)
  unfolding 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)"
  by (blast intro: M_Lset_axioms.intro strong_rep transrec_rep)

theorem M_Lset_L: "M_Lset(L)"
  by (blast intro: M_Lset.intro M_DPow_L M_Lset_axioms_L)

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\<Rightarrow>o,i] \<Rightarrow> o" where
    "constructible(M,x) \<equiv>
       \<exists>i[M]. \<exists>Li[M]. ordinal(M,i) \<and> is_Lset(M,i,Li) \<and> x \<in> Li"

theorem V_equals_L_in_L:
  "L(x) \<longleftrightarrow> constructible(L,x)"
proof -
  have "L(x) \<longleftrightarrow> (\<exists>i[L]. Ord(i) \<and> x \<in> Lset(i))"
    by (auto simp add: L_def intro: Ord_in_L)
  moreover have "\<dots> \<longleftrightarrow> constructible(L,x)"
    by (simp add: constructible_def Lset_abs Lset_closed)
  ultimately show ?thesis by blast
qed

end


header {* Coercion Operator *}

theory Coerce
imports HOLCF
begin

subsection {* Coerce *}

text {* The @{text domain} type class, which is the default type class
in HOLCF, fixes two overloaded functions: @{text "emb::'a \<rightarrow> udom"} and
@{text "prj::udom \<rightarrow> 'a"}. By composing the @{text prj} and @{text emb}
functions together, we can coerce values between any two types in
class @{text domain}. \medskip *}

definition coerce :: "'a \<rightarrow> 'b"
  where "coerce \<equiv> prj oo emb"

text {* When working with proofs involving @{text emb}, @{text prj},
and @{text coerce}, it is often difficult to tell at which types those
constants are being used. To alleviate this problem, we define special
input and output syntax to indicate the types. \medskip *}

syntax
  "_emb" :: "type \<Rightarrow> logic" ("(1EMB/(1'(_')))")
  "_prj" :: "type \<Rightarrow> logic" ("(1PRJ/(1'(_')))")
  "_coerce" :: "type \<Rightarrow> type \<Rightarrow> logic" ("(1COERCE/(1'(_,/ _')))")

translations
  "EMB('a)" \<rightharpoonup> "CONST emb :: 'a \<rightarrow> udom"
  "PRJ('a)" \<rightharpoonup> "CONST prj :: udom \<rightarrow> 'a"
  "COERCE('a,'b)" \<rightharpoonup> "CONST coerce :: 'a \<rightarrow> 'b"

typed_print_translation {*
let
  fun emb_tr' (ctxt : Proof.context) (Type(_, [T, _])) [] =
    Syntax.const @{syntax_const "_emb"} $ Syntax_Phases.term_of_typ ctxt T
  fun prj_tr' ctxt (Type(_, [_, T])) [] =
    Syntax.const @{syntax_const "_prj"} $ Syntax_Phases.term_of_typ ctxt T
  fun coerce_tr' ctxt (Type(_, [T, U])) [] =
    Syntax.const @{syntax_const "_coerce"} $
      Syntax_Phases.term_of_typ ctxt T $ Syntax_Phases.term_of_typ ctxt U
in
  [(@{const_syntax emb}, emb_tr'),
   (@{const_syntax prj}, prj_tr'),
   (@{const_syntax coerce}, coerce_tr')]
end
*}

lemma beta_coerce: "coerce\<cdot>x = prj\<cdot>(emb\<cdot>x)"
by (simp add: coerce_def)

lemma prj_emb: "prj\<cdot>(emb\<cdot>x) = coerce\<cdot>x"
by (simp add: coerce_def)

lemma coerce_strict [simp]: "coerce\<cdot>\<bottom> = \<bottom>"
by (simp add: coerce_def)

text {* Certain type instances of @{text coerce} may reduce to the
identity function, @{text emb}, or @{text prj}. \medskip *}

lemma coerce_eq_ID [simp]: "COERCE('a, 'a) = ID"
by (rule cfun_eqI, simp add: beta_coerce)

lemma coerce_eq_emb [simp]: "COERCE('a, udom) = EMB('a)"
by (rule cfun_eqI, simp add: beta_coerce)

lemma coerce_eq_prj [simp]: "COERCE(udom, 'a) = PRJ('a)"
by (rule cfun_eqI, simp add: beta_coerce)

text "Cancellation rules"

lemma emb_coerce:
  "DEFL('a) \<sqsubseteq> DEFL('b)
   \<Longrightarrow> EMB('b)\<cdot>(COERCE('a,'b)\<cdot>x) = EMB('a)\<cdot>x"
by (simp add: beta_coerce emb_prj_emb)

lemma coerce_prj:
  "DEFL('a) \<sqsubseteq> DEFL('b)
   \<Longrightarrow> COERCE('b,'a)\<cdot>(PRJ('b)\<cdot>x) = PRJ('a)\<cdot>x"
by (simp add: beta_coerce prj_emb_prj)

lemma coerce_idem [simp]:
  "DEFL('a) \<sqsubseteq> DEFL('b)
   \<Longrightarrow> COERCE('b,'c)\<cdot>(COERCE('a,'b)\<cdot>x) = COERCE('a,'c)\<cdot>x"
by (simp add: beta_coerce emb_prj_emb)

subsection {* More lemmas about emb and prj *}

lemma prj_cast_DEFL [simp]: "PRJ('a)\<cdot>(cast\<cdot>DEFL('a)\<cdot>x) = PRJ('a)\<cdot>x"
by (simp add: cast_DEFL)

lemma cast_DEFL_emb [simp]: "cast\<cdot>DEFL('a)\<cdot>(EMB('a)\<cdot>x) = EMB('a)\<cdot>x"
by (simp add: cast_DEFL)

text {* @{term "DEFL(udom)"} *}

lemma below_DEFL_udom [simp]: "A \<sqsubseteq> DEFL(udom)"
apply (rule cast_below_imp_below)
apply (rule cast.belowI)
apply (simp add: cast_DEFL)
done

subsection {* Coercing various datatypes *}

text {* Coercing from the strict product type @{typ "'a \<otimes> 'b"} to
another strict product type @{typ "'c \<otimes> 'd"} is equivalent to mapping
the @{text coerce} function separately over each component using
@{text "sprod_map :: ('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'd) \<rightarrow> 'a \<otimes> 'b \<rightarrow> 'c \<otimes> 'd"}. Each
of the several type constructors defined in HOLCF satisfies a similar
property, with respect to its own map combinator. \medskip *}

lemma coerce_u: "coerce = u_map\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_u_def prj_u_def liftemb_eq liftprj_eq)
apply (subst ep_pair.e_inverse [OF ep_pair_u])
apply (simp add: u_map_map cfcomp1)
done

lemma coerce_sfun: "coerce = sfun_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_sfun_def prj_sfun_def)
apply (subst ep_pair.e_inverse [OF ep_pair_sfun])
apply (simp add: sfun_map_map cfcomp1)
done

lemma coerce_cfun': "coerce = cfun_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: prj_emb [symmetric])
apply (simp add: emb_cfun_def prj_cfun_def)
apply (simp add: prj_emb coerce_sfun coerce_u)
apply (simp add: encode_cfun_map [symmetric])
done

lemma coerce_ssum: "coerce = ssum_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_ssum_def prj_ssum_def)
apply (subst ep_pair.e_inverse [OF ep_pair_ssum])
apply (simp add: ssum_map_map cfcomp1)
done

lemma coerce_sprod: "coerce = sprod_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_sprod_def prj_sprod_def)
apply (subst ep_pair.e_inverse [OF ep_pair_sprod])
apply (simp add: sprod_map_map cfcomp1)
done

lemma coerce_prod: "coerce = prod_map\<cdot>coerce\<cdot>coerce"
apply (rule cfun_eqI, simp add: coerce_def)
apply (simp add: emb_prod_def prj_prod_def)
apply (subst ep_pair.e_inverse [OF ep_pair_prod])
apply (simp add: prod_map_map cfcomp1)
done

subsection {* Simplifying coercions *}

text {* When simplifying applications of the @{text coerce} function,
rewrite rules are always oriented to replace @{text coerce} at complex
types with other applications of @{text coerce} at simpler types. *}

text {* The safest rewrite rules for @{text coerce} are given the
@{text "[simp]"} attribute. For other rules that do not belong in the
global simpset, we use dynamic theorem list called @{text coerce_simp},
which will collect additional rules for simplifying coercions. \medskip *}

named_theorems coerce_simp "rule for simplifying coercions"

text {* The @{text coerce} function commutes with data constructors
for various HOLCF datatypes. \medskip *}

lemma coerce_up [simp]: "coerce\<cdot>(up\<cdot>x) = up\<cdot>(coerce\<cdot>x)"
by (simp add: coerce_u)

lemma coerce_sinl [simp]: "coerce\<cdot>(sinl\<cdot>x) = sinl\<cdot>(coerce\<cdot>x)"
by (simp add: coerce_ssum ssum_map_sinl')

lemma coerce_sinr [simp]: "coerce\<cdot>(sinr\<cdot>x) = sinr\<cdot>(coerce\<cdot>x)"
by (simp add: coerce_ssum ssum_map_sinr')

lemma coerce_spair [simp]: "coerce\<cdot>(:x, y:) = (:coerce\<cdot>x, coerce\<cdot>y:)"
by (simp add: coerce_sprod sprod_map_spair')

lemma coerce_Pair [simp]: "coerce\<cdot>(x, y) = (coerce\<cdot>x, coerce\<cdot>y)"
by (simp add: coerce_prod)

lemma beta_coerce_cfun [simp]: "coerce\<cdot>f\<cdot>x = coerce\<cdot>(f\<cdot>(coerce\<cdot>x))"
by (simp add: coerce_cfun')

lemma coerce_cfun: "coerce\<cdot>f = coerce oo f oo coerce"
by (simp add: cfun_eqI)

lemma coerce_cfun_app [coerce_simp]:
  "coerce\<cdot>f = (\<Lambda> x. coerce\<cdot>(f\<cdot>(coerce\<cdot>x)))"
by (simp add: cfun_eqI)

end


(*  Title:      HOL/Library/Linear_Temporal_Logic_on_Streams.thy
    Author:     Andrei Popescu, TU Muenchen
    Author:     Dmitriy Traytel, TU Muenchen
*)

section \<open>Linear Temporal Logic on Streams\<close>

theory Linear_Temporal_Logic_on_Streams
  imports Stream Sublist Extended_Nat Infinite_Set
begin

section\<open>Preliminaries\<close>

lemma shift_prefix:
assumes "xl @- xs = yl @- ys" and "length xl \<le> length yl"
shows "prefix xl yl"
using assms proof(induct xl arbitrary: yl xs ys)
  case (Cons x xl yl xs ys)
  thus ?case by (cases yl) auto
qed auto

lemma shift_prefix_cases:
assumes "xl @- xs = yl @- ys"
shows "prefix xl yl \<or> prefix yl xl"
using shift_prefix[OF assms]
by (cases "length xl \<le> length yl") (metis, metis assms nat_le_linear shift_prefix)

section\<open>Linear temporal logic\<close>

(* Propositional connectives: *)
abbreviation (input) IMPL (infix "impl" 60)
where "\<phi> impl \<psi> \<equiv> \<lambda> xs. \<phi> xs \<longrightarrow> \<psi> xs"

abbreviation (input) OR (infix "or" 60)
where "\<phi> or \<psi> \<equiv> \<lambda> xs. \<phi> xs \<or> \<psi> xs"

abbreviation (input) AND (infix "aand" 60)
where "\<phi> aand \<psi> \<equiv> \<lambda> xs. \<phi> xs \<and> \<psi> xs"

abbreviation (input) "not \<phi> \<equiv> \<lambda> xs. \<not> \<phi> xs"

abbreviation (input) "true \<equiv> \<lambda> xs. True"

abbreviation (input) "false \<equiv> \<lambda> xs. False"

lemma impl_not_or: "\<phi> impl \<psi> = (not \<phi>) or \<psi>"
by blast

lemma not_or: "not (\<phi> or \<psi>) = (not \<phi>) aand (not \<psi>)"
by blast

lemma not_aand: "not (\<phi> aand \<psi>) = (not \<phi>) or (not \<psi>)"
by blast

lemma non_not[simp]: "not (not \<phi>) = \<phi>" by simp

(* Temporal (LTL) connectives: *)
fun holds where "holds P xs \<longleftrightarrow> P (shd xs)"
fun nxt where "nxt \<phi> xs = \<phi> (stl xs)"

definition "HLD s = holds (\<lambda>x. x \<in> s)"

abbreviation HLD_nxt (infixr "\<cdot>" 65) where
  "s \<cdot> P \<equiv> HLD s aand nxt P"

context
  notes [[inductive_internals]]
begin

inductive ev for \<phi> where
base: "\<phi> xs \<Longrightarrow> ev \<phi> xs"
|
step: "ev \<phi> (stl xs) \<Longrightarrow> ev \<phi> xs"

coinductive alw for \<phi> where
alw: "\<lbrakk>\<phi> xs; alw \<phi> (stl xs)\<rbrakk> \<Longrightarrow> alw \<phi> xs"

(* weak until: *)
coinductive UNTIL (infix "until" 60) for \<phi> \<psi> where
base: "\<psi> xs \<Longrightarrow> (\<phi> until \<psi>) xs"
|
step: "\<lbrakk>\<phi> xs; (\<phi> until \<psi>) (stl xs)\<rbrakk> \<Longrightarrow> (\<phi> until \<psi>) xs"

end

lemma holds_mono:
assumes holds: "holds P xs" and 0: "\<And> x. P x \<Longrightarrow> Q x"
shows "holds Q xs"
using assms by auto

lemma holds_aand:
"(holds P aand holds Q) steps \<longleftrightarrow> holds (\<lambda> step. P step \<and> Q step) steps" by auto

lemma HLD_iff: "HLD s \<omega> \<longleftrightarrow> shd \<omega> \<in> s"
  by (simp add: HLD_def)

lemma HLD_Stream[simp]: "HLD X (x ## \<omega>) \<longleftrightarrow> x \<in> X"
  by (simp add: HLD_iff)

lemma nxt_mono:
assumes nxt: "nxt \<phi> xs" and 0: "\<And> xs. \<phi> xs \<Longrightarrow> \<psi> xs"
shows "nxt \<psi> xs"
using assms by auto

declare ev.intros[intro]
declare alw.cases[elim]

lemma ev_induct_strong[consumes 1, case_names base step]:
  "ev \<phi> x \<Longrightarrow> (\<And>xs. \<phi> xs \<Longrightarrow> P xs) \<Longrightarrow> (\<And>xs. ev \<phi> (stl xs) \<Longrightarrow> \<not> \<phi> xs \<Longrightarrow> P (stl xs) \<Longrightarrow> P xs) \<Longrightarrow> P x"
  by (induct rule: ev.induct) auto

lemma alw_coinduct[consumes 1, case_names alw stl]:
  "X x \<Longrightarrow> (\<And>x. X x \<Longrightarrow> \<phi> x) \<Longrightarrow> (\<And>x. X x \<Longrightarrow> \<not> alw \<phi> (stl x) \<Longrightarrow> X (stl x)) \<Longrightarrow> alw \<phi> x"
  using alw.coinduct[of X x \<phi>] by auto

lemma ev_mono:
assumes ev: "ev \<phi> xs" and 0: "\<And> xs. \<phi> xs \<Longrightarrow> \<psi> xs"
shows "ev \<psi> xs"
using ev by induct (auto simp: 0)

lemma alw_mono:
assumes alw: "alw \<phi> xs" and 0: "\<And> xs. \<phi> xs \<Longrightarrow> \<psi> xs"
shows "alw \<psi> xs"
using alw by coinduct (auto simp: 0)

lemma until_monoL:
assumes until: "(\<phi>1 until \<psi>) xs" and 0: "\<And> xs. \<phi>1 xs \<Longrightarrow> \<phi>2 xs"
shows "(\<phi>2 until \<psi>) xs"
using until by coinduct (auto elim: UNTIL.cases simp: 0)

lemma until_monoR:
assumes until: "(\<phi> until \<psi>1) xs" and 0: "\<And> xs. \<psi>1 xs \<Longrightarrow> \<psi>2 xs"
shows "(\<phi> until \<psi>2) xs"
using until by coinduct (auto elim: UNTIL.cases simp: 0)

lemma until_mono:
assumes until: "(\<phi>1 until \<psi>1) xs" and
0: "\<And> xs. \<phi>1 xs \<Longrightarrow> \<phi>2 xs" "\<And> xs. \<psi>1 xs \<Longrightarrow> \<psi>2 xs"
shows "(\<phi>2 until \<psi>2) xs"
using until by coinduct (auto elim: UNTIL.cases simp: 0)

lemma until_false: "\<phi> until false = alw \<phi>"
proof-
  {fix xs assume "(\<phi> until false) xs" hence "alw \<phi> xs"
   by coinduct (auto elim: UNTIL.cases)
  }
  moreover
  {fix xs assume "alw \<phi> xs" hence "(\<phi> until false) xs"
   by coinduct auto
  }
  ultimately show ?thesis by blast
qed

lemma ev_nxt: "ev \<phi> = (\<phi> or nxt (ev \<phi>))"
by (rule ext) (metis ev.simps nxt.simps)

lemma alw_nxt: "alw \<phi> = (\<phi> aand nxt (alw \<phi>))"
by (rule ext) (metis alw.simps nxt.simps)

lemma ev_ev[simp]: "ev (ev \<phi>) = ev \<phi>"
proof-
  {fix xs
   assume "ev (ev \<phi>) xs" hence "ev \<phi> xs"
   by induct auto
  }
  thus ?thesis by auto
qed

lemma alw_alw[simp]: "alw (alw \<phi>) = alw \<phi>"
proof-
  {fix xs
   assume "alw \<phi> xs" hence "alw (alw \<phi>) xs"
   by coinduct auto
  }
  thus ?thesis by auto
qed

lemma ev_shift:
assumes "ev \<phi> xs"
shows "ev \<phi> (xl @- xs)"
using assms by (induct xl) auto

lemma ev_imp_shift:
assumes "ev \<phi> xs"  shows "\<exists> xl xs2. xs = xl @- xs2 \<and> \<phi> xs2"
using assms by induct (metis shift.simps(1), metis shift.simps(2) stream.collapse)+

lemma alw_ev_shift: "alw \<phi> xs1 \<Longrightarrow> ev (alw \<phi>) (xl @- xs1)"
by (auto intro: ev_shift)

lemma alw_shift:
assumes "alw \<phi> (xl @- xs)"
shows "alw \<phi> xs"
using assms by (induct xl) auto

lemma ev_ex_nxt:
assumes "ev \<phi> xs"
shows "\<exists> n. (nxt ^^ n) \<phi> xs"
using assms proof induct
  case (base xs) thus ?case by (intro exI[of _ 0]) auto
next
  case (step xs)
  then obtain n where "(nxt ^^ n) \<phi> (stl xs)" by blast
  thus ?case by (intro exI[of _ "Suc n"]) (metis funpow.simps(2) nxt.simps o_def)
qed

lemma alw_sdrop:
assumes "alw \<phi> xs"  shows "alw \<phi> (sdrop n xs)"
by (metis alw_shift assms stake_sdrop)

lemma nxt_sdrop: "(nxt ^^ n) \<phi> xs \<longleftrightarrow> \<phi> (sdrop n xs)"
by (induct n arbitrary: xs) auto

definition "wait \<phi> xs \<equiv> LEAST n. (nxt ^^ n) \<phi> xs"

lemma nxt_wait:
assumes "ev \<phi> xs"  shows "(nxt ^^ (wait \<phi> xs)) \<phi> xs"
unfolding wait_def using ev_ex_nxt[OF assms] by(rule LeastI_ex)

lemma nxt_wait_least:
assumes ev: "ev \<phi> xs" and nxt: "(nxt ^^ n) \<phi> xs"  shows "wait \<phi> xs \<le> n"
unfolding wait_def using ev_ex_nxt[OF ev] by (metis Least_le nxt)

lemma sdrop_wait:
assumes "ev \<phi> xs"  shows "\<phi> (sdrop (wait \<phi> xs) xs)"
using nxt_wait[OF assms] unfolding nxt_sdrop .

lemma sdrop_wait_least:
assumes ev: "ev \<phi> xs" and nxt: "\<phi> (sdrop n xs)"  shows "wait \<phi> xs \<le> n"
using assms nxt_wait_least unfolding nxt_sdrop by auto

lemma nxt_ev: "(nxt ^^ n) \<phi> xs \<Longrightarrow> ev \<phi> xs"
by (induct n arbitrary: xs) auto

lemma not_ev: "not (ev \<phi>) = alw (not \<phi>)"
proof(rule ext, safe)
  fix xs assume "not (ev \<phi>) xs" thus "alw (not \<phi>) xs"
  by (coinduct) auto
next
  fix xs assume "ev \<phi> xs" and "alw (not \<phi>) xs" thus False
  by (induct) auto
qed

lemma not_alw: "not (alw \<phi>) = ev (not \<phi>)"
proof-
  have "not (alw \<phi>) = not (alw (not (not \<phi>)))" by simp
  also have "... = ev (not \<phi>)" unfolding not_ev[symmetric] by simp
  finally show ?thesis .
qed

lemma not_ev_not[simp]: "not (ev (not \<phi>)) = alw \<phi>"
unfolding not_ev by simp

lemma not_alw_not[simp]: "not (alw (not \<phi>)) = ev \<phi>"
unfolding not_alw by simp

lemma alw_ev_sdrop:
assumes "alw (ev \<phi>) (sdrop m xs)"
shows "alw (ev \<phi>) xs"
using assms
by coinduct (metis alw_nxt ev_shift funpow_swap1 nxt.simps nxt_sdrop stake_sdrop)

lemma ev_alw_imp_alw_ev:
assumes "ev (alw \<phi>) xs"  shows "alw (ev \<phi>) xs"
using assms by induct (metis (full_types) alw_mono ev.base, metis alw alw_nxt ev.step)

lemma alw_aand: "alw (\<phi> aand \<psi>) = alw \<phi> aand alw \<psi>"
proof-
  {fix xs assume "alw (\<phi> aand \<psi>) xs" hence "(alw \<phi> aand alw \<psi>) xs"
   by (auto elim: alw_mono)
  }
  moreover
  {fix xs assume "(alw \<phi> aand alw \<psi>) xs" hence "alw (\<phi> aand \<psi>) xs"
   by coinduct auto
  }
  ultimately show ?thesis by blast
qed

lemma ev_or: "ev (\<phi> or \<psi>) = ev \<phi> or ev \<psi>"
proof-
  {fix xs assume "(ev \<phi> or ev \<psi>) xs" hence "ev (\<phi> or \<psi>) xs"
   by (auto elim: ev_mono)
  }
  moreover
  {fix xs assume "ev (\<phi> or \<psi>) xs" hence "(ev \<phi> or ev \<psi>) xs"
   by induct auto
  }
  ultimately show ?thesis by blast
qed

lemma ev_alw_aand:
assumes \<phi>: "ev (alw \<phi>) xs" and \<psi>: "ev (alw \<psi>) xs"
shows "ev (alw (\<phi> aand \<psi>)) xs"
proof-
  obtain xl xs1 where xs1: "xs = xl @- xs1" and \<phi>\<phi>: "alw \<phi> xs1"
  using \<phi> by (metis ev_imp_shift)
  moreover obtain yl ys1 where xs2: "xs = yl @- ys1" and \<psi>\<psi>: "alw \<psi> ys1"
  using \<psi> by (metis ev_imp_shift)
  ultimately have 0: "xl @- xs1 = yl @- ys1" by auto
  hence "prefix xl yl \<or> prefix yl xl" using shift_prefix_cases by auto
  thus ?thesis proof
    assume "prefix xl yl"
    then obtain yl1 where yl: "yl = xl @ yl1" by (elim prefixE)
    have xs1': "xs1 = yl1 @- ys1" using 0 unfolding yl by simp
    have "alw \<phi> ys1" using \<phi>\<phi> unfolding xs1' by (metis alw_shift)
    hence "alw (\<phi> aand \<psi>) ys1" using \<psi>\<psi> unfolding alw_aand by auto
    thus ?thesis unfolding xs2 by (auto intro: alw_ev_shift)
  next
    assume "prefix yl xl"
    then obtain xl1 where xl: "xl = yl @ xl1" by (elim prefixE)
    have ys1': "ys1 = xl1 @- xs1" using 0 unfolding xl by simp
    have "alw \<psi> xs1" using \<psi>\<psi> unfolding ys1' by (metis alw_shift)
    hence "alw (\<phi> aand \<psi>) xs1" using \<phi>\<phi> unfolding alw_aand by auto
    thus ?thesis unfolding xs1 by (auto intro: alw_ev_shift)
  qed
qed

lemma ev_alw_alw_impl:
assumes "ev (alw \<phi>) xs" and "alw (alw \<phi> impl ev \<psi>) xs"
shows "ev \<psi> xs"
using assms by induct auto

lemma ev_alw_stl[simp]: "ev (alw \<phi>) (stl x) \<longleftrightarrow> ev (alw \<phi>) x"
by (metis (full_types) alw_nxt ev_nxt nxt.simps)

lemma alw_alw_impl_ev:
"alw (alw \<phi> impl ev \<psi>) = (ev (alw \<phi>) impl alw (ev \<psi>))" (is "?A = ?B")
proof-
  {fix xs assume "?A xs \<and> ev (alw \<phi>) xs" hence "alw (ev \<psi>) xs"
    by coinduct (auto elim: ev_alw_alw_impl)
  }
  moreover
  {fix xs assume "?B xs" hence "?A xs"
   by coinduct auto
  }
  ultimately show ?thesis by blast
qed

lemma ev_alw_impl:
assumes "ev \<phi> xs" and "alw (\<phi> impl \<psi>) xs"  shows "ev \<psi> xs"
using assms by induct auto

lemma ev_alw_impl_ev:
assumes "ev \<phi> xs" and "alw (\<phi> impl ev \<psi>) xs"  shows "ev \<psi> xs"
using ev_alw_impl[OF assms] by simp

lemma alw_mp:
assumes "alw \<phi> xs" and "alw (\<phi> impl \<psi>) xs"
shows "alw \<psi> xs"
proof-
  {assume "alw \<phi> xs \<and> alw (\<phi> impl \<psi>) xs" hence ?thesis
   by coinduct auto
  }
  thus ?thesis using assms by auto
qed

lemma all_imp_alw:
assumes "\<And> xs. \<phi> xs"  shows "alw \<phi> xs"
proof-
  {assume "\<forall> xs. \<phi> xs"
   hence ?thesis by coinduct auto
  }
  thus ?thesis using assms by auto
qed

lemma alw_impl_ev_alw:
assumes "alw (\<phi> impl ev \<psi>) xs"
shows "alw (ev \<phi> impl ev \<psi>) xs"
using assms by coinduct (auto dest: ev_alw_impl)

lemma ev_holds_sset:
"ev (holds P) xs \<longleftrightarrow> (\<exists> x \<in> sset xs. P x)" (is "?L \<longleftrightarrow> ?R")
proof safe
  assume ?L thus ?R by induct (metis holds.simps stream.set_sel(1), metis stl_sset)
next
  fix x assume "x \<in> sset xs" "P x"
  thus ?L by (induct rule: sset_induct) (simp_all add: ev.base ev.step)
qed

(* LTL as a program logic: *)
lemma alw_invar:
assumes "\<phi> xs" and "alw (\<phi> impl nxt \<phi>) xs"
shows "alw \<phi> xs"
proof-
  {assume "\<phi> xs \<and> alw (\<phi> impl nxt \<phi>) xs" hence ?thesis
   by coinduct auto
  }
  thus ?thesis using assms by auto
qed

lemma variance:
assumes 1: "\<phi> xs" and 2: "alw (\<phi> impl (\<psi> or nxt \<phi>)) xs"
shows "(alw \<phi> or ev \<psi>) xs"
proof-
  {assume "\<not> ev \<psi> xs" hence "alw (not \<psi>) xs" unfolding not_ev[symmetric] .
   moreover have "alw (not \<psi> impl (\<phi> impl nxt \<phi>)) xs"
   using 2 by coinduct auto
   ultimately have "alw (\<phi> impl nxt \<phi>) xs" by(auto dest: alw_mp)
   with 1 have "alw \<phi> xs" by(rule alw_invar)
  }
  thus ?thesis by blast
qed

lemma ev_alw_imp_nxt:
assumes e: "ev \<phi> xs" and a: "alw (\<phi> impl (nxt \<phi>)) xs"
shows "ev (alw \<phi>) xs"
proof-
  obtain xl xs1 where xs: "xs = xl @- xs1" and \<phi>: "\<phi> xs1"
  using e by (metis ev_imp_shift)
  have "\<phi> xs1 \<and> alw (\<phi> impl (nxt \<phi>)) xs1" using a \<phi> unfolding xs by (metis alw_shift)
  hence "alw \<phi> xs1" by(coinduct xs1 rule: alw.coinduct) auto
  thus ?thesis unfolding xs by (auto intro: alw_ev_shift)
qed

inductive ev_at :: "('a stream \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a stream \<Rightarrow> bool" for P :: "'a stream \<Rightarrow> bool" where
  base: "P \<omega> \<Longrightarrow> ev_at P 0 \<omega>"
| step:"\<not> P \<omega> \<Longrightarrow> ev_at P n (stl \<omega>) \<Longrightarrow> ev_at P (Suc n) \<omega>"

inductive_simps ev_at_0[simp]: "ev_at P 0 \<omega>"
inductive_simps ev_at_Suc[simp]: "ev_at P (Suc n) \<omega>"

lemma ev_at_imp_snth: "ev_at P n \<omega> \<Longrightarrow> P (sdrop n \<omega>)"
  by (induction n arbitrary: \<omega>) auto

lemma ev_at_HLD_imp_snth: "ev_at (HLD X) n \<omega> \<Longrightarrow> \<omega> !! n \<in> X"
  by (auto dest!: ev_at_imp_snth simp: HLD_iff)

lemma ev_at_HLD_single_imp_snth: "ev_at (HLD {x}) n \<omega> \<Longrightarrow> \<omega> !! n = x"
  by (drule ev_at_HLD_imp_snth) simp

lemma ev_at_unique: "ev_at P n \<omega> \<Longrightarrow> ev_at P m \<omega> \<Longrightarrow> n = m"
proof (induction arbitrary: m rule: ev_at.induct)
  case (base \<omega>) then show ?case
    by (simp add: ev_at.simps[of _ _ \<omega>])
next
  case (step \<omega> n) from step.prems step.hyps step.IH[of "m - 1"] show ?case
    by (auto simp add: ev_at.simps[of _ _ \<omega>])
qed

lemma ev_iff_ev_at: "ev P \<omega> \<longleftrightarrow> (\<exists>n. ev_at P n \<omega>)"
proof
  assume "ev P \<omega>" then show "\<exists>n. ev_at P n \<omega>"
    by (induction rule: ev_induct_strong) (auto intro: ev_at.intros)
next
  assume "\<exists>n. ev_at P n \<omega>"
  then obtain n where "ev_at P n \<omega>"
    by auto
  then show "ev P \<omega>"
    by induction auto
qed

lemma ev_at_shift: "ev_at (HLD X) i (stake (Suc i) \<omega> @- \<omega>' :: 's stream) \<longleftrightarrow> ev_at (HLD X) i \<omega>"
  by (induction i arbitrary: \<omega>) (auto simp: HLD_iff)

lemma ev_iff_ev_at_unqiue: "ev P \<omega> \<longleftrightarrow> (\<exists>!n. ev_at P n \<omega>)"
  by (auto intro: ev_at_unique simp: ev_iff_ev_at)

lemma alw_HLD_iff_streams: "alw (HLD X) \<omega> \<longleftrightarrow> \<omega> \<in> streams X"
proof
  assume "alw (HLD X) \<omega>" then show "\<omega> \<in> streams X"
  proof (coinduction arbitrary: \<omega>)
    case (streams \<omega>) then show ?case by (cases \<omega>) auto
  qed
next
  assume "\<omega> \<in> streams X" then show "alw (HLD X) \<omega>"
  proof (coinduction arbitrary: \<omega>)
    case (alw \<omega>) then show ?case by (cases \<omega>) auto
  qed
qed

lemma not_HLD: "not (HLD X) = HLD (- X)"
  by (auto simp: HLD_iff)

lemma not_alw_iff: "\<not> (alw P \<omega>) \<longleftrightarrow> ev (not P) \<omega>"
  using not_alw[of P] by (simp add: fun_eq_iff)

lemma not_ev_iff: "\<not> (ev P \<omega>) \<longleftrightarrow> alw (not P) \<omega>"
  using not_alw_iff[of "not P" \<omega>, symmetric]  by simp

lemma ev_Stream: "ev P (x ## s) \<longleftrightarrow> P (x ## s) \<or> ev P s"
  by (auto elim: ev.cases)

lemma alw_ev_imp_ev_alw:
  assumes "alw (ev P) \<omega>" shows "ev (P aand alw (ev P)) \<omega>"
proof -
  have "ev P \<omega>" using assms by auto
  from this assms show ?thesis
    by induct auto
qed

lemma ev_False: "ev (\<lambda>x. False) \<omega> \<longleftrightarrow> False"
proof
  assume "ev (\<lambda>x. False) \<omega>" then show False
    by induct auto
qed auto

lemma alw_False: "alw (\<lambda>x. False) \<omega> \<longleftrightarrow> False"
  by auto

lemma ev_iff_sdrop: "ev P \<omega> \<longleftrightarrow> (\<exists>m. P (sdrop m \<omega>))"
proof safe
  assume "ev P \<omega>" then show "\<exists>m. P (sdrop m \<omega>)"
    by (induct rule: ev_induct_strong) (auto intro: exI[of _ 0] exI[of _ "Suc n" for n])
next
  fix m assume "P (sdrop m \<omega>)" then show "ev P \<omega>"
    by (induct m arbitrary: \<omega>) auto
qed

lemma alw_iff_sdrop: "alw P \<omega> \<longleftrightarrow> (\<forall>m. P (sdrop m \<omega>))"
proof safe
  fix m assume "alw P \<omega>" then show "P (sdrop m \<omega>)"
    by (induct m arbitrary: \<omega>) auto
next
  assume "\<forall>m. P (sdrop m \<omega>)" then show "alw P \<omega>"
    by (coinduction arbitrary: \<omega>) (auto elim: allE[of _ 0] allE[of _ "Suc n" for n])
qed

lemma infinite_iff_alw_ev: "infinite {m. P (sdrop m \<omega>)} \<longleftrightarrow> alw (ev P) \<omega>"
  unfolding infinite_nat_iff_unbounded_le alw_iff_sdrop ev_iff_sdrop
  by simp (metis le_Suc_ex le_add1)

lemma alw_inv:
  assumes stl: "\<And>s. f (stl s) = stl (f s)"
  shows "alw P (f s) \<longleftrightarrow> alw (\<lambda>x. P (f x)) s"
proof
  assume "alw P (f s)" then show "alw (\<lambda>x. P (f x)) s"
    by (coinduction arbitrary: s rule: alw_coinduct)
       (auto simp: stl)
next
  assume "alw (\<lambda>x. P (f x)) s" then show "alw P (f s)"
    by (coinduction arbitrary: s rule: alw_coinduct) (auto simp: stl[symmetric])
qed

lemma ev_inv:
  assumes stl: "\<And>s. f (stl s) = stl (f s)"
  shows "ev P (f s) \<longleftrightarrow> ev (\<lambda>x. P (f x)) s"
proof
  assume "ev P (f s)" then show "ev (\<lambda>x. P (f x)) s"
    by (induction "f s" arbitrary: s) (auto simp: stl)
next
  assume "ev (\<lambda>x. P (f x)) s" then show "ev P (f s)"
    by induction (auto simp: stl[symmetric])
qed

lemma alw_smap: "alw P (smap f s) \<longleftrightarrow> alw (\<lambda>x. P (smap f x)) s"
  by (rule alw_inv) simp

lemma ev_smap: "ev P (smap f s) \<longleftrightarrow> ev (\<lambda>x. P (smap f x)) s"
  by (rule ev_inv) simp

lemma alw_cong:
  assumes P: "alw P \<omega>" and eq: "\<And>\<omega>. P \<omega> \<Longrightarrow> Q1 \<omega> \<longleftrightarrow> Q2 \<omega>"
  shows "alw Q1 \<omega> \<longleftrightarrow> alw Q2 \<omega>"
proof -
  from eq have "(alw P aand Q1) = (alw P aand Q2)" by auto
  then have "alw (alw P aand Q1) \<omega> = alw (alw P aand Q2) \<omega>" by auto
  with P show "alw Q1 \<omega> \<longleftrightarrow> alw Q2 \<omega>"
    by (simp add: alw_aand)
qed

lemma ev_cong:
  assumes P: "alw P \<omega>" and eq: "\<And>\<omega>. P \<omega> \<Longrightarrow> Q1 \<omega> \<longleftrightarrow> Q2 \<omega>"
  shows "ev Q1 \<omega> \<longleftrightarrow> ev Q2 \<omega>"
proof -
  from P have "alw (\<lambda>xs. Q1 xs \<longrightarrow> Q2 xs) \<omega>" by (rule alw_mono) (simp add: eq)
  moreover from P have "alw (\<lambda>xs. Q2 xs \<longrightarrow> Q1 xs) \<omega>" by (rule alw_mono) (simp add: eq)
  moreover note ev_alw_impl[of Q1 \<omega> Q2] ev_alw_impl[of Q2 \<omega> Q1]
  ultimately show "ev Q1 \<omega> \<longleftrightarrow> ev Q2 \<omega>"
    by auto
qed

lemma alwD: "alw P x \<Longrightarrow> P x"
  by auto

lemma alw_alwD: "alw P \<omega> \<Longrightarrow> alw (alw P) \<omega>"
  by simp

lemma alw_ev_stl: "alw (ev P) (stl \<omega>) \<longleftrightarrow> alw (ev P) \<omega>"
  by (auto intro: alw.intros)

lemma holds_Stream: "holds P (x ## s) \<longleftrightarrow> P x"
  by simp

lemma holds_eq1[simp]: "holds (op = x) = HLD {x}"
  by rule (auto simp: HLD_iff)

lemma holds_eq2[simp]: "holds (\<lambda>y. y = x) = HLD {x}"
  by rule (auto simp: HLD_iff)

lemma not_holds_eq[simp]: "holds (- op = x) = not (HLD {x})"
  by rule (auto simp: HLD_iff)

text \<open>Strong until\<close>

context
  notes [[inductive_internals]]
begin

inductive suntil (infix "suntil" 60) for \<phi> \<psi> where
  base: "\<psi> \<omega> \<Longrightarrow> (\<phi> suntil \<psi>) \<omega>"
| step: "\<phi> \<omega> \<Longrightarrow> (\<phi> suntil \<psi>) (stl \<omega>) \<Longrightarrow> (\<phi> suntil \<psi>) \<omega>"

inductive_simps suntil_Stream: "(\<phi> suntil \<psi>) (x ## s)"

end

lemma suntil_induct_strong[consumes 1, case_names base step]:
  "(\<phi> suntil \<psi>) x \<Longrightarrow>
    (\<And>\<omega>. \<psi> \<omega> \<Longrightarrow> P \<omega>) \<Longrightarrow>
    (\<And>\<omega>. \<phi> \<omega> \<Longrightarrow> \<not> \<psi> \<omega> \<Longrightarrow> (\<phi> suntil \<psi>) (stl \<omega>) \<Longrightarrow> P (stl \<omega>) \<Longrightarrow> P \<omega>) \<Longrightarrow> P x"
  using suntil.induct[of \<phi> \<psi> x P] by blast

lemma ev_suntil: "(\<phi> suntil \<psi>) \<omega> \<Longrightarrow> ev \<psi> \<omega>"
  by (induct rule: suntil.induct) auto

lemma suntil_inv:
  assumes stl: "\<And>s. f (stl s) = stl (f s)"
  shows "(P suntil Q) (f s) \<longleftrightarrow> ((\<lambda>x. P (f x)) suntil (\<lambda>x. Q (f x))) s"
proof
  assume "(P suntil Q) (f s)" then show "((\<lambda>x. P (f x)) suntil (\<lambda>x. Q (f x))) s"
    by (induction "f s" arbitrary: s) (auto simp: stl intro: suntil.intros)
next
  assume "((\<lambda>x. P (f x)) suntil (\<lambda>x. Q (f x))) s" then show "(P suntil Q) (f s)"
    by induction (auto simp: stl[symmetric] intro: suntil.intros)
qed

lemma suntil_smap: "(P suntil Q) (smap f s) \<longleftrightarrow> ((\<lambda>x. P (smap f x)) suntil (\<lambda>x. Q (smap f x))) s"
  by (rule suntil_inv) simp

lemma hld_smap: "HLD x (smap f s) = holds (\<lambda>y. f y \<in> x) s"
  by (simp add: HLD_def)

lemma suntil_mono:
  assumes eq: "\<And>\<omega>. P \<omega> \<Longrightarrow> Q1 \<omega> \<Longrightarrow> Q2 \<omega>" "\<And>\<omega>. P \<omega> \<Longrightarrow> R1 \<omega> \<Longrightarrow> R2 \<omega>"
  assumes *: "(Q1 suntil R1) \<omega>" "alw P \<omega>" shows "(Q2 suntil R2) \<omega>"
  using * by induct (auto intro: eq suntil.intros)

lemma suntil_cong:
  "alw P \<omega> \<Longrightarrow> (\<And>\<omega>. P \<omega> \<Longrightarrow> Q1 \<omega> \<longleftrightarrow> Q2 \<omega>) \<Longrightarrow> (\<And>\<omega>. P \<omega> \<Longrightarrow> R1 \<omega> \<longleftrightarrow> R2 \<omega>) \<Longrightarrow>
    (Q1 suntil R1) \<omega> \<longleftrightarrow> (Q2 suntil R2) \<omega>"
  using suntil_mono[of P Q1 Q2 R1 R2 \<omega>] suntil_mono[of P Q2 Q1 R2 R1 \<omega>] by auto

lemma ev_suntil_iff: "ev (P suntil Q) \<omega> \<longleftrightarrow> ev Q \<omega>"
proof
  assume "ev (P suntil Q) \<omega>" then show "ev Q \<omega>"
   by induct (auto dest: ev_suntil)
next
  assume "ev Q \<omega>" then show "ev (P suntil Q) \<omega>"
    by induct (auto intro: suntil.intros)
qed

lemma true_suntil: "((\<lambda>_. True) suntil P) = ev P"
  by (simp add: suntil_def ev_def)

lemma suntil_lfp: "(\<phi> suntil \<psi>) = lfp (\<lambda>P s. \<psi> s \<or> (\<phi> s \<and> P (stl s)))"
  by (simp add: suntil_def)

lemma sfilter_P[simp]: "P (shd s) \<Longrightarrow> sfilter P s = shd s ## sfilter P (stl s)"
  using sfilter_Stream[of P "shd s" "stl s"] by simp

lemma sfilter_not_P[simp]: "\<not> P (shd s) \<Longrightarrow> sfilter P s = sfilter P (stl s)"
  using sfilter_Stream[of P "shd s" "stl s"] by simp

lemma sfilter_eq:
  assumes "ev (holds P) s"
  shows "sfilter P s = x ## s' \<longleftrightarrow>
    P x \<and> (not (holds P) suntil (HLD {x} aand nxt (\<lambda>s. sfilter P s = s'))) s"
  using assms
  by (induct rule: ev_induct_strong)
     (auto simp add: HLD_iff intro: suntil.intros elim: suntil.cases)

lemma sfilter_streams:
  "alw (ev (holds P)) \<omega> \<Longrightarrow> \<omega> \<in> streams A \<Longrightarrow> sfilter P \<omega> \<in> streams {x\<in>A. P x}"
proof (coinduction arbitrary: \<omega>)
  case (streams \<omega>)
  then have "ev (holds P) \<omega>" by blast
  from this streams show ?case
    by (induct rule: ev_induct_strong) (auto elim: streamsE)
qed

lemma alw_sfilter:
  assumes *: "alw (ev (holds P)) s"
  shows "alw Q (sfilter P s) \<longleftrightarrow> alw (\<lambda>x. Q (sfilter P x)) s"
proof
  assume "alw Q (sfilter P s)" with * show "alw (\<lambda>x. Q (sfilter P x)) s"
  proof (coinduction arbitrary: s rule: alw_coinduct)
    case (stl s)
    then have "ev (holds P) s"
      by blast
    from this stl show ?case
      by (induct rule: ev_induct_strong) auto
  qed auto
next
  assume "alw (\<lambda>x. Q (sfilter P x)) s" with * show "alw Q (sfilter P s)"
  proof (coinduction arbitrary: s rule: alw_coinduct)
    case (stl s)
    then have "ev (holds P) s"
      by blast
    from this stl show ?case
      by (induct rule: ev_induct_strong) auto
  qed auto
qed

lemma ev_sfilter:
  assumes *: "alw (ev (holds P)) s"
  shows "ev Q (sfilter P s) \<longleftrightarrow> ev (\<lambda>x. Q (sfilter P x)) s"
proof
  assume "ev Q (sfilter P s)" from this * show "ev (\<lambda>x. Q (sfilter P x)) s"
  proof (induction "sfilter P s" arbitrary: s rule: ev_induct_strong)
    case (step s)
    then have "ev (holds P) s"
      by blast
    from this step show ?case
      by (induct rule: ev_induct_strong) auto
  qed auto
next
  assume "ev (\<lambda>x. Q (sfilter P x)) s" then show "ev Q (sfilter P s)"
  proof (induction rule: ev_induct_strong)
    case (step s) then show ?case
      by (cases "P (shd s)") auto
  qed auto
qed

lemma holds_sfilter:
  assumes "ev (holds Q) s" shows "holds P (sfilter Q s) \<longleftrightarrow> (not (holds Q) suntil (holds (Q aand P))) s"
proof
  assume "holds P (sfilter Q s)" with assms show "(not (holds Q) suntil (holds (Q aand P))) s"
    by (induct rule: ev_induct_strong) (auto intro: suntil.intros)
next
  assume "(not (holds Q) suntil (holds (Q aand P))) s" then show "holds P (sfilter Q s)"
    by induct auto
qed

lemma suntil_aand_nxt:
  "(\<phi> suntil (\<phi> aand nxt \<psi>)) \<omega> \<longleftrightarrow> (\<phi> aand nxt (\<phi> suntil \<psi>)) \<omega>"
proof
  assume "(\<phi> suntil (\<phi> aand nxt \<psi>)) \<omega>" then show "(\<phi> aand nxt (\<phi> suntil \<psi>)) \<omega>"
    by induction (auto intro: suntil.intros)
next
  assume "(\<phi> aand nxt (\<phi> suntil \<psi>)) \<omega>"
  then have "(\<phi> suntil \<psi>) (stl \<omega>)" "\<phi> \<omega>"
    by auto
  then show "(\<phi> suntil (\<phi> aand nxt \<psi>)) \<omega>"
    by (induction "stl \<omega>" arbitrary: \<omega>)
       (auto elim: suntil.cases intro: suntil.intros)
qed

lemma alw_sconst: "alw P (sconst x) \<longleftrightarrow> P (sconst x)"
proof
  assume "P (sconst x)" then show "alw P (sconst x)"
    by coinduction auto
qed auto

lemma ev_sconst: "ev P (sconst x) \<longleftrightarrow> P (sconst x)"
proof
  assume "ev P (sconst x)" then show "P (sconst x)"
    by (induction "sconst x") auto
qed auto

lemma suntil_sconst: "(\<phi> suntil \<psi>) (sconst x) \<longleftrightarrow> \<psi> (sconst x)"
proof
  assume "(\<phi> suntil \<psi>) (sconst x)" then show "\<psi> (sconst x)"
    by (induction "sconst x") auto
qed (auto intro: suntil.intros)

lemma hld_smap': "HLD x (smap f s) = HLD (f -` x) s"
  by (simp add: HLD_def)

lemma pigeonhole_stream:
  assumes "alw (HLD s) \<omega>"
  assumes "finite s"
  shows "\<exists>x\<in>s. alw (ev (HLD {x})) \<omega>"
proof -
  have "\<forall>i\<in>UNIV. \<exists>x\<in>s. \<omega> !! i = x"
    using `alw (HLD s) \<omega>` by (simp add: alw_iff_sdrop HLD_iff)
  from pigeonhole_infinite_rel[OF infinite_UNIV_nat `finite s` this]
  show ?thesis
    by (simp add: HLD_iff infinite_iff_alw_ev[symmetric])
qed

lemma ev_eq_suntil: "ev P \<omega> \<longleftrightarrow> (not P suntil P) \<omega>"
proof
  assume "ev P \<omega>" then show "((\<lambda>xs. \<not> P xs) suntil P) \<omega>"
    by (induction rule: ev_induct_strong) (auto intro: suntil.intros)
qed (auto simp: ev_suntil)

end


theory tut3
imports Main

begin
(*Exercise 2*)
locale geometry =
  fixes on :: 'point \<Rightarrow> 'line \<Rightarrow> bool
  assumes line_exs: "x \<noteq> y \<Rightarrow> \<exists>l. on x l \<and> on y l"
  assumes line_eq: "\<exists>x y. x \<noteq> y \<and> on x l \<and> on y l"
  assumes line_points: "\<exists>x y z. x \<noteq> y \<and> x \<noteq> z \<and> y \<noteq> z \<and> \<forall>l. \<not>(on x l \<and> on y l \<and> on z l)"

begin
(*Not all points lie on the same line*)
lemma a: "\<forall>l. \<exists>p. \<not>on p l"
  apply (rule allI)
  oops

(*There exist at least two lines through each point*)
lemma b: "\<exists>l1 l2. \<forall>p. on p l1 \<and> on p l2 "
  oops
(*Two lines cannot intersect in more than one point*)

end

end


theory Ex036
  imports Main
begin

lemma "(A \<Longrightarrow> B) \<Longrightarrow> A \<Longrightarrow> B"
  using [[simp_trace_new mode=full]]
proof -
  {
    assume a:"A \<Longrightarrow> B"
    hence b:"A \<longrightarrow> B" by (rule impI)
    {
      assume A
      with b show B by (rule mp)
    }
  }
qed

(*just another way to I like to represent this proof*)
lemma "(A \<Longrightarrow> B) \<Longrightarrow> A \<Longrightarrow> B"
proof -
  assume a:"A \<Longrightarrow> B"
  hence b:"A \<longrightarrow> B" by (rule impI)
  assume A
  with b show B by (rule mp)
qed

(*proving with meta implication*)
lemma "(A \<Longrightarrow> B) \<Longrightarrow> A \<Longrightarrow> B"
proof -
  assume a:"A \<Longrightarrow> B"
  assume A
  with a have B by (rule meta_mp)
qed


section \<open> Reactive Weakest Preconditions \<close>

theory utp_rea_wp
  imports utp_rea_prog
begin

text \<open> Here, we create a weakest precondition calculus for reactive relations, using the recast
  boolean algebra and relational operators. Please see our journal paper~\cite{Foster17c} for more information. \<close>

definition wp_rea ::
  "('t::trace, '\<alpha>) hrel_rp \<Rightarrow>
   ('t, '\<alpha>) hrel_rp \<Rightarrow>
   ('t, '\<alpha>) hrel_rp" (infix "wp\<^sub>r" 60)
where [upred_defs]: "P wp\<^sub>r Q = (\<not>\<^sub>r P ;; (\<not>\<^sub>r Q))"

lemma in_var_unrest_wp_rea [unrest]: "\<lbrakk> $x \<sharp> P; tr \<bowtie> x \<rbrakk> \<Longrightarrow> $x \<sharp> (P wp\<^sub>r Q)"
  by (simp add: wp_rea_def unrest R1_def rea_not_def)

lemma out_var_unrest_wp_rea [unrest]: "\<lbrakk> $x\<acute> \<sharp> Q; tr \<bowtie> x \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> (P wp\<^sub>r Q)"
  by (simp add: wp_rea_def unrest R1_def rea_not_def)

lemma wp_rea_R1 [closure]: "P wp\<^sub>r Q is R1"
  by (rel_auto)

lemma wp_rea_RR_closed [closure]: "\<lbrakk> P is RR; Q is RR \<rbrakk> \<Longrightarrow> P wp\<^sub>r Q is RR"
  by (simp add: wp_rea_def closure)

lemma wp_rea_impl_lemma:
  "((P wp\<^sub>r Q) \<Rightarrow>\<^sub>r (R1(P) ;; R1(Q \<Rightarrow>\<^sub>r R))) = ((P wp\<^sub>r Q) \<Rightarrow>\<^sub>r (R1(P) ;; R1(R)))"
  by (rel_auto, blast)

lemma wpR_impl_post_spec:
  assumes "P is RR"
  shows "(P wp\<^sub>r Q\<^sub>1 \<Rightarrow>\<^sub>r (P ;; (Q\<^sub>1 \<Rightarrow>\<^sub>r Q\<^sub>2))) = (P ;; (Q\<^sub>1 \<Rightarrow>\<^sub>r Q\<^sub>2))"
  by (simp add: R1_seqr_closure RR_implies_R1 assms rea_impl_def rea_not_R1 rea_not_not seqr_or_distr wp_rea_def)

lemma wpR_R1_right [wp]:
  "P wp\<^sub>r R1(Q) = P wp\<^sub>r Q"
  by (rel_auto)

lemma wp_rea_true [wp]: "P wp\<^sub>r true = true\<^sub>r"
  by (rel_auto)

lemma wp_rea_conj [wp]: "P wp\<^sub>r (Q \<and> R) = (P wp\<^sub>r Q \<and> P wp\<^sub>r R)"
  by (simp add: wp_rea_def seqr_or_distr)

lemma wp_rea_USUP_mem [wp]:
  "A \<noteq> {} \<Longrightarrow> P wp\<^sub>r (\<Squnion> i\<in>A \<bullet> Q(i)) = (\<Squnion> i\<in>A \<bullet> P wp\<^sub>r Q(i))"
  by (simp add: wp_rea_def seq_UINF_distl)

lemma wp_rea_Inf_pre [wp]:
  "P wp\<^sub>r (\<Squnion>i\<in>{0..n::nat}. Q(i)) = (\<Squnion>i\<in>{0..n}. P wp\<^sub>r Q(i))"
  by (simp add: wp_rea_def seq_SUP_distl)

lemma wp_rea_div [wp]:
  "(\<not>\<^sub>r P ;; true\<^sub>r) = true\<^sub>r \<Longrightarrow> true\<^sub>r wp\<^sub>r P = false"
  by (simp add: wp_rea_def rpred, rel_blast)

lemma wp_rea_st_cond_div [wp]:
  "P \<noteq> true \<Longrightarrow> true\<^sub>r wp\<^sub>r [P]\<^sub>S\<^sub>< = false"
  by (rel_auto)

lemma wp_rea_cond [wp]:
  "out\<alpha> \<sharp> b \<Longrightarrow> (P \<triangleleft> b \<triangleright> Q) wp\<^sub>r R = (P wp\<^sub>r R) \<triangleleft> b \<triangleright> (Q wp\<^sub>r R)"
  by (simp add: wp_rea_def cond_seq_left_distr, rel_auto)

lemma wp_rea_RC_false [wp]:
  "P is RC \<Longrightarrow> (\<not>\<^sub>r P) wp\<^sub>r false = P"
  by (metis Healthy_if RC1_def RC_implies_RC1 rea_not_false wp_rea_def)

lemma wp_rea_seq [wp]:
  assumes "Q is R1"
  shows "(P ;; Q) wp\<^sub>r R = P wp\<^sub>r (Q wp\<^sub>r R)" (is "?lhs = ?rhs")
proof -
  have "?rhs = R1 (\<not> P ;; R1 (Q ;; R1 (\<not> R)))"
    by (simp add: wp_rea_def rea_not_def R1_negate_R1 assms)
  also have "... = R1 (\<not> P ;; (Q ;; R1 (\<not> R)))"
    by (metis Healthy_if R1_seqr assms)
  also have "... = R1 (\<not> (P ;; Q) ;; R1 (\<not> R))"
    by (simp add: seqr_assoc)
  finally show ?thesis
    by (simp add: wp_rea_def rea_not_def)
qed

lemma wp_rea_skip [wp]:
  assumes "Q is R1"
  shows "II wp\<^sub>r Q = Q"
  by (simp add: wp_rea_def rpred assms Healthy_if)

lemma wp_rea_rea_skip [wp]:
  assumes "Q is RR"
  shows "II\<^sub>r wp\<^sub>r Q = Q"
  by (simp add: wp_rea_def rpred closure assms Healthy_if)

lemma power_wp_rea_RR_closed [closure]:
  "\<lbrakk> R is RR; P is RR \<rbrakk> \<Longrightarrow> R \<^bold>^ i wp\<^sub>r P is RR"
  by (induct i, simp_all add: wp closure)

lemma wp_rea_rea_assigns [wp]:
  assumes "P is RR"
  shows "\<langle>\<sigma>\<rangle>\<^sub>r wp\<^sub>r P = \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> P"
proof -
  have "\<langle>\<sigma>\<rangle>\<^sub>r wp\<^sub>r (RR P) = \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> (RR P)"
    by (rel_auto)
  thus ?thesis
    by (metis Healthy_def assms)
qed

lemma wp_rea_miracle [wp]: "false wp\<^sub>r Q = true\<^sub>r"
  by (simp add: wp_rea_def)

lemma wp_rea_disj [wp]: "(P \<or> Q) wp\<^sub>r R = (P wp\<^sub>r R \<and> Q wp\<^sub>r R)"
  by (rel_blast)

lemma wp_rea_UINF [wp]:
  assumes "A \<noteq> {}"
  shows "(\<Sqinter> x\<in>A \<bullet> P(x)) wp\<^sub>r Q = (\<Squnion> x\<in>A \<bullet> P(x) wp\<^sub>r Q)"
  by (simp add: wp_rea_def rea_not_def seq_UINF_distr not_UINF R1_UINF assms)

lemma wp_rea_choice [wp]:
  "(P \<sqinter> Q) wp\<^sub>r R = (P wp\<^sub>r R \<and> Q wp\<^sub>r R)"
  by (rel_blast)

lemma wp_rea_UINF_ind [wp]:
  "(\<Sqinter> i \<bullet> P(i)) wp\<^sub>r Q = (\<Squnion> i \<bullet> P(i) wp\<^sub>r Q)"
  by (simp add: wp_rea_def rea_not_def seq_UINF_distr' not_UINF_ind R1_UINF_ind)

lemma rea_assume_wp [wp]:
  assumes "P is RC"
  shows "([b]\<^sup>\<top>\<^sub>r wp\<^sub>r P) = ([b]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r P)"
proof -
  have "([b]\<^sup>\<top>\<^sub>r wp\<^sub>r RC P) = ([b]\<^sub>S\<^sub>< \<Rightarrow>\<^sub>r RC P)"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma rea_star_wp [wp]:
  assumes "P is RR" "Q is RR"
  shows "P\<^sup>\<star>\<^sup>r wp\<^sub>r Q = (\<Squnion> i \<bullet> P \<^bold>^ i wp\<^sub>r Q)"
proof -
  have "P\<^sup>\<star>\<^sup>r wp\<^sub>r Q = (Q \<and> P\<^sup>+ wp\<^sub>r Q)"
    by (simp add: assms rrel_theory.Star_alt_def wp_rea_choice wp_rea_rea_skip)
  also have "... = (II wp\<^sub>r Q \<and> (\<Squnion> i \<bullet> P \<^bold>^ Suc i wp\<^sub>r Q))"
    by (simp add: uplus_power_def wp closure assms)
  also have "... = (\<Squnion> i \<bullet> P \<^bold>^ i wp\<^sub>r Q)"
  proof -
    have "P\<^sup>\<star> wp\<^sub>r Q = P\<^sup>\<star>\<^sup>r wp\<^sub>r Q"
      by (metis (no_types) RA1 assms(2) rea_no_RR rea_skip_unit(2) rrel_theory.Star_def wp_rea_def)
    then show ?thesis
      by (simp add: calculation ustar_def wp_rea_UINF_ind)
  qed
  finally show ?thesis .
qed

lemma wp_rea_R2_closed [closure]:
  "\<lbrakk> P is R2; Q is R2 \<rbrakk> \<Longrightarrow> P wp\<^sub>r Q is R2"
  by (simp add: wp_rea_def closure)

lemma wp_rea_false_RC1': "P is R2 \<Longrightarrow> RC1(P wp\<^sub>r false) = P wp\<^sub>r false"
  by (simp add: wp_rea_def RC1_def closure rpred seqr_assoc)

lemma wp_rea_false_RC1: "P is R2 \<Longrightarrow> P wp\<^sub>r false is RC1"
  by (simp add :Healthy_def wp_rea_false_RC1')

lemma wp_rea_false_RR:
  "\<lbrakk> $ok \<sharp> P; $wait \<sharp> P; P is R2 \<rbrakk> \<Longrightarrow> P wp\<^sub>r false is RR"
  by (rule RR_R2_intro, simp_all add: unrest closure)

lemma wp_rea_false_RC:
  "\<lbrakk> $ok \<sharp> P; $wait \<sharp> P; P is R2 \<rbrakk> \<Longrightarrow> P wp\<^sub>r false is RC"
  by (rule RC_intro', simp_all add:  wp_rea_false_RC1 wp_rea_false_RR)

lemma wp_rea_RC1: "\<lbrakk> P is RR; Q is RC \<rbrakk> \<Longrightarrow> P wp\<^sub>r Q is RC1"
  by (rule Healthy_intro, simp add: wp_rea_def RC1_def rpred closure seqr_assoc RC1_prop RC_implies_RC1)

lemma wp_rea_RC [closure]: "\<lbrakk> P is RR; Q is RC \<rbrakk> \<Longrightarrow> P wp\<^sub>r Q is RC"
  by (rule RC_intro', simp_all add: wp_rea_RC1 closure)

lemma wpR_power_RC_closed [closure]:
  assumes "P is RR" "Q is RC"
  shows "P \<^bold>^ i wp\<^sub>r Q is RC"
  by (metis RC_implies_RR RR_implies_R1 assms power.power_eq_if power_Suc_RR_closed wp_rea_RC wp_rea_skip)

end


section \<open>Syntax\<close>

theory Syntax imports List_Syntax begin

subsection \<open>Terms and Formulas\<close>

datatype tm
  = Var nat (\<open>\<^bold>#\<close>)
  | Fun nat \<open>tm list\<close> (\<open>\<^bold>\<dagger>\<close>)

datatype fm
  = Falsity (\<open>\<^bold>\<bottom>\<close>)
  | Pre nat \<open>tm list\<close> (\<open>\<^bold>\<ddagger>\<close>)
  | Imp fm fm (infixr \<open>\<^bold>\<longrightarrow>\<close> 55)
  | Uni fm (\<open>\<^bold>\<forall>\<close>)

type_synonym sequent = \<open>fm list \<times> fm list\<close>

subsubsection \<open>Substitution\<close>

primrec add_env :: \<open>'a \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a\<close> (infix \<open>\<Zsemi>\<close> 0) where
  \<open>(t \<Zsemi> s) 0 = t\<close>
| \<open>(t \<Zsemi> s) (Suc n) = s n\<close>

primrec lift_tm :: \<open>tm \<Rightarrow> tm\<close> where
  \<open>lift_tm (\<^bold>#n) = \<^bold>#(n+1)\<close>
| \<open>lift_tm (\<^bold>\<dagger>f ts) = \<^bold>\<dagger>f (map lift_tm ts)\<close>

primrec sub_tm :: \<open>(nat \<Rightarrow> tm) \<Rightarrow> tm \<Rightarrow> tm\<close> where
  \<open>sub_tm s (\<^bold>#n) = s n\<close>
| \<open>sub_tm s (\<^bold>\<dagger>f ts) = \<^bold>\<dagger>f (map (sub_tm s) ts)\<close>

primrec sub_fm :: \<open>(nat \<Rightarrow> tm) \<Rightarrow> fm \<Rightarrow> fm\<close> where
  \<open>sub_fm _ \<^bold>\<bottom> = \<^bold>\<bottom>\<close>
| \<open>sub_fm s (\<^bold>\<ddagger>P ts) = \<^bold>\<ddagger>P (map (sub_tm s) ts)\<close>
| \<open>sub_fm s (p \<^bold>\<longrightarrow> q) = sub_fm s p \<^bold>\<longrightarrow> sub_fm s q\<close>
| \<open>sub_fm s (\<^bold>\<forall>p) = \<^bold>\<forall>(sub_fm (\<^bold>#0 \<Zsemi> \<lambda>n. lift_tm (s n)) p)\<close>

abbreviation inst_single :: \<open>tm \<Rightarrow> fm \<Rightarrow> fm\<close> (\<open>\<langle>_\<rangle>\<close>) where
  \<open>\<langle>t\<rangle> \<equiv> sub_fm (t \<Zsemi> \<^bold>#)\<close>

subsubsection \<open>Variables\<close>

primrec vars_tm :: \<open>tm \<Rightarrow> nat list\<close> where
  \<open>vars_tm (\<^bold>#n) = [n]\<close>
| \<open>vars_tm (\<^bold>\<dagger>_ ts) = concat (map vars_tm ts)\<close>

primrec vars_fm :: \<open>fm \<Rightarrow> nat list\<close> where
  \<open>vars_fm \<^bold>\<bottom> = []\<close>
| \<open>vars_fm (\<^bold>\<ddagger>_ ts) = concat (map vars_tm ts)\<close>
| \<open>vars_fm (p \<^bold>\<longrightarrow> q) = vars_fm p @ vars_fm q\<close>
| \<open>vars_fm (\<^bold>\<forall>p) = vars_fm p\<close>

primrec max_list :: \<open>nat list \<Rightarrow> nat\<close> where
  \<open>max_list [] = 0\<close>
| \<open>max_list (x # xs) = max x (max_list xs)\<close>

lemma max_list_append: \<open>max_list (xs @ ys) = max (max_list xs) (max_list ys)\<close>
  by (induct xs) auto

lemma max_list_concat: \<open>xs [\<in>] xss \<Longrightarrow> max_list xs \<le> max_list (concat xss)\<close>
  by (induct xss) (auto simp: max_list_append)

lemma max_list_in: \<open>max_list xs < n \<Longrightarrow> n [\<notin>] xs\<close>
  by (induct xs) auto

definition vars_fms :: \<open>fm list \<Rightarrow> nat list\<close> where
  \<open>vars_fms A \<equiv> concat (map vars_fm A)\<close>

lemma vars_fms_member: \<open>p [\<in>] A \<Longrightarrow> vars_fm p [\<subseteq>] vars_fms A\<close>
  unfolding vars_fms_def by (induct A) auto

lemma max_list_mono: \<open>A [\<subseteq>] B \<Longrightarrow> max_list A \<le> max_list B\<close>
  by (induct A) (simp, metis linorder_not_le list.set_intros(1) max.absorb2 max.absorb3
      max_list.simps(2) max_list_in set_subset_Cons subset_code(1))

lemma max_list_vars_fms:
  assumes \<open>max_list (vars_fms A) \<le> n\<close> \<open>p [\<in>] A\<close>
  shows \<open>max_list (vars_fm p) \<le> n\<close>
  using assms max_list_mono vars_fms_member by (meson dual_order.trans)

definition fresh :: \<open>fm list \<Rightarrow> nat\<close> where
  \<open>fresh A \<equiv> Suc (max_list (vars_fms A))\<close>

subsection \<open>Rules\<close>

datatype rule =
  Idle | Axiom nat \<open>tm list\<close> | FlsL | FlsR | ImpL fm fm | ImpR fm fm | UniL tm fm | UniR fm

end


theory Tut10
  imports "HOL-IMP.VCG" "HOL-IMP.Hoare_Sound_Complete" "HOL-IMP.Hoare_Total"
begin

bundle ACOM begin
no_notation SKIP ("SKIP")
no_notation Assign ("_ ::= _" [1000, 61] 61)
no_notation Seq    ("_;;/ _"  [60, 61] 60)
no_notation If ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
notation Askip ("SKIP")
notation Aassign ("(_ ::= _)" [1000, 61] 61)
notation Aseq ("_;;/ _"  [60, 61] 60)
notation Aif ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
end

bundle COM begin
no_notation Askip ("SKIP")
no_notation Aassign ("(_ ::= _)" [1000, 61] 61)
no_notation Aseq ("_;;/ _"  [60, 61] 60)
no_notation Aif ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
notation SKIP ("SKIP")
notation Assign ("_ ::= _" [1000, 61] 61)
notation Seq    ("_;;/ _"  [60, 61] 60)
notation If ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
end

unbundle COM
definition MUL :: com where
"MUL =
  ''z''::=N 0;;
  ''c''::=N 0;;
  WHILE (Less (V ''c'') (V ''y'')) DO (
    ''z''::=Plus (V ''z'') (V ''x'');;
    ''c''::=Plus (V ''c'') (N 1))"

unbundle ACOM

abbreviation "MUL_invar sorig s \<equiv> s ''z'' = s ''c'' * s ''x'' \<and> s ''c'' \<le> s ''y'' \<and> (\<forall>v. v\<notin>{''z'',''c''} \<longrightarrow> s v = sorig v)"

definition MUL_annot :: "state \<Rightarrow> acom" where
"MUL_annot sorig =
  ''z''::=N 0;;
  ''c''::=N 0;;
  {MUL_invar sorig} WHILE (Less (V ''c'') (V ''y'')) DO (
    ''z''::=Plus (V ''z'') (V ''x'');;
    ''c''::=Plus (V ''c'') (N 1))"

lemma MUL_annot_same: "strip (MUL_annot sorig) = MUL"
  unfolding MUL_annot_def MUL_def by auto

theorem MUL_partially_correct:
"\<turnstile> {\<lambda>s. 0 \<le> s ''y'' \<and> s=sorig}
     MUL
   {\<lambda>s. s ''z'' = s ''x'' * s ''y'' \<and> (\<forall>v. v\<notin>{''z'',''c''} \<longrightarrow> s v = sorig v)}"
  unfolding MUL_annot_same[symmetric, of sorig]
  apply (rule vc_sound')
  unfolding MUL_annot_def
  by (simp add: algebra_simps | fastforce)+

unbundle COM

definition SQRT :: com where
"SQRT =
  ''r'' ::= N 0;;
  ''s'' ::= N 1;;
  WHILE (Not (Less (V ''x'') (V ''s''))) DO (
    ''r'' ::= Plus (V ''r'') (N 1);;
    ''s'' ::= Plus (V ''s'') (V ''r'');;
    ''s'' ::= Plus (V ''s'') (V ''r'');;
    ''s'' ::= Plus (V ''s'') (N 1)
  )"

unbundle ACOM

abbreviation "SQRT_invar sorig s \<equiv>
s ''r'' \<ge> 0
\<and> s ''s'' \<ge> 0
\<and> (s ''r'' + 1)^2 = s ''s''
\<and> (s ''r'')^2 \<le> s ''x''
\<and> (\<forall>v. v\<notin>{''s'',''r''} \<longrightarrow> s v = sorig v)"

definition SQRT_annot :: "state \<Rightarrow> acom" where
"SQRT_annot sorig =
  ''r'' ::= N 0;;
  ''s'' ::= N 1;;
  {SQRT_invar sorig} WHILE (Not (Less (V ''x'') (V ''s''))) DO (
    ''r'' ::= Plus (V ''r'') (N 1);;
    ''s'' ::= Plus (V ''s'') (V ''r'');;
    ''s'' ::= Plus (V ''s'') (V ''r'');;
    ''s'' ::= Plus (V ''s'') (N 1)
  )"

lemma SQRT_annot_strip: "strip (SQRT_annot sorig) = SQRT"
  unfolding SQRT_annot_def SQRT_def by auto

thm power2_eq_square

theorem SQRT_partially_correct:
"\<turnstile> {\<lambda>s. s=sorig \<and> s ''x'' \<ge> 0}
     SQRT
   {\<lambda>s. (s ''r'')^2 \<le> s ''x'' \<and> s ''x'' < (s ''r''+1)^2 \<and> (\<forall>v. v\<notin>{''s'',''r''} \<longrightarrow> s v = sorig v)}"
  unfolding SQRT_annot_strip[symmetric, of sorig]
  apply (rule vc_sound')
  unfolding SQRT_annot_def
  by (simp add: algebra_simps power2_eq_square | fastforce)+

lemmas Seq_bwd = Hoare_Total.Seq[rotated]

unbundle COM

lemma IfT:
  assumes "\<turnstile>\<^sub>t {P1} c\<^sub>1 {Q}"
      and "\<turnstile>\<^sub>t {P2} c\<^sub>2 {Q}"
    shows "\<turnstile>\<^sub>t {\<lambda>s. (bval b s \<longrightarrow> P1 s) \<and> (\<not> bval b s \<longrightarrow> P2 s)} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"
  by (auto intro: If conseq assms)
(*
  apply (rule If)
   apply (rule conseq)
     defer
     apply(rule assms(1))
    apply simp
   apply (rule conseq)
  defer
     apply (rule assms(2))
    apply simp+
  done
*)

lemmas hoareT_rule[intro?] = Seq_bwd Hoare_Total.Assign Hoare_Total.Assign' IfT

theorem MUL_totally_correct:
"\<turnstile>\<^sub>t {\<lambda>s. 0 \<le> s ''y'' \<and> s=sorig}
      MUL
    {\<lambda>s. s ''z'' = s ''x'' * s ''y'' \<and> (\<forall>v. v\<notin>{''z'',''c''} \<longrightarrow> s v = sorig v)}"
  unfolding MUL_def
  by(rule hoareT_rule While_fun'[where P="MUL_invar sorig" and f="\<lambda>s. nat (s ''y'' - s ''c'')"]
      | simp add: algebra_simps | fastforce)+

theorem SQRT_totally_correct:
"\<turnstile>\<^sub>t {\<lambda>s. s=sorig \<and> s ''x'' \<ge> 0}
      SQRT
    {\<lambda>s. (s ''r'')^2 \<le> s ''x'' \<and> s ''x'' < (s ''r''+1)^2 \<and> (\<forall>v. v\<notin>{''s'',''r''} \<longrightarrow> s v = sorig v)}"
  unfolding SQRT_def
  by(rule hoareT_rule While_fun'[where P="SQRT_invar sorig" and f="\<lambda>s. nat (s ''x'' - s ''r''^2)"]
      | simp add: algebra_simps power2_eq_square | fastforce)+

end


(* Sebastian Reiche and Christoph Benzmüller, 2021 *)
theory PAL_WiseMenPuzzle imports PAL_definitions

begin
 (* Parameter settings *)
 declare [[smt_solver=cvc4,smt_oracle,smt_timeout=120]]

 (*** Encoding of the wise men puzzle in PAL ***)
 consts a::"\<alpha>" b::"\<alpha>" c::"\<alpha>" (* Agents modeled as accessibility relations *)
 abbreviation  Agent::"\<alpha>\<Rightarrow>bool" ("\<A>") where "\<A> x \<equiv> x = a \<or> x = b \<or> x = c"
 axiomatization where  group_S5: "S5Agents \<A>"

 (* Common knowledge: At least one of a, b and c has a white spot *)
 consts ws::"\<alpha>\<Rightarrow>\<sigma>"
 axiomatization where WM1: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^sup>Aws a \<^bold>\<or> \<^sup>Aws b \<^bold>\<or> \<^sup>Aws c)\<^bold>\<rfloor>"
 axiomatization where
   (* Common knowledge: If x does not have a white spot then y know this *)
   WM2ab: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ac: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ba: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2bc: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2ca: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>" and
   WM2cb: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>"

 (* Positive introspection principles are implied *)
 lemma WM2ab': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> \<^bold>K\<^sub>b (\<^sup>Aws a))\<^bold>\<rfloor>" using WM2ab group_S5 unfolding Defs by metis
 lemma WM2ac': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> \<^bold>K\<^sub>c (\<^sup>Aws a))\<^bold>\<rfloor>" using WM2ac group_S5 unfolding Defs by metis
 lemma WM2ba': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> \<^bold>K\<^sub>a (\<^sup>Aws b))\<^bold>\<rfloor>" using WM2ba group_S5 unfolding Defs by metis
 lemma WM2bc': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> \<^bold>K\<^sub>c (\<^sup>Aws b))\<^bold>\<rfloor>" using WM2bc group_S5 unfolding Defs by metis
 lemma WM2ca': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> \<^bold>K\<^sub>a (\<^sup>Aws c))\<^bold>\<rfloor>" using WM2ca group_S5 unfolding Defs by metis
 lemma WM2cb': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> \<^bold>K\<^sub>b (\<^sup>Aws c))\<^bold>\<rfloor>" using WM2cb group_S5 unfolding Defs by metis

 (* Automated solutions of the Wise Men Puzzle *)
 theorem whitespot_c: "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>a(\<^sup>Aws a)\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>b(\<^sup>Aws b)\<^bold>](\<^bold>K\<^sub>c (\<^sup>Aws c)))\<^bold>\<rfloor>"
   using WM1 WM2ba WM2ca WM2cb unfolding Defs by (smt (verit))

 theorem whitespot_c':
   "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>a (\<^sup>Aws a)) \<^bold>\<or> (\<^bold>K\<^sub>a (\<^bold>\<not>\<^sup>Aws a)))\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>b (\<^sup>Aws b)) \<^bold>\<or> (\<^bold>K\<^sub>b (\<^bold>\<not>\<^sup>Aws b)))\<^bold>](\<^bold>K\<^sub>c (\<^sup>Aws c)))\<^bold>\<rfloor>"
   using WM1 WM2ba WM2ca WM2cb unfolding Defs by (smt (verit))

 (* Consistency confirmed by nitpick *)
 lemma True nitpick [satisfy,show_all] oops  (* model found *)
end


section \<open>Structures\<close>

text \<open>Collection of various structure definitions.\<close>

theory Structures_Old
imports Object_Old

begin

subsection \<open>Various basic structure templates\<close>

text \<open>Structures with a distinguished element.\<close>

object Pointed "name::set" "A::set"
  is "\<lparr> (base name). base: element A \<rparr>"

text \<open>Structures with binary operation.\<close>

object Binop_Equipped "name::set" "A::set"
  is "\<lparr> (op name). op: element (A \<rightarrow> A \<rightarrow> A) \<rparr>"

declare Pointed_def [typedef] Binop_Equipped_def [typedef]

subsection \<open>Plus (additive binop) structures\<close>

definition Plus :: "set \<Rightarrow> set type"
  where [typeclass]: "Plus A \<equiv> Binop_Equipped @plus A"

lemma Plus_typeI:
  "struct[@plus]: element (A \<rightarrow> A \<rightarrow> A) \<Longrightarrow> struct: Plus A"
  unfolding Plus_def Binop_Equipped_def by unfold_types (simp add: object_simps)

lemma Plus_plus_type [derive]:
  "struct: Plus A \<Longrightarrow> struct[@plus]: element (A \<rightarrow> A \<rightarrow> A)"
  unfolding Plus_def Binop_Equipped_def by unfold_types (simp add: object_simps)

definition plus :: "set \<Rightarrow> set \<Rightarrow> set \<Rightarrow> set"
  where "plus p = (\<lambda>x y. p[@plus] `x `y)"

lemma plus_type [type]: "plus: Plus A \<Rightarrow> element A \<Rightarrow> element A \<Rightarrow> element A"
  sorry

abbreviation plus_implicit :: "set \<Rightarrow> set \<Rightarrow> set" (infixl "+" 65)
  where "x + y \<equiv> plus \<implicit>M x y"

subsection \<open>Times (multiplicative binop) structures\<close>

definition Times :: "set \<Rightarrow> set type"
  where [typeclass]: "Times A \<equiv> Binop_Equipped @times A"

lemma Times_typeI:
  "struct[@times]: element (A \<rightarrow> A \<rightarrow> A) \<Longrightarrow> struct: Times A"
  unfolding Times_def Binop_Equipped_def by unfold_types (simp add: object_simps)

lemma Times_times_type [derive]:
  "struct: Times A \<Longrightarrow> struct[@times]: element (A \<rightarrow> A \<rightarrow> A)"
  unfolding Times_def Binop_Equipped_def by unfold_types (simp add: object_simps)

definition times :: "set \<Rightarrow> set \<Rightarrow> set \<Rightarrow> set"
  where "times p = (\<lambda>x y. p[@times] `x `y)"

lemma times_type [type]: "times: (P: Times A) \<Rightarrow> element A \<Rightarrow> element A \<Rightarrow> element A"
  unfolding times_def oops

abbreviation times_implicit :: "set \<Rightarrow> set \<Rightarrow> set" (infixl "\<cdot>" 65)
  where "x \<cdot> y \<equiv> times \<implicit>M x y"

subsection \<open>"Zero" and "one" structures\<close>

text \<open>Just structures with distinguished elements of their carriers.\<close>

definition Zero :: \<open>set \<Rightarrow> set type\<close>
  where [typeclass]: "Zero A = Pointed @zero A"

lemma Zero_typeI: "struct[@zero]: element A \<Longrightarrow> struct: Zero A"
  unfolding Zero_def Pointed_def by unfold_types (simp add: object_simps)

lemma Zero_zero_type [derive]: "struct: Zero A \<Longrightarrow> struct[@zero]: element A"
  unfolding Zero_def Pointed_def by unfold_types (simp add: object_simps)

definition zero :: "set \<Rightarrow> set"
  where "zero struct = struct[@zero]"

lemma zero_type [type]: "zero: (struct: Zero A) \<Rightarrow> element A"
  unfolding zero_def by discharge_types

abbreviation zero_implicit :: "set" ("0")
  where "0 \<equiv> zero \<implicit>struct"

definition One :: \<open>set \<Rightarrow> set type\<close>
  where [typeclass]: "One A = Pointed @one A"

lemma One_typeI: "struct[@one]: element A \<Longrightarrow> struct: One A"
  unfolding One_def Pointed_def by unfold_types (simp add: object_simps)

lemma One_one_type [derive]: "struct: One A \<Longrightarrow> struct[@one]: element A"
  unfolding One_def Pointed_def by unfold_types (simp add: object_simps)

definition one :: "set \<Rightarrow> set"
  where "one struct = struct[@one]"

lemma one_type [type]: "one: (struct: One A) \<Rightarrow> element A"
  unfolding one_def by discharge_types

abbreviation one_implicit :: "set" ("1")
  where "1 \<equiv> one \<implicit>struct"

end