section\<open>The Delta System Lemma, Relativized\label{sec:dsl-rel}\<close>

theory Delta_System_Relative
  imports
    Cardinal_Library_Relative
begin

relativize functional "delta_system" "delta_system_rel" external

locale M_delta = M_cardinal_library_extra +
  assumes
    countable_lepoll_assms:
    "M(G) \<Longrightarrow> M(A) \<Longrightarrow> M(b) \<Longrightarrow> M(f) \<Longrightarrow> separation(M, \<lambda>y. \<exists>x\<in>A.
                          y = \<langle>x, \<mu> i. x \<in> if_range_F_else_F(\<lambda>x. {xa \<in> G . x \<in> xa}, b, f, i)\<rangle>)"
begin

lemma disjoint_separation: "M(c) \<Longrightarrow> separation(M, \<lambda> x. \<exists>a. \<exists>b. x=\<langle>a,b\<rangle> \<and> a \<inter> b = c)"
  using separation_Pair separation_eq lam_replacement_constant lam_replacement_Int
  by simp

lemma (in M_trans) mem_F_bound6:
  fixes F G
  defines "F \<equiv> \<lambda>_ x. Collect(G, (\<in>)(x))"
  shows "x\<in>F(G,c) \<Longrightarrow> c \<in> (range(f) \<union> \<Union>G)"
  using apply_0 unfolding F_def
  by (cases "M(c)", auto simp:F_def)

lemma delta_system_Aleph_rel1:
  assumes "\<forall>A\<in>F. Finite(A)" "F \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "M(F)"
  shows "\<exists>D[M]. D \<subseteq> F \<and> delta_system(D) \<and> D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
