subsection \<open>Semantics Based on DBMs\<close>

theory DBM_Zone_Semantics
imports DBM_Operations
begin

subsection \<open>Single Step\<close>

inductive step_z_dbm ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('t::time) DBM
    \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> ('t::time) DBM \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<leadsto>\<^bsub>_,_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  step_t_z_dbm:
    "D_inv = abstr (inv_of A l) (\<lambda>i j. \<infinity>) v \<Longrightarrow> A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l,And (up (And D D_inv)) D_inv\<rangle>" |
  step_a_z_dbm:
    "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'
    \<Longrightarrow> A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l',And (reset' (And D (abstr g (\<lambda>i j. \<infinity>) v)) n r v 0)
                                             (abstr (inv_of A l') (\<lambda>i j. \<infinity>) v)\<rangle>"
inductive_cases step_z_cases: "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l', D'\<rangle>"

declare step_z_dbm.intros[intro]

lemma step_z_dbm_preserves_int:
  assumes "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l',D'\<rangle>" "global_clock_numbering A v n" "valid_abstraction A X k"
          "dbm_int D n"
  shows "dbm_int D' n"
using assms
proof (cases, goal_cases)
  case (1 D'')
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" by blast+
  from 1(2) have "\<forall> (x, m) \<in> clkp_set A. m \<in> \<nat>" by (auto elim: valid_abstraction.cases)
  from dbm_int_inv_abstr[OF this] 1 have D''_int: "dbm_int D'' n" by simp
  show ?thesis unfolding 1(5) by (intro And_int_preservation up_int_preservation dbm_int_inv_abstr D''_int 1)
next
  case (2 g a r)
  hence assms: "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" "\<forall>k\<le>n. k > 0 \<longrightarrow> (\<exists>c. v c = k)" by blast+
  from 2(2) have *: "\<forall> (x, m) \<in> clkp_set A. m \<in> \<nat>" by (auto elim: valid_abstraction.cases)
  from dbm_int_inv_abstr[OF this] have D'_int: "dbm_int (abstr (inv_of A l') (\<lambda>i j. \<infinity>) v) n" by simp
  from dbm_int_guard_abstr 2 have D''_int: "dbm_int (abstr g (\<lambda>i j. \<infinity>) v) n" by simp
  have "set r \<subseteq> clk_set A" using 2(5) unfolding trans_of_def collect_clkvt_def by fastforce
  hence **:"\<forall>c\<in>set r. v c \<le> n" using assms(2) by fastforce
  show ?thesis unfolding 2(4)
  by (intro And_int_preservation DBM_reset'_int_preservation dbm_int_inv_abstr 2 D''_int)
     (simp_all add: assms(1) * **)
qed

lemma And_correct:
  shows "[M1]\<^bsub>v,n\<^esub> \<inter> [M2]\<^bsub>v,n\<^esub> = [And M1 M2]\<^bsub>v,n\<^esub>"
using DBM_and_sound1 DBM_and_sound2 DBM_and_complete unfolding DBM_zone_repr_def by auto

lemma up_correct:
  assumes "clock_numbering' v n"
  shows "[up M]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>\<^sup>\<up>"
using assms
 apply safe
  apply (rule DBM_up_sound')
   apply assumption+
 apply (rule DBM_up_complete')
  apply auto
done

lemma step_z_dbm_sound:
  assumes "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l', D'\<rangle>" "global_clock_numbering A v n"
  shows "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto> \<langle>l', [D']\<^bsub>v,n\<^esub>\<rangle>"
using assms
proof (cases, goal_cases)
  case (1 D'')
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" by blast+
  note assms = assms(1) this
  from assms(3) have *: "\<forall>c\<in>collect_clks (inv_of A l). v c \<le> n"
  unfolding clkp_set_def collect_clki_def inv_of_def by (fastforce simp: collect_clks_id)
  from 1 have D'':"[D'']\<^bsub>v,n\<^esub> = {u. u \<turnstile> inv_of A l}" using dbm_abstr_zone_eq[OF assms(2) *] by metis
  with And_correct have A11: "[And D D'']\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l})" by blast
  with And_correct D'' have
    "[D']\<^bsub>v,n\<^esub> = ([up (And D D'')]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l})"
  unfolding 1(3) by blast
  with up_correct[OF assms(2)] A11 have
    "[D']\<^bsub>v,n\<^esub> = (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}"
  by metis
  with 1(2) show ?thesis by auto
next
  case (2 g a r)
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" "\<forall>k\<le>n. k > 0 \<longrightarrow> (\<exists>c. v c = k)" by blast+
  note assms = assms(1) this
  from assms(3) have *: "\<forall>c\<in>collect_clks (inv_of A l'). v c \<le> n"
  unfolding clkp_set_def collect_clki_def inv_of_def by (fastforce simp: collect_clks_id)
  have D':
    "[abstr (inv_of A l') (\<lambda>i j. \<infinity>) v]\<^bsub>v,n\<^esub> = {u. u \<turnstile> inv_of A l'}"
  using 2 dbm_abstr_zone_eq[OF assms(2) *] by simp
  from assms(3) 2(3) have *: "\<forall>c\<in>collect_clks g. v c \<le> n"
  unfolding clkp_set_def collect_clkt_def inv_of_def by (fastforce simp: collect_clks_id)
  have D'':"[abstr g (\<lambda>i j. \<infinity>) v]\<^bsub>v,n\<^esub> = {u. u \<turnstile> g}" using 2 dbm_abstr_zone_eq[OF assms(2) *] by auto
  with And_correct have A11: "[And D (abstr g (\<lambda>i j. \<infinity>) v)]\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> g})" by blast
  let ?D = "reset' (And D (abstr g (\<lambda>i j. \<infinity>) v)) n r v 0"
  have "set r \<subseteq> clk_set A" using 2(3) unfolding trans_of_def collect_clkvt_def by fastforce
  hence **:"\<forall>c\<in>set r. v c \<le> n" using assms(3) by fastforce
  have D_reset: "[?D]\<^bsub>v,n\<^esub> = zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r"
  proof safe
    fix u assume u: "u \<in> [?D]\<^bsub>v,n\<^esub>"
    from DBM_reset'_sound[OF assms(4,2) ** this] obtain ts where
      "set_clocks r ts u \<in> [And D (abstr g (\<lambda>i j. \<infinity>) v)]\<^bsub>v,n\<^esub>"
    by auto
    with A11 have *: "set_clocks r ts u \<in> ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> g})" by blast
    from DBM_reset'_resets[OF assms(4,2) **] u
    have "\<forall>c \<in> set r. u c = 0" unfolding DBM_zone_repr_def by auto
    from reset_set[OF this] have "[r\<rightarrow>0]set_clocks r ts u = u" by simp
    with * show "u \<in> zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r" unfolding zone_set_def by force
  next
    fix u assume u: "u \<in> zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r"
    from DBM_reset'_complete[OF _ assms(2) **] u A11
    show "u \<in> [?D]\<^bsub>v,n\<^esub>" unfolding DBM_zone_repr_def zone_set_def by force
  qed
  from D' And_correct D_reset have A22:
    "[And ?D (abstr (inv_of A l') (\<lambda>i j. \<infinity>) v)]\<^bsub>v,n\<^esub> = ([?D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l'})"
  by blast
  with D_reset 2(2,3) show ?thesis by auto
qed

lemma step_z_dbm_DBM:
  assumes "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto> \<langle>l', Z\<rangle>" "global_clock_numbering A v n"
  obtains D' where "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l', D'\<rangle>" "Z = [D']\<^bsub>v,n\<^esub>"
using assms
proof (cases, goal_cases)
  case 1
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" by metis+
  note assms = assms(1) this
  from assms(3) have *: "\<forall>c\<in>collect_clks (inv_of A l). v c \<le> n"
  unfolding clkp_set_def collect_clki_def inv_of_def by (fastforce simp: collect_clks_id)
  obtain D'' where D''_def: "D'' = abstr (inv_of A l) (\<lambda>i j. \<infinity>) v" by auto
  hence D'':"[D'']\<^bsub>v,n\<^esub> = {u. u \<turnstile> inv_of A l}" using dbm_abstr_zone_eq[OF assms(2) *] by metis
  obtain A1 where A1: "A1 = And D D''" by fast
  with And_correct D'' have A11: "[A1]\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l})" by blast
  then obtain D_up where D_up': "D_up = up A1" by blast
  with up_correct assms(2) A11 have D_up: "[D_up]\<^bsub>v,n\<^esub> = (([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l}))\<^sup>\<up>" by metis
  obtain A2 where A2: "A2 = And D_up D''" by fast
  with And_correct D'' have A22: "[A2]\<^bsub>v,n\<^esub> = ([D_up]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l})" by blast
  from A2 D_up' D''_def A1 have "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l,A2\<rangle>" by blast
  moreover from A22 D_up have
    "[A2]\<^bsub>v,n\<^esub> = (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}"
  by auto
  ultimately show thesis using 1 by (intro that[of A2]) auto
next
  case (2 g a r)
  hence "clock_numbering' v n" "\<forall>c\<in>clk_set A. v c \<le> n" "\<forall>k\<le>n. k > 0 \<longrightarrow> (\<exists>c. v c = k)" by metis+
  note assms = assms(1) this
  from assms(3) have *: "\<forall>c\<in>collect_clks (inv_of A l'). v c \<le> n"
  unfolding clkp_set_def collect_clki_def inv_of_def by (fastforce simp: collect_clks_id)
  obtain D' where D'_def: "D' = abstr (inv_of A l') (\<lambda>i j. \<infinity>) v" by blast
  hence D':"[D']\<^bsub>v,n\<^esub> = {u. u \<turnstile> inv_of A l'}" using dbm_abstr_zone_eq[OF assms(2) *] by simp
  from assms(3) 2(4) have *: "\<forall>c\<in>collect_clks g. v c \<le> n"
  unfolding clkp_set_def collect_clkt_def inv_of_def by (fastforce simp: collect_clks_id)
  obtain D'' where D''_def: "D'' = abstr g (\<lambda>i j. \<infinity>) v" by blast
  hence D'':"[D'']\<^bsub>v,n\<^esub> = {u. u \<turnstile> g}" using dbm_abstr_zone_eq[OF assms(2) *] by auto
  obtain A1 where A1: "A1 = And D D''" by fast
  with And_correct D'' have A11: "[A1]\<^bsub>v,n\<^esub> = ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> g})" by blast
  let ?D = "reset' A1 n r v 0"
  have "set r \<subseteq> clk_set A" using 2(4) unfolding trans_of_def collect_clkvt_def by fastforce
  hence **:"\<forall>c\<in>set r. v c \<le> n" using assms(3) by fastforce
  have D_reset: "[?D]\<^bsub>v,n\<^esub> = zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r"
  proof safe
    fix u assume u: "u \<in> [?D]\<^bsub>v,n\<^esub>"
    from DBM_reset'_sound[OF assms(4,2) ** this] obtain ts where
      "set_clocks r ts u \<in> [A1]\<^bsub>v,n\<^esub>"
    by auto
    with A11 have *: "set_clocks r ts u \<in> ([D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> g})" by blast
    from DBM_reset'_resets[OF assms(4,2) **] u
    have "\<forall>c \<in> set r. u c = 0" unfolding DBM_zone_repr_def by auto
    from reset_set[OF this] have "[r\<rightarrow>0]set_clocks r ts u = u" by simp
    with * show "u \<in> zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r" unfolding zone_set_def by force
  next
    fix u assume u: "u \<in> zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r"
    from DBM_reset'_complete[OF _ assms(2) **] u A11
    show "u \<in> [?D]\<^bsub>v,n\<^esub>" unfolding DBM_zone_repr_def zone_set_def by force
  qed
  obtain A2 where A2: "A2 = And ?D D'" by fast
  with And_correct D' have A22: "[A2]\<^bsub>v,n\<^esub> = ([?D]\<^bsub>v,n\<^esub>) \<inter> ({u. u \<turnstile> inv_of A l'})" by blast
  from 2(4) A2 D'_def D''_def A1 have "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l',A2\<rangle>" by blast
  moreover from A22 D_reset have
    "[A2]\<^bsub>v,n\<^esub> = zone_set (([D]\<^bsub>v,n\<^esub>) \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
  by auto
  ultimately show ?thesis using 2 by (intro that[of A2]) simp+
qed

lemma step_z_computable:
  assumes "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto> \<langle>l',Z\<rangle>" "global_clock_numbering A v n"
  obtains D' where "Z = [D']\<^bsub>v,n\<^esub>"
using step_z_dbm_DBM[OF assms] by blast

lemma step_z_dbm_complete:
  assumes "global_clock_numbering A v n" "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u'\<rangle>"
  and     "u \<in> [(D )]\<^bsub>v,n\<^esub>"
  shows "\<exists> D'. A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l',D'\<rangle> \<and> u' \<in> [D']\<^bsub>v,n\<^esub>"
