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

section {*Absoluteness for the Definable Powerset Function*}

theory DPow_absolute imports Satisfies_absolute begin

subsection{*Preliminary Internalizations*}

subsubsection{*The Operator @{term is_formula_rec}*}

text{*The three arguments of @{term p} are always 2, 1, 0.  It is buried
   within 11 quantifiers!!*}

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

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

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

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

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

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

subsubsection{*The Operator @{term is_satisfies}*}

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

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

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

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

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 {*Relativization of the Operator @{term DPow'}*}

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

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

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

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

subsubsection{*The Operator @{term is_DPow_sats}, Internalized*}

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

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

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

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

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

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

subsection{*A Locale for Relativizing the Operator @{term DPow'}*}

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

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

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

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

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

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

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

subsection{*Instantiating the Locale @{text M_DPow}*}

subsubsection{*The Instance of Separation*}

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

subsubsection{*The Instance of Replacement*}

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

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

subsubsection{*Actually Instantiating the Locale*}

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: "PROP 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{*The Operator @{term is_Collect}*}

text{*The formula @{term is_P} has one free variable, 0, and it is
enclosed within a single quantifier.*}

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

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

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

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

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

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

subsubsection{*The Operator @{term is_Replace}*}

text{*BEWARE!  The formula @{term is_P} has free variables 0, 1
 and not the usual 1, 0!  It is enclosed within two quantifiers.*}

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

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

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

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

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

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

subsubsection{*The Operator @{term is_DPow'}, Internalized*}

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

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

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

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

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

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{*A Locale for Relativizing the Operator @{term Lset}*}

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

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

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

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

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

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

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

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

text{*Relativization of the Operator @{term Lset}*}

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

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

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

subsection{*Instantiating the Locale @{text M_Lset}*}

subsubsection{*The First Instance of Replacement*}

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

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

subsubsection{*The Second Instance of Replacement*}

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

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

subsubsection{*Actually Instantiating @{text M_Lset}*}

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

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

text{*Finally: the point of the whole theory!*}
lemmas Lset_closed = M_Lset.Lset_closed [OF M_Lset_L]
   and Lset_abs = M_Lset.Lset_abs [OF M_Lset_L]

subsection{*The Notion of Constructible Set*}

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

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

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Set_F_cpo
imports Set_F CPO
begin

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

         1. Set_F is a pointed cpo.
         2.
         3.
         4.

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

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(*********************************************************
                      Bottom in Set_T
 *********************************************************)
(*
instance setF :: (type) bot0
by (intro_classes)
*)

instantiation setF :: (type) bot0
begin

definition
  bottom_setF_def : "Bot == {}f"
instance ..
end

(*

defs (overloaded)
  bottom_setF_def : "Bot == {}f"
*)

lemma bottom_setF : "ALL (F::'a setF). Bot <= F"
by (simp add: bottom_setF_def)

instance setF :: (type) bot
apply (intro_classes)
by (simp add: bottom_setF)

(**********************************************************
      lemmas used in a proof that set_F is a cpo.
 **********************************************************)

(* UnionF Fs is an upper bound of Fs *)

lemma UnionF_isUB : "(UnionF Fs) isUB Fs"
apply (simp add: isUB_def)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (rule_tac x=y in bexI)
by (auto)

(* UnionF Fs is the least upper bound of Fs *)

lemma UnionF_isLUB : "UnionF Fs isLUB Fs"
apply (simp add: isLUB_def UnionF_isUB)
apply (simp add: isUB_def)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (erule bexE)
apply (drule_tac x="F" in spec)
by (simp)

(* the least upper bound of Fs is UnionF Fs *)

lemma isLUB_UnionF_only_if: "F isLUB Fs ==> F = UnionF Fs"
apply (insert UnionF_isLUB[of Fs])
apply (rule LUB_unique)
by (simp_all)

(* iff *)

lemma isLUB_UnionF : "(F isLUB Fs) = (F = UnionF Fs)"
apply (rule iffI)
apply (simp add: isLUB_UnionF_only_if)
apply (simp add: UnionF_isLUB)
done

(* LUB is UnionF Fs *)

lemma LUB_UnionF : "LUB Fs = UnionF Fs"
by (simp add: isLUB_LUB UnionF_isLUB)

(**********************************************************
                 ( setF, <= ) is a CPO
 **********************************************************)

instance setF :: (type) cpo
apply (intro_classes)
apply (simp add: hasLUB_def)
apply (rule_tac x="UnionF X" in exI)
apply (simp add: directed_def UnionF_isLUB)
done

(**********************************************************
              ( setF, <= ) is a pointed CPO
 **********************************************************)

instance setF :: (type) cpo_bot
by (intro_classes)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
end


(*  Title:      ZF/Resid/Reduction.thy
    Author:     Ole Rasmussen
    Copyright   1995  University of Cambridge
*)

theory Reduction imports Residuals begin

(**** Lambda-terms ****)

consts
  lambda        :: "i"
  unmark        :: "i=>i"

abbreviation
  Apl :: "[i,i]=>i" where
  "Apl(n,m) == App(0,n,m)"

inductive
  domains       "lambda" \<subseteq> redexes
  intros
    Lambda_Var:  "               n \<in> nat ==>     Var(n) \<in> lambda"
    Lambda_Fun:  "            u \<in> lambda ==>     Fun(u) \<in> lambda"
    Lambda_App:  "[|u \<in> lambda; v \<in> lambda|] ==> Apl(u,v) \<in> lambda"
  type_intros    redexes.intros bool_typechecks

declare lambda.intros [intro]

primrec
  "unmark(Var(n)) = Var(n)"
  "unmark(Fun(u)) = Fun(unmark(u))"
  "unmark(App(b,f,a)) = Apl(unmark(f), unmark(a))"

declare lambda.intros [simp]
declare lambda.dom_subset [THEN subsetD, simp, intro]

(* ------------------------------------------------------------------------- *)
(*        unmark lemmas                                                      *)
(* ------------------------------------------------------------------------- *)

lemma unmark_type [intro, simp]:
     "u \<in> redexes ==> unmark(u) \<in> lambda"
by (erule redexes.induct, simp_all)

lemma lambda_unmark: "u \<in> lambda ==> unmark(u) = u"
by (erule lambda.induct, simp_all)

(* ------------------------------------------------------------------------- *)
(*         lift and subst preserve lambda                                    *)
(* ------------------------------------------------------------------------- *)

lemma liftL_type [rule_format]:
     "v \<in> lambda ==> \<forall>k \<in> nat. lift_rec(v,k) \<in> lambda"
by (erule lambda.induct, simp_all add: lift_rec_Var)

lemma substL_type [rule_format, simp]:
     "v \<in> lambda ==>  \<forall>n \<in> nat. \<forall>u \<in> lambda. subst_rec(u,v,n) \<in> lambda"
by (erule lambda.induct, simp_all add: liftL_type subst_Var)

(* ------------------------------------------------------------------------- *)
(*        type-rule for reduction definitions                               *)
(* ------------------------------------------------------------------------- *)

lemmas red_typechecks = substL_type nat_typechecks lambda.intros
                        bool_typechecks

consts
  Sred1     :: "i"
  Sred      :: "i"
  Spar_red1 :: "i"
  Spar_red  :: "i"

abbreviation
  Sred1_rel (infixl "-1->" 50) where
  "a -1-> b == <a,b> \<in> Sred1"

abbreviation
  Sred_rel (infixl "-\<longrightarrow>" 50) where
  "a -\<longrightarrow> b == <a,b> \<in> Sred"

abbreviation
  Spar_red1_rel (infixl "=1=>" 50) where
  "a =1=> b == <a,b> \<in> Spar_red1"

abbreviation
  Spar_red_rel (infixl "===>" 50) where
  "a ===> b == <a,b> \<in> Spar_red"

inductive
  domains       "Sred1" \<subseteq> "lambda*lambda"
  intros
    beta:       "[|m \<in> lambda; n \<in> lambda|] ==> Apl(Fun(m),n) -1-> n/m"
    rfun:       "[|m -1-> n|] ==> Fun(m) -1-> Fun(n)"
    apl_l:      "[|m2 \<in> lambda; m1 -1-> n1|] ==> Apl(m1,m2) -1-> Apl(n1,m2)"
    apl_r:      "[|m1 \<in> lambda; m2 -1-> n2|] ==> Apl(m1,m2) -1-> Apl(m1,n2)"
  type_intros    red_typechecks

declare Sred1.intros [intro, simp]

inductive
  domains       "Sred" \<subseteq> "lambda*lambda"
  intros
    one_step:   "m-1->n ==> m-\<longrightarrow>n"
    refl:       "m \<in> lambda==>m -\<longrightarrow>m"
    trans:      "[|m-\<longrightarrow>n; n-\<longrightarrow>p|] ==>m-\<longrightarrow>p"
  type_intros    Sred1.dom_subset [THEN subsetD] red_typechecks

declare Sred.one_step [intro, simp]
declare Sred.refl     [intro, simp]

inductive
  domains       "Spar_red1" \<subseteq> "lambda*lambda"
  intros
    beta:       "[|m =1=> m'; n =1=> n'|] ==> Apl(Fun(m),n) =1=> n'/m'"
    rvar:       "n \<in> nat ==> Var(n) =1=> Var(n)"
    rfun:       "m =1=> m' ==> Fun(m) =1=> Fun(m')"
    rapl:       "[|m =1=> m'; n =1=> n'|] ==> Apl(m,n) =1=> Apl(m',n')"
  type_intros    red_typechecks

declare Spar_red1.intros [intro, simp]

inductive
  domains "Spar_red" \<subseteq> "lambda*lambda"
  intros
    one_step:   "m =1=> n ==> m ===> n"
    trans:      "[|m===>n; n===>p|] ==> m===>p"
  type_intros    Spar_red1.dom_subset [THEN subsetD] red_typechecks

declare Spar_red.one_step [intro, simp]

(* ------------------------------------------------------------------------- *)
(*     Setting up rule lists for reduction                                   *)
(* ------------------------------------------------------------------------- *)

lemmas red1D1 [simp] = Sred1.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas red1D2 [simp] = Sred1.dom_subset [THEN subsetD, THEN SigmaD2]
lemmas redD1 [simp] = Sred.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas redD2 [simp] = Sred.dom_subset [THEN subsetD, THEN SigmaD2]

lemmas par_red1D1 [simp] = Spar_red1.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas par_red1D2 [simp] = Spar_red1.dom_subset [THEN subsetD, THEN SigmaD2]
lemmas par_redD1 [simp] = Spar_red.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas par_redD2 [simp] = Spar_red.dom_subset [THEN subsetD, THEN SigmaD2]

declare bool_typechecks [intro]

inductive_cases  [elim!]: "Fun(t) =1=> Fun(u)"

(* ------------------------------------------------------------------------- *)
(*     Lemmas for reduction                                                  *)
(* ------------------------------------------------------------------------- *)

lemma red_Fun: "m-\<longrightarrow>n ==> Fun(m) -\<longrightarrow> Fun(n)"
apply (erule Sred.induct)
apply (rule_tac [3] Sred.trans, simp_all)
done

lemma red_Apll: "[|n \<in> lambda; m -\<longrightarrow> m'|] ==> Apl(m,n)-\<longrightarrow>Apl(m',n)"
apply (erule Sred.induct)
apply (rule_tac [3] Sred.trans, simp_all)
done

lemma red_Aplr: "[|n \<in> lambda; m -\<longrightarrow> m'|] ==> Apl(n,m)-\<longrightarrow>Apl(n,m')"
apply (erule Sred.induct)
apply (rule_tac [3] Sred.trans, simp_all)
done

lemma red_Apl: "[|m -\<longrightarrow> m'; n-\<longrightarrow>n'|] ==> Apl(m,n)-\<longrightarrow>Apl(m',n')"
apply (rule_tac n = "Apl (m',n) " in Sred.trans)
apply (simp_all add: red_Apll red_Aplr)
done

lemma red_beta: "[|m \<in> lambda; m':lambda; n \<in> lambda; n':lambda; m -\<longrightarrow> m'; n-\<longrightarrow>n'|] ==>
               Apl(Fun(m),n)-\<longrightarrow> n'/m'"
apply (rule_tac n = "Apl (Fun (m'),n') " in Sred.trans)
apply (simp_all add: red_Apl red_Fun)
done

(* ------------------------------------------------------------------------- *)
(*      Lemmas for parallel reduction                                        *)
(* ------------------------------------------------------------------------- *)

lemma refl_par_red1: "m \<in> lambda==> m =1=> m"
by (erule lambda.induct, simp_all)

lemma red1_par_red1: "m-1->n ==> m=1=>n"
by (erule Sred1.induct, simp_all add: refl_par_red1)

lemma red_par_red: "m-\<longrightarrow>n ==> m===>n"
apply (erule Sred.induct)
apply (rule_tac [3] Spar_red.trans)
apply (simp_all add: refl_par_red1 red1_par_red1)
done

lemma par_red_red: "m===>n ==> m-\<longrightarrow>n"
apply (erule Spar_red.induct)
apply (erule Spar_red1.induct)
apply (rule_tac [5] Sred.trans)
apply (simp_all add: red_Fun red_beta red_Apl)
done

(* ------------------------------------------------------------------------- *)
(*      Simulation                                                           *)
(* ------------------------------------------------------------------------- *)

lemma simulation: "m=1=>n ==> \<exists>v. m|>v = n & m \<sim> v & regular(v)"
by (erule Spar_red1.induct, force+)

(* ------------------------------------------------------------------------- *)
(*           commuting of unmark and subst                                   *)
(* ------------------------------------------------------------------------- *)

lemma unmmark_lift_rec:
     "u \<in> redexes ==> \<forall>k \<in> nat. unmark(lift_rec(u,k)) = lift_rec(unmark(u),k)"
by (erule redexes.induct, simp_all add: lift_rec_Var)

lemma unmmark_subst_rec:
 "v \<in> redexes ==> \<forall>k \<in> nat. \<forall>u \<in> redexes.
                  unmark(subst_rec(u,v,k)) = subst_rec(unmark(u),unmark(v),k)"
by (erule redexes.induct, simp_all add: unmmark_lift_rec subst_Var)

(* ------------------------------------------------------------------------- *)
(*        Completeness                                                       *)
(* ------------------------------------------------------------------------- *)

lemma completeness_l [rule_format]:
     "u \<sim> v ==> regular(v) \<longrightarrow> unmark(u) =1=> unmark(u|>v)"
apply (erule Scomp.induct)
apply (auto simp add: unmmark_subst_rec)
done

lemma completeness: "[|u \<in> lambda; u \<sim> v; regular(v)|] ==> u =1=> unmark(u|>v)"
by (drule completeness_l, simp_all add: lambda_unmark)

end


theory SepLogic_Misc
imports Imperative_HOL_Time.SLTC_More NREST.DataRefinement
begin

subsection \<open>Relators\<close>

definition nrest_rel where
  nres_rel_def_internal: "nrest_rel R \<equiv> {(c,a). c \<le> \<Down>R a}"

lemma nrest_rel_def: "\<langle>R\<rangle>nrest_rel \<equiv> {(c,a). c \<le> \<Down>R a}"
  by (simp add: nres_rel_def_internal relAPP_def)

lemma nrest_relD: "(c,a)\<in>\<langle>R\<rangle>nrest_rel \<Longrightarrow> c \<le>\<Down>R a" by (simp add: nrest_rel_def)
lemma nrest_relI: "c \<le>\<Down>R a \<Longrightarrow> (c,a)\<in>\<langle>R\<rangle>nrest_rel" by (simp add: nrest_rel_def)

lemma nrest_rel_comp: "\<langle>A\<rangle>nrest_rel O \<langle>B\<rangle>nrest_rel = \<langle>A O B\<rangle>nrest_rel"
  by (auto simp: nrest_rel_def conc_fun_chain[symmetric] conc_trans)

lemma pw_nrest_rel_iff: "(a,b)\<in>\<langle>A\<rangle>nrest_rel \<longleftrightarrow> nofailT (\<Down> A b) \<longrightarrow> nofailT a \<and> (\<forall>x t. inresT a x t \<longrightarrow> inresT (\<Down> A b) x t)"
  by (simp add: pw_le_iff nrest_rel_def)

lemma param_FAIL[param]: "(FAILT,FAILT) \<in> \<langle>R\<rangle>nrest_rel"
  by (auto simp: nrest_rel_def)

lemma param_RETURN[param]:
  "(RETURNT,RETURNT) \<in> R \<rightarrow> \<langle>R\<rangle>nrest_rel"
  by (auto simp: nrest_rel_def RETURNT_refine)

lemma param_bind[param]:
  "(bindT,bindT) \<in> \<langle>Ra\<rangle>nrest_rel \<rightarrow> (Ra\<rightarrow>\<langle>Rb\<rangle>nrest_rel) \<rightarrow> \<langle>Rb\<rangle>nrest_rel"
  by (auto simp: nrest_rel_def intro: bindT_refine dest: fun_relD)

end


theory Centralised_Model imports
  CryptHOL.CryptHOL
begin

sledgehammer_params[timeout = 1000]

type_synonym ('user', 'query_out') query = "'user' \<Rightarrow> 'query_out'"

type_synonym ('store_non_sens_sttrs', 'store_sens_attrs') govt_store_data = "'store_non_sens_sttrs' set \<times> 'store_sens_attrs' set"

locale centralised_id =
  fixes reg :: "'user \<Rightarrow> ('token \<times> ('store_non_sens_sttrs, 'store_sens_attrs) govt_store_data) spmf"
    and auth :: "'user \<Rightarrow> 'token \<Rightarrow> ('user, 'query_out) query  \<Rightarrow> 'auth_token spmf"
    and ver :: "'auth_token \<Rightarrow> 'query_out spmf"
    and valid_user :: "'user \<Rightarrow> bool"
    and valid_token :: "'token \<Rightarrow> bool"
    and valid_query :: "('user, 'query_out) query \<Rightarrow> bool"
    and users_attr_creation :: "'user \<Rightarrow> ('non_sens_attrs set \<times> 'sens_atrrs set)"
    and valid_non_sens_attrs :: "'non_sens_attrs set \<Rightarrow> bool"
    and valid_sens_attrs :: "'sens_atrrs set \<Rightarrow> bool"
  assumes lossless_reg_user: "lossless_spmf (reg user)"
begin

definition correct_game :: "'user \<Rightarrow> ('user, 'query_out) query  \<Rightarrow> bool spmf"
  where
    "correct_game user query = do {
      (token, govt_output) \<leftarrow> reg user;
      auth_token \<leftarrow> auth user token query;
      result \<leftarrow> ver auth_token;
      return_spmf (result = query user)}"

definition "correct \<longleftrightarrow> (\<forall> user query. valid_user user \<longrightarrow> valid_query query
                            \<longrightarrow> spmf (correct_game user query) True = 1)"

primrec sens_attrs_hiding_game :: "((('user \<times> 'user) \<times> 'state) spmf \<times> ('state \<Rightarrow> 'store_sens_attrs set \<Rightarrow> bool spmf)) \<Rightarrow> bool spmf"
  where
    "sens_attrs_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b \<leftarrow> coin_spmf;
      (token, (non_sens_attrs, sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> sens_attrs;
      return_spmf (b' = b)} ELSE coin_spmf"

definition "sens_attrs_hiding_advantage \ = \<bar>spmf (sens_attrs_hiding_game \) True - 1/2\<bar>"

definition "perfect_sens_attrs_hiding \ \<longleftrightarrow> sens_attrs_hiding_advantage \ = 0"

lemma no_sens_attrs_imp_perfect_sens_attrs_hiding:
  assumes "\<forall> user output. output \<in> set_spmf (reg user) \<longrightarrow> snd (snd (output)) = {}"
  shows "perfect_sens_attrs_hiding \"
proof-
  note [simp] = Let_def split_def
  have "\<bar>spmf (sens_attrs_hiding_game \) True - 1/2\<bar> = 0"
  proof-
    obtain \1 and \2 where \ [simp]: "\ = (\1, \2)" by(cases \)
    have "sens_attrs_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      (card, (store_non_sens_attrs, store_sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> store_sens_attrs;
      return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: sens_attrs_hiding_game_def)
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      (card, (store_non_sens_attrs, store_sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> {};
      return_spmf (b' = b)} ELSE coin_spmf"
      apply auto
      apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)+
      apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)
      using assms by auto
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b' \<leftarrow> \2 \<sigma> {};
      map_spmf((=) b') coin_spmf} ELSE coin_spmf"
      including monad_normalisation
      apply(simp add: bind_spmf_const lossless_reg_user lossless_weight_spmfD)
      by(simp add: map_spmf_conv_bind_spmf)
    also have "... = coin_spmf"
      by(auto simp add: bind_spmf_const map_eq_const_coin_spmf try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
    ultimately show ?thesis
      by(simp add: spmf_of_set)
  qed
  thus ?thesis
    by(simp add: perfect_sens_attrs_hiding_def sens_attrs_hiding_advantage_def)
qed

definition token_hiding_game :: "('user, 'query_out) query \<Rightarrow> (((('user \<times> 'user) \<times> 'state) spmf) \<times> ('state \<Rightarrow> 'token \<Rightarrow> bool spmf)) \<Rightarrow> bool spmf"
  where
    "token_hiding_game query \ = TRY do {
      let (\1, \2) = \;
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b \<leftarrow> coin_spmf;
      (token, (non_sens_attrs, sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> token;
      return_spmf (b = b')} ELSE coin_spmf"

definition "token_hiding_advantage query \ = (\<bar>spmf (token_hiding_game query \) True - 1/2\<bar>)"

definition "perfect_token_hiding \ \<longleftrightarrow> (\<forall> query. valid_query query \<longrightarrow> token_hiding_advantage query \ = 0)"

(*this property does not mean much*)

(*primrec auth_token_hiding_game :: "('user, 'query_out) query \<Rightarrow> (('token \<times> 'token) \<times> 's) spmf \<times> ('s \<Rightarrow> 'auth_token \<Rightarrow> bool spmf) \<Rightarrow> bool spmf"
  where
    "auth_token_hiding_game query (\1, \2) = TRY do {
      ((token0, token1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_token (token0 :: 'token) \<and> valid_token (token1 :: 'token));
      b :: bool \<leftarrow> coin_spmf;
      auth_token :: 'auth_token \<leftarrow> auth (if b then token0 else token1) query;
      b' :: bool \<leftarrow> \2 \<sigma> auth_token;
      return_spmf (b = b')} ELSE coin_spmf"

definition "auth_token_hiding_advantage \ query = \<bar>spmf (auth_token_hiding_game query \) True - 1/2\<bar>"

definition "auth_token_perfect_hiding \ \<longleftrightarrow> (\<forall> query. auth_token_hiding_advantage \ query = 0)"*)

definition user_binding_game :: "'user \<Rightarrow> ('user, 'query_out) query \<Rightarrow> ('token \<Rightarrow> 'token spmf) \<Rightarrow> bool spmf"
  where
    "user_binding_game user query \ = TRY do {
      (token1, govt_output) \<leftarrow> reg user;
      token2 \<leftarrow> \ token1;
      _ :: unit \<leftarrow> assert_spmf (valid_token token2);
      auth_token1 :: 'auth_token \<leftarrow> auth user token1 query;
      auth_token2 :: 'auth_token \<leftarrow> auth user token2 query;
      result1 :: 'query_out \<leftarrow> ver auth_token1;
      result2 \<leftarrow> ver auth_token2;
      return_spmf (result1 \<noteq> result2)} ELSE return_spmf False"

definition "user_binding_advantage user query \ = spmf (user_binding_game user query \) True"

definition "peferfect_user_binding \ \<longleftrightarrow> (\<forall> user query. user_binding_advantage user query \ = 0)"

primrec query_output_hiding_game :: "('user, 'query_out) query \<Rightarrow> ((('user \<times> 'user) \<times> 'state) spmf \<times> ('state \<Rightarrow> 'query_out \<Rightarrow> bool spmf))  \<Rightarrow> bool spmf"
  where
    "query_output_hiding_game query (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      (token, govt_output) \<leftarrow> reg (if b then user0 else user1);
      auth_token :: 'auth_token \<leftarrow> auth (if b then user0 else user1) token query;
      result :: 'query_out \<leftarrow> ver auth_token;
      b' \<leftarrow> \2 \<sigma> result;
      return_spmf (b = b')} ELSE return_spmf False"

definition "query_output_hiding_advantage query \ = spmf (query_output_hiding_game query \) True"

definition "perfect_query_output_hiding \ \<longleftrightarrow> (\<forall> query. valid_query query \<longrightarrow> query_output_hiding_advantage query \ = 0)"

end

end

(*locale centralised_id =
  fixes user_enc_reg_phase :: "'sens_atrrs set \<Rightarrow> 'enc_sens_atrrs set spmf"
  fixes govt_reg_phase :: "'attrs set \<Rightarrow> 'enc_sens_atrrs set \<Rightarrow> ('token \<times> ('store_non_sens_attrs, 'store_sens_attrs) govt_store_data) spmf"
    and auth :: "'token \<Rightarrow> ('user, 'query_out) query  \<Rightarrow> 'auth_token spmf"
    and ver :: "'auth_token \<Rightarrow> 'query_out spmf"
    and valid_user :: "'user \<Rightarrow> bool"
    and valid_query :: "('user, 'query_out) query \<Rightarrow> bool"
    and users_attr_creation :: "'user \<Rightarrow> ('attrs set \<times> 'sens_atrrs set)"
begin

definition reg :: "'user \<Rightarrow> ('token \<times> ('store_non_sens_attrs, 'store_sens_attrs) govt_store_data) spmf"
  where "reg user = do {
    let (non_sens_attrs, sens_attrs) = users_attr_creation user;
    enc_sens_attr \<leftarrow> user_enc_reg_phase sens_attrs;

definition correct_game :: "'user \<Rightarrow> ('user, 'query_out) query  \<Rightarrow> bool spmf"
  where
    "correct_game user query = do {
      (token, govt_output) \<leftarrow> reg user;
      auth_token \<leftarrow> auth token query;
      result \<leftarrow> ver auth_token;
      return_spmf (result = query user)}"

definition "correct \<longleftrightarrow> (\<forall> user query. valid_user user \<longrightarrow> valid_query query
                            \<longrightarrow> spmf (correct_game user query) True = 1)"

primrec sens_attrs_hiding_game :: "((('user \<times> 'user) \<times> 'state) spmf \<times> ('state \<Rightarrow> 'store_sens_attrs set \<Rightarrow> bool spmf)) \<Rightarrow> bool spmf"
  where
    "sens_attrs_hiding_game (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b \<leftarrow> coin_spmf;
      (card, (non_sens_attrs, sens_attrs)) \<leftarrow> reg (if b then user0 else user1);
      b' \<leftarrow> \2 \<sigma> sens_attrs;
      return_spmf (b' = b)} ELSE coin_spmf"

definition "sens_attrs_hiding_advantage \ = \<bar>spmf (sens_attrs_hiding_game \) True - 1/2\<bar>"

definition "perfect_sens_attrs_hiding \ \<longleftrightarrow> sens_attrs_hiding_advantage \ = 0"

definition "no_sens_attr \<longleftrightarrow> (\<forall> user. snd (users_attr_creation user) = {})"

lemma
  assumes "no_sens_attr"
  shows "perfect_sens_attrs_hiding' \"
  including monad_normalisation
proof-
  note [simp] = Let_def split_def
  have "\<bar>spmf (sens_attrs_hiding_game' \) True - 1/2\<bar> = 0"
  proof-
    obtain \1 and \2 where \ [simp]: "\ = (\1, \2)" by(cases \)
    have "sens_attrs_hiding_game' (\1, \2) = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      let (attrs, sens_attrs) = users_attr_creation (if b then user0 else user1);
      enc_attrs \<leftarrow> reg_enc_sens_attrs sens_attrs;
      (S, \<sigma>') \<leftarrow> reg_govt_shares attrs enc_attrs;
      b' \<leftarrow> \2 \<sigma> S;
      return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: sens_attrs_hiding_game_def reg_def bind_spmf_const lossless_reg_govt_token lossless_weight_spmfD)
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      let (attrs, sens_attrs) = users_attr_creation (if b then user0 else user1);
      enc_attrs \<leftarrow> reg_enc_sens_attrs {};
      (S, \<sigma>') \<leftarrow> reg_govt_shares attrs enc_attrs;
      b' \<leftarrow> \2 \<sigma> S;
      return_spmf (b' = b)} ELSE coin_spmf"
      using assms[unfolded no_sens_attr_def]
      by simp
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      let (attrs, sens_attrs) = users_attr_creation (if b then user0 else user1);
      enc_attrs \<leftarrow> reg_enc_sens_attrs {};
      (S, \<sigma>') \<leftarrow> reg_govt_shares attrs enc_attrs;
      b' \<leftarrow> \2 \<sigma> S;
      return_spmf (b' = b)} ELSE coin_spmf"

    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      b :: bool \<leftarrow> coin_spmf;
      enc_attrs_b \<leftarrow> reg_enc_sens_attrs {};
      b' :: bool \<leftarrow> \2 \<sigma> enc_attrs_b;
      return_spmf (b' = b)} ELSE coin_spmf"
      using assms[unfolded no_sens_attr_def]
      by simp
    also have "... = TRY do {
      ((user0, user1), \<sigma>) \<leftarrow> \1;
      _ :: unit \<leftarrow> assert_spmf (valid_user user0 \<and> valid_user user1);
      enc_attrs_b \<leftarrow> reg_enc_sens_attrs {};
      b' :: bool \<leftarrow> \2 \<sigma> enc_attrs_b;
      map_spmf((=) b') coin_spmf} ELSE coin_spmf"
      by(simp add: map_spmf_conv_bind_spmf)
    also have "... = coin_spmf"
      by(auto simp add: bind_spmf_const map_eq_const_coin_spmf try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
    ultimately show ?thesis
      by(simp add: spmf_of_set)
  qed
  thus ?thesis
    by(simp add: perfect_sens_attrs_hiding_def sens_attrs_hiding_advantage_def)
qed

end *)


section \<open> Grothendieck.thy \<close>

theory Grothendieck
imports Main Poset Prealgebra
begin

abbreviation d :: "('A set \<times> 'a)  \<Rightarrow> 'A set" where
"d Aa \<equiv> fst Aa"

abbreviation e :: "('A set \<times> 'a)  \<Rightarrow> 'a" where
"e Aa \<equiv> snd Aa"

definition gc :: "('A, 'a) Prealgebra \<Rightarrow> ('A set \<times> 'a) Poset" where
  "gc F \<equiv>
    \<lparr> Poset.el = { (A, a) . A \<in> opens (space F) \<and> a \<in> Poset.el (ob F \<cdot> A)},
      Poset.le_rel = { ((A, a), (B, b)) .
                     A \<in> opens (space F) \<and> B \<in> opens (space F)
                     \<and> a \<in> Poset.el (ob F \<cdot> A) \<and> b \<in> Poset.el (ob F \<cdot> B)
                     \<and> B \<subseteq> A \<and> Poset.le (ob F \<cdot> B) (ar F \<cdot> (Space.make_inc B A) \<star> a) b } \<rparr>"

lemma gc_elD [dest] : "a \<in> el (gc F) \<Longrightarrow> a = (d a, e a)"
  by simp

lemma gc_leI_raw : "A \<in> opens (space F) \<Longrightarrow> B \<in> opens (space F) \<Longrightarrow> B \<subseteq> A
\<Longrightarrow> a \<in> Poset.el (ob F \<cdot> A) \<Longrightarrow> b \<in> Poset.el (ob F \<cdot> B)
\<Longrightarrow> Poset.le (ob F \<cdot> B) ((ar F \<cdot> (Space.make_inc B A)) \<star> a) b \<Longrightarrow> Poset.le (gc F) (A,a) (B,b)"
  unfolding gc_def
  by simp

lemma gc_leI [intro] : "a \<in> el (gc F) \<Longrightarrow> b \<in> el (gc F) \<Longrightarrow> d
 b \<subseteq> d a \<Longrightarrow> Poset.le (ob F \<cdot> d b) ((ar F \<cdot> (Space.make_inc (d b) (d a))) \<star> e a) (e b) \<Longrightarrow> Poset.le (gc F) a b"
  unfolding gc_def
  apply clarsimp
  by force

lemma gc_leD [dest] : "a \<in> el (gc F) \<Longrightarrow> b \<in> el (gc F) \<Longrightarrow> Poset.le (gc F) a b
\<Longrightarrow> d b \<subseteq> d a \<and>  Poset.le (ob F \<cdot> d b) ((ar F \<cdot> (Space.make_inc (d b) (d a))) \<star> e a) (e b)"
  unfolding gc_def
  by force

lemma gc_le_eq : "a \<in> el (gc F) \<Longrightarrow> b \<in> el (gc F) \<Longrightarrow> Poset.le (gc F) a b
= (d b \<subseteq> d a \<and>  Poset.le (ob F \<cdot> d b) ((ar F \<cdot> (Space.make_inc (d b) (d a))) \<star> e a) (e b))"
  unfolding gc_def
  by fastforce

lemma gc_el : "el (gc F) = { (A, a) . A \<in> opens (space F) \<and> a \<in> Poset.el (ob F \<cdot> A)}"
  unfolding gc_def
  by simp

lemma gc_le_rel : "le_rel (gc F) = { ((A, a), (B, b)) .
 A \<in> opens (space F) \<and> B \<in> opens (space F)
 \<and> a \<in> Poset.el (ob F \<cdot> A) \<and> b \<in> Poset.el (ob F \<cdot> B)
 \<and> B \<subseteq> A \<and> Poset.le (ob F \<cdot> B) (ar F \<cdot> (Space.make_inc B A) \<star> a) b }"
  unfolding gc_def
  by simp

lemma local_dom : "valid F \<Longrightarrow> Aa \<in> Poset.el (gc F)
\<Longrightarrow> d Aa \<in> opens (space F)"
  by (metis (no_types, lifting) Poset.Poset.select_convs(1) Product_Type.Collect_case_prodD gc_def)

lemma gc_elem_local : "valid F \<Longrightarrow> Aa \<in> Poset.el (gc F) \<Longrightarrow> A = d Aa
\<Longrightarrow> e Aa \<in> Poset.el (ob F \<cdot> (d Aa))"
  by (metis (no_types, lifting) Poset.Poset.select_convs(1) Product_Type.Collect_case_prodD gc_def)

lemma local_elem_gc : "valid F \<Longrightarrow> A \<in> opens (space F)
\<Longrightarrow> a \<in> Poset.el (ob F \<cdot> A) \<Longrightarrow> (A, a) \<in> Poset.el (gc F)"
  unfolding gc_def
  by simp

lemma d_antitone : "valid F \<Longrightarrow> Aa \<in> Poset.el (gc F) \<Longrightarrow> Bb \<in> Poset.el (gc F) \<Longrightarrow>
Poset.le (gc F) Aa Bb \<Longrightarrow> d Bb \<subseteq> d Aa"
  unfolding gc_def
  by (smt (verit) Poset.Poset.select_convs(2) case_prod_conv case_prod_unfold mem_Collect_eq)

lemma local_le : "valid F \<Longrightarrow> Aa \<in> Poset.el (gc F) \<Longrightarrow> Aa' \<in> Poset.el (gc F) \<Longrightarrow>
d Aa = d Aa' \<Longrightarrow> Poset.le (gc F) Aa Aa' \<Longrightarrow> Poset.le (ob F \<cdot> (d Aa)) (e Aa) (e Aa')"
  unfolding gc_def
  by (smt (z3) Poset.Poset.select_convs(2) Poset.ident_app valid_welldefined Product_Type.Collect_case_prodD Space.ident_def eq_fst_iff eq_snd_iff old.prod.case valid_identity)

lemma valid_gc_transitive :
  fixes F :: "('A,'a) Prealgebra" and A B C :: "'A Open" and a b c :: "'a"
  defines "T \<equiv> space F"
  defines "i_BA \<equiv> Space.make_inc B A"
  defines "i_CB \<equiv> Space.make_inc C B"
  defines "i_CA \<equiv> Space.make_inc C A"
  defines "prj_AB \<equiv> ar F \<cdot> i_BA"
  defines "prj_BC \<equiv> ar F \<cdot> i_CB"
  defines "prj_AC \<equiv> ar F \<cdot> i_CA"
  assumes F_valid : "valid F" and C_le_B : "C \<subseteq> B" and B_le_A : "B \<subseteq> A"
  and A_open : "A \<in> opens T" and B_open : "B \<in> opens T" and C_open "C \<in> opens T"
  and A_el : "a \<in> el (ob F \<cdot> A)" and b_el : "b \<in> el (ob F \<cdot> B)" and c_el : "c \<in> el (ob F \<cdot> C)"
  and le_prj_a_b : "le (ob F \<cdot> B) (prj_AB \<star> a) b"
  and le_prj_b_c : "le (ob F \<cdot> C) (prj_BC \<star> b) c"
shows "le (ob F \<cdot> C) (prj_AC \<star> a) c"
proof -
  have "Poset.valid_map prj_AB" using assms
  using valid_ar by fastforce
  moreover have "Poset.valid_map prj_BC" using assms calculation
    using valid_ar by fastforce
  moreover have "Poset.valid_map prj_AC" using assms calculation
    using valid_ar by fastforce
  moreover have "le (ob F \<cdot> C) (prj_BC \<star> (prj_AB \<star>  a)) (prj_BC \<star>  b)"
    by (metis (no_types, lifting) A_el A_open B_le_A B_open C_le_B F_valid Inclusion.select_convs(1) Inclusion.select_convs(2) Poset.fun_app2 valid_welldefined T_def assms(14) b_el i_BA_def i_CB_def le_prj_a_b mem_Collect_eq prj_AB_def prj_BC_def valid_map_monotone)
  moreover have "le (ob F \<cdot> C) (prj_BC \<star> (prj_AB \<star> a)) c"
    by (smt (z3) A_el A_open B_le_A B_open C_le_B F_valid Inclusion.select_convs(1) Inclusion.select_convs(2) Poset.fun_app2 valid_welldefined T_def assms(14) b_el c_el calculation(4) i_BA_def i_CB_def le_prj_b_c mem_Collect_eq prj_AB_def prj_BC_def valid_transitivity)
  moreover have "prj_BC \<diamondop> prj_AB = prj_AC" using assms calculation
    by (metis (no_types, lifting) Inclusion.select_convs(1) Inclusion.select_convs(2) compose_inc_def mem_Collect_eq valid_composition)
  moreover have "prj_BC \<star> (prj_AB \<star> a) = prj_AC \<star> a" using assms calculation
    by (smt (verit) Inclusion.select_convs(1) Inclusion.select_convs(2) Poset.compose_app Poset.fun_app Poset.fun_app2 valid_welldefined mem_Collect_eq)
  ultimately show ?thesis
    by metis
qed

(* Main result *)

proposition valid_gc:
  fixes F :: "('A, 'a) Prealgebra"
  assumes valid_F : "valid F"
  shows "Poset.valid (gc F)"
proof (intro Poset.validI)
  fix x y
  assume a1: "(x, y) \<in> le_rel (gc F)"
   show "x \<in> el (gc F) \<and> y \<in> el (gc F)" using assms a1 gc_def [where ?F=F]
     by (smt (verit) Poset.Poset.select_convs(2) Product_Type.Collect_case_prodD case_prod_unfold fst_conv local_elem_gc prod.collapse snd_conv)
next
  fix x
  assume "x \<in> el (gc F)"
  define "T" where "T = space F"
  define "i" where "i = Space.ident (d x)"
  have "e x = ((ar F) \<cdot> i) \<star> (e x)"
    by (metis Poset.ident_app T_def \<open>x \<in> el (gc F)\<close> gc_elem_local i_def local_dom valid_F valid_identity valid_ob)
  moreover have "d x \<in> opens (space F)"
    using \<open>x \<in> el (gc F)\<close> local_dom valid_F by blast

  moreover have "e x \<in> Poset.el (ob F \<cdot> (d x))"
    by (meson \<open>x \<in> el (gc F)\<close> gc_elem_local valid_F)
  moreover have "Poset.le (ob F \<cdot> (d x)) (((ar F) \<cdot> i) \<star> (e x)) (e x)"
    by (metis calculation(1) calculation(2) calculation(3) valid_F valid_ob valid_reflexivity)

  moreover have "(x,x) \<in> le_rel (gc F)"  using  calculation i_def T_def gc_def [where ?F = F]
    by (smt (verit) Poset.Poset.select_convs(2) Space.ident_def case_prod_conv mem_Collect_eq prod.collapse subsetI)
  show "le (gc F) x x"
    by (simp add: \<open>(x, x) \<in> le_rel (gc F)\<close> \<open>x \<in> el (gc F)\<close>)
next
  fix x y
  assume a1: "x \<in> el (gc F)"
  assume a2: "y \<in> el (gc F)"
  assume a3: "le (gc F) x y"
  assume a4: "le (gc F) y x "
  show "x = y" using gc_def  [where ?F = F] assms  a1 a2 a3 a4
    by (smt (verit, del_insts) d_antitone gc_elem_local inf.absorb_iff2 le_boolE local_dom local_le prod.split_sel subset_antisym valid_antisymmetry valid_ob)
next
  fix x y z
  assume a1: "x \<in> el (gc F)"
  assume a2: "y \<in> el (gc F)"
  assume a3: "z \<in> el (gc F)"
  assume a4: "le (gc F) x y"
  assume a5: "le (gc F) y z "
  show "le (gc F) x z" using gc_def [where ?F = F] assms a1 a2 a3 a4 a5
valid_gc_transitive [where ?F = F and ?a="e x" and ?b="e y" and ?c="e z" and ?A="d x" and ?B="d y"
  and ?C="d z"]
    by (smt (verit, del_insts) Poset.Poset.select_convs(2) case_prod_conv  mem_Collect_eq prod.collapse subset_trans)
qed

(* Local to global ordering *)

lemma valid_gc_le_wrap :
  fixes F :: "('A, 'a) Prealgebra" and Aa Bb :: "('A set \<times> 'a)"

  defines "i \<equiv> Space.make_inc (d Bb) (d Aa)"
  defines "pr \<equiv>  (ar F) \<cdot> i"
  defines "FA \<equiv>  ob F \<cdot> (d Aa)"
  defines "FB \<equiv>  ob F \<cdot> (d Bb)"

  assumes  "valid F"
  assumes "d Aa \<in> opens (space F)"
  assumes "d Bb \<in> opens (space F)"
  assumes "e Aa \<in> Poset.el FA"
  assumes "e Bb \<in> Poset.el FB"
  assumes "d Bb \<subseteq> d Aa"
  assumes "Poset.le FB (pr \<star> (e Aa)) (e Bb) "

  shows "le (gc F) Aa (Bb)"
  unfolding gc_def
  by (smt (verit) Poset.Poset.select_convs(1) Poset.Poset.select_convs(2) FA_def FB_def assms(10) assms(11) assms(6) assms(7) assms(8) assms(9) case_prod_conv i_def mem_Collect_eq pr_def prod.collapse)

lemma valid_gc_le_unwrap :
  fixes F :: "('A, 'a) Prealgebra" and Aa Bb :: "('A set \<times> 'a)"
  defines "i \<equiv> Space.make_inc (d Bb) (d Aa)"
  defines "pr \<equiv> ar F \<cdot> i"
  defines "FA \<equiv> ob F \<cdot> (d Aa)"
  defines "FB \<equiv> ob F \<cdot> (d Bb)"

  assumes  F_valid : "valid F"
  and Aa_el : "Aa \<in> Poset.el (gc F) " and Bb_el : "Bb \<in> Poset.el (gc F)"
  and le_gc: "le (gc F) Aa Bb"

  shows "Poset.le FB (pr \<star> (e Aa)) (e Bb) \<and> d Bb \<subseteq> d Aa \<and> e Bb \<in> Poset.el FB \<and> e Aa \<in> Poset.el FA"
  proof -
    have "e Bb \<in> Poset.el FB \<and> e Aa \<in> Poset.el FA"
      by (simp add: Aa_el Bb_el FA_def FB_def gc_elem_local F_valid)
    moreover have "Space.valid_inc i"
      by (metis Aa_el Inclusion.select_convs(1) Inclusion.select_convs(2) assms(7) d_antitone i_def le_gc F_valid)
  moreover have "Poset.valid_map pr" using assms calculation
    by (metis (no_types, lifting) Inclusion.select_convs(1) Inclusion.select_convs(2) valid_welldefined local_dom mem_Collect_eq)
    define "a_B" where "a_B = (pr \<star> (e Aa))"
    moreover have "Poset.dom pr = FA \<and> Poset.cod pr = FB"
      by (metis (no_types, lifting) Aa_el Bb_el FA_def FB_def Inclusion.simps(1) Inclusion.simps(2) valid_welldefined assms(1) assms(2) calculation(2) local_dom mem_Collect_eq F_valid)
    moreover have "a_B \<in> Poset.el FB"
      by (metis Poset.fun_app2 \<open>Poset.valid_map pr\<close> a_B_def calculation(1) calculation(4))
    moreover have " Poset.valid (gc F)"
      by (simp add: F_valid valid_gc)
    moreover have "Poset.valid FB"
      using Poset.valid_map_welldefined_cod \<open>Poset.valid_map pr\<close> calculation(4) by blast
    moreover have " d Bb \<subseteq> d Aa \<and> e Bb \<in> Poset.el FB \<and> e Aa \<in> Poset.el FA"
      using Aa_el Bb_el F_valid calculation(1) d_antitone le_gc by blast
    moreover have "Poset.le FB a_B (e Bb)" using assms calculation gc_def [where ?F=F]
      by (smt (z3) Poset.Poset.select_convs(2) Product_Type.Collect_case_prodD eq_fst_iff old.prod.case snd_def)
    ultimately show ?thesis
      by blast
  qed

end


(*  File:       Revision_Composition.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Revision Composition\<close>

theory Revision_Composition
  imports "Basic_Modules/Component_Types/Electoral_Module"
begin

text
\<open>A revised electoral module rejects all originally rejected or deferred
alternatives, and defers the originally elected alternatives.
It does not elect any alternatives.\<close>

subsection \<open>Definition\<close>

fun revision_composition :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module" where
  "revision_composition m A p vs = ({}, A - elect m A p vs, elect m A p vs)"

abbreviation rev ::
"'a Electoral_Module \<Rightarrow> 'a Electoral_Module" ("_\<down>" 50) where
  "m\<down> == revision_composition m"

subsection \<open>Soundness\<close>

theorem rev_comp_sound[simp]:
  assumes module: "electoral_module m"
  shows "electoral_module (revision_composition m)"
proof -
  from module have "\<forall>A p vs. finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow> elect m A p vs \<subseteq> A"
    by (simp add: elect_in_alts)
  hence "\<forall>A p vs. finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow> (A - elect m A p vs) \<union> elect m A p vs = A"
    by blast
  hence unity:
    "\<forall>A p vs. finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow>
      set_equals_partition A (revision_composition m A p vs)"
    by simp
  have "\<forall>A p vs. finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow> (A - elect m A p vs) \<inter> elect m A p vs = {}"
    by blast
  hence disjoint:
    "\<forall>A p vs. finite_profile A p \<and> finite_pair_vectors A vs \<longrightarrow> disjoint3 (revision_composition m A p vs)"
    by simp
  from unity disjoint show ?thesis
    by (simp add: electoral_modI)
qed

subsection \<open>Composition Rules\<close>

(*An electoral module received by revision is never electing.*)
theorem rev_comp_non_electing[simp]:
  assumes "electoral_module m"
  shows "non_electing (m\<down>)"
  by (simp add: assms non_electing_def)

(*
   Revising an electing electoral module results in a
   non-blocking electoral module.
*)
theorem rev_comp_non_blocking[simp]:
  assumes "electing m"
  shows "non_blocking (m\<down>)"
  unfolding non_blocking_def
proof (safe, simp_all)
  show "electoral_module (m\<down>)"
    using assms electing_def rev_comp_sound
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs :: "'a Pair_Vectors" and
    x :: "'a"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    no_elect: "A - elect m A p vs  = A" and
    x_in_A: "x \<in> A"
  from no_elect have non_elect:
    "non_electing m"
    using assms prof_A x_in_A fin_A electing_def empty_iff
          Diff_disjoint Int_absorb2 elect_in_alts vec_A
    by (metis (no_types, lifting))
  show "False"
    using non_elect assms electing_def empty_iff fin_A
          non_electing_def prof_A x_in_A vec_A
    by (metis (no_types, lifting))
qed

(*
   Revising an invariant monotone electoral module results in a
   defer-invariant-monotone electoral module.
*)
theorem rev_comp_def_inv_mono[simp]:
  assumes "invariant_monotonicity m"
  shows "defer_invariant_monotonicity (m\<down>)"
proof -
  have "\<forall>A p q w vs. (w \<in> defer (m\<down>) A p vs \<and> lifted A p q w) \<longrightarrow>
                  (defer (m\<down>) A q vs = defer (m\<down>) A p vs \<or> defer (m\<down>) A q vs = {w})"
    using assms
    by (simp add: invariant_monotonicity_def)
  moreover have "electoral_module (m\<down>)"
    using assms rev_comp_sound invariant_monotonicity_def
    by auto
  moreover have "non_electing (m\<down>)"
    using assms rev_comp_non_electing invariant_monotonicity_def
    by auto
  ultimately have "electoral_module (m\<down>) \<and> non_electing (m\<down>) \<and>
      (\<forall>A p q w vs. (w \<in> defer (m\<down>) A p vs \<and> lifted A p q w) \<longrightarrow>
                 (defer (m\<down>) A q vs = defer (m\<down>) A p vs \<or> defer (m\<down>) A q vs = {w}))"
    by blast
  thus ?thesis
    using defer_invariant_monotonicity_def
    by (simp add: defer_invariant_monotonicity_def)
qed

end


theory Tree_Diameter
  imports "../DP_CRelVS"
begin

datatype tree = Node "(int \<times> tree) list"
term 0 (**)

context dp_consistency begin
definition hd\<^sub>T :: "('M, 'a list =='M\<Longrightarrow> 'a) state" where
  "hd\<^sub>T \<equiv> lift_3 hd"
definition "cc \<equiv> case_list"
context
  includes lifting_syntax
begin
thm hd_def[folded cc_def]

  thm list.rel_intros list.rel_induct list.rel_transfer list.rel_inject
  thm list.rel_cases list.rel_cong
    thm list.rel_flip list.rel_sel
lemma "list_all2 P (x#xs) (y#ys) \<Longrightarrow> P x y \<and> list_all2 P xs ys"
  using [[simp_trace]]
  by simp

term 0 (**
lemma "crel_vs (list_all2 R ===>\<^sub>T R) hd hd\<^sub>T"
  thm lift_3_transfer
  unfolding hd\<^sub>T_def
  apply transfer_prover_start
    apply transfer_step


(*  Title:      Jinja/Common/TypeRel.thy
    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section \<open>Relations between Jinja Types\<close>

theory TypeRel imports
  "HOL-Library.Transitive_Closure_Table"
  Decl
begin

subsection\<open>The subclass relations\<close>

inductive_set
  subcls1 :: "'m prog \<Rightarrow> (cname \<times> cname) set"
  and subcls1' :: "'m prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<prec>\<^sup>1 _" [71,71,71] 70)
  for P :: "'m prog"
where
  "P \<turnstile> C  \<prec>\<^sup>1 D \<equiv> (C,D) \<in> subcls1 P"
| subcls1I: "\<lbrakk>class P C = Some (D,rest); C \<noteq> Object\<rbrakk> \<Longrightarrow> P \<turnstile> C \<prec>\<^sup>1 D"

abbreviation
  subcls  :: "'m prog \<Rightarrow> [cname, cname] \<Rightarrow> bool" ("_ \<turnstile> _ \<preceq>\<^sup>* _"  [71,71,71] 70)
  where "P \<turnstile> C  \<preceq>\<^sup>*  D \<equiv> (C,D) \<in> (subcls1 P)\<^sup>*"

lemma subcls1D: "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>fs ms. class P C = Some (D,fs,ms))"
(*<*)by(erule subcls1.induct)(fastforce simp add:is_class_def)(*>*)

lemma [iff]: "(P \<turnstile> Object \<preceq>\<^sup>* C) = (C = Object)"
(*<*)
proof(rule iffI)
 assume "P \<turnstile> Object \<preceq>\<^sup>* C" then show "C = Object"
  by(auto elim: converse_rtranclE)
qed simp
(*>*)

lemma subcls1_def2:
  "subcls1 P =
     (SIGMA C:{C. is_class P C}. {D. C\<noteq>Object \<and> fst (the (class P C))=D})"
(*<*)
  by (fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
(*>*)

lemma finite_subcls1: "finite (subcls1 P)"
(*<*)
proof -
  let ?SIG = "SIGMA C:{C. is_class P C}. {D. fst (the (class P C)) = D \<and> C \<noteq> Object}"
  have "subcls1 P = ?SIG" by(simp add: subcls1_def2)
  also have "finite ?SIG"
  proof(rule finite_SigmaI [OF finite_is_class])
    fix C assume C_in: "C \<in> {C. is_class P C}"
    then show "finite {D. fst (the (class P C)) = D \<and> C \<noteq> Object}"
     by(rule_tac finite_subset[where B = "{fst (the (class P C))}"]) auto
  qed
  ultimately show ?thesis by simp
qed
(*>*)
(*
lemma subcls_is_class: "(C,D) \<in> (subcls1 P)\<^sup>+ \<Longrightarrow> is_class P C"
apply (unfold is_class_def)
apply(erule trancl_trans_induct)
apply (auto dest!: subcls1D)
done

lemma subcls_is_class: "P \<turnstile> C \<preceq>\<^sup>* D \<Longrightarrow> is_class P D \<longrightarrow> is_class P C"
apply (unfold is_class_def)
apply (erule rtrancl_induct)
apply  (drule_tac [2] subcls1D)
apply  auto
done
*)

subsection\<open>The subtype relations\<close>

inductive
  widen   :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ \<le> _"   [71,71,71] 70)
  for P :: "'m prog"
where
  widen_refl[iff]: "P \<turnstile> T \<le> T"
| widen_subcls: "P \<turnstile> C \<preceq>\<^sup>* D  \<Longrightarrow>  P \<turnstile> Class C \<le> Class D"
| widen_null[iff]: "P \<turnstile> NT \<le> Class C"

abbreviation
  widens :: "'m prog \<Rightarrow> ty list \<Rightarrow> ty list \<Rightarrow> bool"
    ("_ \<turnstile> _ [\<le>] _" [71,71,71] 70) where
  "widens P Ts Ts' \<equiv> list_all2 (widen P) Ts Ts'"

lemma [iff]: "(P \<turnstile> T \<le> Void) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> T \<le> Boolean) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> T \<le> Integer) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Void \<le> T) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Boolean \<le> T) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Integer \<le> T) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma Class_widen: "P \<turnstile> Class C \<le> T  \<Longrightarrow>  \<exists>D. T = Class D"
(*<*)
by (ind_cases "P \<turnstile> Class C \<le> T") auto
(*>*)

lemma [iff]: "(P \<turnstile> T \<le> NT) = (T = NT)"
(*<*)
by(cases T) (auto dest:Class_widen)
(*>*)

lemma Class_widen_Class [iff]: "(P \<turnstile> Class C \<le> Class D) = (P \<turnstile> C \<preceq>\<^sup>* D)"
(*<*)
proof(rule iffI)
  show "P \<turnstile> Class C \<le> Class D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
  proof(ind_cases "P \<turnstile> Class C \<le> Class D") qed(auto)
qed(auto elim: widen_subcls)
(*>*)

lemma widen_Class: "(P \<turnstile> T \<le> Class C) = (T = NT \<or> (\<exists>D. T = Class D \<and> P \<turnstile> D \<preceq>\<^sup>* C))"
(*<*)by(induct T, auto)(*>*)

lemma widen_trans[trans]: "\<lbrakk>P \<turnstile> S \<le> U; P \<turnstile> U \<le> T\<rbrakk> \<Longrightarrow> P \<turnstile> S \<le> T"
(*<*)
proof -
  assume "P\<turnstile>S \<le> U" thus "\<And>T. P \<turnstile> U \<le> T \<Longrightarrow> P \<turnstile> S \<le> T"
  proof induct
    case (widen_refl T T') thus "P \<turnstile> T \<le> T'" .
  next
    case (widen_subcls C D T)
    then obtain E where "T = Class E" by (blast dest: Class_widen)
    with widen_subcls show "P \<turnstile> Class C \<le> T" by (auto elim: rtrancl_trans)
  next
    case (widen_null C RT)
    then obtain D where "RT = Class D" by (blast dest: Class_widen)
    thus "P \<turnstile> NT \<le> RT" by auto
  qed
qed
(*>*)

lemma widens_trans [trans]: "\<lbrakk>P \<turnstile> Ss [\<le>] Ts; P \<turnstile> Ts [\<le>] Us\<rbrakk> \<Longrightarrow> P \<turnstile> Ss [\<le>] Us"
(*<*)by (rule list_all2_trans, rule widen_trans)(*>*)

(*<*)
lemmas widens_refl [iff] = list_all2_refl [of "widen P", OF widen_refl] for P
lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P
(*>*)

subsection\<open>Method lookup\<close>

inductive
  Methods :: "['m prog, cname, mname \<rightharpoonup> (ty list \<times> ty \<times> 'm) \<times> cname] \<Rightarrow> bool"
                    ("_ \<turnstile> _ sees'_methods _" [51,51,51] 50)
  for P :: "'m prog"
where
  sees_methods_Object:
 "\<lbrakk> class P Object = Some(D,fs,ms); Mm = map_option (\<lambda>m. (m,Object)) \<circ> map_of ms \<rbrakk>
  \<Longrightarrow> P \<turnstile> Object sees_methods Mm"
| sees_methods_rec:
 "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D sees_methods Mm;
    Mm' = Mm ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms) \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees_methods Mm'"

lemma sees_methods_fun:
assumes 1: "P \<turnstile> C sees_methods Mm"
shows "\<And>Mm'. P \<turnstile> C sees_methods Mm' \<Longrightarrow> Mm' = Mm"
 (*<*)
using 1
proof induct
  case (sees_methods_rec C D fs ms Dres Cres Cres')
  have "class": "class P C = Some (D, fs, ms)"
   and notObj: "C \<noteq> Object" and Dmethods: "P \<turnstile> D sees_methods Dres"
   and IH: "\<And>Dres'. P \<turnstile> D sees_methods Dres' \<Longrightarrow> Dres' = Dres"
   and Cres: "Cres = Dres ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)"
   and Cmethods': "P \<turnstile> C sees_methods Cres'" by fact+
  from Cmethods' notObj "class" obtain Dres'
    where Dmethods': "P \<turnstile> D sees_methods Dres'"
     and Cres': "Cres' = Dres' ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)"
    by(auto elim: Methods.cases)
  from Cres Cres' IH[OF Dmethods'] show "Cres' = Cres" by simp
next
  case sees_methods_Object thus ?case by(auto elim: Methods.cases)
qed
(*>*)

lemma visible_methods_exist:
  "P \<turnstile> C sees_methods Mm \<Longrightarrow> Mm M = Some(m,D) \<Longrightarrow>
   (\<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some m)"
 (*<*)by(induct rule:Methods.induct) auto(*>*)

lemma sees_methods_decl_above:
assumes Csees: "P \<turnstile> C sees_methods Mm"
shows "Mm M = Some(m,D) \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
 (*<*)
using Csees
proof induct
  case sees_methods_Object thus ?case by auto
next
  case sees_methods_rec thus ?case
    by(fastforce simp:map_option_case split:option.splits
                elim:converse_rtrancl_into_rtrancl[OF subcls1I])
qed
(*>*)

lemma sees_methods_idemp:
assumes Cmethods: "P \<turnstile> C sees_methods Mm"
shows "\<And>m D. Mm M = Some(m,D) \<Longrightarrow>
              \<exists>Mm'. (P \<turnstile> D sees_methods Mm') \<and> Mm' M = Some(m,D)"
(*<*)
using Cmethods
proof induct
  case sees_methods_Object thus ?case
    by(fastforce dest: Methods.sees_methods_Object)
next
  case sees_methods_rec thus ?case
    by(fastforce split:option.splits dest: Methods.sees_methods_rec)
qed
(*>*)

(*FIXME something wrong with induct: need to attache [consumes 1]
directly to proof of thm, declare does not work. *)

lemma sees_methods_decl_mono:
assumes sub: "P \<turnstile> C' \<preceq>\<^sup>* C"
shows "P \<turnstile> C sees_methods Mm \<Longrightarrow>
       \<exists>Mm' Mm\<^sub>2. P \<turnstile> C' sees_methods Mm' \<and> Mm' = Mm ++ Mm\<^sub>2 \<and>
                 (\<forall>M m D. Mm\<^sub>2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
(*<*)
      (is "_ \<Longrightarrow> \<exists>Mm' Mm2. ?Q C' C Mm' Mm2")
using sub
proof (induct rule:converse_rtrancl_induct)
  assume "P \<turnstile> C sees_methods Mm"
  hence "?Q C C Mm Map.empty" by simp
  thus "\<exists>Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
  fix C'' C'
  assume sub1: "P \<turnstile> C'' \<prec>\<^sup>1 C'" and sub: "P \<turnstile> C' \<preceq>\<^sup>* C"
  and IH: "P \<turnstile> C sees_methods Mm \<Longrightarrow>
           \<exists>Mm' Mm2. P \<turnstile> C' sees_methods Mm' \<and>
                Mm' = Mm ++ Mm2 \<and> (\<forall>M m D. Mm2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
  and Csees: "P \<turnstile> C sees_methods Mm"
  from IH[OF Csees] obtain Mm' Mm2 where C'sees: "P \<turnstile> C' sees_methods Mm'"
    and Mm': "Mm' = Mm ++ Mm2"
    and subC:"\<forall>M m D. Mm2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C" by blast
  obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C'' \<noteq> Object"
    using subcls1D[OF sub1] by blast
  let ?Mm3 = "map_option (\<lambda>m. (m,C'')) \<circ> map_of ms"
  have "P \<turnstile> C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
    using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
  hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
    using converse_rtrancl_into_rtrancl[OF sub1 sub]
    by simp (simp add:map_add_def subC split:option.split)
  thus "\<exists>Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed
(*>*)

definition Method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'm \<Rightarrow> cname \<Rightarrow> bool"
            ("_ \<turnstile> _ sees _: _\<rightarrow>_ = _ in _" [51,51,51,51,51,51,51] 50)
where
  "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D  \<equiv>
  \<exists>Mm. P \<turnstile> C sees_methods Mm \<and> Mm M = Some((Ts,T,m),D)"

definition has_method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> bool" ("_ \<turnstile> _ has _" [51,0,51] 50)
where
  "P \<turnstile> C has M \<equiv> \<exists>Ts T m D. P \<turnstile> C sees M:Ts\<rightarrow>T = m in D"

lemma sees_method_fun:
  "\<lbrakk>P \<turnstile> C sees M:TS\<rightarrow>T = m in D; P \<turnstile> C sees M:TS'\<rightarrow>T' = m' in D' \<rbrakk>
   \<Longrightarrow> TS' = TS \<and> T' = T \<and> m' = m \<and> D' = D"
 (*<*)by(fastforce dest: sees_methods_fun simp:Method_def)(*>*)

lemma sees_method_decl_above:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
 (*<*)by(clarsimp simp:Method_def sees_methods_decl_above)(*>*)

lemma visible_method_exists:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow>
  \<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some(Ts,T,m)"
(*<*)by(fastforce simp:Method_def dest!: visible_methods_exist)(*>*)

lemma sees_method_idemp:
  "P \<turnstile> C sees M:Ts\<rightarrow>T=m in D \<Longrightarrow> P \<turnstile> D sees M:Ts\<rightarrow>T=m in D"
 (*<*)by(fastforce simp: Method_def intro:sees_methods_idemp)(*>*)

lemma sees_method_decl_mono:
assumes sub: "P \<turnstile> C' \<preceq>\<^sup>* C" and
        C_sees: "P \<turnstile> C sees M:Ts\<rightarrow>T=m in D" and
        C'_sees: "P \<turnstile> C' sees M:Ts'\<rightarrow>T'=m' in D'"
shows   "P \<turnstile> D' \<preceq>\<^sup>* D"
 (*<*)
proof -
  obtain Ms where Ms: "P \<turnstile> C sees_methods Ms"
    using C_sees by(auto simp: Method_def)
  obtain Ms' Ms2 where Ms': "P \<turnstile> C' sees_methods Ms'" and
     Ms'_def: "Ms' = Ms ++ Ms2" and
     Ms2_imp: "(\<forall>M m D. Ms2 M = \<lfloor>(m, D)\<rfloor> \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
    using sees_methods_decl_mono[OF sub Ms] by clarsimp
  have "(Ms ++ Ms2) M = \<lfloor>((Ts', T', m'), D')\<rfloor>"
    using C'_sees sees_methods_fun[OF Ms'] Ms'_def by(clarsimp simp: Method_def)
  then have "Ms2 M = \<lfloor>((Ts', T', m'), D')\<rfloor> \<or>
             Ms2 M = None \<and> Ts = Ts' \<and> T = T' \<and> m = m' \<and> D = D'"
    using C_sees sees_methods_fun[OF Ms] by(clarsimp simp: Method_def)
  also have "Ms2 M = \<lfloor>((Ts', T', m'), D')\<rfloor> \<Longrightarrow> P \<turnstile> D' \<preceq>\<^sup>* C"
    using Ms2_imp by simp
  ultimately show ?thesis using sub sees_method_decl_above[OF C_sees] by auto
qed
(*>*)

lemma sees_method_is_class:
  "\<lbrakk> P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<rbrakk> \<Longrightarrow> is_class P C"
(*<*)by (auto simp add: is_class_def Method_def elim: Methods.induct)(*>*)

subsection\<open>Field lookup\<close>

inductive
  Fields :: "['m prog, cname, ((vname \<times> cname) \<times> ty) list] \<Rightarrow> bool"
                  ("_ \<turnstile> _ has'_fields _" [51,51,51] 50)
  for P :: "'m prog"
where
  has_fields_rec:
  "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D has_fields FDTs;
     FDTs' = map (\<lambda>(F,T). ((F,C),T)) fs @ FDTs \<rbrakk>
   \<Longrightarrow> P \<turnstile> C has_fields FDTs'"
| has_fields_Object:
  "\<lbrakk> class P Object = Some(D,fs,ms); FDTs = map (\<lambda>(F,T). ((F,Object),T)) fs \<rbrakk>
   \<Longrightarrow> P \<turnstile> Object has_fields FDTs"

lemma has_fields_fun:
assumes 1: "P \<turnstile> C has_fields FDTs"
shows "\<And>FDTs'. P \<turnstile> C has_fields FDTs' \<Longrightarrow> FDTs' = FDTs"
 (*<*)
using 1
proof induct
  case (has_fields_rec C D fs ms Dres Cres Cres')
  have "class": "class P C = Some (D, fs, ms)"
   and notObj: "C \<noteq> Object" and DFields: "P \<turnstile> D has_fields Dres"
   and IH: "\<And>Dres'. P \<turnstile> D has_fields Dres' \<Longrightarrow> Dres' = Dres"
   and Cres: "Cres = map (\<lambda>(F,T). ((F,C),T)) fs @ Dres"
   and CFields': "P \<turnstile> C has_fields Cres'" by fact+
  from CFields' notObj "class" obtain Dres'
    where DFields': "P \<turnstile> D has_fields Dres'"
     and Cres': "Cres' = map (\<lambda>(F,T). ((F,C),T)) fs @ Dres'"
    by(auto elim: Fields.cases)
  from Cres Cres' IH[OF DFields'] show "Cres' = Cres" by simp
next
  case has_fields_Object thus ?case by(auto elim: Fields.cases)
qed
(*>*)

lemma all_fields_in_has_fields:
assumes sub: "P \<turnstile> C has_fields FDTs"
shows "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* D; class P D = Some(D',fs,ms); (F,T) \<in> set fs \<rbrakk>
       \<Longrightarrow> ((F,D),T) \<in> set FDTs"
(*<*)
using sub proof(induct)
  case (has_fields_rec C D' fs ms FDTs FDTs')
  then have C_D: "P \<turnstile> C \<preceq>\<^sup>* D" by simp
  then show ?case proof(rule converse_rtranclE)
    assume "C = D"
    then show ?case using has_fields_rec by force
  next
    fix y assume sub1: "P \<turnstile> C \<prec>\<^sup>1 y" and sub2: "P \<turnstile> y \<preceq>\<^sup>* D"
    then show ?case using has_fields_rec subcls1D[OF sub1] by simp
  qed
next
  case (has_fields_Object D fs ms FDTs)
  then show ?case by force
qed
(*>*)

lemma has_fields_decl_above:
assumes fields: "P \<turnstile> C has_fields FDTs"
shows "((F,D),T) \<in> set FDTs \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
(*<*)
using fields proof(induct)
  case (has_fields_rec C D' fs ms FDTs FDTs')
  then have "((F, D), T) \<in> (\<lambda>x. case x of (F, x) \<Rightarrow> ((F, C), x)) ` set fs \<or>
    ((F, D), T) \<in> set FDTs" by clarsimp
  then show ?case proof(rule disjE)
    assume "((F, D), T) \<in> (\<lambda>x. case x of (F, x) \<Rightarrow> ((F, C), x)) ` set fs"
    then show ?case using has_fields_rec by clarsimp
  next
    assume "((F, D), T) \<in> set FDTs"
    then show ?case using has_fields_rec
     by(blast dest:subcls1I converse_rtrancl_into_rtrancl)
  qed
next
  case (has_fields_Object D fs ms FDTs)
  then show ?case by fastforce
qed
(*>*)

lemma subcls_notin_has_fields:
assumes fields: "P \<turnstile> C has_fields FDTs"
shows "((F,D),T) \<in> set FDTs \<Longrightarrow> (D,C) \<notin> (subcls1 P)\<^sup>+"
(*<*)
using fields proof(induct)
  case (has_fields_rec C D' fs ms FDTs FDTs')
  then have "((F, D), T) \<in> (\<lambda>x. case x of (F, x) \<Rightarrow> ((F, C), x)) ` set fs
               \<or> ((F, D), T) \<in> set FDTs" by clarsimp
  then show ?case proof(rule disjE)
    assume "((F, D), T) \<in> (\<lambda>x. case x of (F, x) \<Rightarrow> ((F, C), x)) ` set fs"
    then have CD[simp]: "C = D" and fs: "(F, T) \<in> set fs" by clarsimp+
    then have "(D, D) \<in> (subcls1 P)\<^sup>+ \<Longrightarrow> False" proof -
      assume DD: "(D, D) \<in> (subcls1 P)\<^sup>+"
      obtain z where z1: "P \<turnstile> D \<prec>\<^sup>1 z" and z_s: "P \<turnstile> z \<preceq>\<^sup>* D"
        using tranclD[OF DD] by clarsimp
      have [simp]: "z = D'" using subcls1D[OF z1] has_fields_rec.hyps(1) by clarsimp
      then have "((F, D), T) \<in> set FDTs"
        using z_s all_fields_in_has_fields[OF has_fields_rec.hyps(3) _ has_fields_rec.hyps(1) fs]
         by simp
      then have "(D, z) \<notin> (subcls1 P)\<^sup>+" using has_fields_rec.hyps(4) by simp
      then show False using z1 by auto
    qed
    then show ?case by clarsimp
  next
    assume "((F, D), T) \<in> set FDTs"
    then show ?case using has_fields_rec by(blast dest:subcls1I trancl_into_trancl)
  qed
next
  case (has_fields_Object D fs ms FDTs)
  then show ?case by(fastforce dest: tranclD)
qed
(*>*)

lemma has_fields_mono_lem:
assumes sub: "P \<turnstile> D \<preceq>\<^sup>* C"
shows "P \<turnstile> C has_fields FDTs
         \<Longrightarrow> \<exists>pre. P \<turnstile> D has_fields pre@FDTs \<and> dom(map_of pre) \<inter> dom(map_of FDTs) = {}"
(*<*)
using sub proof(induct rule:converse_rtrancl_induct)
  case base
  then show ?case by(rule_tac x = "[]" in exI) simp
next
  case (step D' D)
  then obtain pre where D_flds: "P \<turnstile> D has_fields pre @ FDTs" and
    dom: "dom (map_of pre) \<inter> dom (map_of FDTs) = {}" by clarsimp
  have "(D',C) \<in> (subcls1 P)^+" by (rule rtrancl_into_trancl2[OF step.hyps(1,2)])
  obtain fs ms where D'_cls: "class P D' = \<lfloor>(D, fs, ms)\<rfloor>" "D' \<noteq> Object"
    using subcls1D[OF step.hyps(1)] by clarsimp+
  have "P \<turnstile> D' has_fields map (\<lambda>(F, T). ((F, D'), T)) fs @ pre @ FDTs"
    using has_fields_rec[OF D'_cls D_flds] by simp
  also have "dom (map_of (map (\<lambda>(F, T). ((F, D'), T)) fs @ pre))
                 \<inter> dom (map_of FDTs) = {}"
    using dom subcls_notin_has_fields[OF D_flds, where D=D'] step.hyps(1)
      by(auto simp:dom_map_of_conv_image_fst) fast
  ultimately show ?case
    by(rule_tac x = "map (\<lambda>(F,T). ((F,D'),T)) fs @ pre" in exI) simp
qed
(*>*)

(* FIXME why is Field not displayed correctly? TypeRel qualifier seems to confuse printer*)
definition has_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> cname \<Rightarrow> bool"
                   ("_ \<turnstile> _ has _:_ in _" [51,51,51,51,51] 50)
where
  "P \<turnstile> C has F:T in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and> map_of FDTs (F,D) = Some T"

lemma has_field_mono:
assumes has: " P \<turnstile> C has F:T in D" and sub: "P \<turnstile> C' \<preceq>\<^sup>* C"
shows "P \<turnstile> C' has F:T in D"
(*<*)
proof -
  obtain FDTs where FDTs:"P \<turnstile> C has_fields FDTs" and "map_of FDTs (F, D) = \<lfloor>T\<rfloor>"
    using has by(clarsimp simp: has_field_def)
  also obtain pre where "P \<turnstile> C' has_fields pre @ FDTs"
     and "dom (map_of pre) \<inter> dom (map_of FDTs) = {}"
    using has_fields_mono_lem[OF sub FDTs] by clarify
  ultimately show ?thesis by(fastforce simp: has_field_def map_add_def split:option.splits)
qed
(*>*)

definition sees_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> cname \<Rightarrow> bool"
                  ("_ \<turnstile> _ sees _:_ in _" [51,51,51,51,51] 50)
where
  "P \<turnstile> C sees F:T in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and>
            map_of (map (\<lambda>((F,D),T). (F,(D,T))) FDTs) F = Some(D,T)"

lemma map_of_remap_SomeD:
  "map_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) \<Longrightarrow> map_of t (k, k') = Some x"
(*<*)by (induct t) (auto simp:fun_upd_apply split: if_split_asm)(*>*)

lemma has_visible_field:
  "P \<turnstile> C sees F:T in D \<Longrightarrow> P \<turnstile> C has F:T in D"
(*<*)by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)(*>*)

lemma sees_field_fun:
  "\<lbrakk>P \<turnstile> C sees F:T in D; P \<turnstile> C sees F:T' in D'\<rbrakk> \<Longrightarrow> T' = T \<and> D' = D"
(*<*)by(fastforce simp:sees_field_def dest:has_fields_fun)(*>*)

lemma sees_field_decl_above:
  "P \<turnstile> C sees F:T in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
(*<*)
by(auto simp:sees_field_def
        intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)
(*>*)

lemma sees_field_idemp:
assumes sees: "P \<turnstile> C sees F:T in D"
shows "P \<turnstile> D sees F:T in D"
(*<*)
proof -
  obtain FDTs where C_flds: "P \<turnstile> C has_fields FDTs"
     and FDTs: "map_of (map (\<lambda>((F, D), T). (F, D, T)) FDTs) F = \<lfloor>(D, T)\<rfloor>"
     (is "?FDTs")
   using sees by(clarsimp simp: sees_field_def)
  have map: "\<And>C' fs. map_of (map ((\<lambda>((F, D), a). (F, D, a)) \<circ> (\<lambda>(F, y). ((F, C'), y))) fs) F
              = \<lfloor>(D, T)\<rfloor> \<Longrightarrow> C' = D \<and> (F, T) \<in> set fs"
    by(frule map_of_SomeD) clarsimp
  have "?FDTs \<longrightarrow> P \<turnstile> D sees F:T in D"
  using C_flds proof induct
    case NObj: has_fields_rec
    then show ?case using map by (fastforce intro: has_fields_rec simp: sees_field_def)
  next
    case Obj: has_fields_Object
    then show ?case using map by(fastforce intro: has_fields_Object simp: sees_field_def)
  qed
  then show ?thesis using FDTs by(rule mp)
qed
(*>*)

subsection "Functional lookup"

definition "method" :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> cname \<times> ty list \<times> ty \<times> 'm"
where
  "method P C M  \<equiv>  THE (D,Ts,T,m). P \<turnstile> C sees M:Ts \<rightarrow> T = m in D"

definition field  :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> cname \<times> ty"
where
  "field P C F  \<equiv>  THE (D,T). P \<turnstile> C sees F:T in D"

definition fields :: "'m prog \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> ty) list"
where
  "fields P C  \<equiv>  THE FDTs. P \<turnstile> C has_fields FDTs"

lemma fields_def2 [simp]: "P \<turnstile> C has_fields FDTs \<Longrightarrow> fields P C = FDTs"
(*<*)by (unfold fields_def) (auto dest: has_fields_fun)(*>*)

lemma field_def2 [simp]: "P \<turnstile> C sees F:T in D \<Longrightarrow> field P C F = (D,T)"
(*<*)by (unfold field_def) (auto dest: sees_field_fun)(*>*)

lemma method_def2 [simp]: "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D \<Longrightarrow> method P C M = (D,Ts,T,m)"
(*<*)by (unfold method_def) (auto dest: sees_method_fun)(*>*)

subsection "Code generator setup"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  subcls1p
.
declare subcls1_def [code_pred_def]

code_pred
  (modes: i \<Rightarrow> i \<times> o \<Rightarrow> bool, i \<Rightarrow> i \<times> i \<Rightarrow> bool)
  [inductify]
  subcls1
.
definition subcls' where "subcls' G = (subcls1p G)^**"
code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  subcls'
.

lemma subcls_conv_subcls' [code_unfold]:
  "(subcls1 G)^* = {(C, D). subcls' G C D}"
  by (simp add: subcls'_def subcls1_def rtrancl_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  widen
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Fields
.

lemma has_field_code [code_pred_intro]:
  "\<lbrakk> P \<turnstile> C has_fields FDTs; map_of FDTs (F, D) = \<lfloor>T\<rfloor> \<rbrakk>
  \<Longrightarrow> P \<turnstile> C has F:T in D"
by(auto simp add: has_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  has_field
by(auto simp add: has_field_def)

lemma sees_field_code [code_pred_intro]:
  "\<lbrakk> P \<turnstile> C has_fields FDTs; map_of (map (\<lambda>((F, D), T). (F, D, T)) FDTs) F = \<lfloor>(D, T)\<rfloor> \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees F:T in D"
by(auto simp add: sees_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
          i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  sees_field
by(auto simp add: sees_field_def)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Methods
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
          i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  Method
by(auto simp add: Method_def)

lemma eval_Method_i_i_i_o_o_o_o_conv:
  "Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (\<lambda>(Ts, T, m, D). P \<turnstile> C sees M:Ts\<rightarrow>T=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)

lemma method_code [code]:
  "method P C M =
  Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (\<lambda>(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_Fields_conv:
  "Predicate.eval (Fields_i_i_o P C) = (\<lambda>FDTs. P \<turnstile> C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)

lemma fields_code [code]:
  "fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)

lemma eval_sees_field_i_i_i_o_o_conv:
  "Predicate.eval (sees_field_i_i_i_o_o P C F) = (\<lambda>(T, D). P \<turnstile> C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_oI elim: sees_field_i_i_i_o_oE)

lemma eval_sees_field_i_i_i_o_i_conv:
  "Predicate.eval (sees_field_i_i_i_o_i P C F D) = (\<lambda>T. P \<turnstile> C sees F:T in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_iI elim: sees_field_i_i_i_o_iE)

lemma field_code [code]:
  "field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o P C F) (\<lambda>(T, D). Predicate.single (D, T)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: Sup_fun_def Sup_bool_def fun_eq_iff)
done

(*<*)
end
(*>*)