proof -
  have "M(G) \<Longrightarrow> M(p) \<Longrightarrow> M({A\<in>G . p \<in> A})" for G p
  proof -
    assume "M(G)" "M(p)"
    have "{A\<in>G . p \<in> A} = G \<inter> (Memrel({p} \<union> G) `` {p})"
      unfolding Memrel_def by auto
    with \<open>M(G)\<close> \<open>M(p)\<close>
    show ?thesis by simp
  qed
  from \<open>\<forall>A\<in>F. Finite(A)\<close> \<open>M(F)\<close>
  have "M(\<lambda>A\<in>F. |A|\<^bsup>M\<^esup>)"
    using cardinal_rel_separation Finite_cardinal_rel_in_nat[OF _ transM[of _ F]]
      separation_imp_lam_closed[of _ "cardinal_rel(M)" \<omega>]
    by simp
  text\<open>Since all members are finite,\<close>
  with \<open>\<forall>A\<in>F. Finite(A)\<close> \<open>M(F)\<close>
  have "(\<lambda>A\<in>F. |A|\<^bsup>M\<^esup>) : F \<rightarrow>\<^bsup>M\<^esup> \<omega>" (is "?cards : _")
    by (simp add:mem_function_space_rel_abs, rule_tac lam_type)
      (force dest:transM)
  moreover from this
  have a:"?cards -`` {n} = { A\<in>F . |A|\<^bsup>M\<^esup> = n }" for n
    using vimage_lam by auto
  moreover
  note \<open>F \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close> \<open>M(F)\<close>
  moreover from calculation
  text\<open>there are uncountably many have the same cardinal:\<close>
  obtain n where "n\<in>\<omega>" "|?cards -`` {n}|\<^bsup>M\<^esup> = \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
    using eqpoll_rel_Aleph_rel1_cardinal_rel_vimage[of F ?cards] by auto
  moreover
  define G where "G \<equiv> ?cards -`` {n}"
  moreover from calculation and \<open>M(?cards)\<close>
  have "M(G)" by blast
  moreover from calculation
  have "G \<subseteq> F" by auto
  ultimately
  text\<open>Therefore, without loss of generality, we can assume that all
  elements of the family have cardinality \<^term>\<open>n\<in>\<omega>\<close>.\<close>
  have "A\<in>G \<Longrightarrow> |A|\<^bsup>M\<^esup> = n" and "G \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" and "M(G)" for A
    using cardinal_rel_Card_rel_eqpoll_rel_iff by auto
  with \<open>n\<in>\<omega>\<close>
  text\<open>So we prove the result by induction on this \<^term>\<open>n\<close> and
  generalizing \<^term>\<open>G\<close>, since the argument requires changing the
  family in order to apply the inductive hypothesis.\<close>
  have "\<exists>D[M]. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
  proof (induct arbitrary:G)
    case 0 \<comment> \<open>This case is impossible\<close>
    then
    have "G \<subseteq> {0}"
      using cardinal_rel_0_iff_0 by (blast dest:transM)
    with \<open>G \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close> \<open>M(G)\<close>
    show ?case
      using nat_lt_Aleph_rel1 subset_imp_le_cardinal_rel[of G "{0}"]
        lt_trans2 cardinal_rel_Card_rel_eqpoll_rel_iff by auto
  next
    case (succ n)
    have "\<forall>a\<in>G. Finite(a)"
    proof
      fix a
      assume "a \<in> G"
      moreover
      note \<open>M(G)\<close> \<open>n\<in>\<omega>\<close>
      moreover from calculation
      have "M(a)" by (auto dest: transM)
      moreover from succ and \<open>a\<in>G\<close>
      have "|a|\<^bsup>M\<^esup> = succ(n)" by simp
      ultimately
      show "Finite(a)"
        using Finite_cardinal_rel_iff' nat_into_Finite[of "succ(n)"]
        by fastforce
    qed
    show "\<exists>D[M]. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
    proof (cases "\<exists>p[M]. {A\<in>G . p \<in> A} \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>")
      case True \<comment> \<open>the positive case, uncountably many sets with a
                    common element\<close>
      then
      obtain p where "{A\<in>G . p \<in> A} \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "M(p)" by blast
      moreover
      note 1=\<open>M(G)\<close> \<open>M(G) \<Longrightarrow> M(p) \<Longrightarrow> M({A\<in>G . p \<in> A})\<close> singleton_closed[OF \<open>M(p)\<close>]
      moreover from this
      have "M({x - {p} . x \<in> {x \<in> G . p \<in> x}})"
        using RepFun_closed[OF lam_replacement_Diff'[THEN
              lam_replacement_imp_strong_replacement]]
          Diff_closed[OF transM[OF _ 1(2)]] by auto
      moreover from 1
      have "M(converse(\<lambda>x\<in>{x \<in> G . p \<in> x}. x - {p}))" (is "M(converse(?h))")
        using converse_closed[of ?h] lam_closed[OF diff_Pair_replacement]
          Diff_closed[OF transM[OF _ 1(2)]]
        by auto
      moreover from calculation
      have "{A-{p} . A\<in>{X\<in>G. p\<in>X}} \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" (is "?F \<approx>\<^bsup>M\<^esup> _")
        using Diff_bij_rel[of "{A\<in>G . p \<in> A}" "{p}", THEN
            comp_bij_rel[OF bij_rel_converse_bij_rel, where C="\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>",
              THEN bij_rel_imp_eqpoll_rel, of _ _ ?F]]
        unfolding eqpoll_rel_def
        by (auto simp del:mem_bij_abs)
      text\<open>Now using the hypothesis of the successor case,\<close>
      moreover from \<open>\<And>A. A\<in>G \<Longrightarrow> |A|\<^bsup>M\<^esup>=succ(n)\<close> \<open>\<forall>a\<in>G. Finite(a)\<close>
        and this \<open>M(G)\<close>
      have "p\<in>A \<Longrightarrow> A\<in>G \<Longrightarrow> |A - {p}|\<^bsup>M\<^esup> = n" for A
        using Finite_imp_succ_cardinal_rel_Diff[of _ p] by (force dest: transM)
      moreover
      have "\<forall>a\<in>?F. Finite(a)"
      proof (clarsimp)
        fix A
        assume "p\<in>A" "A\<in>G"
        with \<open>\<And>A. p \<in> A \<Longrightarrow> A \<in> G \<Longrightarrow> |A - {p}|\<^bsup>M\<^esup> = n\<close> and \<open>n\<in>\<omega>\<close> \<open>M(G)\<close>
        have "Finite(|A - {p}|\<^bsup>M\<^esup>)"
          using nat_into_Finite by simp
        moreover from \<open>p\<in>A\<close> \<open>A\<in>G\<close> \<open>M(G)\<close>
        have "M(A - {p})" by (auto dest: transM)
        ultimately
        show "Finite(A - {p})"
          using Finite_cardinal_rel_iff' by simp
      qed
      moreover
      text\<open>we may apply the inductive hypothesis to the new family \<^term>\<open>?F\<close>:\<close>
      note \<open>(\<And>A. A \<in> ?F \<Longrightarrow> |A|\<^bsup>M\<^esup> = n) \<Longrightarrow> ?F \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> M(?F) \<Longrightarrow>
             \<exists>D[M]. D \<subseteq> ?F \<and> delta_system(D) \<and> D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close>
      moreover
      note 1=\<open>M(G)\<close> \<open>M(G) \<Longrightarrow> M(p) \<Longrightarrow> M({A\<in>G . p \<in> A})\<close> singleton_closed[OF \<open>M(p)\<close>]
      moreover from this
      have "M({x - {p} . x \<in> {x \<in> G . p \<in> x}})"
        using RepFun_closed[OF lam_replacement_Diff'[THEN
              lam_replacement_imp_strong_replacement]]
          Diff_closed[OF transM[OF _ 1(2)]] by auto
      ultimately
      obtain D where "D\<subseteq>{A-{p} . A\<in>{X\<in>G. p\<in>X}}" "delta_system(D)" "D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "M(D)"
        by auto
      moreover from this
      obtain r where "\<forall>A\<in>D. \<forall>B\<in>D. A \<noteq> B \<longrightarrow> A \<inter> B = r"
        by fastforce
      then
      have "\<forall>A\<in>D.\<forall>B\<in>D. A\<union>{p} \<noteq> B\<union>{p}\<longrightarrow>(A \<union> {p}) \<inter> (B \<union> {p}) = r\<union>{p}"
        by blast
      ultimately
      have "delta_system({B \<union> {p} . B\<in>D})" (is "delta_system(?D)")
        by fastforce
      moreover from \<open>M(D)\<close> \<open>M(p)\<close>
      have "M(?D)"
        using RepFun_closed un_Pair_replacement transM[of _ D] by auto
      moreover from \<open>D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close> \<open>M(D)\<close>
      have "Infinite(D)" "|D|\<^bsup>M\<^esup> = \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
        using uncountable_rel_iff_subset_eqpoll_rel_Aleph_rel1[THEN iffD2,
            THEN uncountable_rel_imp_Infinite, of D]
          cardinal_rel_eqpoll_rel_iff[of D "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"] \<open>M(D)\<close> \<open>D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close>
        by auto
      moreover from this \<open>M(?D)\<close> \<open>M(D)\<close> \<open>M(p)\<close>
      have "?D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
        using cardinal_rel_map_Un[of D "{p}"] naturals_lt_nat
          cardinal_rel_eqpoll_rel_iff[THEN iffD1] by simp
      moreover
      note \<open>D \<subseteq> {A-{p} . A\<in>{X\<in>G. p\<in>X}}\<close>
      have "?D \<subseteq> G"
      proof -
        {
          fix A
          assume "A\<in>G" "p\<in>A"
          moreover from this
          have "A = A - {p} \<union> {p}"
            by blast
          ultimately
          have "A -{p} \<union> {p} \<in> G"
            by auto
        }
        with \<open>D \<subseteq> {A-{p} . A\<in>{X\<in>G. p\<in>X}}\<close>
        show ?thesis
          by blast
      qed
      moreover
      note \<open>M(?D)\<close>
      ultimately
      show "\<exists>D[M]. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" by auto
    next
      case False
      note \<open>\<not> (\<exists>p[M]. {A \<in> G . p \<in> A} \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>)\<close> \<comment> \<open>the other case\<close>
        \<open>M(G)\<close> \<open>\<And>p. M(G) \<Longrightarrow> M(p) \<Longrightarrow> M({A\<in>G . p \<in> A})\<close>
      moreover from \<open>G \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close> and this
      have "M(p) \<Longrightarrow> {A \<in> G . p \<in> A} \<lesssim>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" (is "_ \<Longrightarrow> ?G(p) \<lesssim>\<^bsup>M\<^esup> _") for p
        by (auto intro!:lepoll_rel_eq_trans[OF subset_imp_lepoll_rel] dest:transM)
      moreover from calculation
      have "M(p) \<Longrightarrow> ?G(p) \<prec>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" for p
        using \<open>M(G) \<Longrightarrow> M(p) \<Longrightarrow> M({A\<in>G . p \<in> A})\<close>
        unfolding lesspoll_rel_def by simp
      moreover from calculation
      have "M(p) \<Longrightarrow> ?G(p) \<lesssim>\<^bsup>M\<^esup> \<omega>" for p
        using lesspoll_rel_Aleph_rel_succ[of 0] Aleph_rel_zero by auto
      moreover
      have "{A \<in> G . S \<inter> A \<noteq> 0} = (\<Union>p\<in>S. ?G(p))" for S
        by auto
      moreover from calculation
      have "M(S) \<Longrightarrow> i \<in> S \<Longrightarrow> M({x \<in> G . i \<in> x})" for i S
        by (auto dest: transM)
      moreover
      have "M(S) \<Longrightarrow> countable_rel(M,S) \<Longrightarrow> countable_rel(M,{A \<in> G . S \<inter> A \<noteq> 0})" for S
      proof -
        from \<open>M(G)\<close>
        interpret M_replacement_lepoll M "\<lambda>_ x. Collect(G, (\<in>)(x))"
          using countable_lepoll_assms lam_replacement_inj_rel separation_in_rev
            lam_replacement_Collect'[of G "\<lambda>x y. x\<in>y"] mem_F_bound6[of _ G]
            lam_replacement_minimum separation_in lam_replacement_fst lam_replacement_snd
          by  unfold_locales
            (auto dest:transM intro:lam_Least_assumption_general[of _  _ _ _ Union])
        fix S
        assume "M(S)"
        with \<open>M(G)\<close> \<open>\<And>i. M(S) \<Longrightarrow> i \<in> S \<Longrightarrow> M({x \<in> G . i \<in> x})\<close>
        interpret M_cardinal_UN_lepoll _ ?G S
          using lepoll_assumptions
          by unfold_locales (auto dest:transM)
        assume "countable_rel(M,S)"
        with \<open>M(S)\<close> calculation(6) calculation(7,8)[of S]
        show "countable_rel(M,{A \<in> G . S \<inter> A \<noteq> 0})"
          using InfCard_rel_nat Card_rel_nat
            le_Card_rel_iff[THEN iffD2, THEN [3] lepoll_rel_imp_cardinal_rel_UN_le,
              THEN [4] le_Card_rel_iff[THEN iffD1], of \<omega>] j.UN_closed
          unfolding countable_rel_def by (auto dest: transM)
      qed
      define Disjoint where "Disjoint = {<A,B> \<in> G\<times>G . B \<inter> A = 0}"
      have "Disjoint = {x \<in> G\<times>G . \<exists> a b. x=<a,b> \<and> a\<inter>b=0}"
        unfolding Disjoint_def by force
      with \<open>M(G)\<close>
      have "M(Disjoint)"
        using disjoint_separation by simp
      text\<open>For every countable\_rel subfamily of \<^term>\<open>G\<close> there is another some
      element disjoint from all of them:\<close>
      have "\<exists>A\<in>G. \<forall>S\<in>X. <S,A>\<in>Disjoint" if "|X|\<^bsup>M\<^esup> < \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "X \<subseteq> G" "M(X)" for X
      proof -
        note \<open>n\<in>\<omega>\<close> \<open>M(G)\<close>
        moreover from this and \<open>\<And>A. A\<in>G \<Longrightarrow> |A|\<^bsup>M\<^esup> = succ(n)\<close>
        have "|A|\<^bsup>M\<^esup>= succ(n)" "M(A)" if "A\<in>G" for A
          using that Finite_cardinal_rel_eq_cardinal[of A] Finite_cardinal_rel_iff'[of A]
            nat_into_Finite transM[of A G] by (auto dest:transM)
        ultimately
        have "A\<in>G \<Longrightarrow> Finite(A)" for A
          using cardinal_rel_Card_rel_eqpoll_rel_iff[of "succ(n)" A]
            Finite_cardinal_rel_eq_cardinal[of A] nat_into_Card_rel[of "succ(n)"]
            nat_into_M[of n] unfolding Finite_def eqpoll_rel_def by (auto)
        with \<open>X\<subseteq>G\<close> \<open>M(X)\<close>
        have "A\<in>X \<Longrightarrow> countable_rel(M,A)" for A
          using Finite_imp_countable_rel by (auto dest: transM)
        moreover from \<open>M(X)\<close>
        have "M(\<Union>X)" by simp
        moreover
        note \<open>|X|\<^bsup>M\<^esup> < \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close> \<open>M(X)\<close>
        ultimately
        have "countable_rel(M,\<Union>X)"
          using Card_rel_nat[THEN cardinal_rel_lt_csucc_rel_iff, of X]
            countable_rel_union_countable_rel[of X]
            countable_rel_iff_cardinal_rel_le_nat[of X] Aleph_rel_succ
            Aleph_rel_zero by simp
        with \<open>M(\<Union>X)\<close> \<open>M(_) \<Longrightarrow> countable_rel(M,_) \<Longrightarrow> countable_rel(M,{A \<in> G . _  \<inter> A \<noteq> 0})\<close>
        have "countable_rel(M,{A \<in> G . (\<Union>X) \<inter> A \<noteq> 0})" by simp
        with \<open>G \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close> \<open>M(G)\<close>
        obtain B where "B\<in>G" "B \<notin> {A \<in> G . (\<Union>X) \<inter> A \<noteq> 0}"
          using nat_lt_Aleph_rel1 cardinal_rel_Card_rel_eqpoll_rel_iff[of "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" G]
            uncountable_rel_not_subset_countable_rel
            [of "{A \<in> G . (\<Union>X) \<inter> A \<noteq> 0}" G]
            uncountable_rel_iff_nat_lt_cardinal_rel[of G]
          by force
        then
        have "\<exists>A\<in>G. \<forall>S\<in>X. A \<inter> S = 0" by auto
        with \<open>X\<subseteq>G\<close>
        show "\<exists>A\<in>G. \<forall>S\<in>X. <S,A>\<in>Disjoint" unfolding Disjoint_def
          using subsetD by simp
      qed
      moreover from \<open>G \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close> \<open>M(G)\<close>
      obtain b where "b\<in>G"
        using uncountable_rel_iff_subset_eqpoll_rel_Aleph_rel1
          uncountable_rel_not_empty by blast
      ultimately
      text\<open>Hence, the hypotheses to perform a bounded-cardinal selection
      are satisfied,\<close>
      obtain S where "S:\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<rightarrow>\<^bsup>M\<^esup>G" "\<alpha>\<in>\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> \<beta>\<in>\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> \<alpha><\<beta> \<Longrightarrow> <S`\<alpha>, S`\<beta>> \<in>Disjoint"
        for \<alpha> \<beta>
        using bounded_cardinal_rel_selection[of "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" G Disjoint] \<open>M(Disjoint)\<close>
        by force
      moreover from this \<open>n\<in>\<omega>\<close> \<open>M(G)\<close>
      have inM:"M(S)" "M(n)" "\<And>x. x \<in> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> S ` x \<in> G" "\<And>x. x \<in> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> M(x)"
        using function_space_rel_char by (auto dest: transM)
      ultimately
      have "\<alpha> \<in> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> \<beta> \<in> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> \<alpha>\<noteq>\<beta> \<Longrightarrow> S`\<alpha> \<inter> S`\<beta> = 0" for \<alpha> \<beta>
        unfolding Disjoint_def
        using lt_neq_symmetry[of "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "\<lambda>\<alpha> \<beta>. S`\<alpha> \<inter> S`\<beta> = 0"] Card_rel_is_Ord
        by auto (blast)
      text\<open>and a symmetry argument shows that obtained \<^term>\<open>S\<close> is
      an injective  \<^term>\<open>\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>\<close>-sequence of disjoint elements of \<^term>\<open>G\<close>.\<close>
      moreover from this and \<open>\<And>A. A\<in>G \<Longrightarrow> |A|\<^bsup>M\<^esup> = succ(n)\<close> inM
        \<open>S : \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<rightarrow>\<^bsup>M\<^esup> G\<close> \<open>M(G)\<close>
      have "S \<in> inj_rel(M,\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>, G)"
        using def_inj_rel[OF Aleph_rel_closed \<open>M(G)\<close>, of 1]
      proof (clarsimp)
        fix w x
        from inM
        have "a \<in> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> b \<in> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> \<Longrightarrow> a \<noteq> b \<Longrightarrow> S ` a \<noteq> S ` b" for a b
          using \<open>\<And>A. A\<in>G \<Longrightarrow> |A|\<^bsup>M\<^esup> = succ(n)\<close>[THEN [4] cardinal_rel_succ_not_0[THEN [4]
                Int_eq_zero_imp_not_eq[OF calculation, of "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "\<lambda>x. x"],
                of "\<lambda>_.n"], OF _ _ _ _ apply_closed] by auto
        moreover
        assume "w \<in> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "x \<in> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "S ` w = S ` x"
        ultimately
        show "w = x" by blast
      qed
      moreover from this \<open>M(G)\<close>
      have "range(S) \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
        using inj_rel_bij_rel_range eqpoll_rel_sym unfolding eqpoll_rel_def
        by (blast dest: transM)
      moreover
      note \<open>M(G)\<close>
      moreover from calculation
      have "range(S) \<subseteq> G"
        using inj_rel_is_fun range_fun_subset_codomain
        by (fastforce dest: transM)
      moreover
      note \<open>M(S)\<close>
      ultimately
      show "\<exists>D[M]. D \<subseteq> G \<and> delta_system(D) \<and> D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
        using inj_rel_is_fun ZF_Library.range_eq_image[of S "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" G]
          image_function[OF fun_is_function, OF inj_rel_is_fun, of S "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" G]
          domain_of_fun[OF inj_rel_is_fun, of S "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" G] apply_replacement[of S]
        by (rule_tac x="S``\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" in rexI) (auto dest:transM intro!:RepFun_closed)
      text\<open>This finishes the successor case and hence the proof.\<close>
    qed
  qed
  with \<open>G \<subseteq> F\<close>
  show ?thesis by blast
qed

lemma delta_system_uncountable_rel:
  assumes "\<forall>A\<in>F. Finite(A)" "uncountable_rel(M,F)" "M(F)"
  shows "\<exists>D[M]. D \<subseteq> F \<and> delta_system(D) \<and> D \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
proof -
  from assms
  obtain S where "S \<subseteq> F" "S \<approx>\<^bsup>M\<^esup> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "M(S)"
    using uncountable_rel_iff_subset_eqpoll_rel_Aleph_rel1[of F] by auto
  moreover from \<open>\<forall>A\<in>F. Finite(A)\<close> and this
  have "\<forall>A\<in>S. Finite(A)" by auto
  ultimately
  show ?thesis using delta_system_Aleph_rel1[of S]
    by (auto dest:transM)
qed

end \<comment> \<open>\<^locale>\<open>M_delta\<close>\<close>

end


section \<open>Infrastructures\<close>
text \<open>The Isabelle Infrastructure framework supports the representation of infrastructures
as graphs with actors and policies attached to nodes. These infrastructures
are the {\it states} of the Kripke structure.
The transition between states is triggered by non-parametrized
actions @{text \<open>get, move, eval, put\<close>} executed by actors.
Actors are given by an abstract type @{text \<open>actor\<close>} and a function
@{text \<open>Actor\<close>} that creates elements of that type from identities
(of type @{text \<open>string\<close>}). Policies are given by pairs of predicates
(conditions) and sets of (enabled) actions.\<close>
subsection \<open>Actors, actions, and data labels\<close>
theory Infrastructure
  imports Refinement
begin
datatype action = get | move | eval | put

typedecl actor
type_synonym identity = string
consts Actor :: "string \<Rightarrow> actor"
type_synonym policy = "((actor \<Rightarrow> bool) * action set)"

definition ID :: "[actor, string] \<Rightarrow> bool"
  where "ID a s \<equiv> (a = Actor s)"
text \<open>The Decentralised Label Model (DLM) \cite{ml:98} introduced the idea to
label data by owners and readers. We pick up this idea and formalize
a new type to encode the owner and the set of readers as a pair.
The first element is the owner of a data item, the second one is the
set of all actors that may access the data item.
This enables the unique security
labelling of data within the system additionally taking the ownership into
account.\<close>
type_synonym data = nat
type_synonym dlm = "actor * actor set"

subsection \<open>Infrastructure graphs and policies\<close>
text\<open>Actors are contained in an infrastructure graph. An @{text \<open>igraph\<close>} contains
a set of location pairs representing the topology of the infrastructure
as a graph of nodes and a list of actor identities associated to each node
(location) in the graph.
Also an @{text \<open>igraph\<close>} associates actors to a pair of string sets by
a pair-valued function whose first range component is a set describing
the credentials in the possession of an actor and the second component
is a set defining the roles the actor can take on. More importantly in this
context, an  @{text \<open>igraph\<close>} assigns locations to a pair of a string that defines
the state of the component and an element of type @{text \<open>(dlm * data) set\<close>}. This
set of labelled data may represent a condition on that data.
Corresponding projection functions for each of these components of an
@{text \<open>igraph\<close>} are provided; they are named @{text \<open>gra\<close>} for the actual set of pairs of
locations, @{text \<open>agra\<close>} for the actor map, @{text \<open>cgra\<close>} for the credentials,
and @{text \<open>lgra\<close>} for the state of a location and the data at that location.
Finally, there is the map of the (Efemeral) Ids that are posted by mobile phones at a location
(which is added here for the CoronaApp) and the map for each actor to the knowledge set which
represents the combinatorial explosion of all Ids with all people present at a location representing the
knowledge about who might be who. \<close>
datatype location = Location nat
datatype efid = Efid nat
datatype igraph = Lgraph "(location * location)set" "location \<Rightarrow> identity set"
                           "identity \<Rightarrow>  efid"
                           "location \<Rightarrow> string * (dlm * data) set"
                           "location \<Rightarrow> efid set"
                           "identity \<Rightarrow> location \<Rightarrow> (identity * efid)set"

datatype infrastructure =
         Infrastructure "igraph"
                        "[igraph, location] \<Rightarrow> policy set"

primrec loc :: "location \<Rightarrow> nat"
where  "loc(Location n) = n"
primrec gra :: "igraph \<Rightarrow> (location * location)set"
where  "gra(Lgraph g a c l e k) = g"
primrec agra :: "igraph \<Rightarrow> (location \<Rightarrow> identity set)"
where  "agra(Lgraph g a c l e k) = a"
primrec cgra :: "igraph \<Rightarrow> identity \<Rightarrow> efid"
where  "cgra(Lgraph g a c l e k) = c"
primrec lgra :: "igraph \<Rightarrow> (location \<Rightarrow> string * (dlm * data) set)"
  where  "lgra(Lgraph g a c l e k) = l"
primrec egra :: "igraph \<Rightarrow> location \<Rightarrow> efid set"
  where  "egra(Lgraph g a c l e k) = e"
primrec kgra:: "[igraph, identity, location] \<Rightarrow> (identity * efid)set"
  where "kgra(Lgraph g a c l e k) = k"

definition nodes :: "igraph \<Rightarrow> location set"
where "nodes g == { x. (? y. ((x,y): gra g) | ((y,x): gra g))}"

definition actors_graph :: "igraph \<Rightarrow> identity set"
where  "actors_graph g == {x. ? y. y : nodes g \<and> x \<in> (agra g y)}"

text \<open>There are projection functions text{@ \<open>graphI\<close>} and text{@ \<open>delta\<close>} when applied
to an infrastructure return the graph and the policy, respectively. Other projections
are introduced for the labels, the credential, and roles and to express their meaning.\<close>
primrec graphI :: "infrastructure \<Rightarrow> igraph"
where "graphI (Infrastructure g d) = g"
primrec delta :: "[infrastructure, igraph, location] \<Rightarrow> policy set"
where "delta (Infrastructure g d) = d"
primrec tspace :: "[infrastructure, identity ] \<Rightarrow> efid"
  where "tspace (Infrastructure g d) = cgra g"
primrec lspace :: "[infrastructure, location ] \<Rightarrow> string * (dlm * data)set"
  where "lspace (Infrastructure g d) = lgra g"

text \<open>Predicates and projections for the labels to encode their meaning.\<close>
definition owner :: "dlm * data \<Rightarrow> actor" where "owner d \<equiv> fst(fst d)"
definition owns :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
  where "owns G l a d \<equiv> owner d = a"
definition readers :: "dlm * data \<Rightarrow> actor set"
  where "readers d \<equiv> snd (fst d)"

text \<open>The predicate @{text \<open>has_access\<close>} is true for owners or readers.\<close>
definition has_access :: "[igraph, location, actor, dlm * data] \<Rightarrow> bool"
where "has_access G l a d \<equiv> owns G l a d \<or> a \<in> readers d"

(*
text \<open>Actors can delete data.\<close>
definition actor_can_delete ::   "[infrastructure, actor, location] \<Rightarrow> bool"
where actor_can_delete_def: "actor_can_delete I h l \<equiv>
                   (\<forall> as n. ((h, as), n) \<notin> (snd (lgra (graphI I) l)))"
*)
text \<open>We define a type of functions that preserves the security labeling and a
   corresponding function application  operator.\<close>
typedef label_fun = "{f :: dlm * data \<Rightarrow> dlm * data.
                        \<forall> x:: dlm * data. fst x = fst (f x)}"
  by (fastforce)

definition secure_process :: "label_fun \<Rightarrow> dlm * data \<Rightarrow> dlm * data" (infixr "\<Updown>" 50)
  where "f  \<Updown> d \<equiv> (Rep_label_fun f) d"

(*
subsection \<open>Insider predicate\<close>
text \<open>The human actor's level is modelled in the Isabelle Insider framework by assigning
the individual actor's psychological disposition\footnote{Note that the determination of
the psychological state of an actor is not done using the formal system. It is up to a
psychologist to determine this. However, if for instance, an actor is classified as
@{text \<open>disgruntled\<close>} then this may have an influence on what they are allowed to do according
to a company policy and this can be formally described and reasoned about in Isabelle.}
@{text \<open>actor_state\<close>} to each actor's identity.\<close>
datatype psy_states = happy | depressed | disgruntled | angry | stressed
datatype motivations = financial | political | revenge | curious | competitive_advantage | power | peer_recognition

text \<open>The values used for the definition of the types
@{text \<open>motivations\<close>} and @{text \<open>psy_state\<close>}
are based on a taxonomy from psychological insider research \cite{nblgcww:14}.
The transition to become an insider is represented by a {\it Catalyst} that tips the insider
over the edge so he acts as an insider formalized as a ``tipping point''
predicate.\<close>
datatype actor_state = Actor_state "psy_states" "motivations set"
primrec motivation :: "actor_state \<Rightarrow> motivations set"
where "motivation  (Actor_state p m) =  m"
primrec psy_state :: "actor_state \<Rightarrow> psy_states"
where "psy_state  (Actor_state p m) = p"

definition tipping_point :: "actor_state \<Rightarrow> bool" where
  "tipping_point a \<equiv> ((motivation a \<noteq> {}) \<and> (happy \<noteq> psy_state a))"

text \<open>To embed the fact that the attacker is an insider, the actor can then
impersonate other actors. In the Isabelle Insider framework, the
predicate @{text \<open>Insider\<close>} must be used as a {\it locale} assumption
to enable impersonation for the insider:
this assumption entails that an insider @{text \<open>Actor ''Eve''\<close>} can act like
their alter ego, say @{text \<open>Actor ''Charly''\<close>} within the context of the locale.
This is realized by the predicate  @{text \<open>UasI\<close>}:
@{text \<open>UasI\<close>} and @{text \<open>UasI'\<close>} are the central predicates allowing to specify Insiders.
They define which identities can be mapped to the same role by the @{text \<open>Actor\<close>} function
(an impersonation predicate "@{text \<open>a\<close>} can act as @{text \<open>b\<close>}").
For all other identities, @{text \<open>Actor\<close>} is defined as injective on those identities.
The first one is stronger and allows substitution of the insider in any context; the second
one is parameterized over a context predicate to describe this.\<close>
definition UasI ::  "[identity, identity] \<Rightarrow> bool "
where "UasI a b \<equiv> (Actor a = Actor b) \<and> (\<forall> x y. x \<noteq> a \<and> y \<noteq> a \<and> Actor x = Actor y \<longrightarrow> x = y)"
definition UasI' ::  "[actor \<Rightarrow> bool, identity, identity] \<Rightarrow> bool "
where "UasI' P a b \<equiv> P (Actor b) \<longrightarrow> P (Actor a)"

text \<open>Two versions of Insider predicate corresponding to @{text \<open>UasI\<close>} and @{text \<open>UasI'\<close>}
exist. Under the assumption that the tipping point has been reached for a person @{text \<open>a\<close>}
then @{text \<open>a\<close>} can impersonate all @{text \<open>b\<close>} (take all of @{text \<open>b\<close>}'s "roles") where
the @{text \<open>b\<close>}'s are specified by a given set of identities.\<close>
definition Insider :: "[identity, identity set, identity \<Rightarrow> actor_state] \<Rightarrow> bool"
where "Insider a C as \<equiv> (tipping_point (as a) \<longrightarrow> (\<forall> b\<in>C. UasI a b))"
definition Insider' :: "[actor \<Rightarrow> bool, identity, identity set, identity \<Rightarrow> actor_state] \<Rightarrow> bool"
where "Insider' P a C as \<equiv> (tipping_point (as a) \<longrightarrow> (\<forall> b\<in>C. UasI' P a b \<and> inj_on Actor C))"
*)
text \<open>The predicate atI -- mixfix syntax @{text \<open>@\<^bsub>G\<^esub>\<close>} -- expresses that an actor (identity)
      is at a certain location in an igraph.\<close>
definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> (agra G l)"

text \<open>Policies specify the expected behaviour of actors of an infrastructure.
They are defined by the @{text \<open>enables\<close>} predicate:
an actor @{text \<open>h\<close>} is enabled to perform an action @{text \<open>a\<close>}
in infrastructure @{text \<open>I\<close>}, at location @{text \<open>l\<close>}
if there exists a pair @{text \<open>(p,e)\<close>} in the local policy of @{text \<open>l\<close>}
(@{text \<open>delta I l\<close>} projects to the local policy) such that the action
@{text \<open>a\<close>} is a member of the action set @{text \<open>e\<close>} and the policy
predicate @{text \<open>p\<close>} holds for actor @{text \<open>h\<close>}.\<close>
definition enables :: "[infrastructure, location, actor, action] \<Rightarrow> bool"
where
"enables I l a a' \<equiv>  (\<exists> (p,e) \<in> delta I (graphI I) l. a' \<in> e \<and> p a)"

text \<open>The behaviour is the good behaviour, i.e. everything allowed by the policy of infrastructure I.\<close>
definition behaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "behaviour I \<equiv> {(t,a,a'). enables I t a a'}"

text \<open>The misbehaviour is the complement of the behaviour of an infrastructure I.\<close>
definition misbehaviour :: "infrastructure \<Rightarrow> (location * actor * action)set"
where "misbehaviour I \<equiv> -(behaviour I)"

subsection "State transition on infrastructures"
text \<open>The state transition defines how actors may act on infrastructures through actions
    within the boundaries of the policy. It is given as an inductive definition over the
    states which are infrastructures.  This state transition relation is dependent on actions but also on
    enabledness and the current state of the infrastructure.

    First we introduce some auxiliary functions dealing
    with repetitions in lists and actors moving in an igraph.\<close>
primrec jonce :: "['a, 'a list] \<Rightarrow> bool"
where
jonce_nil: "jonce a [] = False" |
jonce_cons: "jonce a (x#ls) = (if x = a then (a \<notin> (set ls)) else jonce a ls)"
(*
primrec nodup :: "['a, 'a list] \<Rightarrow> bool"
  where
    nodup_nil: "nodup a [] = True" |
    nodup_step: "nodup a (x # ls) = (if x = a then (a \<notin> (set ls)) else nodup a ls)"
*)
text \<open>The @{text \<open>move_graph_a\<close>} function encapsulates the infrastructure state change for a
      move action used in the subsequent rule move. It relocates the actor from a location l
      to a new location l' if the actor is actually at l and is not at l'. Additionally,
      here for the CoronaApp application, under the same conditons the local sending of the
      ephemeral Id of the actor is also moved to the new location l' by adapting the egra component
      of the infrastructure state graph.\<close>
definition move_graph_a :: "[identity, location, location, igraph] \<Rightarrow> igraph"
where "move_graph_a n l l' g \<equiv> Lgraph (gra g)
                    (if n \<in> ((agra g) l) &  n \<notin> ((agra g) l') then
                     ((agra g)(l := (agra g l) - {n}))(l' := (insert n (agra g l')))
                     else (agra g))
                               (cgra g)(lgra g)
                     (if n \<in> ((agra g) l) &  n \<notin> ((agra g) l') then
                       ((egra g)(l := (egra g l) - {cgra g n}))
                                (l' := (insert (cgra g n)(egra g l')))
                      else egra g)
                               (kgra g)"

definition put_graph_efid :: "[identity, location, igraph] \<Rightarrow> igraph"
  where \<open>put_graph_efid n l g  \<equiv> Lgraph (gra g)(agra g)
                               (cgra g)
                               (lgra g)
                             ((egra g)(l := insert ((cgra g n))(egra g l)))
                              (kgra g)\<close>

text \<open>The state transition relation defines the semantics for the actions. We concentrate
     only on two: move and get. Move models the moving of actors from one locations to another
     automatically posting the ephemeral ids at the new location (and stop posting them at the
     old location, i.e. deleting them there) -- this is implemented in @{text \<open>move_graph_a\<close>}
     above.
     For get, an actor a at a location can use get, if he's entitled to do that by the policy,
     to extend hos knowledge set. He adds all combinations of the actors a sees at the location
     with all ephemeral ids she measures, i.e. which are in the set @{text \<open>egra G l\<close>}. If a
     already has a nonempty knowledge set @{text \<open>kgra G (Actor a)\<close>} she can already improve
     her knowledge by building an intersection with the previous knowledge set.\<close>
inductive state_transition_in :: "[infrastructure, infrastructure] \<Rightarrow> bool" ("(_ \<rightarrow>\<^sub>n _)" 50)
where
  move: "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G; l' \<in> nodes G;
          (a) \<in> actors_graph(graphI I); enables I l' (Actor a) move;
         I' = Infrastructure (move_graph_a a l l' (graphI I))(delta I) \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get : "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G;
        enables I l (Actor a) get;
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)(lgra G)(egra G)
                       ((kgra G)(a := ((kgra G a)(l:= {(x,y). x \<in> agra G l \<and> y \<in> egra G l})))))
                   (delta I)
         \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| put : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> enables I l (Actor a) put \<Longrightarrow>
        I' = Infrastructure (put_graph_efid a l (graphI I))(delta I)
          \<Longrightarrow> I \<rightarrow>\<^sub>n I'"