proof -
  note A = assms
  from step_z_complete[OF A(2,3)] obtain Z' where Z': "A \<turnstile> \<langle>l, [D]\<^bsub>v,n\<^esub>\<rangle> \<leadsto> \<langle>l',Z'\<rangle>" "u' \<in> Z'" by auto
  with step_z_dbm_DBM[OF Z'(1) A(1)] obtain D' where D':
    "A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l',D'\<rangle>" "Z' = [D']\<^bsub>v,n\<^esub>"
  by metis
  with Z'(2) show ?thesis by auto
qed

subsection \<open>Multi Step\<close>

inductive steps_z_dbm ::
  "('a, 'c, 't, 's) ta \<Rightarrow> 's \<Rightarrow> ('t::time) DBM
    \<Rightarrow> ('c \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> ('t::time) DBM \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<leadsto>*\<^bsub>_,_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  refl: "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>*\<^bsub>v,n\<^esub> \<langle>l,D\<rangle>" |
  step: "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l',D'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l',D'\<rangle> \<leadsto>*\<^bsub>v,n\<^esub> \<langle>l'',D''\<rangle> \<Longrightarrow>
         A \<turnstile> \<langle>l,D\<rangle> \<leadsto>*\<^bsub>v,n\<^esub> \<langle>l'',D''\<rangle>"

declare steps_z_dbm.intros[intro]

lemma steps_z_dbm_sound:
  assumes "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>*\<^bsub>v,n\<^esub> \<langle>l',D'\<rangle>"
  and "global_clock_numbering A v n"
  and "u' \<in> [D']\<^bsub>v,n\<^esub>"
  shows "\<exists> u \<in> [D]\<^bsub>v,n\<^esub>. A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>* \<langle>l',u'\<rangle>" using assms
proof (induction A l D v n l' D' rule: steps_z_dbm.induct)
  case refl thus ?case by fast
next
  case (step A l D v n l' D' l'' D'')
  then obtain u'' where u'': "A \<turnstile> \<langle>l', u''\<rangle> \<rightarrow>* \<langle>l'',u'\<rangle>" "u''\<in>[D']\<^bsub>v,n\<^esub>" by blast
  with step_z_sound[OF step_z_dbm_sound[OF step(1,4)]] obtain u where
    "u \<in> [D]\<^bsub>v,n\<^esub>" "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow> \<langle>l',u''\<rangle>"
  by blast
  with u'' show ?case by blast
qed

lemma steps_z_dbm_complete:
  assumes "A \<turnstile> \<langle>l, u\<rangle> \<rightarrow>* \<langle>l',u'\<rangle>"
  and "global_clock_numbering A v n"
  and "u \<in> [D]\<^bsub>v,n\<^esub>"
  shows "\<exists> D'. A \<turnstile> \<langle>l, D\<rangle> \<leadsto>*\<^bsub>v,n\<^esub> \<langle>l', D'\<rangle> \<and> u' \<in> [D']\<^bsub>v,n\<^esub>" using assms
proof (induction arbitrary: D rule: steps.induct)
  case refl thus ?case by auto
next
  case (step A l u l' u' l'' u'' D)
  from step_z_dbm_complete[OF step(4,1,5)] obtain D'
  where D': "A \<turnstile> \<langle>l,D\<rangle> \<leadsto>\<^bsub>v,n\<^esub> \<langle>l',D'\<rangle>" "u' \<in> [D']\<^bsub>v,n\<^esub>" by auto
  with step(3)[OF step(4)] obtain D'' where
    "A \<turnstile> \<langle>l',D'\<rangle> \<leadsto>*\<^bsub>v,n\<^esub> \<langle>l'',D''\<rangle>" "u'' \<in> [D'']\<^bsub>v,n\<^esub>"
  by blast
  with D' show ?case by blast
qed

end
(*>*)


theory mPow
  imports mMem
begin

context GZF_Model begin

lemma mPow_eq :
  assumes "x : mSet"
  shows "m\<P> x = <set, set \<oplus> \<P> (snd x)>"
  unfolding mPow_def mPow'_def
  using assms
  by auto

lemma mpow_typ : "m\<P> : mSet \<rightarrow> mSetOf mSet"
proof (rule funI, unfold mPow_eq, rule msetofI, rule msetI)
  fix x assume "x : mSet"
  then obtain x'
    where x' : "x = <set,x'>" "x' : Set"
    by (rule msetE)
  then obtain j
    where j : "j : Ord" and "<set,x'> \<in> Tier j"
    using mE[OF mset_m[OF \<open>x : mSet\<close>]] by auto
  hence x'_sub:"x' \<subseteq> Tier j \<ominus> set"
    using tierD_mset[OF j tier_succI1[OF j]] by auto

  have "set \<oplus> \<P> x' \<subseteq> Tier (succ j) \<ominus> set"
  proof (rule, erule tmapE[OF tag_pmem[OF set_tag] pow_set[OF x'(2)]],
         rule exsetI[OF tier_set[OF succ_ord[OF j]]])
    fix y y' assume "y' \<in> \<P> x'" "y = <set,y'>"
    hence "y' \<subseteq> Tier j \<ominus> set" "y' : Set"
      using subset_trans[OF powD[OF x'(2)] x'_sub]
            pow_mem[OF \<open>x' : Set\<close>] by auto
    thus "y \<in> Tier (succ j)" using tierI_mset[OF j] \<open>y = <set,y'>\<close> by auto
    show "\<not> Excluded set y"
      using not_set_excluded_mset
      unfolding \<open>y = <set,y'>\<close> by auto
  qed

  thus "<set, set \<oplus> \<P> (snd x)> : M"
    unfolding x'(1) mset_snd_eq'[OF x'(2)]
  by (rule mI[OF succ_ord[OF succ_ord[OF j]]
    tierI_mset[OF succ_ord[OF j] tmap_set[OF tag_pmem[OF set_tag] pow_set[OF x'(2)]]]])
(*  by (rule mI[OF succ_ord[OF succ_ord[OF j]] tierI_mset[OF succ_ord[OF j]]]) *)

  fix b assume "b m <set, set \<oplus> \<P> (snd x)>"
  hence "b \<in> set \<oplus> \<P> x'"
    using mmemD
    unfolding x'(1) mset_snd_eq'[OF x'(2)] by auto
  then obtain b' where "b = <set,b'>" "b' \<in> \<P> x'"
    by (rule tmapE[OF tag_pmem[OF set_tag] pow_set[OF x'(2)]])
  hence "b' \<subseteq> Tier j \<ominus> set" "b' : Set"
    using subset_trans[OF powD[OF x'(2)] x'_sub]
          pow_mem[OF \<open>x' : Set\<close>] by auto
  thus "b : mSet"
    using msetI[OF mI_mset[OF j]] \<open>b = <set,b'>\<close> by auto
qed

lemmas mpow_mset = funE[OF mpow_typ]

lemma msubsetI :
  assumes "\<And>b. b m x \<Longrightarrow> b m y"
  shows "mSubset x y"
  using assms
  unfolding mSubset_def by auto

lemma msubsetD :
  assumes xy : "mSubset x y"
      and b  : "b m x"
    shows "b m y"
 using assms mmem_m
 unfolding mSubset_def mall_def by auto

lemma mpowI :
  assumes x : "x : mSet" and y : "y : mSet"
      and xy:"mSubset x y"
    shows "x m m\<P> y"
  unfolding mPow_eq[OF y]
proof (rule msetE[OF x], rule msetE[OF y])
  fix x' y'
  assume x':"x = <set, x'>" "x' : Set"
     and y':"y = <set, y'>" "y' : Set"

  show "x m <set, set \<oplus> \<P> (snd y)>"
    unfolding y' mset_snd_eq'[OF y'(2)] x'
  proof (rule mmemI)
    show "\<langle>set,set \<oplus> \<P> y'\<rangle> : mSet"
      using msetof_mset[OF funE[OF mpow_typ y]] mPow_eq[OF y]
      unfolding  y' mset_snd_eq'[OF y'(2)]
      by auto
  next
    have "x' \<subseteq> y'"
    proof
      fix a assume "a \<in> x'"
      hence "a m x" using mmemI_eq[OF x x'(1)] by auto
      hence "a m y" using msubsetD[OF xy] by auto
      thus "a \<in> y'" using mmemD_eq[OF y'(1)] by auto
    qed
    hence "x' \<in> \<P> y'"
      using powI x' y' by auto
    thus "<set, x'> \<in> set \<oplus> \<P> y'"
      using tmapI[OF tag_pmem[OF set_tag] pow_set[OF y'(2)]]
      by auto
  qed
qed

lemma mpowD :
  assumes x : "x : mSet" and y : "y : mSet"
      and pow : "x m m\<P> y"
    shows "mSubset x y"
proof (rule msetE[OF x], rule msetE[OF y])
  fix x' y'
  assume x':"x = <set, x'>" "x' : Set"
     and y':"y = <set, y'>" "y' : Set"

  from pow have "<set,x'> \<in> set \<oplus> \<P> y'"
    using mmemD mPow_eq[OF y]
    unfolding y' mset_snd_eq'[OF y'(2)] x' by auto
  hence "x' \<in> \<P> y'"
    using tmap_iff[OF tag_pmem[OF set_tag] pow_set[OF y'(2)] set_setmem[OF x'(2)]]
    by auto
  hence "x' \<subseteq> y'"
    using powD[OF y'(2)] by auto
  thus "mSubset x y"
    unfolding
      mSubset_def
      mmem_iff_eq[OF x x'(1)]
      mmem_iff_eq[OF y y'(1)]
    by auto
qed

lemma mpow_iff :
  assumes "x : mSet" "y : mSet"
  shows "x m m\<P> y \<longleftrightarrow> mSubset x y"
  using mpowI mpowD assms by auto

theorem msubset_eq :
  "mSubset x y = (m\<forall>a. a m x \<longrightarrow> a m y)"
  unfolding mall_def tall_def mSubset_def
  using mmem_m by auto

theorem mpow_ax :
  "m\<forall>x : mSet. m\<forall>z : mSet. z m m\<P> x \<longleftrightarrow> mSubset z x"
  unfolding mtall_def tall_def mall_def
  using mpow_iff by auto

theorem mpow_rsp :
  "x : M \<Longrightarrow> m\<P> x : M"
  using mset_m[OF msetof_mset[OF mpow_mset]]
        GZF_Model_mdefault_m
  unfolding mPow_def by auto

end
end


subsection \<open>Partial heaps: Partial maps from heap location to values\<close>

theory PartialHeapSA
  imports Mask "Package_logic.PackageLogic"
begin

subsubsection \<open>Definitions\<close>

type_synonym heap = "heap_loc \<rightharpoonup> val"
type_synonym pre_state = "mask \<times> heap"

definition valid_heap :: "mask \<Rightarrow> heap \<Rightarrow> bool" where
  "valid_heap \<pi> h \<longleftrightarrow> (\<forall>hl. ppos (\<pi> hl) \<longrightarrow> h hl \<noteq> None)"

fun valid_state :: "pre_state \<Rightarrow> bool" where
  "valid_state (\<pi>, h) \<longleftrightarrow> valid_mask \<pi> \<and> valid_heap \<pi> h"

lemma valid_stateI:
  assumes "valid_mask \<pi>"
      and "\<And>hl. ppos (\<pi> hl) \<Longrightarrow> h hl \<noteq> None"
    shows "valid_state (\<pi>, h)"
  using assms(1) assms(2) valid_heap_def valid_state.simps by blast

definition empty_heap where "empty_heap hl = None"

lemma valid_pre_unit:
  "valid_state (empty_mask, empty_heap)"
  using pnone.rep_eq ppos.rep_eq valid_empty valid_stateI by fastforce

typedef state = "{ \<phi> |\<phi>. valid_state \<phi> }"
  using valid_pre_unit by blast

fun get_m :: "state \<Rightarrow> mask" where "get_m a = fst (Rep_state a)"
fun get_h :: "state \<Rightarrow> heap" where "get_h a = snd (Rep_state a)"

fun compatible_options where
  "compatible_options (Some a) (Some b) \<longleftrightarrow> a = b"
| "compatible_options _ _ \<longleftrightarrow> True"

definition compatible_heaps :: "heap \<Rightarrow> heap \<Rightarrow> bool" where
  "compatible_heaps h h' \<longleftrightarrow> (\<forall>hl. compatible_options (h hl) (h' hl))"

definition compatible :: "pre_state \<Rightarrow> pre_state \<Rightarrow> bool" where
  "compatible \<phi> \<phi>' \<longleftrightarrow> compatible_heaps (snd \<phi>) (snd \<phi>') \<and> valid_mask (add_masks (fst \<phi>) (fst \<phi>'))"

fun add_states :: "pre_state \<Rightarrow> pre_state \<Rightarrow> pre_state" where
  "add_states (\<pi>, h) (\<pi>', h') = (add_masks \<pi> \<pi>', h ++ h')"

definition larger_heap where
  "larger_heap h' h \<longleftrightarrow> (\<forall>hl x. h hl = Some x \<longrightarrow> h' hl = Some x)"

definition unit :: "state" where
  "unit = Abs_state (empty_mask, empty_heap)"

definition plus :: "state \<Rightarrow> state \<rightharpoonup> state" (infixl "\<oplus>" 63) where
  "a \<oplus> b = (if compatible (Rep_state a) (Rep_state b) then Some (Abs_state (add_states (Rep_state a) (Rep_state b))) else None)"

definition core :: "state \<Rightarrow> state" (" |_| ") where
  "core \<phi> = Abs_state (empty_mask, get_h \<phi>)"

definition stable :: "state \<Rightarrow> bool" where
  "stable \<phi> \<longleftrightarrow> (\<forall>hl. ppos (get_m \<phi> hl) \<longleftrightarrow> get_h \<phi> hl \<noteq> None)"

subsubsection Lemmas

lemma valid_heapI:
  assumes "\<And>hl. ppos (\<pi> hl) \<Longrightarrow> h hl \<noteq> None"
  shows "valid_heap \<pi> h"
  using assms valid_heap_def by presburger

lemma valid_state_decompose:
  assumes "valid_state (add_masks a b, h)"
  shows "valid_state (a, h)"
proof (rule valid_stateI)
  show "valid_mask a"
    using assms upper_valid_aux valid_state.simps by blast
  fix hl assume "ppos (a hl)" then show "h hl \<noteq> None"
    by (metis add_masks.simps assms ppos_add valid_heap_def valid_state.simps)
qed

lemma compatible_heapsI:
  assumes "\<And>hl a b. h hl = Some a \<Longrightarrow> h' hl = Some b \<Longrightarrow> a = b"
  shows "compatible_heaps h h'"
  by (metis assms compatible_heaps_def compatible_options.elims(3))

lemma compatibleI_old:
  assumes "\<And>hl x y. snd \<phi> hl = Some x \<and> snd \<phi>' hl = Some y \<Longrightarrow> x = y"
      and "valid_mask (add_masks (fst \<phi>) (fst \<phi>'))"
    shows "compatible \<phi> \<phi>'"
  using assms(1) assms(2) compatible_def compatible_heapsI by presburger

lemma larger_heap_anti:
  assumes "larger_heap a b"
      and "larger_heap b a"
    shows "a = b"
proof (rule ext)
  fix x show "a x = b x"
  proof (cases "a x")
    case None
    then show ?thesis
      by (metis assms(1) larger_heap_def not_None_eq)
  next
    case (Some a)
    then show ?thesis
      by (metis assms(2) larger_heap_def)
  qed
qed

lemma larger_heapI:
  assumes "\<And>hl x. h hl = Some x \<Longrightarrow> h' hl = Some x"
  shows "larger_heap h' h"
  by (simp add: assms larger_heap_def)

lemma larger_heap_refl:
  "larger_heap h h"
  using larger_heap_def by blast

lemma compatible_heaps_comm:
  assumes "compatible_heaps a b"
  shows "a ++ b = b ++ a"
proof (rule ext)
  fix x show "(a ++ b) x = (b ++ a) x"
  proof (cases "a x")
    case None
    then show ?thesis
      by (simp add: domIff map_add_dom_app_simps(2) map_add_dom_app_simps(3))
  next
    case (Some a)
    then show ?thesis
      by (metis (no_types, lifting) assms compatible_heaps_def compatible_options.elims(2) map_add_None map_add_dom_app_simps(1) map_add_dom_app_simps(3))
  qed
qed

lemma larger_heaps_sum_ineq:
  assumes "larger_heap a' a"
      and "larger_heap b' b"
      and "compatible_heaps a' b'"
    shows "larger_heap (a' ++ b') (a ++ b)"
proof (rule larger_heapI)
  fix hl x assume "(a ++ b) hl = Some x"
  show "(a' ++ b') hl = Some x"
  proof (cases "a hl")
    case None
    then show ?thesis
      by (metis \<open>(a ++ b) hl = Some x\<close> assms(2) larger_heap_def map_add_SomeD map_add_find_right)
  next
    case (Some aa)
    then show ?thesis
      by (metis (mono_tags, lifting) \<open>(a ++ b) hl = Some x\<close> assms(1) assms(2) assms(3) compatible_heaps_comm larger_heap_def map_add_Some_iff)
  qed
qed

lemma larger_heap_trans:
  assumes "larger_heap a b"
      and "larger_heap b c"
    shows "larger_heap a c"
  by (metis (no_types, opaque_lifting) assms(1) assms(2) larger_heap_def)

lemma larger_heap_comp:
  assumes "larger_heap a b"
      and "compatible_heaps a c"
    shows "compatible_heaps b c"
proof (rule compatible_heapsI)
  fix hl a ba
  assume "b hl = Some a" "c hl = Some ba"
  then show "a = ba"
    by (metis assms(1) assms(2) compatible_heaps_def compatible_options.simps(1) larger_heap_def)
qed

lemma larger_heap_plus:
  assumes "larger_heap a b"
      and "larger_heap a c"
    shows "larger_heap a (b ++ c)"
proof (rule larger_heapI)
  fix hl x assume "(b ++ c) hl = Some x"
  then show "a hl = Some x"
  proof (cases "b hl")
    case None
    then show ?thesis
      by (metis \<open>(b ++ c) hl = Some x\<close> assms(2) larger_heap_def map_add_SomeD)
  next
    case (Some bb)
    then show ?thesis
      by (metis \<open>(b ++ c) hl = Some x\<close> assms(1) assms(2) larger_heap_def map_add_SomeD)
  qed
qed

lemma compatible_heaps_sum:
  assumes "compatible_heaps a b"
      and "compatible_heaps a c"
    shows "compatible_heaps a (b ++ c)"
  by (metis (no_types, opaque_lifting) assms(1) assms(2) compatible_heaps_def map_add_dom_app_simps(1) map_add_dom_app_simps(3))

lemma larger_compatible_sum_heaps:
  assumes "larger_heap a x"
      and "larger_heap b y"
      and "compatible_heaps a b"
    shows "compatible_heaps x y"
proof (rule compatible_heapsI)
  fix hl a b assume "x hl = Some a" "y hl = Some b"
  then show "a = b"
    by (metis assms(1) assms(2) assms(3) compatible_heaps_def compatible_options.simps(1) larger_heap_def)
qed

lemma get_h_m:
  "Rep_state x = (get_m x, get_h x)" by simp

lemma get_pre:
  "get_h x = snd (Rep_state x)"
  "get_m x = fst (Rep_state x)"
  by simp_all

lemma plus_ab_defined:
  "\<phi> \<oplus> \<phi>' \<noteq> None \<longleftrightarrow> compatible_heaps (get_h \<phi>) (get_h \<phi>') \<and> valid_mask (add_masks (get_m \<phi>) (get_m \<phi>'))"
  (is "?A \<longleftrightarrow> ?B")
proof
  show "?A \<Longrightarrow> ?B"
    by (metis compatible_def get_pre(1) get_pre(2) plus_def)
  show "?B \<Longrightarrow> ?A"
    using compatible_def plus_def by auto
qed

lemma plus_charact:
  assumes "a \<oplus> b = Some x"
    shows "get_m x = add_masks (get_m a) (get_m b)"
      and "get_h x = (get_h a) ++ (get_h b)"
proof -
  have "x = (Abs_state (add_states (Rep_state a) (Rep_state b)))"
    by (metis assms option.discI option.inject plus_def)
  moreover have "compatible (Rep_state a) (Rep_state b)"
    using assms(1) plus_def by (metis option.discI)

  moreover have "valid_state (add_states (Rep_state a) (Rep_state b))"
  proof -
    have "valid_state (add_masks (get_m a) (get_m b), (get_h a) ++ (get_h b))"
    proof (rule valid_stateI)
      show "valid_mask (add_masks (get_m a) (get_m b))"
        using calculation(2) compatible_def by fastforce
      fix hl assume "ppos (add_masks (get_m a) (get_m b) hl)"
      then show "(get_h a ++ get_h b) hl \<noteq> None"
      proof (cases "ppos (get_m a hl)")
        case True
        then show ?thesis
          by (metis Rep_state get_h_m map_add_None mem_Collect_eq valid_heap_def valid_state.simps)
      next
        case False
        then have "ppos (get_m b hl)"
          using \<open>ppos (add_masks (get_m a) (get_m b) hl)\<close> padd.rep_eq ppos.rep_eq by auto
        then show ?thesis
          by (metis Rep_state get_h_m map_add_None mem_Collect_eq valid_heap_def valid_state.simps)
      qed
    qed
    then show ?thesis
      using add_states.simps get_h_m by presburger
  qed
  ultimately show "get_m x = add_masks (get_m a) (get_m b)"
    by (metis Abs_state_inverse add_states.simps fst_conv get_h_m mem_Collect_eq)

  show "get_h x = (get_h a) ++ (get_h b)"
    by (metis Abs_state_inject CollectI Rep_state Rep_state_inverse \<open>valid_state (add_states (Rep_state a) (Rep_state b))\<close> \<open>x = Abs_state (add_states (Rep_state a) (Rep_state b))\<close> add_states.simps eq_snd_iff get_h.simps)
qed

lemma commutative:
  "a \<oplus> b = b \<oplus> a"
proof (cases "compatible_heaps (get_h a) (get_h b) \<and> valid_mask (add_masks (get_m a) (get_m b))")
  case True
  then have r0: "compatible_heaps (get_h b) (get_h a) \<and> add_masks (get_m a) (get_m b) = add_masks (get_m b) (get_m a)"
    by (metis add_masks_comm compatible_heapsI compatible_heaps_def compatible_options.simps(1))
  then have "(get_h a) ++ (get_h b) = (get_h b) ++ (get_h a)"
    by (simp add: compatible_heaps_comm)
  then show ?thesis
    by (metis True r0 add_states.simps get_h_m plus_ab_defined plus_def)
next
  case False
  then show ?thesis
    by (metis add_masks_comm compatible_heapsI compatible_heaps_def compatible_options.simps(1) plus_ab_defined)
qed

lemma asso1:
  assumes "a \<oplus> b = Some ab \<and> b \<oplus> c = Some bc"
  shows "ab \<oplus> c = a \<oplus> bc"
proof (cases "ab \<oplus> c")
  case None
  then show ?thesis
  proof (cases "compatible_heaps (get_h ab) (get_h c)")
    case True
    then have "\<not> valid_mask (add_masks (add_masks (get_m a) (get_m b)) (get_m c))"
      by (metis None assms plus_ab_defined plus_charact(1))
    then show ?thesis
      by (metis add_masks_asso assms plus_ab_defined plus_charact(1))
  next
    case False
    then have "\<not> compatible_heaps (get_h a ++ get_h b) (get_h c)"
      using assms plus_charact(2) by force
    then obtain l x y where "(get_h a ++ get_h b) l = Some x" "get_h c l = Some y" "x \<noteq> y"
      using compatible_heapsI by blast
    then have "\<not> compatible_heaps (get_h a) (get_h b ++ get_h c)"
    proof (cases "get_h a l")
      case None
      then show ?thesis
        by (metis \<open>(get_h a ++ get_h b) l = Some x\<close> \<open>get_h c l = Some y\<close> \<open>x \<noteq> y\<close> assms compatible_heaps_comm map_add_dom_app_simps(1) map_add_dom_app_simps(3) map_add_find_right option.inject option.simps(3) plus_ab_defined)
    next
      case (Some aa)
      then show ?thesis
        by (metis \<open>(get_h a ++ get_h b) l = Some x\<close> \<open>get_h c l = Some y\<close> \<open>x \<noteq> y\<close> assms commutative compatible_heaps_def compatible_options.elims(2) map_add_find_right option.inject option.simps(3) plus_charact(2))
    qed
    then show ?thesis
      by (metis None assms plus_ab_defined plus_charact(2))
  qed
next
  case (Some x)
  then have "compatible_heaps (get_h a ++ get_h b) (get_h c)"
    by (metis assms option.simps(3) plus_ab_defined plus_charact(2))
  then have "compatible_heaps (get_h a) (get_h b ++ get_h c)"
    by (metis (full_types) assms compatible_heaps_comm compatible_heaps_def compatible_heaps_sum compatible_options.simps(2) domIff map_add_dom_app_simps(1) option.distinct(1) plus_ab_defined)
  moreover have "valid_mask (add_masks (get_m a) (add_masks (get_m b) (get_m c)))"
    by (metis Some add_masks_asso assms option.distinct(1) plus_ab_defined plus_charact(1))
  ultimately obtain y where "Some y = a \<oplus> bc"
    by (metis assms plus_ab_defined plus_charact(1) plus_charact(2) plus_def)
  then show ?thesis
    by (metis (mono_tags, lifting) Some add_masks_asso add_states.simps assms get_h_m map_add_assoc option.distinct(1) plus_charact(1) plus_charact(2) plus_def)
qed

lemma asso2:
  assumes "a \<oplus> b = Some ab \<and> b \<oplus> c = None"
  shows " ab \<oplus> c = None"
proof (cases "valid_mask (add_masks (get_m b) (get_m c))")
  case True
  then have "\<not> compatible_heaps (get_h b) (get_h c)"
    using assms plus_ab_defined by blast
  then obtain l x y where "get_h b l = Some x" "get_h c l = Some y" "x \<noteq> y"
    using compatible_heapsI by blast
  then have "get_h ab l = Some x"
    by (metis assms map_add_find_right plus_charact(2))
  then show ?thesis
    by (metis \<open>get_h c l = Some y\<close> \<open>x \<noteq> y\<close> compatible_heaps_def compatible_options.simps(1) plus_ab_defined)
next
  case False
  then obtain l where "\<not> (pgte pwrite (add_masks (get_m b) (get_m c) l))"
    by (metis Abs_state_cases Rep_state_cases Rep_state_inverse add_masks_equiv_valid_null get_h_m mem_Collect_eq valid_mask.simps valid_null_def valid_state.simps)
  then have "\<not> (pgte pwrite (add_masks (get_m ab) (get_m c) l))"
  proof -
    have "pgte (add_masks (get_m ab) (get_m c) l) (add_masks (get_m b) (get_m c) l)"
      using assms p_greater_exists padd_asso padd_comm plus_charact(1) by auto
    then show ?thesis
      by (meson \<open>\<not> pgte pwrite (add_masks (get_m b) (get_m c) l)\<close> order_trans pgte.rep_eq)
  qed
  then show ?thesis
    using plus_ab_defined valid_mask.simps by blast
qed

lemma core_defined:
  "get_h |\<phi>| = get_h \<phi>"
  "get_m |\<phi>| = empty_mask"
  using Abs_state_inverse core_def pnone.rep_eq ppos.rep_eq valid_empty valid_stateI apply force
  by (metis Abs_state_inverse CollectI core_def empty_mask.simps fst_conv get_pre(2) less_irrefl pnone.rep_eq ppos.rep_eq valid_empty valid_stateI)

lemma state_ext:
  assumes "get_h a = get_h b"
      and "get_m a = get_m b"
    shows "a = b"
  by (metis Rep_state_inverse assms(1) assms(2) get_h_m)

lemma core_is_smaller:
  "Some x = x \<oplus> |x|"
proof -
  obtain y where "Some y = x \<oplus> |x|"
    by (metis Rep_state compatible_heapsI core_defined(1) core_defined(2) get_h_m mem_Collect_eq minus_empty option.collapse option.sel plus_ab_defined valid_state.simps)
  moreover have "y = x"
  proof (rule state_ext)
    have "get_h x = get_h x ++ get_h x"
      by (simp add: map_add_subsumed1)
    then show "get_h y = get_h x"
      using calculation core_defined(1) plus_charact(2) by presburger
    show "get_m y = get_m x"
      by (metis calculation core_defined(2) minus_empty plus_charact(1))
  qed
  ultimately show ?thesis by blast
qed

lemma core_is_pure:
  "Some |x| = |x| \<oplus> |x|"
proof -
  obtain y where "Some y = |x| \<oplus> |x|"
    by (metis core_def core_defined(1) core_is_smaller)
  moreover have "y = |x|"
    by (metis calculation core_def core_defined(1) core_is_smaller option.sel)
  ultimately show ?thesis by blast
qed

lemma core_sum:
  assumes "Some c = a \<oplus> b"
  shows "Some |c| = |a| \<oplus> |b|"
proof -
  obtain x where "Some x = |a| \<oplus> |b|"
    by (metis assms core_defined(1) core_defined(2) minus_empty option.exhaust_sel plus_ab_defined valid_empty)
  moreover have "x = |c|"
    by (metis assms calculation core_defined(1) core_defined(2) minus_empty plus_charact(1) plus_charact(2) state_ext)
  ultimately show ?thesis by blast
qed

lemma core_max:
  assumes "Some x = x \<oplus> c"
  shows "\<exists>r. Some |x| = c \<oplus> r"
proof -
  obtain y where "Some y = c \<oplus> |x|"
    by (metis assms asso2 core_is_smaller plus_def)
  moreover have "|x| = y"
    by (metis (mono_tags, opaque_lifting) Rep_state_inverse add_masks_cancellative assms calculation commutative core_defined(1) core_sum get_h_m minus_empty option.inject plus_charact(1))
  ultimately show ?thesis by blast
qed

lemma positivity:
  assumes "a \<oplus> b = Some c"
      and "Some c = c \<oplus> c"
    shows "Some a = a \<oplus> a"
proof -
  obtain x where "Some x = a \<oplus> a"
    by (metis assms(1) assms(2) asso2 commutative option.exhaust_sel)
  moreover have "x = a"
    by (metis Rep_state_inverse add_masks_cancellative add_masks_comm assms(1) assms(2) calculation core_defined(1) core_defined(2) core_is_smaller get_h_m greater_mask_def greater_mask_properties(3) option.sel plus_charact(1))
  ultimately show ?thesis by blast
qed

lemma cancellative:
  assumes "Some a = b \<oplus> x"
      and "Some a = b \<oplus> y"
      and "|x| = |y|"
    shows "x = y"
  by (metis add_masks_cancellative assms(1) assms(2) assms(3) core_defined(1) plus_charact(1) state_ext)

lemma unit_charact:
  "get_h unit = empty_heap"
  "get_m unit = empty_mask"
proof -
  have "valid_state (empty_mask, empty_heap)"
    using valid_pre_unit by auto
  then show "get_h unit = empty_heap" using unit_def
    by (simp add: \<open>unit = Abs_state (empty_mask, empty_heap)\<close> Abs_state_inverse)
  show "get_m unit = empty_mask"
    using \<open>valid_state (empty_mask, empty_heap)\<close> unit_def Abs_state_inverse
    by fastforce
qed

lemma empty_heap_neutral:
  "a ++ empty_heap = a"
proof (rule ext)
  fix x show "(a ++ empty_heap) x = a x"
    by (simp add: domIff empty_heap_def map_add_dom_app_simps(3))
qed

lemma unit_neutral:
  "Some a = a \<oplus> unit"
proof -
  obtain x where "Some x = a \<oplus> unit"
    by (metis Abs_state_cases Rep_state_cases Rep_state_inverse compatible_heapsI empty_heap_def fst_conv get_h_m mem_Collect_eq minus_empty option.distinct(1) option.exhaust_sel plus_ab_defined snd_conv unit_def valid_pre_unit valid_state.simps)
  moreover have "x = a"
  proof (rule state_ext)
    show "get_h x = get_h a"
      using calculation empty_heap_neutral plus_charact(2) unit_charact(1) by auto
    show "get_m x = get_m a"
      by (metis calculation minus_empty plus_charact(1) unit_charact(2))
  qed
  ultimately show ?thesis by blast
qed

lemma stableI:
  assumes "\<And>hl. ppos (get_m \<phi> hl) \<longleftrightarrow> get_h \<phi> hl \<noteq> None"
  shows "stable \<phi>"
  using assms stable_def by blast

lemma stable_unit:
  "stable unit"
  by (metis empty_heap_def stable_def unit_charact(1) unit_charact(2) valid_heap_def valid_pre_unit valid_state.simps)

lemma stable_sum:
  assumes "stable a"
      and "stable b"
      and "Some x = a \<oplus> b"
    shows "stable x"
proof (rule stableI)
  fix hl
  show "ppos (get_m x hl) = (get_h x hl \<noteq> None)" (is "?A \<longleftrightarrow> ?B")
  proof
    show "?A \<Longrightarrow> ?B"
      by (metis add_le_same_cancel2 add_masks.simps assms(1) assms(2) assms(3) leI less_le_trans map_add_None padd.rep_eq plus_charact(1) plus_charact(2) ppos.rep_eq stable_def)
    show "?B \<Longrightarrow> ?A"
      by (metis add_masks.simps assms(1) assms(2) assms(3) map_add_None padd_comm plus_charact(1) plus_charact(2) ppos_add stable_def)
  qed
qed

lemma multiply_valid:
  assumes "pgte pwrite p"
  shows "valid_state (multiply_mask p (get_m \<phi>), get_h \<phi>)"
proof (rule valid_stateI)
  show "valid_mask (multiply_mask p (get_m \<phi>))"
    by (metis Rep_state assms(1) get_h_m mem_Collect_eq valid_mult valid_state.simps)
  fix hl show "ppos (multiply_mask p (get_m \<phi>) hl) \<Longrightarrow> get_h \<phi> hl \<noteq> None"
    by (metis Abs_state_cases Rep_state_cases Rep_state_inverse get_h_m mem_Collect_eq multiply_mask_def pmult_comm pmult_special(2) ppos_eq_pnone valid_heap_def valid_state.simps)
qed

subsection \<open>This state model corresponds to a separation algebra\<close>

global_interpretation PartialSA: package_logic plus core unit stable
  defines greater (infixl "\<succeq>" 50) = "PartialSA.greater"
      and add_set (infixl "\<otimes>" 60) = "PartialSA.add_set"
      and defined (infixl "|#|" 60) = "PartialSA.defined"
      and greater_set (infixl "|\<ggreater>|" 50) = "PartialSA.greater_set"
      and minus (infixl "|\<ominus>|" 60) = "PartialSA.minus"
  apply standard
  apply (simp add: commutative)
  using asso1 apply blast
  using asso2 apply blast
  using core_is_smaller apply blast
  using core_is_pure apply blast
  using core_max apply blast
  using core_sum apply blast
  using positivity apply blast
  using cancellative apply blast
  using unit_neutral apply blast
  using stable_sum apply blast
  using stable_unit by blast

lemma greaterI:
  assumes "larger_heap (get_h a) (get_h b)"
      and "greater_mask (get_m a) (get_m b)"
    shows "a \<succeq> b"
proof -
  let ?m = "\<lambda>l. SOME p. get_m a l = padd (get_m b l) p"
  have r0: "get_m a = add_masks (get_m b) ?m"
  proof (rule ext)
    fix l
    have "pgte (get_m a l) (get_m b l)"
      by (meson assms(2) greater_mask_equiv_def)
    then have "get_m a l = padd (get_m b l) (SOME p. get_m a l = padd (get_m b l) p)"
      by (simp add: p_greater_exists verit_sko_ex')
    then show "get_m a l = add_masks (get_m b) (\<lambda>l. SOME p. get_m a l = padd (get_m b l) p) l"
      by simp
  qed
  moreover have "valid_state (?m, get_h a)"
  proof (rule valid_stateI)
    show "valid_mask (\<lambda>l. SOME p. get_m a l = padd (get_m b l) p)"
      by (metis (no_types, lifting) Rep_state calculation get_h_m mem_Collect_eq upper_valid valid_state.simps)
    fix hl
    assume asm0: "ppos (SOME p. get_m a hl = padd (get_m b hl) p)"
    then have "ppos (get_m a hl)"
      by (metis (no_types, lifting) add_masks.elims add_masks_comm calculation greater_mask_def ppos_add)
    then show "get_h a hl \<noteq> None"
      by (metis Rep_state get_h.simps get_pre(2) mem_Collect_eq prod.collapse valid_heap_def valid_state.simps)
  qed
  moreover have "compatible_heaps (get_h b) (get_h a)"
    by (metis (mono_tags, lifting) assms(1) compatible_heapsI larger_heap_def option.inject)
  ultimately have r2: "(get_m a, get_h a) = add_states (get_m b, get_h b) (?m, get_h a)"
  proof -
    have "get_h b ++ get_h a = get_h a"
    proof (rule ext)
      fix x show "(get_h b ++ get_h a) x = get_h a x"
        by (metis assms(1) domIff larger_heap_def map_add_dom_app_simps(1) map_add_dom_app_simps(3) not_Some_eq)
    qed
    then show ?thesis
      by (metis r0 add_states.simps)
  qed
  moreover have r1: "compatible_heaps (get_h b) (get_h a) \<and> valid_mask (add_masks (get_m b) ?m)"
    by (metis Rep_state \<open>compatible_heaps (get_h b) (get_h a)\<close> r0 get_h_m mem_Collect_eq valid_state.simps)
  ultimately have "Some a = b \<oplus> Abs_state (?m, get_h a)"
  proof -
    have "Rep_state (Abs_state (?m, get_h a)) = (?m, get_h a)"
      using Abs_state_inverse \<open>valid_state (\<lambda>l. SOME p. get_m a l = padd (get_m b l) p, get_h a)\<close> by blast
    moreover have "compatible (Rep_state b) (?m, get_h a)"
      using r1 compatible_def by auto
    moreover have "valid_state (add_states (Rep_state b) (?m, get_h a))"
      by (metis Rep_state r2 get_h_m mem_Collect_eq)
    ultimately show ?thesis
      by (metis (no_types, lifting) Rep_state_inverse r2 get_h_m plus_def)
  qed
  then show ?thesis
    by (meson PartialSA.greater_def)
qed

lemma larger_implies_greater_mask_hl:
  assumes "a \<succeq> b"
  shows "pgte (get_m a hl) (get_m b hl)"
  using PartialSA.greater_def assms p_greater_exists plus_charact(1) by auto

lemma larger_implies_larger_heap:
  assumes "a \<succeq> b"
  shows "larger_heap (get_h a) (get_h b)"
  by (metis (full_types) PartialSA.greater_equiv assms larger_heapI map_add_find_right plus_charact(2))

lemma compatibleI:
  assumes "compatible_heaps (get_h a) (get_h b)"
      and "valid_mask (add_masks (get_m a) (get_m b))"
    shows "a |#| b"
  using PartialSA.defined_def assms(1) assms(2) plus_ab_defined by presburger

end


section \<open>\isaheader{Implementation of Annotated Lists by 2-3 Finger Trees}\<close>
theory FTAnnotatedListImpl
imports
  "../../../Finger-Trees/FingerTree"
  "../tools/Locale_Code"
  "../tools/Record_Intf"
  "../spec/AnnotatedListSpec"
begin

(*@impl AnnotatedList
  @type ('a,'b::monoid_add) ft
  @abbrv ft
  Annotated lists implemented by 2-3 finger trees.
*)

type_synonym ('a,'b) ft = "('a,'b) FingerTree"
subsection "Definitions"

definition ft_\<alpha> where
  "ft_\<alpha> \<equiv> FingerTree.toList"
abbreviation (input) ft_invar :: "('a,'b) FingerTree \<Rightarrow> bool" where
  "ft_invar \<equiv> \<lambda>_. True"
definition ft_empty where
  "ft_empty \<equiv> \<lambda>_::unit. FingerTree.empty"
definition ft_isEmpty where
  "ft_isEmpty \<equiv> FingerTree.isEmpty"
definition ft_count where
  "ft_count \<equiv> FingerTree.count"
definition ft_consl where
  "ft_consl e a s = FingerTree.lcons (e,a) s"
definition ft_consr where
  "ft_consr s e a = FingerTree.rcons s (e,a)"
definition ft_head where
  "ft_head \<equiv> FingerTree.head"
definition ft_tail where
  "ft_tail \<equiv> FingerTree.tail"
definition ft_headR where
  "ft_headR \<equiv> FingerTree.headR"
definition ft_tailR where
  "ft_tailR \<equiv> FingerTree.tailR"
definition ft_foldl where
  "ft_foldl \<equiv> FingerTree.foldl"
definition ft_foldr where
  "ft_foldr \<equiv> FingerTree.foldr"
definition ft_app where
  "ft_app \<equiv> FingerTree.app"
definition ft_annot where
  "ft_annot \<equiv> FingerTree.annot"
definition ft_splits where
  "ft_splits \<equiv> FingerTree.splitTree"

lemmas ft_defs =
  ft_\<alpha>_def
  ft_empty_def
  ft_isEmpty_def
  ft_count_def
  ft_consl_def
  ft_consr_def
  ft_head_def
  ft_tail_def
  ft_headR_def
  ft_tailR_def
  ft_foldl_def
  ft_foldr_def
  ft_app_def
  ft_annot_def
  ft_splits_def

lemma ft_empty_impl: "al_empty ft_\<alpha> ft_invar ft_empty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.empty_correct)
  done

lemma ft_consl_impl: "al_consl ft_\<alpha> ft_invar ft_consl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.lcons_correct)
done

lemma ft_consr_impl: "al_consr ft_\<alpha> ft_invar ft_consr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.rcons_correct)
done

lemma ft_isEmpty_impl: "al_isEmpty ft_\<alpha> ft_invar ft_isEmpty"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.isEmpty_correct FingerTree.empty_correct)
  done

lemma ft_count_impl: "al_count ft_\<alpha> ft_invar ft_count"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.count_correct)
  done

lemma ft_head_impl: "al_head ft_\<alpha> ft_invar ft_head"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.head_correct FingerTree.empty_correct)
done

lemma ft_tail_impl: "al_tail ft_\<alpha> ft_invar ft_tail"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tail_correct FingerTree.empty_correct)
done

lemma ft_headR_impl: "al_headR ft_\<alpha> ft_invar ft_headR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.headR_correct FingerTree.empty_correct)
done

lemma ft_tailR_impl: "al_tailR ft_\<alpha> ft_invar ft_tailR"
    apply unfold_locales
    apply (auto simp add: ft_defs FingerTree.tailR_correct FingerTree.empty_correct)
    done

lemma ft_foldl_impl: "al_foldl ft_\<alpha> ft_invar ft_foldl"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done

lemma ft_foldr_impl: "al_foldr ft_\<alpha> ft_invar ft_foldr"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done

lemma ft_foldl_cunfold[code_unfold]:
  "List.foldl f \<sigma> (ft_\<alpha> t) = ft_foldl f \<sigma> t"
  apply (auto simp add: ft_defs FingerTree.foldl_correct)
  done

lemma ft_foldr_cunfold[code_unfold]:
  "List.foldr f (ft_\<alpha> t) \<sigma> = ft_foldr f t \<sigma>"
  apply (auto simp add: ft_defs FingerTree.foldr_correct)
  done

lemma ft_app_impl: "al_app ft_\<alpha> ft_invar ft_app"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.app_correct)
  done

lemma ft_annot_impl: "al_annot ft_\<alpha> ft_invar ft_annot"
  apply unfold_locales
  apply (auto simp add: ft_defs FingerTree.annot_correct)
  done

lemma ft_splits_impl: "al_splits ft_\<alpha> ft_invar ft_splits"
  apply unfold_locales
  apply (unfold ft_defs)
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply (frule (3) FingerTree.splitTree_correct(1))
  apply (frule (3) FingerTree.splitTree_correct(2))
  apply (frule (3) FingerTree.splitTree_correct(3))
  apply (simp only: FingerTree.annot_correct[symmetric])
  apply simp
  done

subsubsection "Record Based Implementation"

definition [icf_rec_def]: "ft_ops = \<lparr>
  alist_op_\<alpha> = ft_\<alpha>,
  alist_op_invar = ft_invar,
  alist_op_empty = ft_empty,
  alist_op_isEmpty = ft_isEmpty,
  alist_op_count = ft_count,
  alist_op_consl = ft_consl,
  alist_op_consr = ft_consr,
  alist_op_head = ft_head,
  alist_op_tail = ft_tail,
  alist_op_headR = ft_headR,
  alist_op_tailR = ft_tailR,
  alist_op_app = ft_app,
  alist_op_annot = ft_annot,
  alist_op_splits = ft_splits
  \<rparr>"

setup Locale_Code.open_block
interpretation ft: StdAL ft_ops
  apply (rule StdAL.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    ft_empty_impl
    ft_consl_impl
    ft_consr_impl
    ft_isEmpty_impl
    ft_count_impl
    ft_head_impl
    ft_tail_impl
    ft_headR_impl
    ft_tailR_impl
    ft_foldl_impl
    ft_foldr_impl
    ft_app_impl
    ft_annot_impl
    ft_splits_impl
  )+
  done
interpretation ft: StdAL_no_invar ft_ops
  by (unfold_locales) (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "ft"\<close>

definition "test_codegen \<equiv> (
  ft.empty,
  ft.isEmpty,
  ft.count,
  ft.consl,
  ft.consr,
  ft.head,
  ft.tail,
  ft.headR,
  ft.tailR,
  ft.app,
  ft.annot,
  ft.splits,
  ft.foldl,
  ft.foldr
)"

export_code test_codegen checking SML

end


(*  Title:      HOL/Quotient_Examples/Int_Pow.thy
    Author:     Ondrej Kuncar
    Author:     Lars Noschinski
*)

theory Int_Pow
imports Main "~~/src/HOL/Algebra/Group"
begin

(*
  This file demonstrates how to restore Lifting/Transfer enviromenent.

  We want to define int_pow (a power with an integer exponent) by directly accessing
  the representation type "nat * nat" that was used to define integers.
*)

context monoid
begin

(* first some additional lemmas that are missing in monoid *)

lemma Units_nat_pow_Units [intro, simp]:
  "a \<in> Units G \<Longrightarrow> a (^) (c :: nat) \<in> Units G" by (induct c) auto

lemma Units_r_cancel [simp]:
  "[| z \<in> Units G; x \<in> carrier G; y \<in> carrier G |] ==>
   (x \<otimes> z = y \<otimes> z) = (x = y)"
proof
  assume eq: "x \<otimes> z = y \<otimes> z"
    and G: "z \<in> Units G"  "x \<in> carrier G"  "y \<in> carrier G"
  then have "x \<otimes> (z \<otimes> inv z) = y \<otimes> (z \<otimes> inv z)"
    by (simp add: m_assoc[symmetric] Units_closed del: Units_r_inv)
  with G show "x = y" by simp
next
  assume eq: "x = y"
    and G: "z \<in> Units G"  "x \<in> carrier G"  "y \<in> carrier G"
  then show "x \<otimes> z = y \<otimes> z" by simp
qed

lemma inv_mult_units:
  "[| x \<in> Units G; y \<in> Units G |] ==> inv (x \<otimes> y) = inv y \<otimes> inv x"
proof -
  assume G: "x \<in> Units G"  "y \<in> Units G"
  moreover then have "x \<in> carrier G"  "y \<in> carrier G" by auto
  ultimately have "inv (x \<otimes> y) \<otimes> (x \<otimes> y) = (inv y \<otimes> inv x) \<otimes> (x \<otimes> y)"
    by (simp add: m_assoc) (simp add: m_assoc [symmetric])
  with G show ?thesis by (simp del: Units_l_inv)
qed

lemma mult_same_comm:
  assumes [simp, intro]: "a \<in> Units G"
  shows "a (^) (m::nat) \<otimes> inv (a (^) (n::nat)) = inv (a (^) n) \<otimes> a (^) m"
proof (cases "m\<ge>n")
  have [simp]: "a \<in> carrier G" using `a \<in> _` by (rule Units_closed)
  case True
    then obtain k where *:"m = k + n" and **:"m = n + k" by (metis Nat.le_iff_add add.commute)
    have "a (^) (m::nat) \<otimes> inv (a (^) (n::nat)) = a (^) k"
      using * by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    also have "\<dots> = inv (a (^) n) \<otimes> a (^) m"
      using ** by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric])
    finally show ?thesis .
next
  have [simp]: "a \<in> carrier G" using `a \<in> _` by (rule Units_closed)
  case False
    then obtain k where *:"n = k + m" and **:"n = m + k"
      by (metis Nat.le_iff_add add.commute nat_le_linear)
    have "a (^) (m::nat) \<otimes> inv (a (^) (n::nat)) = inv(a (^) k)"
      using * by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    also have "\<dots> = inv (a (^) n) \<otimes> a (^) m"
      using ** by (auto simp add: nat_pow_mult[symmetric] m_assoc inv_mult_units)
    finally show ?thesis .
qed

lemma mult_inv_same_comm:
  "a \<in> Units G \<Longrightarrow> inv (a (^) (m::nat)) \<otimes> inv (a (^) (n::nat)) = inv (a (^) n) \<otimes> inv (a (^) m)"
by (simp add: inv_mult_units[symmetric] nat_pow_mult ac_simps Units_closed)

context
includes int.lifting (* restores Lifting/Transfer for integers *)
begin

lemma int_pow_rsp:
  assumes eq: "(b::nat) + e = d + c"
  assumes a_in_G [simp, intro]: "a \<in> Units G"
  shows "a (^) b \<otimes> inv (a (^) c) = a (^) d \<otimes> inv (a (^) e)"
proof(cases "b\<ge>c")
  have [simp]: "a \<in> carrier G" using `a \<in> _` by (rule Units_closed)
  case True
    then obtain n where "b = n + c" by (metis Nat.le_iff_add add.commute)
    then have "d = n + e" using eq by arith
    from `b = _` have "a (^) b \<otimes> inv (a (^) c) = a (^) n"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    also from `d = _`  have "\<dots> = a (^) d \<otimes> inv (a (^) e)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc)
    finally show ?thesis .
next
  have [simp]: "a \<in> carrier G" using `a \<in> _` by (rule Units_closed)
  case False
    then obtain n where "c = n + b" by (metis Nat.le_iff_add add.commute nat_le_linear)
    then have "e = n + d" using eq by arith
    from `c = _` have "a (^) b \<otimes> inv (a (^) c) = inv (a (^) n)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    also from `e = _` have "\<dots> = a (^) d \<otimes> inv (a (^) e)"
      by (auto simp add: nat_pow_mult[symmetric] m_assoc[symmetric] inv_mult_units)
    finally show ?thesis .
qed

(*
  This definition is more convinient than the definition in HOL/Algebra/Group because
  it doesn't contain a test z < 0 when a (^) z is being defined.
*)

lift_definition int_pow :: "('a, 'm) monoid_scheme \<Rightarrow> 'a \<Rightarrow> int \<Rightarrow> 'a" is
  "\<lambda>G a (n1, n2). if a \<in> Units G \<and> monoid G then (a (^)\<^bsub>G\<^esub> n1) \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> (a (^)\<^bsub>G\<^esub> n2)) else \<one>\<^bsub>G\<^esub>"
unfolding intrel_def by (auto intro: monoid.int_pow_rsp)

(*
  Thus, for example, the proof of distributivity of int_pow and addition
  doesn't require a substantial number of case distinctions.
*)

lemma int_pow_dist:
  assumes [simp]: "a \<in> Units G"
  shows "int_pow G a ((n::int) + m) = int_pow G a n \<otimes>\<^bsub>G\<^esub> int_pow G a m"
proof -
  {
    fix k l m :: nat
    have "a (^) l \<otimes> (inv (a (^) m) \<otimes> inv (a (^) k)) = (a (^) l \<otimes> inv (a (^) k)) \<otimes> inv (a (^) m)"
      (is "?lhs = _")
      by (simp add: mult_inv_same_comm m_assoc Units_closed)
    also have "\<dots> = (inv (a (^) k) \<otimes> a (^) l) \<otimes> inv (a (^) m)"
      by (simp add: mult_same_comm)
    also have "\<dots> = inv (a (^) k) \<otimes> (a (^) l \<otimes> inv (a (^) m))" (is "_ = ?rhs")
      by (simp add: m_assoc Units_closed)
    finally have "?lhs = ?rhs" .
  }
  then show ?thesis
    by (transfer fixing: G) (auto simp add: nat_pow_mult[symmetric] inv_mult_units m_assoc Units_closed)
qed

end

lifting_update int.lifting
lifting_forget int.lifting

end

end


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

section \<open>Preference Profile\<close>

theory Profile
  imports Preference_Relation
begin

text \<open>
  Preference profiles denote the decisions made by the individual voters on
  the eligible alternatives. They are represented in the form of one preference
  relation (e.g., selected on a ballot) per voter, collectively captured in a
  list of such preference relations.
  Unlike a the common preference profiles in the social-choice sense, the
  profiles described here considers only the (sub-)set of alternatives that are
  received.
\<close>

subsection \<open>Definition\<close>

text \<open>
  A profile contains one ballot for each voter.
\<close>

type_synonym 'a Profile = "('a Preference_Relation) list"

text \<open>
  A profile on a finite set of alternatives A contains only ballots that are
  linear orders on A.
\<close>

definition profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "profile A p \<equiv> \<forall> i::nat. i < length p \<longrightarrow> linear_order_on A (p!i)"

(*definition profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "profile A p \<equiv> \<forall> i::nat. i < length p \<longrightarrow> strict_linear_order_on A (p!i)"*)

lemma profile_set : "profile A p \<equiv> (\<forall> b \<in> (set p). linear_order_on A b)"
  unfolding profile_def all_set_conv_all_nth
  by simp

abbreviation finite_profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "finite_profile A p \<equiv> finite A \<and> profile A p"

subsection \<open>Preference Counts and Comparisons\<close>

text \<open>
  The win count for an alternative a in a profile p is
  the amount of ballots in p that rank alternative a in first position.
\<close>

(*
fun win_count :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "win_count p a = length [i \<leftarrow> [0..<length p]. above (p ! i) a = {}]"*)

fun win_count :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "win_count p a =
    card {i::nat. i < length p \<and> above (p!i) a = {a}}"

fun loose_count_code :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "loose_count_code Nil a = 0" |
  "loose_count_code (p#ps) a =
      (if (under p a = {a}) then 1 else 0) + loose_count_code ps a"

definition is_least_preferred :: "'a Preference_Relation \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_least_preferred r a = (under r a = Field r - {a})"

fun loose_count :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "loose_count p a =
    card {i::nat. i < length p \<and> is_least_preferred (p!i) a}"

fun has_majority :: "'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "has_majority p a = (win_count p a > ( length p div 2))"

fun not_has_majority :: "'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "not_has_majority p a = (win_count p a \<le> ( length p div 2))"

fun win_count_code :: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat" where
  "win_count_code Nil a = 0" |
  "win_count_code (p#ps) a =
      (if (above p a = {a}) then 1 else 0) + win_count_code ps a"

lemma win_count_equiv[code]: "win_count p x = win_count_code p x"
proof (induction p rule: rev_induct, simp)
  case (snoc a p)
  fix
    a :: "'a Preference_Relation" and
    p :: "'a Profile"
  assume base_case: "win_count p x = win_count_code p x"
  have size_one: "length [a] = 1"
    by simp
  have p_pos_in_ps:
    "\<forall> i < length p. p!i = (p@[a])!i"
    by (simp add: nth_append)
  have
    "win_count [a] x =
      (let q = [a] in
        card {i::nat. i < length q \<and>
              (let r = (q!i) in (above r x = {x}))})"
    by simp
  hence one_ballot_equiv:
    "win_count [a] x = win_count_code [a] x"
    using size_one
    by (simp add: nth_Cons')
  have pref_count_induct:
    "win_count (p@[a]) x =
      win_count p x + win_count [a] x"
  proof (simp)
    have
      "{i. i = 0 \<and> (above ([a]!i) x = {x})} =
        (if (above a x = {x}) then {0} else {})"
      by (simp add: Collect_conv_if)
    hence shift_idx_a:
      "card {i. i = length p \<and> (above ([a]!0) x = {x})} =
        card {i. i = 0 \<and> (above ([a]!i) x = {x})}"
      by simp
    have set_prof_eq:
      "{i. i < Suc (length p) \<and> (above ((p@[a])!i) x = {x})} =
        {i. i < length p \<and> (above (p!i) x = {x})} \<union>
          {i. i = length p \<and> (above ([a]!0) x = {x})}"
    proof (safe, simp_all)
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xa \<noteq> length p" and
        "xaa \<in> above (p!xa) x"
      thus "xaa = x"
        using less_antisym p_pos_in_ps singletonD
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xa \<noteq> length p"
      thus "x \<in> above (p!xa) x"
        using less_antisym insertI1 p_pos_in_ps
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x"
      thus "xa < length p"
        using less_antisym nth_append_length
              p_pos_in_ps singletonD
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a" and
        xb :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x" and
        "xb \<in> above (p!xa) x"
      thus "xb = x"
        using less_antisym p_pos_in_ps
              nth_append_length singletonD
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "xaa \<in> above a x" and
        "xaa \<noteq> x"
      thus "x \<in> above (p!xa) x"
        using insertI1 less_antisym nth_append
              nth_append_length singletonD
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x"
      thus "xa < length p"
        using insertI1 less_antisym nth_append_length
        by metis
    next
      fix
        xa :: nat and
        xb :: "'a"
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x" and
        "xb \<in> above (p!xa) x"
      thus "xb = x"
        using insertI1 less_antisym nth_append_length
              p_pos_in_ps singletonD
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "above ((p@[a])!xa) x = {x}" and
        "x \<notin> above a x"
      thus "x \<in> above (p!xa) x"
        using insertI1 less_antisym nth_append_length p_pos_in_ps
        by metis
    next
      fix
        xa :: nat and
        xaa :: "'a"
      assume
        "xa < length p" and
        "above (p!xa) x = {x}" and
        "xaa \<in> above ((p@[a])!xa) x"
      thus "xaa = x"
        by (simp add: nth_append)
    next
      fix xa :: nat
      assume
        "xa < length p" and
        "above (p!xa) x = {x}"
      thus "x \<in> above ((p@[a])!xa) x"
        by (simp add: nth_append)
    qed
    have fin_len_p:
      "finite {n. n < length p \<and> (above (p!n) x = {x})}"
      by simp
    have fin_len_a_0:
      "finite {n. n = length p \<and> (above ([a]!0) x = {x})}"
      by simp
    have
      "card ({i. i < length p \<and> (above (p!i) x = {x})} \<union>
        {i. i = length p \<and> (above ([a]!0) x = {x})}) =
          card {i. i < length p \<and> (above (p!i) x = {x})} +
            card {i. i = length p \<and> (above ([a]!0) x = {x})}"
      using fin_len_p fin_len_a_0 card_Un_disjoint
      by blast
    thus
      "card {i. i < Suc (length p) \<and> (above ((p@[a])!i) x = {x})} =
        card {i. i < length p \<and> (above (p!i) x = {x})} +
          card {i. i = 0 \<and> (above ([a]!i) x = {x})}"
      using set_prof_eq shift_idx_a
      by auto
  qed
  have "win_count_code (p@[a]) x = win_count_code p x + win_count_code [a] x"
  proof (induction p, simp)
    fix
      aa :: "'a Preference_Relation" and
      p :: "'a Profile"
    assume
      "win_count_code (p@[a]) x =
        win_count_code p x + win_count_code [a] x"
    thus
      "win_count_code ((aa#p)@[a]) x =
        win_count_code (aa#p) x + win_count_code [a] x"
      by simp
  qed
  thus "win_count (p@[a]) x = win_count_code (p@[a]) x"
    using pref_count_induct base_case one_ballot_equiv
    by presburger
qed

fun prefer_count :: "'a Profile \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "prefer_count p x y =
      card {i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"

fun prefer_count_code :: "'a Profile \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "prefer_count_code Nil x y = 0" |
  "prefer_count_code (p#ps) x y =
      (if y \<preceq>\<^sub>p x then 1 else 0) + prefer_count_code ps x y"

lemma pref_count_equiv[code]: "prefer_count p x y = prefer_count_code p x y"
proof (induction p rule: rev_induct, simp)
  case (snoc a p)
  fix
    a :: "'a Preference_Relation" and
    p :: "'a Profile"
  assume base_case: "prefer_count p x y = prefer_count_code p x y"
  have size_one: "length [a] = 1"
    by simp
  have p_pos_in_ps:
    "\<forall> i < length p. p!i = (p@[a])!i"
    by (simp add: nth_append)
  have
    "prefer_count [a] x y =
      (let q = [a] in
        card {i::nat. i < length q \<and>
              (let r = (q!i) in (y \<preceq>\<^sub>r x))})"
    by simp
  hence one_ballot_equiv:
    "prefer_count [a] x y = prefer_count_code [a] x y"
    using size_one
    by (simp add: nth_Cons')
  have pref_count_induct:
    "prefer_count (p@[a]) x y =
      prefer_count p x y + prefer_count [a] x y"
  proof (simp)
    have
      "{i. i = 0 \<and> (y, x) \<in> [a]!i} =
        (if ((y, x) \<in> a) then {0} else {})"
      by (simp add: Collect_conv_if)
    hence shift_idx_a:
      "card {i. i = length p \<and> (y, x) \<in> [a]!0} =
        card {i. i = 0 \<and> (y, x) \<in> [a]!i}"
      by simp
    have set_prof_eq:
      "{i. i < Suc (length p) \<and> (y, x) \<in> (p@[a])!i} =
        {i. i < length p \<and> (y, x) \<in> p!i} \<union>
          {i. i = length p \<and> (y, x) \<in> [a]!0}"
    proof (safe, simp_all)
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "xa \<noteq> length p"
      thus "(y, x) \<in> p!xa"
        using less_antisym p_pos_in_ps
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "(y, x) \<notin> a"
      thus "xa < length p"
        using less_antisym nth_append_length
        by metis
    next
      fix xa :: nat
      assume
        "xa < Suc (length p)" and
        "(y, x) \<in> (p@[a])!xa" and
        "(y, x) \<notin> a"
      thus "(y, x) \<in> p!xa"
        using less_antisym nth_append_length p_pos_in_ps
        by metis
    next
      fix xa :: nat
      assume
        "xa < length p" and
        "(y, x) \<in> p!xa"
      thus "(y, x) \<in> (p@[a])!xa"
        using less_antisym p_pos_in_ps
        by metis
    qed
    have fin_len_p: "finite {n. n < length p \<and> (y, x) \<in> p!n}"
      by simp
    have fin_len_a_0: "finite {n. n = length p \<and> (y, x) \<in> [a]!0}"
      by simp
    have
      "card ({i. i < length p \<and> (y, x) \<in> p!i} \<union>
        {i. i = length p \<and> (y, x) \<in> [a]!0}) =
          card {i. i < length p \<and> (y, x) \<in> p!i} +
            card {i. i = length p \<and> (y, x) \<in> [a]!0}"
      using fin_len_p fin_len_a_0 card_Un_disjoint
      by blast
    thus
      "card {i. i < Suc (length p) \<and> (y, x) \<in> (p@[a])!i} =
        card {i. i < length p \<and> (y, x) \<in> p!i} +
          card {i. i = 0 \<and> (y, x) \<in> [a]!i}"
      using set_prof_eq shift_idx_a
      by simp
  qed
  have pref_count_code_induct:
    "prefer_count_code (p@[a]) x y =
      prefer_count_code p x y + prefer_count_code [a] x y"
  proof (simp, safe)
    assume y_pref_x: "(y, x) \<in> a"
    show "prefer_count_code (p@[a]) x y = Suc (prefer_count_code p x y)"
    proof (induction p, simp_all)
      show "(y, x) \<in> a"
        using y_pref_x
        by simp
    qed
  next
    assume not_y_pref_x: "(y, x) \<notin> a"
    show "prefer_count_code (p@[a]) x y = prefer_count_code p x y"
    proof (induction p, simp_all, safe)
      assume "(y, x) \<in> a"
      thus False
        using not_y_pref_x
        by simp
    qed
  qed
  show "prefer_count (p@[a]) x y = prefer_count_code (p@[a]) x y"
    using pref_count_code_induct pref_count_induct
          base_case one_ballot_equiv
    by presburger
qed

lemma set_compr: "{ f x | x . x \<in> S } = f ` S"
  by auto

lemma pref_count_set_compr: "{prefer_count p x y | y . y \<in> A - {x}} =
          (prefer_count p x) ` (A - {x})"
  by auto

lemma pref_count:
  assumes
    prof: "profile A p" and
    x_in_A: "x \<in> A" and
    y_in_A: "y \<in> A" and
    neq: "x \<noteq> y"
  shows "prefer_count p x y = (length p) - (prefer_count p y x)"
proof -
  have 00: "card {i::nat. i < length p} = length p"
    by simp
  have 10:
    "{i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p} -
          {i::nat. i < length p \<and> \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"
    by auto
  have 0: "\<forall> i::nat . i < length p \<longrightarrow> linear_order_on A (p!i)"
    using prof
    unfolding profile_def
    by simp
  hence "\<forall> i::nat . i < length p \<longrightarrow> connex A (p!i)"
    by (simp add: lin_ord_imp_connex)
  hence 1: "\<forall> i::nat . i < length p \<longrightarrow>
              \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x)) \<longrightarrow> (let r = (p!i) in (x \<preceq>\<^sub>r y))"
    using x_in_A y_in_A
    unfolding connex_def
    by metis
  from 0 have
    "\<forall> i::nat . i < length p \<longrightarrow> antisym  (p!i)"
    using lin_imp_antisym
    by metis
  hence "\<forall> i::nat . i < length p \<longrightarrow> ((y, x) \<in> (p!i) \<longrightarrow> (x, y) \<notin> (p!i))"
    using antisymD neq
    by metis
  hence "\<forall> i::nat . i < length p \<longrightarrow>
          ((let r = (p!i) in (y \<preceq>\<^sub>r x)) \<longrightarrow> \<not> (let r = (p!i) in (x \<preceq>\<^sub>r y)))"
    by simp
  with 1 have
    "\<forall> i::nat . i < length p \<longrightarrow>
      \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x)) = (let r = (p!i) in (x \<preceq>\<^sub>r y))"
    by metis
  hence 2:
    "{i::nat. i < length p \<and> \<not> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}"
    by metis
  hence 20:
    "{i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))} =
        {i::nat. i < length p} -
          {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}"
    using 10 2
    by simp
  have
    "{i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))} \<subseteq>
        {i::nat. i < length p}"
    by (simp add: Collect_mono)
  hence 30:
    "card ({i::nat. i < length p} -
        {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))}) =
      (card {i::nat. i < length p}) -
        card({i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    by (simp add: card_Diff_subset)
  have "prefer_count p x y =
          card {i::nat. i < length p \<and> (let r = (p!i) in (y \<preceq>\<^sub>r x))}"
    by simp
  also have
    "... = card({i::nat. i < length p} -
            {i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    using 20
    by simp
  also have
    "... = (card {i::nat. i < length p}) -
              card({i::nat. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r y))})"
    using 30
    by metis
  also have
    "... = length p - (prefer_count p y x)"
    by simp
  finally show ?thesis
    by (simp add: 20 30)
qed

lemma pref_count_sym:
  assumes
    p1: "prefer_count p a x \<ge> prefer_count p x b" and
    prof: "profile A p" and
    a_in_A: "a \<in> A" and
    b_in_A: "b \<in> A" and
    x_in_A: "x \<in> A" and
    neq1: "a \<noteq> x" and
    neq2: "x \<noteq> b"
  shows "prefer_count p b x \<ge> prefer_count p x a"
proof -
  from prof a_in_A x_in_A neq1 have 0:
    "prefer_count p a x = (length p) - (prefer_count p x a)"
    using pref_count
    by metis
  moreover from prof x_in_A b_in_A neq2 have 1:
    "prefer_count p x b = (length p) - (prefer_count p b x)"
    using pref_count
    by (metis (mono_tags, lifting))
  hence 2: "(length p) - (prefer_count p x a) \<ge>
              (length p) - (prefer_count p b x)"
    using calculation p1
    by auto
  hence 3: "(prefer_count p x a) - (length p) \<le>
              (prefer_count p b x) - (length p)"
    using a_in_A diff_is_0_eq diff_le_self neq1
          pref_count prof x_in_A
    by (metis (no_types))
  hence "(prefer_count p x a) \<le> (prefer_count p b x)"
    using 1 3 calculation p1
    by linarith
  thus ?thesis
    by linarith
qed

lemma empty_prof_imp_zero_pref_count:
  assumes "p = []"
  shows "\<forall> x y. prefer_count p x y = 0"
  using assms
  by simp

lemma empty_prof_imp_zero_pref_count_code:
  assumes "p = []"
  shows "\<forall> x y. prefer_count_code p x y = 0"
  using assms
  by simp

lemma pref_count_code_incr:
  assumes
    "prefer_count_code ps x y = n" and
    "y \<preceq>\<^sub>p x"
  shows "prefer_count_code (p#ps) x y = n+1"
  using assms
  by simp

lemma pref_count_code_not_smaller_imp_constant:
  assumes
    "prefer_count_code ps x y = n" and
    "\<not>(y \<preceq>\<^sub>p x)"
  shows "prefer_count_code (p#ps) x y = n"
  using assms
  by simp

fun wins :: "'a \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "wins x p y =
    (prefer_count p x y > prefer_count p y x)"

text \<open>
  Alternative a wins against b implies that b does not win against a.
\<close>

lemma wins_antisym:
  assumes "wins a p b"
  shows "\<not> wins b p a"
  using assms
  by simp

lemma wins_irreflex: "\<not> wins w p w"
  using wins_antisym
  by metis

subsection \<open>Condorcet Winner\<close>

fun condorcet_winner :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "condorcet_winner A p w =
      (finite_profile A p \<and>  w \<in> A \<and> (\<forall> x \<in> A - {w} . wins w p x))"

lemma cond_winner_unique:
  assumes
    winner_c: "condorcet_winner A p c" and
    winner_w: "condorcet_winner A p w"
  shows "w = c"
proof (rule ccontr)
  assume w_neq_c: "w \<noteq> c"
  from winner_w
  have "wins w p c"
    using w_neq_c insert_Diff insert_iff winner_c
    by simp
  hence "\<not> wins c p w"
    by (simp add: wins_antisym)
  moreover from winner_c
  have
    c_wins_against_w: "wins c p w"
    using Diff_iff w_neq_c
          singletonD winner_w
    by simp
  ultimately show False
    by simp
qed

lemma cond_winner_unique2:
  assumes
    winner: "condorcet_winner A p w" and
    not_w:  "x \<noteq> w"
  shows "\<not> condorcet_winner A p x"
  using not_w cond_winner_unique winner
  by metis

lemma cond_winner_unique3:
  assumes "condorcet_winner A p w"
  shows "{a \<in> A. condorcet_winner A p a} = {w}"
proof (safe, simp_all, safe)
  fix x :: "'a"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    x_in_A: "x \<in> A" and
    x_wins:
      "\<forall> xa \<in> A - {x}.
        card {i. i < length p \<and> (x, xa) \<in> p!i} <
          card {i. i < length p \<and> (xa, x) \<in> p!i}"
  from assms have assm:
    "finite_profile A p \<and>  w \<in> A \<and>
      (\<forall> x \<in> A - {w}.
        card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
          card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  hence
    "(\<forall> x \<in> A - {w}.
      card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
        card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  hence w_beats_x:
    "x \<noteq> w \<Longrightarrow>
      card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
        card {i::nat. i < length p \<and> (x, w) \<in> p!i}"
    using x_in_A
    by simp
  also from assm have
    "finite_profile A p"
    by simp
  moreover from assm have
    "w \<in> A"
    by simp
  hence x_beats_w:
    "x \<noteq> w \<Longrightarrow>
      card {i. i < length p \<and> (x, w) \<in> p!i} <
        card {i. i < length p \<and> (w, x) \<in> p!i}"
    using x_wins
    by simp
  from w_beats_x x_beats_w show "x = w"
    by linarith
next
  from assms show "w \<in> A"
    by simp
next
  from assms show "finite A"
    by simp
next
  from assms show "profile A p"
    by simp
next
  from assms show "w \<in> A"
    by simp
next
  fix
    x :: "'a" and
    x' :: "'a"
  assume
    x_prime_in_A: "x' \<in> A" and
    w_wins:
      "\<not> card {i. i < length p \<and> (w, x') \<in> p!i} <
        card {i. i < length p \<and> (x', w) \<in> p!i}"
  from assms have
    "finite_profile A p \<and>  w \<in> A \<and>
      (\<forall> x \<in> A - {w} .
        card {i::nat. i < length p \<and> (w, x) \<in> p!i} <
          card {i::nat. i < length p \<and> (x, w) \<in> p!i})"
    by simp
  thus "x' = w"
    using x_prime_in_A w_wins insert_Diff insert_iff
    by (metis (no_types, lifting))
qed

subsection \<open>Limited Profile\<close>

text \<open>
  This function restricts a profile p to a set A and
  keeps all of A's preferences.
\<close>

fun limit_profile :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile" where
  "limit_profile A p = map (limit A) p"

lemma limit_prof_trans:
  assumes
    "B \<subseteq> A" and
    "B' \<subseteq> B" and
    "finite_profile A p"
  shows "limit_profile B' p = limit_profile B' (limit_profile B p)"
  using assms
  by auto

lemma limit_profile_sound:
  assumes
    profile: "finite_profile S p" and
    subset: "A \<subseteq> S"
  shows "finite_profile A (limit_profile A p)"
proof (safe)
  have "\<forall> A A'. finite (A::'a set) \<longrightarrow> A' \<subseteq> A \<longrightarrow> finite A'"
    using rev_finite_subset
    by metis
  with profile
  show "finite A"
    using subset
    by metis
next
  have prof_is_lin_ord:
    "\<forall> A r.
      (profile (A::'a set) r \<longrightarrow> (\<forall> n < length r. linear_order_on A (r!n))) \<and>
      ((\<forall> n < length r. linear_order_on A (r!n)) \<longrightarrow> profile A r)"
    unfolding profile_def
    by simp
  have limit_prof_simp: "limit_profile A p = map (limit A) p"
    by simp
  obtain n' :: nat where
    prof_limit_n: "(n' < length (limit_profile A p) \<longrightarrow>
            linear_order_on A (limit_profile A p!n')) \<longrightarrow>
          profile A (limit_profile A p)"
    using prof_is_lin_ord
    by metis
  have prof_n_lin_ord: "\<forall> n < length p. linear_order_on S (p!n)"
    using prof_is_lin_ord profile
    by simp
  have prof_length: "length p = length (map (limit A) p)"
    by simp
  have "n' < length p \<longrightarrow> linear_order_on S (p!n')"
    using prof_n_lin_ord
    by simp
  thus "profile A (limit_profile A p)"
    using prof_length prof_limit_n limit_prof_simp limit_presv_lin_ord nth_map subset
    by (metis (no_types))
qed

lemma limit_prof_presv_size: "length p = length (limit_profile A p)"
  by simp

subsection \<open>Lifting Property\<close>

definition equiv_prof_except_a :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile \<Rightarrow>
                                        'a \<Rightarrow> bool" where
  "equiv_prof_except_a A p q a \<equiv>
    finite_profile A p \<and> finite_profile A q \<and>
      a \<in> A \<and> length p = length q \<and>
      (\<forall> i::nat.
        i < length p \<longrightarrow>
          equiv_rel_except_a A (p!i) (q!i) a)"

text \<open>
  An alternative gets lifted from one profile to another iff
  its ranking increases in at least one ballot, and nothing else changes.
\<close>

definition lifted :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "lifted A p q a \<equiv>
    finite_profile A p \<and> finite_profile A q \<and>
      a \<in> A \<and> length p = length q \<and>
      (\<forall> i::nat.
        (i < length p \<and> \<not>Preference_Relation.lifted A (p!i) (q!i) a) \<longrightarrow>
          (p!i) = (q!i)) \<and>
      (\<exists> i::nat. i < length p \<and> Preference_Relation.lifted A (p!i) (q!i) a)"

lemma lifted_imp_equiv_prof_except_a:
  assumes "lifted A p q a"
  shows "equiv_prof_except_a A p q a"
proof (unfold equiv_prof_except_a_def, safe)
  from assms
  show "finite A"
    unfolding lifted_def
    by metis
next
  from assms
  show "profile A p"
    unfolding lifted_def
    by metis
next
  from assms
  show "finite A"
    unfolding lifted_def
    by metis
next
  from assms
  show "profile A q"
    unfolding lifted_def
    by metis
next
  from assms
  show "a \<in> A"
    unfolding lifted_def
    by metis
next
  from assms
  show "length p = length q"
    unfolding lifted_def
    by metis
next
  fix i :: nat
  assume "i < length p"
  with assms
  show "equiv_rel_except_a A (p!i) (q!i) a"
    using lifted_imp_equiv_rel_except_a trivial_equiv_rel
    unfolding lifted_def profile_def
    by (metis (no_types))
qed

lemma negl_diff_imp_eq_limit_prof:
  assumes
    change: "equiv_prof_except_a S p q a" and
    subset: "A \<subseteq> S" and
    notInA: "a \<notin> A"
  shows "limit_profile A p = limit_profile A q"
proof (simp)
  have
    "\<forall> i::nat. i < length p \<longrightarrow>
      equiv_rel_except_a S (p!i) (q!i) a"
    using change equiv_prof_except_a_def
    by metis
  hence "\<forall> i::nat. i < length p \<longrightarrow> limit A (p!i) = limit A (q!i)"
    using notInA negl_diff_imp_eq_limit subset
    by metis
  thus "map (limit A) p = map (limit A) q"
    using change equiv_prof_except_a_def
          length_map nth_equalityI nth_map
    by (metis (mono_tags, lifting))
qed

lemma limit_prof_eq_or_lifted:
  assumes
    lifted_a: "lifted S p q a" and
    subset: "A \<subseteq> S"
  shows
    "limit_profile A p = limit_profile A q \<or>
        lifted A (limit_profile A p) (limit_profile A q) a"
proof (cases)
  assume inA: "a \<in> A"
  have
    "\<forall> i::nat. i < length p \<longrightarrow>
        (Preference_Relation.lifted S (p!i) (q!i) a \<or> (p!i) = (q!i))"
    using lifted_a
    unfolding lifted_def
    by metis
  hence one:
    "\<forall> i::nat. i < length p \<longrightarrow>
         (Preference_Relation.lifted A (limit A (p!i)) (limit A (q!i)) a \<or>
           (limit A (p!i)) = (limit A (q!i)))"
    using limit_lifted_imp_eq_or_lifted subset
    by metis
  thus ?thesis
  proof (cases)
    assume "\<forall> i::nat. i < length p \<longrightarrow> (limit A (p!i)) = (limit A (q!i))"
    thus ?thesis
      using length_map lifted_a nth_equalityI nth_map
            limit_profile.simps
      unfolding lifted_def
      by (metis (mono_tags, lifting))
  next
    assume forall_limit_p_q: "\<not>(\<forall> i::nat. i < length p \<longrightarrow> (limit A (p!i)) = (limit A (q!i)))"
    let ?p = "limit_profile A p"
    let ?q = "limit_profile A q"
    have "profile A ?p \<and> profile A ?q"
      using lifted_a limit_profile_sound subset
      unfolding lifted_def
      by metis
    moreover have "length ?p = length ?q"
      using lifted_a
      unfolding lifted_def
      by fastforce
    moreover have
      "\<exists> i::nat. i < length ?p \<and> Preference_Relation.lifted A (?p!i) (?q!i) a"
      using forall_limit_p_q length_map lifted_a limit_profile.simps nth_map one
      unfolding lifted_def
      by (metis (no_types, lifting))
    moreover have
      "\<forall> i::nat.
        (i < length ?p \<and> \<not>Preference_Relation.lifted A (?p!i) (?q!i) a) \<longrightarrow>
          (?p!i) = (?q!i)"
      using length_map lifted_a limit_profile.simps nth_map one
      unfolding lifted_def
      by metis
    ultimately have "lifted A ?p ?q a"
      using inA lifted_a rev_finite_subset subset
      unfolding lifted_def
      by (metis (no_types, lifting))
    thus ?thesis
      by simp
  qed
next
  assume "a \<notin> A"
  thus ?thesis
    using lifted_a negl_diff_imp_eq_limit_prof subset
          lifted_imp_equiv_prof_except_a
    by metis
qed

end


section \<open>Uniform Strategies\<close>

text \<open>Theorems about how to get a uniform strategy given strategies for each node.\<close>

theory UniformStrategy
imports
  Main
  AttractingStrategy WinningStrategy WellOrderedStrategy WinningRegion
begin

context ParityGame begin

subsection \<open>A Uniform Attractor Strategy\<close>

lemma merge_attractor_strategies:
  assumes "S \<subseteq> V"
    and strategies_ex: "\<And>v. v \<in> S \<Longrightarrow> \<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts_via p \<sigma> v S W"
  shows "\<exists>\<sigma>. strategy p \<sigma> \<and> strategy_attracts p \<sigma> S W"
proof-
  define good where "good v = {\<sigma>. strategy p \<sigma> \<and> strategy_attracts_via p \<sigma> v S W }" for v
  let ?G = "{\<sigma>. \<exists>v \<in> S - W. \<sigma> \<in> good v}"
  obtain r where r: "well_order_on ?G r" using well_order_on by blast

  interpret WellOrderedStrategies G "S - W" p good r proof
    show "S - W \<subseteq> V" using \<open>S \<subseteq> V\<close> by blast
  next
    show "\<And>v. v \<in> S - W \<Longrightarrow> \<exists>\<sigma>. \<sigma> \<in> good v" unfolding good_def using strategies_ex by blast
  next
    show "\<And>v \<sigma>. \<sigma> \<in> good v \<Longrightarrow> strategy p \<sigma>" unfolding good_def by blast
  next
    fix v w \<sigma> assume v: "v \<in> S - W" "v\<rightarrow>w" "v \<in> VV p \<Longrightarrow> \<sigma> v = w" "\<sigma> \<in> good v"
    hence \<sigma>: "strategy p \<sigma>" "strategy_attracts_via p \<sigma> v S W" unfolding good_def by simp_all
    hence "strategy_attracts_via p \<sigma> w S W" using strategy_attracts_via_successor v by blast
    thus "\<sigma> \<in> good w" unfolding good_def using \<sigma>(1) by blast
  qed (insert r)

  have S_W_no_deadends: "\<And>v. v \<in> S - W \<Longrightarrow> \<not>deadend v"
    using strategy_attracts_via_no_deadends[of _ S W] strategies_ex
    by (metis (no_types) Diff_iff S_V rev_subsetD)

  {
    fix v0 assume "v0 \<in> S"
    fix P assume P: "vmc_path G P v0 p well_ordered_strategy"
    then interpret vmc_path G P v0 p well_ordered_strategy .
    have "visits_via P S W" proof (rule ccontr)
      assume contra: "\<not>visits_via P S W"

      hence "lset P \<subseteq> S - W" proof (induct rule: vmc_path_lset_induction)
        case base
        show "v0 \<in> S - W" using \<open>v0 \<in> S\<close> contra visits_via_trivial by blast
      next
        case (step P v0)
        interpret vmc_path_no_deadend G P v0 p well_ordered_strategy using step.hyps(1) .
        have "insert v0 S = S" using step.hyps(2) by blast
        hence *: "\<not>visits_via (ltl P) S W"
          using visits_via_LCons[of "ltl P" S W v0, folded P_LCons] step.hyps(3) by auto
        hence **: "w0 \<notin> W" using vmc_path.visits_via_trivial[OF vmc_path_ltl] by blast
        have "w0 \<in> S \<union> W" proof (cases)
          assume "v0 \<in> VV p"
          hence "well_ordered_strategy v0 = w0" using v0_conforms by blast
          hence "choose v0 v0 = w0" using step.hyps(2) well_ordered_strategy_def by auto
          moreover have "strategy_attracts_via p (choose v0) v0 S W"
            using choose_good good_def step.hyps(2) by blast
          ultimately show ?thesis
            by (metis strategy_attracts_via_successor strategy_attracts_via_v0
                      choose_strategy step.hyps(2) v0_edge_w0 w0_V)
        qed (metis DiffD1 assms(2) step.hyps(2) strategy_attracts_via_successor
                   strategy_attracts_via_v0 v0_edge_w0 w0_V)
        with * ** show ?case by blast
      qed

      have "\<not>lfinite P" proof
        assume "lfinite P"
        hence "deadend (llast P)" using P_maximal P_not_null maximal_ends_on_deadend by blast
        moreover have "llast P \<in> S - W" using \<open>lset P \<subseteq> S - W\<close> P_not_null \<open>lfinite P\<close> lfinite_lset by blast
        ultimately show False using S_W_no_deadends by blast
      qed

      obtain n where n: "path_conforms_with_strategy p (ldropn n P) (path_strategies P $ n)"
        using path_eventually_conforms_to_\<sigma>_map_n[OF \<open>lset P \<subseteq> S - W\<close> P_valid P_conforms]
          by blast
      define \<sigma>' where [simp]: "\<sigma>' = path_strategies P $ n"
      define P' where [simp]: "P' = ldropn n P"
      interpret vmc_path G P' "lhd P'" p \<sigma>'
      proof
        show "\<not>lnull P'" unfolding P'_def
          using \<open>\<not>lfinite P\<close> lfinite_ldropn lnull_imp_lfinite by blast
      qed (simp_all add: n)
      have "strategy p \<sigma>'" unfolding \<sigma>'_def
        using path_strategies_strategy \<open>lset P \<subseteq> S - W\<close> \<open>\<not>lfinite P\<close> infinite_small_llength
        by blast
      moreover have "strategy_attracts_via p \<sigma>' (lhd P') S W" proof-
        have "P $ n \<in> S - W" using \<open>lset P \<subseteq> S - W\<close> \<open>\<not>lfinite P\<close> lset_nth_member_inf by blast
        hence "\<sigma>' \<in> good (P $ n)"
          using path_strategies_good \<sigma>'_def \<open>\<not>lfinite P\<close> \<open>lset P \<subseteq> S - W\<close> by blast
        hence "strategy_attracts_via p \<sigma>' (P $ n) S W" unfolding good_def by blast
        thus ?thesis unfolding P'_def using P_0 by (simp add: \<open>\<not>lfinite P\<close> infinite_small_llength)
      qed
      moreover from \<open>lset P \<subseteq> S - W\<close> have "lset P' \<subseteq> S - W"
        unfolding P'_def using lset_ldropn_subset[of n P] by blast
      ultimately show False using strategy_attracts_via_lset by blast
    qed
  }
  thus ?thesis using well_ordered_strategy_valid by blast
qed

subsection \<open>A Uniform Winning Strategy\<close>

text \<open>
  Let @{term S} be the winning region of player @{term p}.
  Then there exists a uniform winning strategy on @{term S}.
\<close>

lemma merge_winning_strategies:
  shows "\<exists>\<sigma>. strategy p \<sigma> \<and> (\<forall>v \<in> winning_region p. winning_strategy p \<sigma> v)"
proof-
  define good where "good v = {\<sigma>. strategy p \<sigma> \<and> winning_strategy p \<sigma> v}" for v
  let ?G = "{\<sigma>. \<exists>v \<in> winning_region p. \<sigma> \<in> good v}"
  obtain r where r: "well_order_on ?G r" using well_order_on by blast

  have no_VVp_deadends: "\<And>v. \<lbrakk> v \<in> winning_region p; v \<in> VV p \<rbrakk> \<Longrightarrow> \<not>deadend v"
    using no_winning_strategy_on_deadends unfolding winning_region_def by blast

  interpret WellOrderedStrategies G "winning_region p" p good r proof
    show "\<And>v. v \<in> winning_region p \<Longrightarrow> \<exists>\<sigma>. \<sigma> \<in> good v"
      unfolding good_def winning_region_def by blast
  next
    show "\<And>v \<sigma>. \<sigma> \<in> good v \<Longrightarrow> strategy p \<sigma>" unfolding good_def by blast
  next
    fix v w \<sigma> assume v: "v \<in> winning_region p" "v\<rightarrow>w" "v \<in> VV p \<Longrightarrow> \<sigma> v = w" "\<sigma> \<in> good v"
    hence \<sigma>: "strategy p \<sigma>" "winning_strategy p \<sigma> v" unfolding good_def by simp_all
    hence "winning_strategy p \<sigma> w" proof (cases)
      assume *: "v \<in> VV p"
      hence **: "\<sigma> v = w" using v(3) by blast
      have "\<not>deadend v" using no_VVp_deadends \<open>v \<in> VV p\<close> v(1) by blast
      with * ** show ?thesis using strategy_extends_VVp \<sigma> by blast
    next
      assume "v \<notin> VV p"
      thus ?thesis using strategy_extends_VVpstar \<sigma> \<open>v\<rightarrow>w\<close> by blast
    qed
    thus "\<sigma> \<in> good w" unfolding good_def using \<sigma>(1) by blast
  qed (insert winning_region_in_V r)

  {
    fix v0 assume "v0 \<in> winning_region p"
    fix P assume P: "vmc_path G P v0 p well_ordered_strategy"
    then interpret vmc_path G P v0 p well_ordered_strategy .

    have "lset P \<subseteq> winning_region p" proof (induct rule: vmc_path_lset_induction_simple)
      case (step P v0)
      interpret vmc_path_no_deadend G P v0 p well_ordered_strategy using step.hyps(1) .
      { assume "v0 \<in> VV p"
        hence "well_ordered_strategy v0 = w0" using v0_conforms by blast
        hence "choose v0 v0 = w0" by (simp add: step.hyps(2) well_ordered_strategy_def)
      }
      hence "choose v0 \<in> good w0" using strategies_continue choose_good step.hyps(2) by simp
      thus ?case unfolding good_def winning_region_def using w0_V by blast
    qed (insert \<open>v0 \<in> winning_region p\<close>)

    have "winning_path p P" proof (rule ccontr)
      assume contra: "\<not>winning_path p P"

      have "\<not>lfinite P" proof
        assume "lfinite P"
        hence "deadend (llast P)" using maximal_ends_on_deadend by simp
        moreover have "llast P \<in> winning_region p"
          using \<open>lset P \<subseteq> winning_region p\<close> P_not_null \<open>lfinite P\<close> lfinite_lset by blast
        moreover have "llast P \<in> VV p"
          using contra paths_are_winning_for_one_player \<open>lfinite P\<close>
          unfolding winning_path_def by simp
        ultimately show False using no_VVp_deadends by blast
      qed

      obtain n where n: "path_conforms_with_strategy p (ldropn n P) (path_strategies P $ n)"
        using path_eventually_conforms_to_\<sigma>_map_n[OF \<open>lset P \<subseteq> winning_region p\<close> P_valid P_conforms] by blast
      define \<sigma>' where [simp]: "\<sigma>' = path_strategies P $ n"
      define P' where [simp]: "P' = ldropn n P"
      interpret P': vmc_path G P' "lhd P'" p \<sigma>' proof
        show "\<not>lnull P'" using \<open>\<not>lfinite P\<close> unfolding P'_def
          using lfinite_ldropn lnull_imp_lfinite by blast
      qed (simp_all add: n)
      have "strategy p \<sigma>'" unfolding \<sigma>'_def
        using path_strategies_strategy \<open>lset P \<subseteq> winning_region p\<close> \<open>\<not>lfinite P\<close> by blast
      moreover have "winning_strategy p \<sigma>' (lhd P')" proof-
        have "P $ n \<in> winning_region p"
          using \<open>lset P \<subseteq> winning_region p\<close> \<open>\<not>lfinite P\<close> lset_nth_member_inf by blast
        hence "\<sigma>' \<in> good (P $ n)"
          using path_strategies_good choose_good \<sigma>'_def \<open>\<not>lfinite P\<close> \<open>lset P \<subseteq> winning_region p\<close>
          by blast
        hence "winning_strategy p \<sigma>' (P $ n)" unfolding good_def by blast
        thus ?thesis
          unfolding P'_def using P_0 \<open>\<not>lfinite P\<close> by (simp add: infinite_small_llength lhd_ldropn)
      qed
      ultimately have "winning_path p P'" unfolding winning_strategy_def
        using P'.vmc_path_axioms by blast
      moreover have "\<not>lfinite P'" using \<open>\<not>lfinite P\<close> P'_def by simp
      ultimately show False using contra winning_path_drop_add[OF P_valid] by auto
    qed
  }
  thus ?thesis unfolding winning_strategy_def using well_ordered_strategy_valid by auto
qed

subsection \<open>Extending Winning Regions\<close>

text \<open>
  Now we are finally able to prove the complement of \<open>winning_region_extends_VVp\<close> for
  @{term "VV p**"} nodes, which was still missing.
\<close>

lemma winning_region_extends_VVpstar:
  assumes v: "v \<in> VV p**" and w: "\<And>w. v\<rightarrow>w \<Longrightarrow> w \<in> winning_region p"
  shows "v \<in> winning_region p"
proof-
  obtain \<sigma> where \<sigma>: "strategy p \<sigma>"  "\<And>v. v \<in> winning_region p \<Longrightarrow> winning_strategy p \<sigma> v"
    using merge_winning_strategies by blast
  have "winning_strategy p \<sigma> v" using strategy_extends_backwards_VVpstar[OF v \<sigma>(1)] \<sigma>(2) w by blast
  thus ?thesis unfolding winning_region_def using v \<sigma>(1) by blast
qed

text \<open>It immediately follows that removing a winning region cannot create new deadends.\<close>

lemma removing_winning_region_induces_no_deadends:
  assumes "v \<in> V - winning_region p" "\<not>deadend v"
  shows "\<exists>w \<in> V - winning_region p. v\<rightarrow>w"
  using assms winning_region_extends_VVp winning_region_extends_VVpstar by blast

end \<comment> \<open>context ParityGame\<close>

end