text \<open>Note that the type infrastructure can now be instantiated to the axiomatic type class
      @{text\<open>state\<close>} which enables the use of the underlying Kripke structures and CTL.\<close>
instantiation "infrastructure" :: state
begin
definition
   state_transition_infra_def: "(i \<rightarrow>\<^sub>i i') =  (i \<rightarrow>\<^sub>n (i' :: infrastructure))"

instance
  by (rule MC.class.MC.state.of_class.intro)

definition state_transition_in_refl ("(_ \<rightarrow>\<^sub>n* _)" 50)
where "s \<rightarrow>\<^sub>n* s' \<equiv> ((s,s') \<in> {(x,y). state_transition_in x y}\<^sup>*)"

end

lemma move_graph_eq: "move_graph_a a l l g = g"
  by (simp add: move_graph_a_def, case_tac g, force)

lemma delta_invariant: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow>  delta(z) = delta(z')"
  apply clarify
  apply (erule state_transition_in.cases)
  by simp+

lemma same_actors0[rule_format]: "\<forall> z z'.  z \<rightarrow>\<^sub>n z' \<longrightarrow> actors_graph (graphI z) = actors_graph (graphI z')"
proof (clarify, erule state_transition_in.cases)
  show "\<And>z z' G I a l l' I'.
       z = I \<Longrightarrow>
       z' = I' \<Longrightarrow>
       G = graphI I \<Longrightarrow>
       a @\<^bsub>G\<^esub> l \<Longrightarrow>
       l \<in> nodes G \<Longrightarrow>
       l' \<in> nodes G \<Longrightarrow>
       a \<in> actors_graph (graphI I) \<Longrightarrow>
       enables I l' (Actor a) move \<Longrightarrow>
       I' = Infrastructure (move_graph_a a l l' (graphI I)) (delta I) \<Longrightarrow>
       actors_graph (graphI z) = actors_graph (graphI z')"
    apply (simp add: actors_graph_def)
    apply (rule equalityI)
     apply (rule subsetI)
     apply (rule CollectI)
     apply (drule CollectD)
     apply (erule exE, erule conjE)+
    apply (simp add: move_graph_a_def)
proof -
  fix z :: infrastructure and z' :: infrastructure and G :: igraph and I :: infrastructure and a :: "char list" and l :: location and l' :: location and I' :: infrastructure and x :: "char list" and y :: location and ya :: location
assume a1: "x \<in> agra (graphI I) ya"
assume a2: "ya \<in> nodes (graphI I)"
assume a3: "l' \<in> nodes (graphI I)"
assume "l \<in> nodes (graphI I)"
  have f4: "\<forall>f fa fb fc fd i. nodes (Lgraph (gra i) f fd fa fc fb) = nodes i"
by (simp add: nodes_def)
obtain bb :: bool where
f5: "bb = ((a \<notin> agra (graphI I) l \<or> a \<in> agra (graphI I) l') \<or> (\<exists>X56. (X56 \<noteq> l \<or> (l \<noteq> l' \<or> l' \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I))(l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> (x = a \<or> x \<in> agra (graphI I) l')) \<and> (l = l' \<or> l \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> x \<in> agra (graphI I) l \<and> x \<noteq> a)) \<and> (X56 = l \<or> (X56 \<noteq> l' \<or> l' \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> (x = a \<or> x \<in> agra (graphI I) l')) \<and> (X56 = l' \<or> X56 \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> x \<in> agra (graphI I) X56))))"
by blast
then have "bb \<and> (a \<in> agra (graphI I) l \<and> a \<notin> agra (graphI I) l' \<or> bb \<and> (\<exists>l. l \<in> nodes (Lgraph (gra (graphI I)) (agra (graphI I)) (cgra (graphI I)) (lgra (graphI I)) (egra (graphI I)) (kgra (graphI I))) \<and> x \<in> agra (graphI I) l))"
using f4 a3 a2 a1 by metis
then show "(a \<in> agra (graphI I) l \<and> a \<notin> agra (graphI I) l' \<longrightarrow> (\<exists>la. (la = l \<longrightarrow> (l = l' \<longrightarrow> l' \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I))(l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> (x = a \<or> x \<in> agra (graphI I) l')) \<and> (l \<noteq> l' \<longrightarrow> l \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> x \<in> agra (graphI I) l \<and> x \<noteq> a)) \<and> (la \<noteq> l \<longrightarrow> (la = l' \<longrightarrow> l' \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> (x = a \<or> x \<in> agra (graphI I) l')) \<and> (la \<noteq> l' \<longrightarrow> la \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> x \<in> agra (graphI I) la)))) \<and> ((a \<in> agra (graphI I) l \<longrightarrow> a \<in> agra (graphI I) l') \<longrightarrow> (a \<in> agra (graphI I) l \<and> a \<notin> agra (graphI I) l' \<longrightarrow> (\<exists>la. (la = l \<longrightarrow> (l = l' \<longrightarrow> l' \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I))(l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> (x = a \<or> x \<in> agra (graphI I) l')) \<and> (l \<noteq> l' \<longrightarrow> l \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> x \<in> agra (graphI I) l \<and> x \<noteq> a)) \<and> (la \<noteq> l \<longrightarrow> (la = l' \<longrightarrow> l' \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> (x = a \<or> x \<in> agra (graphI I) l')) \<and> (la \<noteq> l' \<longrightarrow> la \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> x \<in> agra (graphI I) la)))) \<and> (\<exists>l. l \<in> nodes (Lgraph (gra (graphI I)) (agra (graphI I)) (cgra (graphI I)) (lgra (graphI I)) (egra (graphI I)) (kgra (graphI I))) \<and> x \<in> agra (graphI I) l))"
  using f5 by blast
next show "\<And>z z' G I a l l' I'.
       z = I \<Longrightarrow>
       z' = Infrastructure (move_graph_a a l l' (graphI I)) (delta I) \<Longrightarrow>
       G = graphI I \<Longrightarrow>
       a @\<^bsub>graphI I\<^esub> l \<Longrightarrow>
       l \<in> nodes (graphI I) \<Longrightarrow>
       l' \<in> nodes (graphI I) \<Longrightarrow>
       \<exists>y. y \<in> nodes (graphI I) \<and> a \<in> agra (graphI I) y \<Longrightarrow>
       enables I l' (Actor a) move \<Longrightarrow>
       I' = Infrastructure (move_graph_a a l l' (graphI I)) (delta I) \<Longrightarrow>
       {x. \<exists>y. y \<in> nodes (move_graph_a a l l' (graphI I)) \<and> x \<in> agra (move_graph_a a l l' (graphI I)) y}
       \<subseteq> {x. \<exists>y. y \<in> nodes (graphI I) \<and> x \<in> agra (graphI I) y}"
    apply (simp add: enables_def move_graph_a_def)
    apply (rule conjI)
     apply (rule impI)+
     apply (rule subsetI)
     apply (rule CollectI)
     apply (drule CollectD)
     apply (erule exE)+
    apply (erule conjE)+
  proof -
    fix z :: infrastructure and z' :: infrastructure and G :: igraph and I :: infrastructure and a :: "char list" and l :: location and l' :: location and I' :: infrastructure and x :: "char list" and y :: location and ya :: location
    assume a1: "G = graphI I"
    assume a2: "ya = l \<longrightarrow> (l = l' \<longrightarrow> l' \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I))(l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> (x = a \<or> x \<in> agra (graphI I) l')) \<and> (l \<noteq> l' \<longrightarrow> l \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> x \<in> agra (graphI I) l \<and> x \<noteq> a)"
    assume a3: "l \<in> nodes (graphI I)"
    assume a4: "l' \<in> nodes (graphI I)"
    assume a5: "a \<in> agra (graphI I) y"
    assume a6: "ya \<noteq> l \<longrightarrow> (ya = l' \<longrightarrow> l' \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> (x = a \<or> x \<in> agra (graphI I) l')) \<and> (ya \<noteq> l' \<longrightarrow> ya \<in> nodes (Lgraph (gra (graphI I)) ((agra (graphI I)) (l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l'))) (cgra (graphI I)) (lgra (graphI I)) ((egra (graphI I)) (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))) (kgra (graphI I))) \<and> x \<in> agra (graphI I) ya)"
    assume a7: "y \<in> nodes (graphI I)"
    have "ya = l' \<or> ya = l \<or> (\<exists>l. x \<in> agra G l \<and> l \<in> nodes G)"
      using a6 a1 nodes_def by force
    then show "\<exists>l. l \<in> nodes (graphI I) \<and> x \<in> agra (graphI I) l"
      using a7 a6 a5 a4 a3 a2 a1 by (metis (full_types))
  next show "\<And>z z' G I a l l' I'.
       z = I \<Longrightarrow>
       z' =
       Infrastructure
        (Lgraph (gra (graphI I))
          (if a \<in> agra (graphI I) l \<and> a \<notin> agra (graphI I) l'
           then (agra (graphI I))(l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l')) else agra (graphI I))
          (cgra (graphI I)) (lgra (graphI I))
          (if a \<in> agra (graphI I) l \<and> a \<notin> agra (graphI I) l'
           then (egra (graphI I))
                (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))
           else egra (graphI I))
          (kgra (graphI I)))
        (delta I) \<Longrightarrow>
       G = graphI I \<Longrightarrow>
       a @\<^bsub>graphI I\<^esub> l \<Longrightarrow>
       l \<in> nodes (graphI I) \<Longrightarrow>
       l' \<in> nodes (graphI I) \<Longrightarrow>
       \<exists>y. y \<in> nodes (graphI I) \<and> a \<in> agra (graphI I) y \<Longrightarrow>
       \<exists>x\<in>delta I (graphI I) l'. case x of (p, e) \<Rightarrow> move \<in> e \<and> p (Actor a) \<Longrightarrow>
       I' =
       Infrastructure
        (Lgraph (gra (graphI I))
          (if a \<in> agra (graphI I) l \<and> a \<notin> agra (graphI I) l'
           then (agra (graphI I))(l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l')) else agra (graphI I))
          (cgra (graphI I)) (lgra (graphI I))
          (if a \<in> agra (graphI I) l \<and> a \<notin> agra (graphI I) l'
           then (egra (graphI I))
                (l := egra (graphI I) l - {cgra (graphI I) a}, l' := insert (cgra (graphI I) a) (egra (graphI I) l'))
           else egra (graphI I))
          (kgra (graphI I)))
        (delta I) \<Longrightarrow>
       (a \<in> agra (graphI I) l \<longrightarrow> a \<in> agra (graphI I) l') \<longrightarrow>
       (a \<in> agra (graphI I) l \<and> a \<notin> agra (graphI I) l' \<longrightarrow>
        {x. \<exists>y. (y = l \<longrightarrow>
                 (l = l' \<longrightarrow>
                  l' \<in> nodes
                         (Lgraph (gra (graphI I)) ((agra (graphI I))(l' := insert a (agra (graphI I) l')))
                           (cgra (graphI I)) (lgra (graphI I))
                           ((egra (graphI I))(l' := insert (cgra (graphI I) a) (egra (graphI I) l')))
                           (kgra (graphI I))) \<and>
                  (x = a \<or> x \<in> agra (graphI I) l')) \<and>
                 (l \<noteq> l' \<longrightarrow>
                  l \<in> nodes
                        (Lgraph (gra (graphI I))
                          ((agra (graphI I))(l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l')))
                          (cgra (graphI I)) (lgra (graphI I))
                          ((egra (graphI I))
                           (l := egra (graphI I) l - {cgra (graphI I) a},
                            l' := insert (cgra (graphI I) a) (egra (graphI I) l')))
                          (kgra (graphI I))) \<and>
                  x \<in> agra (graphI I) l \<and> x \<noteq> a)) \<and>
                (y \<noteq> l \<longrightarrow>
                 (y = l' \<longrightarrow>
                  l' \<in> nodes
                         (Lgraph (gra (graphI I))
                           ((agra (graphI I))(l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l')))
                           (cgra (graphI I)) (lgra (graphI I))
                           ((egra (graphI I))
                            (l := egra (graphI I) l - {cgra (graphI I) a},
                             l' := insert (cgra (graphI I) a) (egra (graphI I) l')))
                           (kgra (graphI I))) \<and>
                  (x = a \<or> x \<in> agra (graphI I) l')) \<and>
                 (y \<noteq> l' \<longrightarrow>
                  y \<in> nodes
                        (Lgraph (gra (graphI I))
                          ((agra (graphI I))(l := agra (graphI I) l - {a}, l' := insert a (agra (graphI I) l')))
                          (cgra (graphI I)) (lgra (graphI I))
                          ((egra (graphI I))
                           (l := egra (graphI I) l - {cgra (graphI I) a},
                            l' := insert (cgra (graphI I) a) (egra (graphI I) l')))
                          (kgra (graphI I))) \<and>
                  x \<in> agra (graphI I) y))}
        \<subseteq> {x. \<exists>y. y \<in> nodes (graphI I) \<and> x \<in> agra (graphI I) y}) \<and>
       {x. \<exists>y. y \<in> nodes
                     (Lgraph (gra (graphI I)) (agra (graphI I)) (cgra (graphI I)) (lgra (graphI I)) (egra (graphI I))
                       (kgra (graphI I))) \<and>
               x \<in> agra (graphI I) y}
       \<subseteq> {x. \<exists>y. y \<in> nodes (graphI I) \<and> x \<in> agra (graphI I) y} "
      using nodes_def by auto
  qed
qed
next show "\<And>z z' G I a l I'.
       z = I \<Longrightarrow>
       z' = I' \<Longrightarrow>
       G = graphI I \<Longrightarrow>
       a @\<^bsub>G\<^esub> l \<Longrightarrow>
       enables I l (Actor a) put \<Longrightarrow>
       I' = Infrastructure (put_graph_efid a l (graphI I)) (delta I) \<Longrightarrow>
       actors_graph (graphI z) = actors_graph (graphI z') "
    by (simp add: actors_graph_def nodes_def put_graph_efid_def)
next show "\<And>z z' G I a l I'.
       z = I \<Longrightarrow>
       z' = I' \<Longrightarrow>
       G = graphI I \<Longrightarrow>
       a @\<^bsub>G\<^esub> l \<Longrightarrow>
       l \<in> nodes G \<Longrightarrow>
       enables I l (Actor a) get \<Longrightarrow>
       I' =
       Infrastructure
        (Lgraph (gra G) (agra G) (cgra G) (lgra G) (egra G)
          ((kgra G)(a := (kgra G a)(l := {(x, y). x \<in> agra G l \<and> y \<in> egra G l}))))
        (delta I) \<Longrightarrow>
       actors_graph (graphI z) = actors_graph (graphI z') "
    by (simp add: actors_graph_def nodes_def)
qed

lemma same_actors: "(I, y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*
              \<Longrightarrow> actors_graph(graphI I) = actors_graph(graphI y)"
proof (erule rtrancl_induct)
  show "actors_graph (graphI I) = actors_graph (graphI I)"
    by (rule refl)
next show "\<And>(y::infrastructure) z::infrastructure.
       (I, y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<Longrightarrow>
       (y, z) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y} \<Longrightarrow>
       actors_graph (graphI I) = actors_graph (graphI y) \<Longrightarrow>
       actors_graph (graphI I) = actors_graph (graphI z)"
    by (drule CollectD, simp, drule same_actors0, simp)
qed

(* locations invariants *)
 lemma same_nodes0[rule_format]: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow> nodes(graphI z) = nodes(graphI z')"
    apply clarify
  apply (erule Infrastructure.state_transition_in.cases)
  by (simp add: move_graph_a_def atI_def actors_graph_def nodes_def put_graph_efid_def)+

lemma same_nodes: "(c, s) \<in> {(x::Infrastructure.infrastructure, y::Infrastructure.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*
\<Longrightarrow> Infrastructure.nodes (graphI c) = Infrastructure.nodes (graphI s)"
  apply (erule rtrancl_induct)
   apply (rule refl)
  apply (drule CollectD)
    apply simp
    apply (drule same_nodes0)
  by simp

(* delta invariants *)
lemma init_state_policy0: "\<lbrakk> \<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow>  delta(z) = delta(z');
                          (x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<rbrakk> \<Longrightarrow>
                          delta(x) = delta(y)"
  apply (rule mp)
  prefer 2
   apply (rotate_tac 1)
    apply assumption
  thm rtrancl_induct
  apply (erule rtrancl_induct)
    apply (rule impI)
   apply (rule refl)
    apply (subgoal_tac "delta y = delta z")
   apply (erule impE)
    apply assumption
    apply (rule impI)
   apply (rule trans)
    apply assumption+
  apply (drule_tac x = y in spec)
  apply (drule_tac x = z in spec)
    apply (rotate_tac -1)
  apply (erule impE)
    apply simp
by assumption

lemma init_state_policy: "\<lbrakk> (x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<rbrakk> \<Longrightarrow>
                          delta(x) = delta(y)"
  apply (rule init_state_policy0)
    apply (rule delta_invariant)
  by assumption

(* efids invariants *)
lemma eroots_inj_inv0: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow>
inj(cgra (graphI z)) \<longrightarrow> inj (cgra (graphI z'))"
    apply clarify
  apply (erule Infrastructure.state_transition_in.cases)
  apply (simp add: move_graph_a_def)
  apply simp
  by (simp add: put_graph_efid_def)

lemma eroots_inj_inv: "(I, y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*
              \<Longrightarrow> inj(cgra (graphI I)) \<longrightarrow> inj (cgra (graphI y))"
proof (erule rtrancl_induct)
  show "inj (cgra (graphI I)) \<longrightarrow> inj (cgra (graphI I))" by simp
next show "\<And>y z. (I, y) \<in> {(x, y). x \<rightarrow>\<^sub>n y}\<^sup>* \<Longrightarrow>
           (y, z) \<in> {(x, y). x \<rightarrow>\<^sub>n y} \<Longrightarrow>
           inj (cgra (graphI I)) \<longrightarrow> inj (cgra (graphI y)) \<Longrightarrow> inj (cgra (graphI I)) \<longrightarrow> inj (cgra (graphI z)) "
    using eroots_inj_inv0 by auto
qed

end


section \<open> Channel Types \<close>

theory Channel_Type
  imports Prisms
  keywords "chantype" :: "thy_defn"
begin

text \<open> A channel type is a simplified algebraic datatype where each constructor has exactly
  one parameter, and it is wrapped up as a prism. It a dual of an alphabet type. \<close>

definition ctor_prism :: "('a \<Rightarrow> 'd) \<Rightarrow> ('d \<Rightarrow> bool) \<Rightarrow> ('d \<Rightarrow> 'a) \<Rightarrow> ('a \<Longrightarrow>\<^sub>\<triangle> 'd)" where
[lens_defs]:
"ctor_prism ctor disc sel = \<lparr> prism_match = (\<lambda> d. if (disc d) then Some (sel d) else None)
                            , prism_build = ctor \<rparr>"

lemma wb_ctor_prism_intro:
  assumes
    "\<And> v. disc (ctor v)"
    "\<And> v. sel (ctor v) = v"
    "\<And> s. disc s \<Longrightarrow> ctor (sel s) = s"
  shows "wb_prism (ctor_prism ctor disc sel)"
  by (unfold_locales, simp_all add: lens_defs assms)
     (metis assms(3) option.distinct(1) option.sel)

lemma ctor_codep_intro:
  assumes "\<And> x y. ctor1 x \<noteq> ctor2 y"
  shows "ctor_prism ctor1 disc1 sel1 \<nabla> ctor_prism ctor2 disc2 sel2"
  by (rule prism_diff_intro, simp add: lens_defs assms)

ML_file "Channel_Type.ML"

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_propositional_Okay
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Form = x "Form" "Form" | Not "Form" | Var "int"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun or2 :: "bool list => bool" where
  "or2 (nil2) = False"
| "or2 (cons2 y2 xs) = (y2 | (or2 xs))"

fun okay :: "((int, bool) pair) list => int list" where
  "okay (nil2) = nil2"
| "okay (cons2 (pair2 z2 y22) xs) = cons2 z2 (okay xs)"

fun models7 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models7 z (nil2) = nil2"
| "models7 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models7 z xs)
        else
        models7 z xs)"

fun models6 :: "int => ((int, bool) pair) list => bool list" where
  "models6 z (nil2) = nil2"
| "models6 z (cons2 (pair2 y22 True) x2) = models6 z x2"
| "models6 z (cons2 (pair2 y22 False) x2) =
     cons2 (z = y22) (models6 z x2)"

fun models5 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models5 z (nil2) = nil2"
| "models5 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models5 z xs)
        else
        models5 z xs)"

fun models4 :: "int => ((int, bool) pair) list => bool list" where
  "models4 z (nil2) = nil2"
| "models4 z (cons2 (pair2 y22 True) x2) =
     cons2 (z = y22) (models4 z x2)"
| "models4 z (cons2 (pair2 y22 False) x2) = models4 z x2"

function models :: "(((int, bool) pair) list) list => Form =>
                    (((int, bool) pair) list) list => (((int, bool) pair) list) list"
  and
  models2 :: "Form => (((int, bool) pair) list) list =>
                     (((int, bool) pair) list) list"
  and
  models3 :: "Form => ((int, bool) pair) list =>
                     (((int, bool) pair) list) list" where
  "models z q (nil2) = models2 q z"
| "models z q (cons2 z2 x2) = cons2 z2 (models z q x2)"
| "models2 q (nil2) = nil2"
| "models2 q (cons2 y2 z2) = models z2 q (models3 q y2)"
| "models3 (x p q) y2 = models2 q (models3 p y2)"
| "models3 (Not (x r q2)) y2 =
     y (models3 (Not r) y2) (models3 (x r (Not q2)) y2)"
| "models3 (Not (Not p2)) y2 = models3 p2 y2"
| "models3 (Not (Var x2)) y2 =
     (if (~ (or2 (models4 x2 y2))) then
        cons2 (cons2 (pair2 x2 False) (models5 x2 y2)) (nil2)
        else
        nil2)"
| "models3 (Var x3) y2 =
     (if (~ (or2 (models6 x3 y2))) then
        cons2 (cons2 (pair2 x3 True) (models7 x3 y2)) (nil2)
        else
        nil2)"
  by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = ((z2 = z) | (elem z xs))"

fun okay2 :: "((int, bool) pair) list => bool" where
  "okay2 (nil2) = True"
| "okay2 (cons2 (pair2 z2 c2) m) =
     ((~ (elem z2 (okay m))) & (okay2 m))"

fun formula :: "(((int, bool) pair) list) list => bool" where
  "formula (nil2) = True"
| "formula (cons2 y2 xs) = ((okay2 y2) & (formula xs))"

theorem property0 :
  "formula (models3 p (nil2))"
  oops

end


theory StackConversion
imports StackEvaluate
begin

abbreviation reshuffle :: "nat \<Rightarrow> expr \<Rightarrow> expr" where
  "reshuffle x e \<equiv> incr\<^sub>e\<^sub>e (Suc x) (subst\<^sub>x\<^sub>e (Suc x) 0 (incr\<^sub>e\<^sub>e 0 e))"

primrec unfold_heap :: "expr heap \<Rightarrow> expr \<Rightarrow> nat list \<Rightarrow> expr" where
  "unfold_heap h e [] = e"
| "unfold_heap h e (x # xs) = unfold_heap h (Let (lookup\<^sub>h h x) (reshuffle x e)) xs"

primrec unframe :: "frame \<Rightarrow> expr \<Rightarrow> expr heap \<Rightarrow> expr \<times> expr heap" where
  "unframe (SRef x) e h = (Var x, update\<^sub>h h x e)"
| "unframe (SApp e\<^sub>2) e h = (App e e\<^sub>2, h)"
| "unframe (SProj l) e h = (Proj e l, h)"
| "unframe (SCase t cs) e h = (Case e t cs, h)"
| "unframe (SUnfold t) e h = (Unfold t e, h)"
| "unframe (STyApp t) e h = (TyApp e t, h)"

fun unstack :: "nat list list \<Rightarrow> frame list \<Rightarrow> expr \<Rightarrow> expr heap \<Rightarrow> expr" where
  "unstack [] s e h = e"
| "unstack (r # rs) [] e h = unstack rs [] (unfold_heap h e r) h"
| "unstack (r # rs) (f # s) e h =
    (case unframe f (unfold_heap h e r) h of (e', h') \<Rightarrow> unstack rs s e' h')"

fun unstack_state :: "nat list list \<Rightarrow> stack_state \<Rightarrow> expr" where
  "unstack_state rs (StackState (Eval e) s h) = unstack rs s e h"
| "unstack_state rs (StackState (Return v) s h) = unstack rs s (devalue v) h"

primrec ordering_for_heap :: "nat list \<Rightarrow> expr heap \<Rightarrow> bool" where
  "ordering_for_heap [] h = True"
| "ordering_for_heap (r # rs) h =
    (r < length\<^sub>h h \<and> free_vars (lookup\<^sub>h h r) \<subseteq> set rs \<and> ordering_for_heap rs h)"

fun ordering_for_stack :: "expr heap \<Rightarrow> nat list list \<Rightarrow> frame list \<Rightarrow> bool" where
  "ordering_for_stack h [] s = False"
| "ordering_for_stack h (rs # rss) [] = (rss = [])"
| "ordering_for_stack h (rs # rss) (f # s) = ((\<forall>x \<in> free_vars\<^sub>s f. x < length\<^sub>h h) \<and>
    heap_walk free_vars h (free_vars\<^sub>s f) \<subseteq> set (concat rss) \<and> ordering_for_stack h rss s)"

definition safe_unfold_order :: "nat list list \<Rightarrow> expr \<Rightarrow> expr heap \<Rightarrow> frame list \<Rightarrow> type list \<Rightarrow> bool" where
  "safe_unfold_order rss e h s \<Gamma> = (distinct (concat rss) \<and> free_vars e \<subseteq> set (concat rss) \<and>
    h \<turnstile>\<^sub>h \<Gamma> \<and> ordering_for_heap (concat rss) h \<and> ordering_for_stack h rss s)"

fun safe_unfold_order\<^sub>\<Sigma> :: "nat list list \<Rightarrow> stack_state \<Rightarrow> bool" where
  "safe_unfold_order\<^sub>\<Sigma> rss (StackState (Eval e) s h) = (\<forall>\<Gamma>. h \<turnstile>\<^sub>h \<Gamma> \<longrightarrow> safe_unfold_order rss e h s \<Gamma>)"
| "safe_unfold_order\<^sub>\<Sigma> rss (StackState (Return v) s h) =
    (\<forall>\<Gamma>. h \<turnstile>\<^sub>h \<Gamma> \<longrightarrow> safe_unfold_order rss (devalue v) h s \<Gamma>)"

lemma heap_lookup_freevars [simp]: "ordering_for_heap (ys @ [x] @ xs) h \<Longrightarrow>
    free_vars (lookup\<^sub>h h x) \<subseteq> set xs"
  by (induction ys) simp_all

lemma [simp]: "ordering_for_heap (ys @ [x] @ xs) h \<Longrightarrow> h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> \<exists>t. lookup \<Gamma> x = Some t"
  proof (induction ys)
  case Nil
    moreover hence "length\<^sub>h h = length \<Gamma>" by auto
    ultimately show ?case by simp
  qed simp_all

lemma [elim]: "ordering_for_heap (as @ bs) h \<Longrightarrow> ordering_for_heap bs h"
  by (induction as) simp_all

lemma tc_unfold_heap' [simp]: "[],\<Gamma> \<turnstile> e : t \<Longrightarrow> free_vars e \<subseteq> set xs \<Longrightarrow>
    h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> ordering_for_heap (ys @ xs) h \<Longrightarrow> [],[] \<turnstile> unfold_heap h e xs : t"
  proof (induction xs arbitrary: \<Gamma> e ys)
  case (Cons x xs)
    from Cons obtain tt where T: "lookup \<Gamma> x = Some tt" by fastforce
    with Cons have "[],\<Gamma> \<turnstile> lookup\<^sub>h h x : tt" by simp
    moreover from T obtain \<Gamma>' where "\<Gamma> = insert_at x tt \<Gamma>' \<and> x \<le> length \<Gamma>'" by fastforce
    moreover with Cons(2) have "[],insert_at 0 tt (insert_at x tt \<Gamma>') \<turnstile> incr\<^sub>e\<^sub>e 0 e : t"
      using tc_incr\<^sub>e\<^sub>e by blast
    ultimately have A: "[],\<Gamma> \<turnstile> Let (lookup\<^sub>h h x) (reshuffle x e) : t" by simp
    from Cons have C: "free_vars (Let (lookup\<^sub>h h x) (reshuffle x e)) \<subseteq> set xs" by auto
    from Cons have "h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> ordering_for_heap ((ys @ [x]) @ xs) h" by simp
    with Cons A C have "[],[] \<turnstile> unfold_heap h (Let (lookup\<^sub>h h x) (reshuffle x e)) xs : t"
      by blast
    thus ?case by simp
  qed simp_all

lemma [simp]: "[],\<Gamma> \<turnstile> e : t \<Longrightarrow> free_vars e \<subseteq> set rs \<Longrightarrow> h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow>
    ordering_for_heap rs h \<Longrightarrow> [],[] \<turnstile> unfold_heap h e rs : t"
  proof -
    assume "ordering_for_heap rs h"
    hence "ordering_for_heap ([] @ rs) h" by simp
    moreover assume "[],\<Gamma> \<turnstile> e : t"
    moreover assume "h \<turnstile>\<^sub>h \<Gamma>"
    moreover assume "free_vars e \<subseteq> set rs"
    ultimately show "[],[] \<turnstile> unfold_heap h e rs : t" by (metis tc_unfold_heap')
  qed

lemma free_vars_unfold [simp]: "ordering_for_heap (rs @ rss) h \<Longrightarrow> free_vars e \<subseteq> set (rs @ rss) \<Longrightarrow>
    free_vars (unfold_heap h e rs) \<subseteq> set rss"
  proof (induction rs arbitrary: e)
  case (Cons r rs)
    moreover hence "free_vars (Let (lookup\<^sub>h h r) (reshuffle r e)) \<subseteq> set (rs @ rss)" by auto
    ultimately show ?case by simp
  qed simp_all

lemma tc_unfold_heap'' [simp]: "[],\<Gamma> \<turnstile> e : t \<Longrightarrow> free_vars e \<subseteq> set (xs @ rss) \<Longrightarrow>
    h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> ordering_for_heap (ys @ xs @ rss) h \<Longrightarrow> [],\<Gamma> \<turnstile> unfold_heap h e xs : t"
  proof (induction xs arbitrary: \<Gamma> e ys)
  case (Cons x xs)
    from Cons obtain tt where T: "lookup \<Gamma> x = Some tt" by fastforce
    with Cons have "[],\<Gamma> \<turnstile> lookup\<^sub>h h x : tt" by simp
    moreover from T obtain \<Gamma>' where "\<Gamma> = insert_at x tt \<Gamma>' \<and> x \<le> length \<Gamma>'" by fastforce
    moreover with Cons(2) have "[],insert_at 0 tt (insert_at x tt \<Gamma>') \<turnstile> incr\<^sub>e\<^sub>e 0 e : t"
      using tc_incr\<^sub>e\<^sub>e by blast
    ultimately have A: "[],\<Gamma> \<turnstile> Let (lookup\<^sub>h h x) (reshuffle x e) : t" by simp
    from Cons have "free_vars (lookup\<^sub>h h x) \<subseteq> set (xs @ rss)"
      using heap_lookup_freevars by fastforce
    with Cons have C: "free_vars (Let (lookup\<^sub>h h x) (reshuffle x e)) \<subseteq> set (xs @ rss)" by auto
    from Cons have "h \<turnstile>\<^sub>h \<Gamma> \<Longrightarrow> ordering_for_heap ((ys @ [x]) @ (xs @ rss)) h" by simp
    with Cons A C have "[],\<Gamma> \<turnstile> unfold_heap h (Let (lookup\<^sub>h h x) (reshuffle x e)) xs : t"
      by blast
    thus ?case by simp
  qed simp_all

lemma [simp]: "[],\<Gamma> \<turnstile> e : t \<Longrightarrow> safe_unfold_order (rs # rss) e h s \<Gamma> \<Longrightarrow>
    [],\<Gamma> \<turnstile> unfold_heap h e rs : t"
  proof (unfold safe_unfold_order_def)
    assume "distinct (concat (rs # rss)) \<and> free_vars e \<subseteq> set (concat (rs # rss)) \<and> h \<turnstile>\<^sub>h \<Gamma> \<and>
      ordering_for_heap (concat (rs # rss)) h \<and> ordering_for_stack h (rs # rss) s"
    moreover hence "ordering_for_heap ([] @ rs @ concat rss) h" by simp
    moreover assume "[],\<Gamma> \<turnstile> e : t"
    ultimately show "[],\<Gamma> \<turnstile> unfold_heap h e rs : t" by (metis tc_unfold_heap'' concat.simps(2))
  qed

lemma [simp]: "\<Gamma> \<turnstile>\<^sub>s f : t \<rightarrow> t' \<Longrightarrow> [],\<Gamma> \<turnstile> e : t \<Longrightarrow> unframe f e h = (e', h') \<Longrightarrow> [],\<Gamma> \<turnstile> e' : t'"
  by (induction \<Gamma> f t t' rule: typecheck_frame.induct) auto

lemma [simp]: "ordering_for_heap rs h \<Longrightarrow> x < length\<^sub>h h \<Longrightarrow> free_vars e \<subseteq> set rs \<Longrightarrow>
    ordering_for_heap rs (update\<^sub>h h x e)"
  apply (induction rs)
  apply simp_all

lemma [simp]: "ordering_for_stack h rss s \<Longrightarrow> x < length\<^sub>h h \<Longrightarrow>
    ordering_for_stack (update\<^sub>h h x (unfold_heap h e rs)) rss s"
  proof (induction h rss s rule: ordering_for_stack.induct)
  case (3 h rs' rss f s)
    from 3 have "ordering_for_stack (update\<^sub>h h x (unfold_heap h e rs)) rss s" by simp
    from 3 have "\<forall>x \<in> free_vars\<^sub>s f. x < length\<^sub>h h" by simp
    from 3 have "heap_walk free_vars h (free_vars\<^sub>s f) \<subseteq> set (concat rss)" by simp
    from 3 have "ordering_for_stack h rss s" by simp
    from 3 have "x < length\<^sub>h h" by simp

    have "heap_walk free_vars (update\<^sub>h h x (unfold_heap h e rs)) (free_vars\<^sub>s f) \<subseteq> set (concat rss)" by simp
    with 3 show ?case by simp
  qed simp_all

lemma [elim]: "safe_unfold_order (rs # rss) e h (f # s) \<Gamma> \<Longrightarrow> [],\<Gamma> \<turnstile> e : t \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>s f : t \<rightarrow> t' \<Longrightarrow>
    unframe f (unfold_heap h e rs) h = (e', h') \<Longrightarrow> safe_unfold_order rss e' h' s \<Gamma>"
  proof (induction f)
  case (SRef x)
    from SRef have E: "e' = Var x" by simp
    from SRef have H: "h' = update\<^sub>h h x (unfold_heap h e rs)" by simp
    from SRef have "distinct (concat (rs # rss))" by (simp add: safe_unfold_order_def)
    from SRef have "free_vars e \<subseteq> set (concat (rs # rss))" by (simp add: safe_unfold_order_def)
    from SRef have "h \<turnstile>\<^sub>h \<Gamma>" by (simp add: safe_unfold_order_def)
    from SRef have "ordering_for_heap (concat (rs # rss)) h" by (simp add: safe_unfold_order_def)
    from SRef have "heap_walk free_vars h {x} \<subseteq> set (concat rss)" by (simp add: safe_unfold_order_def)
    from SRef have "ordering_for_stack h rss s" by (simp add: safe_unfold_order_def)
    from SRef have "x < length\<^sub>h h" by (simp add: safe_unfold_order_def)
    from SRef have "[],\<Gamma> \<turnstile> e : t" by (simp add: safe_unfold_order_def)

    from SRef have "finite {x} \<and> (\<forall>a. finite (free_vars a)) \<and> (\<forall>x \<in> {x}. x < length\<^sub>h h)"
      by (simp add: safe_unfold_order_def)
    hence "{x} \<subseteq> heap_walk free_vars h {x}" by (metis heap_walk_extends)
    with SRef have X: "x \<in> set (concat rss)" by (auto simp add: safe_unfold_order_def)
    from SRef have A: "h \<turnstile>\<^sub>h \<Gamma>" by (simp add: safe_unfold_order_def)
    from SRef have B: "lookup \<Gamma> x = Some t \<and> t' = t" by fastforce
    from SRef have "[],\<Gamma> \<turnstile> unfold_heap h e rs : t" by simp
    with A B have Y: "update\<^sub>h h x (unfold_heap h e rs) \<turnstile>\<^sub>h \<Gamma>" by simp

    have Z: "ordering_for_heap (concat rss) (update\<^sub>h h x (unfold_heap h e rs))" by simp

    have "ordering_for_stack (update\<^sub>h h x (unfold_heap h e rs)) rss s" by simp
    with SRef E H X Y Z show ?case by (simp add: safe_unfold_order_def)
  next case (SApp e\<^sub>2)
    hence X: "free_vars (unfold_heap h e rs) \<subseteq> set (concat rss)"
      by (metis free_vars_unfold safe_unfold_order_def concat.simps(2))
    from SApp have "heap_walk free_vars h (free_vars e\<^sub>2) \<subseteq> set (concat rss)"
      by (simp add: safe_unfold_order_def)
    moreover from SApp have "free_vars e\<^sub>2 \<subseteq> heap_walk free_vars h (free_vars e\<^sub>2)"
      by (simp add: safe_unfold_order_def)
    ultimately have "free_vars e\<^sub>2 \<subseteq>  set (concat rss)" by simp
    with SApp X have "safe_unfold_order rss (App (unfold_heap h e rs) e\<^sub>2) h s \<Gamma>"
      by (auto simp add: safe_unfold_order_def)
    with SApp show ?case by auto
  next case (SProj l)
    hence "free_vars (unfold_heap h e rs) \<subseteq> set (concat rss)"
      by (metis free_vars_unfold safe_unfold_order_def concat.simps(2))
    with SProj have "safe_unfold_order rss (Proj (unfold_heap h e rs) l) h s \<Gamma>"
      by (auto simp add: safe_unfold_order_def)
    with SProj show ?case by auto
  next case (SCase t cs)
    hence X: "free_vars (unfold_heap h e rs) \<subseteq> set (concat rss)"
      by (metis free_vars_unfold safe_unfold_order_def concat.simps(2))
    from SCase have "heap_walk free_vars h (free_vars\<^sub>c cs) \<subseteq> set (concat rss)"
      by (simp add: safe_unfold_order_def)
    moreover from SCase have "free_vars\<^sub>c cs \<subseteq> heap_walk free_vars h (free_vars\<^sub>c cs)"
      by (simp add: safe_unfold_order_def)
    ultimately have "free_vars\<^sub>c cs \<subseteq>  set (concat rss)" by simp
    with SCase X have "safe_unfold_order rss (Case (unfold_heap h e rs) t cs) h s \<Gamma>"
      by (auto simp add: safe_unfold_order_def)
    with SCase show ?case by auto
  next case (SUnfold t)
    hence "free_vars (unfold_heap h e rs) \<subseteq> set (concat rss)"
      by (metis free_vars_unfold safe_unfold_order_def concat.simps(2))
    with SUnfold have "safe_unfold_order rss (Unfold t (unfold_heap h e rs)) h s \<Gamma>"
      by (auto simp add: safe_unfold_order_def)
    with SUnfold show ?case by auto
  next case (STyApp t)
    hence "free_vars (unfold_heap h e rs) \<subseteq> set (concat rss)"
      by (metis free_vars_unfold safe_unfold_order_def concat.simps(2))
    with STyApp have "safe_unfold_order rss (TyApp (unfold_heap h e rs) t) h s \<Gamma>"
      by (auto simp add: safe_unfold_order_def)
    with STyApp show ?case by auto
  qed

lemma [simp]: "\<Gamma> \<turnstile>\<^sub>s\<^sub>s s : t \<rightarrow> t' \<Longrightarrow> [],\<Gamma> \<turnstile> e : t \<Longrightarrow> safe_unfold_order rs e h s \<Gamma> \<Longrightarrow>
    [],[] \<turnstile> unstack rs s e h : t'"
  proof (induction rs s e h arbitrary: t rule: unstack.induct)
  case (3 r rs f s e h)
    then obtain e' h' where EH: "unframe f (unfold_heap h e r) h = (e', h')" by fastforce
    from 3 obtain t'' where F: "\<Gamma> \<turnstile>\<^sub>s f : t \<rightarrow> t''" and S: "\<Gamma> \<turnstile>\<^sub>s\<^sub>s s : t'' \<rightarrow> t'" by fastforce
    from 3 EH have X: "safe_unfold_order rs e' h' s \<Gamma>" by fastforce
    from 3 have "[],\<Gamma> \<turnstile> unfold_heap h e r : t" by simp
    with F EH have "[],\<Gamma> \<turnstile> e' : t''" by simp
    with 3 EH S X show ?case by simp
  qed (auto simp add: safe_unfold_order_def)

lemma tc_unstack_state [elim]: "\<Sigma> hastype t \<Longrightarrow> safe_unfold_order\<^sub>\<Sigma> rs \<Sigma> \<Longrightarrow>
    [],[] \<turnstile> unstack_state rs \<Sigma> : t"
  by (induction \<Sigma> t rule: typecheck_stack_state.induct) simp_all

end


(* The state equivalence used for the unwinding proofs for the friendship confidentiality
   properties *)
theory Outer_Friend_Receiver_State_Indistinguishability
  imports Outer_Friend_Receiver_Observation_Setup
begin

subsubsection \<open>Unwinding helper definitions and lemmas\<close>

context OuterFriendReceiver
begin

(* The notion of two (apiID \<times> userID) lists being equal except for an occurrence of (AID, UID): *)
fun eqButUIDl :: "(apiID \<times> userID) list \<Rightarrow> (apiID \<times> userID) list \<Rightarrow> bool" where
"eqButUIDl auidl auidl1 = (remove1 (AID,UID) auidl = remove1 (AID,UID) auidl1)"

lemma eqButUIDl_eq[simp,intro!]: "eqButUIDl auidl auidl"
by auto

lemma eqButUIDl_sym:
assumes "eqButUIDl auidl auidl1"
shows "eqButUIDl auidl1 auidl"
using assms by auto

lemma eqButUIDl_trans:
assumes "eqButUIDl auidl auidl1" and "eqButUIDl auidl1 auidl2"
shows "eqButUIDl auidl auidl2"
using assms by auto

lemma eqButUIDl_remove1_cong:
assumes "eqButUIDl auidl auidl1"
shows "eqButUIDl (remove1 auid auidl) (remove1 auid auidl1)"
using assms by (auto simp: remove1_commute)

lemma eqButUIDl_snoc_cong:
assumes "eqButUIDl auidl auidl1"
and "auid' \<in>\<in> auidl \<longleftrightarrow> auid' \<in>\<in> auidl1"
shows "eqButUIDl (auidl ## auid') (auidl1 ## auid')"
using assms by (auto simp: remove1_append remove1_idem)

(* The notion of two functions each taking a userID being equal for observers,
   and eqButUIDs for others. *)
definition eqButUIDf where
"eqButUIDf frds frds1 \<equiv>
  (\<forall>uid. if uid \<in> UIDs AID' then frds uid = frds1 uid else eqButUIDl (frds uid) (frds1 uid))"

lemmas eqButUIDf_intro = eqButUIDf_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUIDf_eeq[simp,intro!]: "eqButUIDf frds frds"
unfolding eqButUIDf_def by auto

lemma eqButUIDf_sym:
assumes "eqButUIDf frds frds1" shows "eqButUIDf frds1 frds"
using assms unfolding eqButUIDf_def
by auto

lemma eqButUIDf_trans:
assumes "eqButUIDf frds frds1" and "eqButUIDf frds1 frds2"
shows "eqButUIDf frds frds2"
using assms unfolding eqButUIDf_def by fastforce

lemma eqButUIDf_cong:
assumes "eqButUIDf frds frds1"
and "uid \<in> UIDs AID' \<Longrightarrow> uu = uu1"
and "uid \<notin> UIDs AID' \<Longrightarrow> eqButUIDl uu uu1"
shows "eqButUIDf (frds (uid := uu)) (frds1(uid := uu1))"
using assms unfolding eqButUIDf_def by auto
(*
lemma eqButUIDf_eqButUIDl:
assumes "eqButUIDf frds frds1"
shows "eqButUIDl UID2 (frds UID1) (frds1 UID1)"
  and "eqButUIDl UID1 (frds UID2) (frds1 UID2)"
using assms unfolding eqButUIDf_def by (auto split: if_splits)
*)
lemma eqButUIDf_UIDs:
"\<lbrakk>eqButUIDf frds frds1; uid \<in> UIDs AID'\<rbrakk> \<Longrightarrow> frds uid = frds1 uid"
unfolding eqButUIDf_def by (auto split: if_splits)
(*
lemma eqButUIDf_not_UID':
assumes eq1: "eqButUIDf frds frds1"
and uid: "(uid,uid') \<notin> {(UID1,UID2), (UID2,UID1)}"
shows "uid \<in>\<in> frds uid' \<longleftrightarrow> uid \<in>\<in> frds1 uid'"
proof -
  from uid have "(uid' = UID1 \<and> uid \<noteq> UID2)
               \<or> (uid' = UID2 \<and> uid \<noteq> UID1)
               \<or> (uid' \<notin> {UID1,UID2})" (is "?u1 \<or> ?u2 \<or> ?n12")
    by auto
  then show ?thesis proof (elim disjE)
    assume "?u1"
    moreover then have "uid \<in>\<in> remove1 UID2 (frds uid') \<longleftrightarrow> uid \<in>\<in> remove1 UID2 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?u2"
    moreover then have "uid \<in>\<in> remove1 UID1 (frds uid') \<longleftrightarrow> uid \<in>\<in> remove1 UID1 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?n12"
    then show ?thesis using eq1 unfolding eqButUIDf_def by auto
  qed
qed

(* The notion of two functions each taking two userID arguments being
  equal everywhere but on the values (UID1,UID2) and (UID2,UID1): *)
definition eqButUID12 where
"eqButUID12 freq freq1 \<equiv>
 \<forall> uid uid'. if (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} then True else freq uid uid' = freq1 uid uid'"

lemmas eqButUID12_intro = eqButUID12_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID12_eeq[simp,intro!]: "eqButUID12 freq freq"
unfolding eqButUID12_def by auto

lemma eqButUID12_sym:
assumes "eqButUID12 freq freq1" shows "eqButUID12 freq1 freq"
using assms unfolding eqButUID12_def
by presburger

lemma eqButUID12_trans:
assumes "eqButUID12 freq freq1" and "eqButUID12 freq1 freq2"
shows "eqButUID12 freq freq2"
using assms unfolding eqButUID12_def by (auto split: if_splits)

lemma eqButUID12_cong:
assumes "eqButUID12 freq freq1"
(*and "uid = UID1 \<Longrightarrow> eqButUID2 uu uu1"*)
and "\<not> (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)} \<Longrightarrow> uu = uu1"
shows "eqButUID12 (fun_upd2 freq uid uid' uu) (fun_upd2 freq1 uid uid' uu1)"
using assms unfolding eqButUID12_def fun_upd2_def by (auto split: if_splits)

lemma eqButUID12_not_UID:
"\<lbrakk>eqButUID12 freq freq1; \<not> (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}\<rbrakk> \<Longrightarrow> freq uid uid' = freq1 uid uid'"
unfolding eqButUID12_def by (auto split: if_splits)
*)

(* The notion of two states being equal everywhere but on the friendship requests or status of users UID1 and UID2: *)
definition eqButUID :: "state \<Rightarrow> state \<Rightarrow> bool" where
"eqButUID s s1 \<equiv>
 admin s = admin s1 \<and>

 pendingUReqs s = pendingUReqs s1 \<and> userReq s = userReq s1 \<and>
 userIDs s = userIDs s1 \<and> user s = user s1 \<and> pass s = pass s1 \<and>

 pendingFReqs s = pendingFReqs s1 \<and>
 friendReq s = friendReq s1 \<and>
 friendIDs s = friendIDs s1 \<and>

 postIDs s = postIDs s1 \<and> admin s = admin s1 \<and>
 post s = post s1 \<and> vis s = vis s1 \<and>
 owner s = owner s1 \<and>

 pendingSApiReqs s = pendingSApiReqs s1 \<and> sApiReq s = sApiReq s1 \<and>
 serverApiIDs s = serverApiIDs s1 \<and> serverPass s = serverPass s1 \<and>
 outerPostIDs s = outerPostIDs s1 \<and> outerPost s = outerPost s1 \<and> outerVis s = outerVis s1 \<and>
 outerOwner s = outerOwner s1 \<and>
 sentOuterFriendIDs s = sentOuterFriendIDs s1 \<and>
 eqButUIDf (recvOuterFriendIDs s) (recvOuterFriendIDs s1) \<and>

 pendingCApiReqs s = pendingCApiReqs s1 \<and> cApiReq s = cApiReq s1 \<and>
 clientApiIDs s = clientApiIDs s1 \<and> clientPass s = clientPass s1 \<and>
 sharedWith s = sharedWith s1"

lemmas eqButUID_intro = eqButUID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID_refl[simp,intro!]: "eqButUID s s"
unfolding eqButUID_def by auto

lemma eqButUID_sym[sym]:
assumes "eqButUID s s1" shows "eqButUID s1 s"
using assms eqButUIDf_sym unfolding eqButUID_def by auto

lemma eqButUID_trans[trans]:
assumes "eqButUID s s1" and "eqButUID s1 s2" shows "eqButUID s s2"
using assms eqButUIDf_trans unfolding eqButUID_def by metis

(* Implications from eqButUID, including w.r.t. auxiliary operations: *)
lemma eqButUID_stateSelectors:
assumes "eqButUID s s1"
shows "admin s = admin s1"
"pendingUReqs s = pendingUReqs s1" "userReq s = userReq s1"
"userIDs s = userIDs s1" "user s = user s1" "pass s = pass s1"
"pendingFReqs s = pendingFReqs s1"
"friendReq s = friendReq s1"
"friendIDs s = friendIDs s1"

"postIDs s = postIDs s1"
"post s = post s1" "vis s = vis s1"
"owner s = owner s1"

"pendingSApiReqs s = pendingSApiReqs s1" "sApiReq s = sApiReq s1"
"serverApiIDs s = serverApiIDs s1" "serverPass s = serverPass s1"
"outerPostIDs s = outerPostIDs s1" "outerPost s = outerPost s1" "outerVis s = outerVis s1"
"outerOwner s = outerOwner s1"
"sentOuterFriendIDs s = sentOuterFriendIDs s1"
"eqButUIDf (recvOuterFriendIDs s) (recvOuterFriendIDs s1)"

"pendingCApiReqs s = pendingCApiReqs s1" "cApiReq s = cApiReq s1"
"clientApiIDs s = clientApiIDs s1" "clientPass s = clientPass s1"
"sharedWith s = sharedWith s1"

"IDsOK s = IDsOK s1"
using assms unfolding eqButUID_def IDsOK_def[abs_def] by auto

lemma eqButUID_UIDs:
"eqButUID s s1 \<Longrightarrow> uid \<in> UIDs AID' \<Longrightarrow> recvOuterFriendIDs s uid = recvOuterFriendIDs s1 uid"
unfolding eqButUID_def eqButUIDf_def by auto

lemma eqButUID_recvOuterFriends_UIDs:
assumes "eqButUID s s1"
and "uid \<noteq> UID \<or> aid \<noteq> AID"
shows "(aid, uid) \<in>\<in> recvOuterFriendIDs s uid' \<longleftrightarrow> (aid, uid) \<in>\<in> recvOuterFriendIDs s1 uid'"
using assms unfolding eqButUID_def eqButUIDf_def
proof -
  have "(aid, uid) \<in>\<in> remove1 (AID,UID) (recvOuterFriendIDs s uid')
    \<longleftrightarrow> (aid, uid) \<in>\<in> remove1 (AID,UID) (recvOuterFriendIDs s1 uid')"
    using assms unfolding eqButUID_def eqButUIDf_def by (cases "uid' \<in> UIDs AID'") auto
  then show ?thesis using assms by auto
qed

lemma eqButUID_remove1_UID_recvOuterFriends:
assumes "eqButUID s s1"
shows "remove1 (AID,UID) (recvOuterFriendIDs s uid) = remove1 (AID,UID) (recvOuterFriendIDs s1 uid)"
using assms unfolding eqButUID_def eqButUIDf_def by (cases "uid \<in> UIDs AID'") auto

lemma eqButUID_cong:
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>admin := uu1\<rparr>) (s1 \<lparr>admin := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingUReqs := uu1\<rparr>) (s1 \<lparr>pendingUReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>userReq := uu1\<rparr>) (s1 \<lparr>userReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>userIDs := uu1\<rparr>) (s1 \<lparr>userIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>user := uu1\<rparr>) (s1 \<lparr>user := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pass := uu1\<rparr>) (s1 \<lparr>pass := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>postIDs := uu1\<rparr>) (s1 \<lparr>postIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>owner := uu1\<rparr>) (s1 \<lparr>owner := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>post := uu1\<rparr>) (s1 \<lparr>post := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>vis := uu1\<rparr>) (s1 \<lparr>vis := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingFReqs := uu1\<rparr>) (s1 \<lparr>pendingFReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>friendReq := uu1\<rparr>) (s1 \<lparr>friendReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>friendIDs := uu1\<rparr>) (s1 \<lparr>friendIDs := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingSApiReqs := uu1\<rparr>) (s1 \<lparr>pendingSApiReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>sApiReq := uu1\<rparr>) (s1 \<lparr>sApiReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>serverApiIDs := uu1\<rparr>) (s1 \<lparr>serverApiIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>serverPass := uu1\<rparr>) (s1 \<lparr>serverPass := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>outerPostIDs := uu1\<rparr>) (s1 \<lparr>outerPostIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>outerPost := uu1\<rparr>) (s1 \<lparr>outerPost := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>outerVis := uu1\<rparr>) (s1 \<lparr>outerVis := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>outerOwner := uu1\<rparr>) (s1 \<lparr>outerOwner := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>sentOuterFriendIDs := uu1\<rparr>) (s1 \<lparr>sentOuterFriendIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> eqButUIDf uu1 uu2 \<Longrightarrow> eqButUID (s \<lparr>recvOuterFriendIDs := uu1\<rparr>) (s1 \<lparr>recvOuterFriendIDs := uu2\<rparr>)"

"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>pendingCApiReqs := uu1\<rparr>) (s1 \<lparr>pendingCApiReqs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>cApiReq := uu1\<rparr>) (s1 \<lparr>cApiReq := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>clientApiIDs := uu1\<rparr>) (s1 \<lparr>clientApiIDs := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>clientPass := uu1\<rparr>) (s1 \<lparr>clientPass := uu2\<rparr>)"
"\<And> uu1 uu2. eqButUID s s1 \<Longrightarrow> uu1 = uu2 \<Longrightarrow> eqButUID (s \<lparr>sharedWith := uu1\<rparr>) (s1 \<lparr>sharedWith:= uu2\<rparr>)"
unfolding eqButUID_def by auto

end

end