(*  File:       Electoral_Module.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>

chapter \<open>Component Types\<close>

section \<open>Electoral Module\<close>

theory Electoral_Module
  imports "Social_Choice_Types/Preference_Relation"
          "Social_Choice_Types/Profile"
          "Social_Choice_Types/Result"
begin

text
\<open>Electoral modules are the principal component type of the composable modules
voting framework, as they are a generalization of voting rules in the sense of
social choice functions.
These are only the types used for electoral modules. Further restrictions are
encompassed by the electoral-module predicate.

An electoral module does not need to make final decisions for all alternatives,
but can instead defer the decision for some or all of them to other modules.
Hence, electoral modules partition the received (possibly empty) set of
alternatives into elected, rejected and deferred alternatives. In particular,
any of those sets, e.g., the set of winning (elected) alternatives, may also
be left empty, as long as they collectively still hold all the received
alternatives. Just like a voting rule, an electoral module also receives a
profile which holds the voters’ preferences, which, unlike a voting rule,
consider only the (sub-)set of alternatives that the module receives.\<close>

subsection \<open>Definition\<close>

(*An electoral module maps a set of alternatives and a profile to a result.*)
type_synonym 'a Electoral_Module = "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result"

subsection \<open>Auxiliary Definitions\<close>

(*
   Electoral modules partition a given set of alternatives A into a set of
   elected alternatives e, a set of rejected alternatives r, and a set of
   deferred alternatives d, using a profile.
   e, r, and d partition A.
   Electoral modules can be used as voting rules. They can also be composed
   in multiple structures to create more complex electoral modules.
*)
definition electoral_module :: " 'a Electoral_Module \<Rightarrow> bool" where
  "electoral_module m \<equiv> \<forall>A p. finite_profile A p \<longrightarrow> well_formed A (m A p)"

lemma electoral_modI:
  "((\<And>A p. \<lbrakk> finite_profile A p \<rbrakk> \<Longrightarrow> well_formed A (m A p)) \<Longrightarrow>
       electoral_module m)"
  unfolding electoral_module_def
  by auto

(*
   The next three functions take an electoral module and turn it into a
   function only outputting the elect, reject, or defer set respectively.
*)
abbreviation elect ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set" where
  "elect m A p \<equiv> elect_r (m A p)"

abbreviation reject ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set" where
  "reject m A p \<equiv> reject_r (m A p)"

abbreviation "defer" ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set" where
  "defer m A p \<equiv> defer_r (m A p)"

(*
   "defers n" is true for all electoral modules that defer exactly
   n alternatives, whenever there are n or more alternatives.
*)
definition defers :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "defers n m \<equiv>
    electoral_module m \<and>
      (\<forall>A p. (card A \<ge> n \<and> finite_profile A p) \<longrightarrow>
          card (defer m A p) = n)"

(*
   "rejects n" is true for all electoral modules that reject exactly
   n alternatives, whenever there are n or more alternatives.
*)
definition rejects :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "rejects n m \<equiv>
    electoral_module m \<and>
      (\<forall>A p. (card A \<ge> n \<and> finite_profile A p) \<longrightarrow> card (reject m A p) = n)"

(*
   As opposed to "rejects", "eliminates" allows to stop rejecting if no
   alternatives were to remain.
*)
definition eliminates :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "eliminates n m \<equiv>
    electoral_module m \<and>
      (\<forall>A p. (card A > n \<and> finite_profile A p) \<longrightarrow> card (reject m A p) = n)"

(*
   "elects n" is true for all electoral modules that
   elect exactly n alternatives, whenever there are n or more alternatives.
*)
definition elects :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "elects n m \<equiv>
    electoral_module m \<and>
      (\<forall>A p. (card A \<ge> n \<and> finite_profile A p) \<longrightarrow> card (elect m A p) = n)"

(*
(*
   An Electoral module m is rejecting iff at least one alternative gets
   rejected when possible
*)
definition rejecting :: "'a Electoral_Module \<Rightarrow> bool" where
  "
  "rejecting m \<equiv> \<forall>A . card A > 1 \<longrightarrow> (\<exists>n . (n > 0 \<and> rejects n m))"

(*WRONG definition, choose `n > card A` and already it is always true.*)
(*An electoral module m is eliminating iff the following holds*)
(*
   If there is at least one alternative that can be rejected,
   at least one alternative gets rejected.
*)
definition eliminating :: "'a Electoral_Module \<Rightarrow> bool" where
  "eliminating m \<equiv>  \<exists> n . (n > 0 \<and> eliminates n m)"
*)

(*
   An electoral module is independent of an alternative a iff
   a's ranking does not influence the outcome.
*)
definition indep_of_alt :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool" where
  "indep_of_alt m A a \<equiv>
    electoral_module m \<and> (\<forall>p q. equiv_prof_except_a A p q a \<longrightarrow> m A p = m A q)"

subsection \<open>Equivalence Definitions\<close>

definition prof_contains_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                                       'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_contains_result m A p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A \<and>
    (a \<in> elect m A p \<longrightarrow> a \<in> elect m A q) \<and>
    (a \<in> reject m A p \<longrightarrow> a \<in> reject m A q) \<and>
    (a \<in> defer m A p \<longrightarrow> a \<in> defer m A q)"

definition prof_leq_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                                  'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_leq_result m A p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A \<and>
    (a \<in> reject m A p \<longrightarrow> a \<in> reject m A q) \<and>
    (a \<in> defer m A p \<longrightarrow> a \<notin> elect m A q)"

definition prof_geq_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                                  'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_geq_result m A p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A \<and>
    (a \<in> elect m A p \<longrightarrow> a \<in> elect m A q) \<and>
    (a \<in> defer m A p \<longrightarrow> a \<notin> reject m A q)"

definition mod_contains_result :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module \<Rightarrow>
                                      'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "mod_contains_result m n A p a \<equiv>
    electoral_module m \<and> electoral_module n \<and> finite_profile A p \<and> a \<in> A \<and>
    (a \<in> elect m A p \<longrightarrow> a \<in> elect n A p) \<and>
    (a \<in> reject m A p \<longrightarrow> a \<in> reject n A p) \<and>
    (a \<in> defer m A p \<longrightarrow> a \<in> defer n A p)"

subsection \<open>Auxiliary Lemmata\<close>

lemma combine_ele_rej_def:
  assumes
    ele: "elect m A p = e" and
    rej: "reject m A p = r" and
    def: "defer m A p = d"
  shows "m A p = (e, r, d)"
  using def ele rej
  by auto

lemma par_comp_result_sound:
  assumes
    mod_m: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "well_formed A (m A p)"
  using electoral_module_def mod_m f_prof
  by auto

lemma result_presv_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "(elect m A p) \<union> (reject m A p) \<union> (defer m A p) = A"
proof (safe)
  fix
    x :: "'a"
  assume
    asm: "x \<in> elect m A p"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from e_mod f_prof have set_partit:
    "set_equals_partition A (m A p)"
    using electoral_module_def
    by auto
  thus "x \<in> A"
    using UnI1 asm fstI set_partit partit
    by (metis (no_types))
next
  fix
    x :: "'a"
  assume
    asm: "x \<in> reject m A p"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from e_mod f_prof have set_partit:
    "set_equals_partition A (m A p)"
    using electoral_module_def
    by auto
  thus "x \<in> A"
    using UnI1 asm fstI set_partit partit
          sndI subsetD sup_ge2
    by metis
next
  fix
    x :: "'a"
  assume
    asm: "x \<in> defer m A p"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from e_mod f_prof have set_partit:
    "set_equals_partition A (m A p)"
    using electoral_module_def
    by auto
  thus "x \<in> A"
    using asm set_partit partit sndI subsetD sup_ge2
    by metis
next
  fix
    x :: "'a"
  assume
    asm1: "x \<in> A" and
    asm2: "x \<notin> defer m A p" and
    asm3: "x \<notin> reject m A p"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from e_mod f_prof have set_partit:
    "set_equals_partition A (m A p)"
    using electoral_module_def
    by auto
  show "x \<in> elect m A p"
    using asm1 asm2 asm3 fst_conv partit
          set_partit snd_conv Un_iff
    by metis
qed

lemma result_disj:
  assumes
    module: "electoral_module m" and
    profile: "finite_profile A p"
  shows
    "(elect m A p) \<inter> (reject m A p) = {} \<and>
        (elect m A p) \<inter> (defer m A p) = {} \<and>
        (reject m A p) \<inter> (defer m A p) = {}"
proof (safe, simp_all)
  fix
    x :: "'a"
  assume
    asm1: "x \<in> elect m A p" and
    asm2: "x \<in> reject m A p"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from module profile have set_partit:
    "set_equals_partition A (m A p)"
    using electoral_module_def
    by auto
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p have wf_A_m:
    "well_formed A (m A p)"
    using electoral_module_def
    by metis
  show "False"
    using prod.exhaust_sel DiffE UnCI asm1 asm2
          module profile result_imp_rej wf_A_m
          prof_p set_partit partit
    by (metis (no_types))
next
  fix
    x :: "'a"
  assume
    asm1: "x \<in> elect m A p" and
    asm2: "x \<in> defer m A p"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  have disj:
    "\<forall>p. \<not> disjoint3 p \<or>
      (\<exists>B C D. p = (B::'a set, C, D) \<and>
        B \<inter> C = {} \<and> B \<inter> D = {} \<and> C \<inter> D = {})"
    by simp
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p have wf_A_m:
    "well_formed A (m A p)"
    using electoral_module_def
    by metis
  hence wf_A_m_0:
    "disjoint3 (m A p) \<and> set_equals_partition A (m A p)"
    by simp
  hence disj3:
    "disjoint3 (m A p)"
    by simp
  have set_partit:
    "set_equals_partition A (m A p)"
    using wf_A_m_0
    by simp
  from disj3 obtain
    AA :: "'a Result \<Rightarrow> 'a set" and
    AAa :: "'a Result \<Rightarrow> 'a set" and
    AAb :: "'a Result \<Rightarrow> 'a set"
    where
    "m A p =
      (AA (m A p), AAa (m A p), AAb (m A p)) \<and>
        AA (m A p) \<inter> AAa (m A p) = {} \<and>
        AA (m A p) \<inter> AAb (m A p) = {} \<and>
        AAa (m A p) \<inter> AAb (m A p) = {}"
    using asm1 asm2 disj
    by metis
  hence "((elect m A p) \<inter> (reject m A p) = {}) \<and>
          ((elect m A p) \<inter> (defer m A p) = {}) \<and>
          ((reject m A p) \<inter> (defer m A p) = {})"
    using disj3 eq_snd_iff fstI
    by metis
  thus "False"
    using asm1 asm2 module profile wf_A_m prof_p
          set_partit partit disjoint_iff_not_equal
    by (metis (no_types))
next
  fix
    x :: "'a"
  assume
    asm1: "x \<in> reject m A p" and
    asm2: "x \<in> defer m A p"
  have partit:
    "\<forall>A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists>B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from module profile have set_partit:
    "set_equals_partition A (m A p)"
    using electoral_module_def
    by auto
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p have wf_A_m:
    "well_formed A (m A p)"
    using electoral_module_def
    by metis
  show "False"
    using prod.exhaust_sel DiffE UnCI asm1 asm2
          module profile result_imp_rej wf_A_m
          prof_p set_partit partit
    by (metis (no_types))
qed

lemma elect_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "elect m A p \<subseteq> A"
  using le_supI1 e_mod f_prof result_presv_alts sup_ge1
  by metis

lemma reject_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "reject m A p \<subseteq> A"
  using le_supI1 e_mod f_prof result_presv_alts sup_ge2
  by fastforce

lemma defer_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "defer m A p \<subseteq> A"
  using e_mod f_prof result_presv_alts
  by auto

lemma def_presv_fin_prof:
  assumes module:  "electoral_module m" and
          f_prof: "finite_profile A p"
  shows
    "let new_A = defer m A p in
        finite_profile new_A (limit_profile new_A p)"
  using defer_in_alts infinite_super
        limit_profile_sound module f_prof
  by metis

(*
   An electoral module can never reject, defer or elect more than
   |A| alternatives.
*)
lemma upper_card_bounds_for_result:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows
    "card (elect m A p) \<le> card A \<and>
      card (reject m A p) \<le> card A \<and>
      card (defer m A p) \<le> card A "
  by (simp add: card_mono defer_in_alts elect_in_alts
                e_mod f_prof reject_in_alts)

lemma reject_not_elec_or_def:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "reject m A p = A - (elect m A p) - (defer m A p)"
proof -
  from e_mod f_prof have 0: "well_formed A (m A p)"
    by (simp add: electoral_module_def)
  with e_mod f_prof
    have "(elect m A p) \<union> (reject m A p) \<union> (defer m A p) = A"
      using result_presv_alts
      by simp
    moreover from 0 have
      "(elect m A p) \<inter> (reject m A p) = {} \<and>
          (reject m A p) \<inter> (defer m A p) = {}"
    using e_mod f_prof result_disj
    by blast
  ultimately show ?thesis
    by blast
qed

lemma elec_and_def_not_rej:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "elect m A p \<union> defer m A p = A - (reject m A p)"
proof -
  from e_mod f_prof have 0: "well_formed A (m A p)"
    by (simp add: electoral_module_def)
  hence
    "disjoint3 (m A p) \<and> set_equals_partition A (m A p)"
    by simp
  with e_mod f_prof
  have "(elect m A p) \<union> (reject m A p) \<union> (defer m A p) = A"
    using e_mod f_prof result_presv_alts
    by blast
  moreover from 0 have
    "(elect m A p) \<inter> (reject m A p) = {} \<and>
        (reject m A p) \<inter> (defer m A p) = {}"
    using e_mod f_prof result_disj
    by blast
  ultimately show ?thesis
    by blast
qed

lemma defer_not_elec_or_rej:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "defer m A p = A - (elect m A p) - (reject m A p)"
proof -
  from e_mod f_prof have 0: "well_formed A (m A p)"
    by (simp add: electoral_module_def)
  hence "(elect m A p) \<union> (reject m A p) \<union> (defer m A p) = A"
    using e_mod f_prof result_presv_alts
    by auto
  moreover from 0 have
    "(elect m A p) \<inter> (defer m A p) = {} \<and>
        (reject m A p) \<inter> (defer m A p) = {}"
      using e_mod f_prof result_disj
      by blast
  ultimately show ?thesis
    by blast
qed

lemma electoral_mod_defer_elem:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    alternative: "x \<in> A" and
    not_elected: "x \<notin> elect m A p" and
    not_rejected: "x \<notin> reject m A p"
  shows "x \<in> defer m A p"
  using DiffI e_mod f_prof alternative
        not_elected not_rejected
        reject_not_elec_or_def
  by metis

lemma mod_contains_result_comm:
  assumes "mod_contains_result m n A p a"
  shows "mod_contains_result n m A p a"
  unfolding mod_contains_result_def
proof (safe)
  show "electoral_module n"
    using assms mod_contains_result_def
    by metis
next
  show "electoral_module m"
    using assms mod_contains_result_def
    by metis
next
  show "finite A"
    using assms mod_contains_result_def
    by metis
next
  show "profile A p"
    using assms mod_contains_result_def
    by metis
next
  show "a \<in> A"
    using assms mod_contains_result_def
    by metis
next
  assume "a \<in> elect n A p"
  thus "a \<in> elect m A p"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
next
  assume "a \<in> reject n A p"
  thus "a \<in> reject m A p"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
next
  assume "a \<in> defer n A p"
  thus "a \<in> defer m A p"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
qed

lemma not_rej_imp_elec_or_def:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    alternative: "x \<in> A" and
    not_rejected: "x \<notin> reject m A p"
  shows "x \<in> elect m A p \<or> x \<in> defer m A p"
  using alternative electoral_mod_defer_elem
        e_mod not_rejected f_prof
  by metis

lemma single_elim_imp_red_def_set:
  assumes
    eliminating: "eliminates 1 m" and
    leftover_alternatives: "card A > 1" and
    f_prof: "finite_profile A p"
  shows "defer m A p \<subset> A"
  using Diff_eq_empty_iff Diff_subset card_eq_0_iff defer_in_alts
        eliminates_def eliminating eq_iff leftover_alternatives
        not_one_le_zero f_prof psubsetI reject_not_elec_or_def
  by metis

lemma eq_alts_in_profs_imp_eq_results:
  assumes
    eq: "\<forall>a \<in> A. prof_contains_result m A p q a" and
    (*for empty A*)
    input: "electoral_module m \<and> finite_profile A p \<and> finite_profile A q"
  shows "m A p = m A q"
proof -
  have "\<forall>a \<in> elect m A p. a \<in> elect m A q"
    using elect_in_alts eq prof_contains_result_def input in_mono
    by metis
  moreover have "\<forall>a \<in> elect m A q. a \<in> elect m A p"
    using contra_subsetD disjoint_iff_not_equal elect_in_alts
          electoral_mod_defer_elem eq prof_contains_result_def input
          result_disj
  proof -
    fix aa :: 'a
    have "\<forall> A Aa. (Aa::'a set) \<inter> A = {} \<or> Aa \<noteq> {}"
      by blast
    moreover have f1: "elect m A q - A = {}"
      using Diff_eq_empty_iff elect_in_alts input
      by metis
    moreover have f2: "defer m A q \<inter> elect m A q = {}"
      using disjoint_iff_not_equal input result_disj
      by (metis (no_types))
    moreover have f3: "reject m A q \<inter> elect m A q = {}"
      using disjoint_iff_not_equal input result_disj
      by (metis (no_types))
    ultimately have f4:
      "(\<exists> Aa. Aa \<inter> elect m A q = {} \<and> aa \<in> Aa) \<or>
          aa \<notin> elect m A q \<or> aa \<in> elect m A p"
      using DiffI electoral_mod_defer_elem eq prof_contains_result_def
      by (metis (no_types))
    hence f5:
      "aa \<notin> elect m A q \<or> aa \<in> elect m A p"
      using disjoint_iff_not_equal
      by metis
    from f1 f2 f3
    show ?thesis
      using Diff_iff Int_iff empty_iff eq not_rej_imp_elec_or_def
            prof_contains_result_def
      by metis
  qed
  moreover have
    "\<forall>a \<in> reject m A p. a \<in> reject m A q"
    using reject_in_alts eq prof_contains_result_def input in_mono
    by fastforce
  moreover have
    "\<forall>a \<in> reject m A q. a \<in> reject m A p"
  proof -
    {
      fix aa :: 'a
      have ff1:
        "\<forall> f. reject f A q \<subseteq> A \<or> \<not> electoral_module f"
        using input reject_in_alts
        by metis
      have ff2:
        "\<forall> f. reject f A q \<inter> defer f A q = {} \<or> \<not> electoral_module f"
        using input result_disj
        by metis
      have "electoral_module m \<and> profile A p \<and> finite_profile A q"
        using input
        by blast
      hence ff3:
        "elect m A q \<inter> reject m A q = {} \<and> elect m A q \<inter> defer m A q = {} \<and>
          reject m A q \<inter> defer m A q = {}"
        by (simp add: result_disj)
      hence
        "aa \<in> elect m A q \<longrightarrow> aa \<notin> reject m A q \<or> aa \<in> reject m A p"
        using disjoint_iff_not_equal ff3
        by metis
      hence "aa \<notin> reject m A q \<or> aa \<in> reject m A p"
        using ff2 ff1 electoral_mod_defer_elem eq
              input prof_contains_result_def
        by fastforce
    }
    thus ?thesis
      by metis
  qed
  moreover have "\<forall>a \<in> defer m A p. a \<in> defer m A q"
    using defer_in_alts eq prof_contains_result_def input in_mono
    by fastforce
  moreover have "\<forall>a \<in> defer m A q. a \<in> defer m A p"
  proof (safe)
    fix a :: "'a"
    assume "a \<in> defer m A q"
    thus "a \<in> defer m A p"
      using calculation defer_not_elec_or_rej
            input subsetI subset_antisym
      by (metis)
  qed
  ultimately show ?thesis
    using prod.collapse subsetI subset_antisym
    by metis
qed

lemma eq_def_and_elect_imp_eq:
  assumes
    "electoral_module m" and
    "electoral_module n" and
    "finite_profile A p" and
    "finite_profile A q" and
    "elect m A p = elect n A q" and
    "defer m A p = defer n A q"
  shows "m A p = n A q"
proof -
  have disj_m:
    "disjoint3 (m A p)"
    using assms(1) assms(3) electoral_module_def
    by auto
  have disj_n:
    "disjoint3 (n A q)"
    using assms(2) assms(4) electoral_module_def
    by auto
  have set_partit_m:
    "set_equals_partition A ((elect m A p), (reject m A p), (defer m A p))"
    using assms(1) assms(3) electoral_module_def
    by auto
  moreover have
    "disjoint3 ((elect m A p),(reject m A p),(defer m A p))"
    using disj_m prod.collapse
    by metis
  have set_partit_n:
    "set_equals_partition A ((elect n A q), (reject n A q), (defer n A q))"
    using assms(2) assms(4) electoral_module_def
    by auto
  moreover have
    "disjoint3 ((elect n A q),(reject n A q),(defer n A q))"
    using disj_n prod.collapse
    by metis
  have reject_p:
    "reject m A p = A - ((elect m A p) \<union> (defer m A p))"
    using assms(1) assms(3) combine_ele_rej_def
          electoral_module_def result_imp_rej
    by metis
  have reject_q:
    "reject n A q = A - ((elect n A q) \<union> (defer n A q))"
    using assms(2) assms(4) combine_ele_rej_def
          electoral_module_def result_imp_rej
    by metis
  from reject_p reject_q
  show ?thesis
    by (simp add: assms(5) assms(6) prod_eqI)
qed

subsection \<open>Non-Blocking\<close>

(*
   An electoral module is non-blocking iff
   this module never rejects all alternatives.
*)
definition non_blocking :: "'a Electoral_Module \<Rightarrow> bool" where
  "non_blocking m \<equiv>
    electoral_module m \<and>
      (\<forall>A p.
          ((A \<noteq> {} \<and> finite_profile A p) \<longrightarrow> reject m A p \<noteq> A))"

subsection \<open>Electing\<close>

(*
   An electoral module is electing iff
   it always elects at least one alternative.
*)
definition electing :: "'a Electoral_Module \<Rightarrow> bool" where
  "electing m \<equiv>
    electoral_module m \<and>
      (\<forall>A p. (A \<noteq> {} \<and> finite_profile A p) \<longrightarrow> elect m A p \<noteq> {})"

lemma electing_for_only_alt:
  assumes
    one_alt: "card A = 1" and
    electing: "electing m" and
    f_prof: "finite_profile A p"
  shows "elect m A p = A"
proof (safe)
  fix x :: "'a"
  assume
    electX: "x \<in> elect m A p"
  have
    "\<not> electoral_module m \<or> elect m A p \<subseteq> A"
    using elect_in_alts f_prof
    by (simp add: elect_in_alts)
  with electing have "elect m A p \<subseteq> A"
    unfolding electing_def
    by metis
  with electX show "x \<in> A"
    by auto
next
  fix x :: "'a"
  assume "x \<in> A"
  with electing f_prof one_alt
  show "x \<in> elect m A p"
    unfolding electing_def
    using One_nat_def Suc_leI card_seteq
          card_gt_0_iff elect_in_alts
          infinite_super
    by metis
qed

theorem electing_imp_non_blocking:
  assumes electing: "electing m"
  shows "non_blocking m"
  unfolding non_blocking_def
proof (safe)
  from electing
  show "electoral_module m"
    using electing_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    x :: "'a"
  assume
    finA: "finite A" and
    profA: "profile A p" and
    rejA: "reject m A p = A" and
    xInA: "x \<in> A"
  from electing have
    "electoral_module m \<and>
      (\<forall>A rs. A = {} \<or> infinite A \<or>
        \<not> profile A rs \<or> elect m A rs \<noteq> {})"
    unfolding electing_def
    by metis
  hence f1: "A = {}"
    using Diff_cancel Un_empty
          elec_and_def_not_rej
          finA profA rejA
    by (metis (no_types))
  from  xInA
  have "x \<in> A"
    by metis
  with f1 show "x \<in> {}"
    by metis
qed

subsection \<open>Properties\<close>

(*
   An electoral module is non-electing iff
   it never elects an alternative.
*)
definition non_electing :: "'a Electoral_Module \<Rightarrow> bool" where
  "non_electing m \<equiv>
    electoral_module m \<and> (\<forall>A p. finite_profile A p \<longrightarrow> elect m A p = {})"

lemma single_elim_decr_def_card:
  assumes
    rejecting: "rejects 1 m" and
    not_empty: "A \<noteq> {}" and
    non_electing: "non_electing m" and
    f_prof: "finite_profile A p"
  shows "card (defer m A p) = card A - 1"
proof -
  have "rejects 1 m"
    using One_nat_def rejecting
    by metis
  moreover have
    "electoral_module m \<and>
      (\<forall> A rs. infinite A \<or> \<not> profile A rs \<or> elect m A rs = {})"
    using non_electing
    unfolding non_electing_def
    by metis
  moreover from this have
    "reject m A p \<subseteq> A"
    using f_prof reject_in_alts
    by metis
  ultimately show ?thesis
    using f_prof not_empty
    by (simp add: Suc_leI card_Diff_subset card_gt_0_iff
                  defer_not_elec_or_rej finite_subset
                  rejects_def)
qed

lemma single_elim_decr_def_card2:
  assumes
    eliminating: "eliminates 1 m" and
    not_empty: "card A > 1" and
    non_electing: "non_electing m" and
    f_prof: "finite_profile A p"
  shows "card (defer m A p) = card A - 1"
proof -
  have
    "\<forall>f. (non_electing f \<or>
            (\<exists>A rs. ({}::'a set) \<noteq> elect f A rs \<and> profile A rs \<and> finite A) \<or>
            \<not> electoral_module f) \<and>
          ((\<forall>A rs. {} = elect f A rs \<or> \<not> profile A rs \<or> infinite A) \<and>
            electoral_module f \<or> \<not> non_electing f)"
    using non_electing_def
    by metis
  moreover from this have
    "electoral_module m \<and>
      (\<forall>A rs. infinite A \<or> \<not> profile A rs \<or> elect m A rs = {})"
    using non_electing
    by (metis (no_types))
  moreover from this have
    "reject m A p \<subseteq> A"
    using f_prof reject_in_alts
    by metis
  moreover have "1 < card A"
    using not_empty
    by presburger
  moreover have "eliminates 1 m"
    using One_nat_def eliminating
    by presburger
  moreover have "eliminates 1 m"
    using eliminating
    by force
  ultimately show ?thesis
    using f_prof
    by (simp add: card_Diff_subset defer_not_elec_or_rej
                  eliminates_def finite_subset)
qed

(*
   An electoral module is defer-deciding iff
   this module chooses exactly 1 alternative to defer and
   rejects any other alternative.
   Note that `rejects n-1 m` can be omitted due to the
   well-formedness property.
*)
definition defer_deciding :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_deciding m \<equiv>
    electoral_module m \<and> non_electing m \<and> defers 1 m"

(*
   An electoral module decrements iff
   this module rejects at least one alternative whenever possible (|A|>1).
*)
definition decrementing :: "'a Electoral_Module \<Rightarrow> bool" where
  "decrementing m \<equiv>
    electoral_module m \<and> (
      \<forall> A p . finite_profile A p \<longrightarrow>
          (card A > 1 \<longrightarrow> card (reject m A p) \<ge> 1))"

definition defer_condorcet_consistency :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_condorcet_consistency m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w. condorcet_winner A p w \<and> finite A \<longrightarrow>
      (m A p =
        ({},
        A - (defer m A p),
        {d \<in> A. condorcet_winner A p d})))"

definition condorcet_compatibility :: "'a Electoral_Module \<Rightarrow> bool" where
  "condorcet_compatibility m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w. condorcet_winner A p w \<and> finite A \<longrightarrow>
      (w \<notin> reject m A p \<and>
        (\<forall>l. \<not>condorcet_winner A p l \<longrightarrow> l \<notin> elect m A p) \<and>
          (w \<in> elect m A p \<longrightarrow>
            (\<forall>l. \<not>condorcet_winner A p l \<longrightarrow> l \<in> reject m A p))))"

(*
   An electoral module is defer-monotone iff,
   when a deferred alternative is lifted, this alternative remains deferred.
*)
definition defer_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_monotonicity m \<equiv>
    electoral_module m \<and>
      (\<forall>A p q w.
          (finite A \<and> w \<in> defer m A p \<and> lifted A p q w) \<longrightarrow> w \<in> defer m A q)"

(*
   An electoral module is defer-lift-invariant iff
   lifting a deferred alternative does not affect the outcome.
*)
definition defer_lift_invariance :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_lift_invariance m \<equiv>
    electoral_module m \<and>
      (\<forall>A p q a.
          (a \<in> (defer m A p) \<and> lifted A p q a) \<longrightarrow> m A p = m A q)"

(*
   Two electoral modules are disjoint-compatible if they only make decisions
   over disjoint sets of alternatives. Electoral modules reject alternatives
   for which they make no decision.
*)
definition disjoint_compatibility :: "'a Electoral_Module \<Rightarrow>
                                         'a Electoral_Module \<Rightarrow> bool" where
  "disjoint_compatibility m n \<equiv>
    electoral_module m \<and> electoral_module n \<and>
        (\<forall>S. finite S \<longrightarrow>
          (\<exists>A \<subseteq> S.
            (\<forall>a \<in> A. indep_of_alt m S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject m S p)) \<and>
            (\<forall>a \<in> S-A. indep_of_alt n S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject n S p))))"

(*
   Lifting an elected alternative a from an invariant-monotone
   electoral module either does not change the elect set, or
   makes a the only elected alternative.
*)
definition invariant_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "invariant_monotonicity m \<equiv>
    electoral_module m \<and>
        (\<forall>A p q a. (a \<in> elect m A p \<and> lifted A p q a) \<longrightarrow>
          (elect m A q = elect m A p \<or> elect m A q = {a}))"

(*
   Lifting a deferred alternative a from a defer-invariant-monotone
   electoral module either does not change the defer set, or
   makes a the only deferred alternative.
*)
definition defer_invariant_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_invariant_monotonicity m \<equiv>
    electoral_module m \<and> non_electing m \<and>
        (\<forall>A p q a. (a \<in> defer m A p \<and> lifted A p q a) \<longrightarrow>
          (defer m A q = defer m A p \<or> defer m A q = {a}))"

subsection \<open>Inference Rules\<close>

lemma ccomp_and_dd_imp_def_only_winner:
  assumes ccomp: "condorcet_compatibility m" and
          dd: "defer_deciding m" and
          winner: "condorcet_winner A p w"
  shows "defer m A p = {w}"
proof (rule ccontr)
  assume not_w: "defer m A p \<noteq> {w}"
  from dd have def_1:
    "defers 1 m"
    using defer_deciding_def
    by metis
  hence c_win:
    "finite_profile A p \<and>  w \<in> A \<and> (\<forall>x \<in> A - {w} . wins w p x)"
    using winner
    by simp
  hence "card (defer m A p) = 1"
    using One_nat_def Suc_leI card_gt_0_iff
          def_1 defers_def equals0D
    by metis
  hence 0: "\<exists>x \<in> A . defer m A p ={x}"
    using card_1_singletonE dd defer_deciding_def
          defer_in_alts insert_subset c_win
    by metis
  with not_w have "\<exists>l \<in> A . l \<noteq> w \<and> defer m A p = {l}"
    by metis
  hence not_in_defer: "w \<notin> defer m A p"
    by auto
  have "non_electing m"
    using dd defer_deciding_def
    by metis
  hence not_in_elect: "w \<notin> elect m A p"
    using c_win equals0D non_electing_def
    by metis
  from not_in_defer not_in_elect have one_side:
    "w \<in> reject m A p"
    using ccomp condorcet_compatibility_def c_win
          electoral_mod_defer_elem
    by metis
  from ccomp have other_side: "w \<notin> reject m A p"
    using condorcet_compatibility_def c_win winner
    by (metis (no_types, hide_lams))
  thus False
    by (simp add: one_side)
qed

theorem ccomp_and_dd_imp_dcc[simp]:
  assumes ccomp: "condorcet_compatibility m" and
          dd: "defer_deciding m"
  shows "defer_condorcet_consistency m"
proof (unfold defer_condorcet_consistency_def, auto)
  show "electoral_module m"
    using dd defer_deciding_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    finiteness: "finite A" and
    assm: "\<forall>x\<in>A - {w}.
          card {i. i < length p \<and> (w, x) \<in> (p!i)} <
            card {i. i < length p \<and> (x, w) \<in> (p!i)}"
  have winner: "condorcet_winner A p w"
    using assm finiteness prof_A w_in_A
    by simp
  hence
    "m A p =
      ({},
        A - defer m A p,
        {d \<in> A. condorcet_winner A p d})"
  proof -
    (*Elect*)
    from dd have 0:
      "elect m A p = {}"
      using defer_deciding_def non_electing_def
            winner
      by fastforce
    (*Defers*)
    from dd ccomp have 1: "defer m A p = {w}"
      using ccomp_and_dd_imp_def_only_winner winner
      by simp
    (*Reject*)
    from 0 1 have 2: "reject m A p = A - defer m A p"
      using Diff_empty dd defer_deciding_def
            reject_not_elec_or_def winner
      by fastforce
    from 0 1 2 have 3: "m A p = ({}, A - defer m A p, {w})"
      using combine_ele_rej_def
      by metis
    have "{w} = {d \<in> A. condorcet_winner A p d}"
      using cond_winner_unique3 winner
      by metis
    thus ?thesis
      using "3"
      by auto
  qed
  hence
    "m A p =
      ({},
        A - defer m A p,
        {d \<in> A. \<forall>x\<in>A - {d}. wins d p x})"
    using finiteness prof_A winner Collect_cong
    by auto
  hence
    "m A p =
        ({},
          A - defer m A p,
          {d \<in> A. \<forall>x\<in>A - {d}.
            prefer_count p x d < prefer_count p d x})"
    by simp
  hence
    "m A p =
        ({},
          A - defer m A p,
          {d \<in> A. \<forall>x\<in>A - {d}.
            card {i. i < length p \<and> (let r = (p!i) in (d \<preceq>\<^sub>r x))} <
                card {i. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r d))}})"
    by simp
  thus
    "m A p =
        ({},
          A - defer m A p,
          {d \<in> A. \<forall>x\<in>A - {d}.
            card {i. i < length p \<and> (d, x) \<in> (p!i)} <
              card {i. i < length p \<and> (x, d) \<in> (p!i)}})"
    by simp
qed

(*If m and n are disjoint compatible, so are n and m.*)
theorem disj_compat_comm[simp]:
  assumes compatible: "disjoint_compatibility m n"
  shows "disjoint_compatibility n m"
proof -
  have
    "\<forall>S. finite S \<longrightarrow>
        (\<exists>A \<subseteq> S.
          (\<forall>a \<in> A. indep_of_alt n S a \<and>
            (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject n S p)) \<and>
          (\<forall>a \<in> S-A. indep_of_alt m S a \<and>
            (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject m S p)))"
  proof
    fix
      S :: "'a set"
    obtain A where old_A:
      "finite S \<longrightarrow>
          (A \<subseteq> S \<and>
            (\<forall>a \<in> A. indep_of_alt m S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject m S p)) \<and>
            (\<forall>a \<in> S-A. indep_of_alt n S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject n S p)))"
      using compatible disjoint_compatibility_def
      by fastforce
    hence
      "finite S \<longrightarrow>
          (\<exists>A \<subseteq> S.
            (\<forall>a \<in> S-A. indep_of_alt n S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject n S p)) \<and>
            (\<forall>a \<in> A. indep_of_alt m S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject m S p)))"
      by auto
    hence
      "finite S \<longrightarrow>
          (\<exists>A \<subseteq> S.
            (\<forall>a \<in> S-A. indep_of_alt n S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject n S p)) \<and>
            (\<forall>a \<in> S-(S-A). indep_of_alt m S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject m S p)))"
      using double_diff order_refl
      by metis
    thus
      "finite S \<longrightarrow>
          (\<exists>A \<subseteq> S.
            (\<forall>a \<in> A. indep_of_alt n S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject n S p)) \<and>
            (\<forall>a \<in> S-A. indep_of_alt m S a \<and>
              (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject m S p)))"
      by fastforce
  qed
  moreover have "electoral_module m \<and> electoral_module n"
    using compatible disjoint_compatibility_def
    by auto
  ultimately show ?thesis
    by (simp add: disjoint_compatibility_def)
qed

(*
   Every electoral module which is defer-lift-invariant is
   also defer-monotone.
*)
theorem dl_inv_imp_def_mono[simp]:
  assumes "defer_lift_invariance m"
  shows "defer_monotonicity m"
  using assms defer_monotonicity_def defer_lift_invariance_def
  by fastforce

subsection \<open>Social Choice Properties\<close>

subsubsection \<open>Condorcet Consistency\<close>

definition condorcet_consistency :: "'a Electoral_Module \<Rightarrow> bool" where
  "condorcet_consistency m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w. condorcet_winner A p w \<longrightarrow>
      (m A p =
        ({e \<in> A. condorcet_winner A p e},
          A - (elect m A p),
          {})))"

lemma condorcet_consistency2:
  "condorcet_consistency m \<longleftrightarrow>
      electoral_module m \<and>
        (\<forall> A p w. condorcet_winner A p w \<longrightarrow>
            (m A p =
              ({w}, A - (elect m A p), {})))"
proof (safe)
  assume "condorcet_consistency m"
  thus "electoral_module m"
    using condorcet_consistency_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    cc: "condorcet_consistency m" and
    cwin: "condorcet_winner A p w"
  show
    "m A p = ({w}, A - elect m A p, {})"
    using cond_winner_unique3 condorcet_consistency_def cc cwin
    by (metis (mono_tags, lifting))
next
  assume
    e_mod: "electoral_module m" and
    cwin:
    "\<forall>A p w. condorcet_winner A p w \<longrightarrow>
      m A p = ({w}, A - elect m A p, {})"
  have
    "\<forall>f. condorcet_consistency f =
      (electoral_module f \<and>
        (\<forall>A rs a. \<not> condorcet_winner A rs (a::'a) \<or>
          f A rs = ({a \<in> A. condorcet_winner A rs a},
                    A - elect f A rs, {})))"
    unfolding condorcet_consistency_def
    by blast
  moreover have
    "\<forall>A rs a. \<not> condorcet_winner A rs (a::'a) \<or>
        {a \<in> A. condorcet_winner A rs a} = {a}"
    using cond_winner_unique3
    by (metis (full_types))
  ultimately show
    "condorcet_consistency m"
    unfolding condorcet_consistency_def
    using cond_winner_unique3 e_mod cwin
    by presburger
qed

subsubsection \<open>(Weak) Monotonicity\<close>

(*
   An electoral module is monotone iff
   when an elected alternative is lifted, this alternative remains elected.
*)
definition monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "monotonicity m \<equiv>
    electoral_module m \<and>
      (\<forall>A p q w.
          (finite A \<and> w \<in> elect m A p \<and> lifted A p q w) \<longrightarrow> w \<in> elect m A q)"

subsubsection \<open>Homogeneity\<close>

fun times :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "times n l = concat (replicate n l)"

definition homogeneity :: "'a Electoral_Module \<Rightarrow> bool" where
"homogeneity m \<equiv>
  electoral_module m \<and>
    (\<forall> A p n .
      (finite_profile A p \<and> n > 0 \<longrightarrow>
          (m A p = m A (times n p))))"

subsubsection \<open>Reinforcement\<close>

definition reinforcement_elect:: "'a Electoral_Module \<Rightarrow> bool" where
"reinforcement_elect m \<equiv> electoral_module m \<and>
(\<forall> A p1 p2. (finite_profile A p1 \<and> finite_profile A p2 \<longrightarrow>
(elect m A p1) \<inter> (elect m A p2) \<noteq> {} \<longrightarrow>
((elect m A p1) \<inter> (elect m A p2) = elect m A (p1 @ p2))))"

definition reinforcement_defer:: "'a Electoral_Module \<Rightarrow> bool" where
"reinforcement_defer m \<equiv> electoral_module m \<and>
(\<forall> A p1 p2. (finite_profile A p1 \<and> finite_profile A p2 \<longrightarrow>
(defer m A p1) \<inter> (defer m A p2) \<noteq> {} \<longrightarrow>
((defer m A p1) \<inter> (defer m A p2) = defer m A (p1 @ p2))))"

definition reinforcement:: "'a Electoral_Module \<Rightarrow> bool" where
"reinforcement m \<equiv> reinforcement_elect m \<and> (\<forall>A p. defer m A p = {})"

definition reinforcement_complete:: "'a Electoral_Module \<Rightarrow> bool" where
"reinforcement_complete m \<equiv> electoral_module m \<and>
(\<forall> A p1 p2. (finite_profile A p1 \<and> finite_profile A p2 \<longrightarrow>
((defer m A p1) \<inter> (defer m A p2) \<noteq> {} \<longrightarrow>
((defer m A p1) \<inter> (defer m A p2) = defer m A (p1 @ p2))) \<and>
((elect m A p1) \<inter> (elect m A p2) \<noteq> {} \<longrightarrow>
((elect m A p1) \<inter> (elect m A p2) = elect m A (p1 @ p2)))))"

lemma from_elect_and_defer_follows_reinforcement:
  assumes "reinforcement_elect m" and "reinforcement_defer m"
  shows "reinforcement_complete m"
proof(unfold reinforcement_complete_def)
  have 0:"(\<forall>A p1 p2.
        finite_profile A p1 \<and> finite_profile A p2 \<longrightarrow>
        defer m A p1 \<inter> defer m A p2 \<noteq> {} \<longrightarrow>
        defer m A p1 \<inter> defer m A p2 = defer m A (p1 @ p2))"
    using assms(2) reinforcement_defer_def by blast
  have 1:"electoral_module m \<and>
    (\<forall>A p1 p2.
        finite_profile A p1 \<and> finite_profile A p2 \<longrightarrow>
        elect m A p1 \<inter> elect m A p2 \<noteq> {} \<longrightarrow>
        elect m A p1 \<inter> elect m A p2 = elect m A (p1 @ p2))"
    using assms(1) reinforcement_elect_def by blast
  then show "electoral_module m \<and>
    (\<forall>A p1 p2.
        finite_profile A p1 \<and> finite_profile A p2 \<longrightarrow>
        (defer m A p1 \<inter> defer m A p2 \<noteq> {} \<longrightarrow>
         defer m A p1 \<inter> defer m A p2 = defer m A (p1 @ p2)) \<and>
        (elect m A p1 \<inter> elect m A p2 \<noteq> {} \<longrightarrow>
         elect m A p1 \<inter> elect m A p2 = elect m A (p1 @ p2)))" using assms(1) assms(2) 0 1
    by presburger
qed

end


(*  Title:       Show
    Author:      Christian Sternagel <c.sternagel@gmail.com>
    Author:      René Thiemann <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel <c.sternagel@gmail.com>
    Maintainer:  René Thiemann <rene.thiemann@uibk.ac.at>
*)

section \<open>Instances of the Show Class for Standard Types\<close>

theory Show_Instances
imports
  Show
  HOL.Rat
begin

definition showsp_unit :: "unit showsp"
where
  "showsp_unit p x = shows_string ''()''"

lemma show_law_unit [show_law_intros]:
  "show_law showsp_unit x"
  by (rule show_lawI) (simp add: showsp_unit_def show_law_simps)

abbreviation showsp_char :: "char showsp"
where
  "showsp_char \<equiv> shows_prec"

lemma show_law_char [show_law_intros]:
  "show_law showsp_char x"
  by (rule show_lawI) (simp add: show_law_simps)

primrec showsp_bool :: "bool showsp"
where
  "showsp_bool p True = shows_string ''True''" |
  "showsp_bool p False = shows_string ''False''"

lemma show_law_bool [show_law_intros]:
  "show_law showsp_bool x"
  by (rule show_lawI, cases x) (simp_all add: show_law_simps)

primrec pshowsp_prod :: "(shows \<times> shows) showsp"
where
  "pshowsp_prod p (x, y) = shows_string ''('' o x o shows_string '', '' o y o shows_string '')''"

(*NOTE: in order to be compatible with automatically generated show funtions,
show-arguments of "map"-functions need to get precedence 1 (which may lead to
redundant parentheses in the output, but seems unavoidable in the current setup,
i.e., pshowsp via primrec followed by defining showsp via pshowsp composed with map).*)
definition showsp_prod :: "'a showsp \<Rightarrow> 'b showsp \<Rightarrow> ('a \<times> 'b) showsp"
where
  [code del]: "showsp_prod s1 s2 p = pshowsp_prod p o map_prod (s1 1) (s2 1)"

lemma showsp_prod_simps [simp, code]:
  "showsp_prod s1 s2 p (x, y) =
    shows_string ''('' o s1 1 x o shows_string '', '' o s2 1 y o shows_string '')''"
  by (simp add: showsp_prod_def)

fun string_of_digit :: "nat \<Rightarrow> string"
where
  "string_of_digit n =
    (if n = 0 then ''0''
    else if n = 1 then ''1''
    else if n = 2 then ''2''
    else if n = 3 then ''3''
    else if n = 4 then ''4''
    else if n = 5 then ''5''
    else if n = 6 then ''6''
    else if n = 7 then ''7''
    else if n = 8 then ''8''
    else ''9'')"

fun showsp_nat :: "nat showsp"
where
  "showsp_nat p n =
    (if n < 10 then shows_string (string_of_digit n)
    else showsp_nat p (n div 10) o shows_string (string_of_digit (n mod 10)))"
declare showsp_nat.simps [simp del]

lemma show_law_nat [show_law_intros]:
  "show_law showsp_nat n"
  by (rule show_lawI, induct n rule: nat_less_induct) (simp add: show_law_simps showsp_nat.simps)

lemma showsp_nat_append [show_law_simps]:
  "showsp_nat p n (x @ y) = showsp_nat p n x @ y"
  by (intro show_lawD show_law_intros)

definition showsp_int :: "int showsp"
where
  "showsp_int p i =
    (if i < 0 then shows_string ''-'' o showsp_nat p (nat (- i)) else showsp_nat p (nat i))"

lemma show_law_int [show_law_intros]:
  "show_law showsp_int i"
  by (rule show_lawI, cases "i < 0") (simp_all add: showsp_int_def show_law_simps)

lemma showsp_int_append [show_law_simps]:
  "showsp_int p i (x @ y) = showsp_int p i x @ y"
  by (intro show_lawD show_law_intros)

definition showsp_rat :: "rat showsp"
where
  "showsp_rat p x =
    (case quotient_of x of (d, n) \<Rightarrow>
      if n = 1 then showsp_int p d else showsp_int p d o shows_string ''/'' o showsp_int p n)"

lemma show_law_rat [show_law_intros]:
  "show_law showsp_rat r"
  by (rule show_lawI, cases "quotient_of r") (simp add: showsp_rat_def show_law_simps)

lemma showsp_rat_append [show_law_simps]:
  "showsp_rat p r (x @ y) = showsp_rat p r x @ y"
  by (intro show_lawD show_law_intros)

text \<open>
  Automatic show functions are not used for @{type unit}, @{type prod}, and numbers:
  for @{type unit} and @{type prod}, we do not want to display @{term "''Unity''"} and
  @{term "''Pair''"}; for @{type nat}, we do not want to display
  @{term "''Suc (Suc (... (Suc 0) ...))''"}; and neither @{type int}
  nor @{type rat} are datatypes.
\<close>

local_setup \<open>
  Show_Generator.register_foreign_partial_and_full_showsp @{type_name prod} 0
       @{term "pshowsp_prod"}
       @{term "showsp_prod"} (SOME @{thm showsp_prod_def})
       @{term "map_prod"} (SOME @{thm prod.map_comp}) [true, true]
       @{thm show_law_prod}
  #> Show_Generator.register_foreign_showsp @{typ unit} @{term "showsp_unit"} @{thm show_law_unit}
  #> Show_Generator.register_foreign_showsp @{typ bool} @{term "showsp_bool"} @{thm show_law_bool}
  #> Show_Generator.register_foreign_showsp @{typ char} @{term "showsp_char"} @{thm show_law_char}
  #> Show_Generator.register_foreign_showsp @{typ nat} @{term "showsp_nat"} @{thm show_law_nat}
  #> Show_Generator.register_foreign_showsp @{typ int} @{term "showsp_int"} @{thm show_law_int}
  #> Show_Generator.register_foreign_showsp @{typ rat} @{term "showsp_rat"} @{thm show_law_rat}
\<close>

derive "show" option sum prod unit bool nat int rat

export_code
  "shows_prec :: 'a::show option showsp"
  "shows_prec :: ('a::show, 'b::show) sum showsp"
  "shows_prec :: ('a::show \<times> 'b::show) showsp"
  "shows_prec :: unit showsp"
  "shows_prec :: char showsp"
  "shows_prec :: bool showsp"
  "shows_prec :: nat showsp"
  "shows_prec :: int showsp"
  "shows_prec :: rat showsp"
  checking

end


theory correspondence
  imports labellings extensions
begin

nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=2] (*default settings*)

(* Define mappings between extensions and labellings. *)
abbreviation Lab2Ext::\<open>'a Labelling \<Rightarrow> 'a Set\<close>
  where \<open>Lab2Ext Lab \<equiv> in(Lab)\<close>
abbreviation Ext2Lab::\<open>'a \<A>\<F> \<Rightarrow> 'a Set \<Rightarrow> 'a Labelling\<close> (* Warning: works only for conflict-free sets! *)
  where \<open>Ext2Lab AF E \<equiv> \<lambda>a. if (E a) then In else (if ([AF|E]\<^sup>+ a) then Out else Undec)\<close>

(*conflict-free*)

lemma conflictfree_LE:  "conflictfree AF Lab \<longrightarrow> conflictfree_ext AF (Lab2Ext Lab)"
  by (metis (mono_tags, lifting) conflictfree_ext_def conflictfree_def legallyOut_def)

lemma conflictfree_LE': "conflictfree_ext AF (Lab2Ext Lab) \<longrightarrow> conflictfree AF Lab"
  nitpick oops (*as expected*)

lemma conflictfree_EL:  "conflictfree_ext AF E \<longrightarrow> conflictfree AF (Ext2Lab AF E)"
  unfolding conflictfree_ext_def conflictfree_def
  by (smt (verit, best) Label.distinct(1) Label.distinct(3) Label.distinct(5) inset_def legallyOut_def outset_def plusset_def)

lemma conflictfree_EL': "conflictfree AF (Ext2Lab AF E) \<longrightarrow> conflictfree_ext AF E"
  unfolding conflictfree_ext_def conflictfree_def by (simp add: inset_def legallyOut_def)

(*admissible*)

lemma admissible_LE:  "admissible AF Lab \<longrightarrow> admissible_ext AF (Lab2Ext Lab)"
  unfolding admissible_ext_def admissible_def
  by (metis (mono_tags, hide_lams) Label.distinct(1) defends_def conflictfree_ext_def inset_def legallyIn_def legallyOut_def outset_def)

lemma admissible_LE': "admissible_ext AF (Lab2Ext Lab) \<longrightarrow> admissible AF Lab"
  nitpick oops (*as expected*)

lemma admissible_EL:  "admissible_ext AF E \<longrightarrow> admissible AF (Ext2Lab AF E)"
  unfolding admissible_ext_def admissible_def
  by (smt (verit, del_insts) Label.distinct(1) Label.distinct(3) Label.distinct(5) defends_def conflictfree_ext_def inset_def legallyIn_def legallyOut_def outset_def plusset_def)

lemma admissible_EL': "admissible AF (Ext2Lab AF E) \<longrightarrow> admissible_ext AF E"
  unfolding admissible_ext_def admissible_def
  by (smt (verit, best) Label.distinct(1) Label.distinct(5) conflictfree_ext_def defends_def2 inset_def legallyIn_def minusset_def outset_def)

(*complete*)

lemma complete_LE:  "complete AF Lab \<longrightarrow> complete_ext AF (Lab2Ext Lab)"
  unfolding complete_ext_def
  by (metis admissible_LE complete2_def complete_def complete_def2 defends_def legallyIn_def legallyOut_def)

lemma complete_LE': "complete_ext AF (Lab2Ext Lab) \<longrightarrow> complete AF Lab"
  nitpick oops (*as expected*)

lemma complete_EL:  "complete_ext AF E \<longrightarrow> complete AF (Ext2Lab AF E)"
  unfolding complete_ext_def complete_def2
  by (smt (z3) Label.distinct(1) Label.distinct(3) Label.distinct(5) admissible_ext_def complete2_def conflictfree_ext_def defends_def inset_def legallyIn_def legallyOut_def outset_def plusset_def)

lemma complete_EL': "complete AF (Ext2Lab AF E) \<longrightarrow> complete_ext AF E"
  unfolding complete_ext_def complete_def
  by (smt (verit, del_insts) Label.distinct(1) Label.distinct(3) MONO_def \<F>_mono admissible_ext_def complete_LE complete_def complete_ext_def conflictfree_ext_def inset_def)

(*preferred*)

lemma preferred_LE:  "preferred AF Lab \<longrightarrow> preferred_ext AF (Lab2Ext Lab)"
  unfolding preferred_ext_def preferred_def
  (*nitpick[timeout=100]*) oops (*TODO*)

lemma preferred_LE': "preferred_ext AF (Lab2Ext Lab) \<longrightarrow> preferred AF Lab"
  nitpick oops (*as expected*)

lemma preferred_EL:  "preferred_ext AF E \<longrightarrow> preferred AF (Ext2Lab AF E)"
  unfolding preferred_ext_def preferred_def
  oops (*TODO*)

lemma preferred_EL': "preferred AF (Ext2Lab AF E) \<longrightarrow> preferred_ext AF E"
  unfolding preferred_ext_def preferred_def
  (*nitpick[timeout=100]*) oops (*TODO*)

(*grounded*)

lemma grounded_LE:  "grounded AF Lab \<longrightarrow> grounded_ext AF (Lab2Ext Lab)"
  unfolding grounded_ext_def grounded_def
  by (smt (verit, ccfv_SIG) Label.distinct(1) Label.distinct(3) complete_EL complete_LE id_apply inset_def minimal_def)

lemma grounded_LE': "grounded_ext AF (Lab2Ext Lab) \<longrightarrow> grounded AF Lab"
  nitpick oops (*as expected*)

lemma grounded_EL:  "grounded_ext AF E \<longrightarrow> grounded2 AF (Ext2Lab AF E)"
  oops (*TODO*)

lemma grounded_EL': "grounded2 AF (Ext2Lab AF E) \<longrightarrow> grounded_ext AF E"
  oops (*TODO*)

end


section \<open>Imperative Weighted Graphs\<close>
theory Sepref_WGraph
imports
  "../Sepref_ICF_Bindings"
  Dijkstra_Shortest_Path.Graph
begin

  type_synonym 'w graph_impl = "(('w\<times>nat) list) Heap.array"

  abbreviation (input) "node_rel \<equiv> nbn_rel"
  abbreviation (input) "node_assn \<equiv> nbn_assn"

  definition "is_graph n R G Gi \<equiv>
      \<exists>\<^sub>Al. Gi \<mapsto>\<^sub>a l * \<up>(
        valid_graph G \<and>
        n = length l \<and>
        nodes G = {0..<length l} \<and>
        (\<forall>v\<in>nodes G. (l!v, succ G v) \<in> \<langle>R \<times>\<^sub>r node_rel (length l)\<rangle>list_set_rel)
      )"

  definition succi :: "'w::heap graph_impl \<Rightarrow> nat \<Rightarrow> ('w\<times>nat) list Heap"
  where "succi G v = do {
    l \<leftarrow> Array.len G;
    if v<l then do { \<comment> \<open>TODO: Alternatively, require \<open>v\<close> to be a valid node as precondition!\<close>
      r \<leftarrow> Array.nth G v;
      return r
    } else return []
  }"

  lemma "
    < is_graph n R G Gi * \<up>(v\<in>nodes G) >
      succi Gi v
    < \<lambda>r. is_graph n R G Gi * \<up>((r,succ G v)\<in>\<langle>R \<times>\<^sub>r node_rel n\<rangle>list_set_rel) >"
    unfolding is_graph_def succi_def
    by sep_auto

  lemma (in valid_graph) succ_no_node_empty: "v\<notin>V \<Longrightarrow> succ G v = {}"
    unfolding succ_def using E_valid
    by auto

  lemma [sepref_fr_rules]: "
    hn_refine
      (hn_ctxt (is_graph n R) G Gi * hn_ctxt (node_assn n) v vi)
      (succi Gi vi)
      (hn_ctxt (is_graph n R) G Gi * hn_ctxt (node_assn n) v vi)
      (pure (\<langle>R \<times>\<^sub>r node_rel n\<rangle>list_set_rel))
      (RETURN$(succ$G$v))"
    apply rule
    unfolding hn_ctxt_def pure_def is_graph_def succi_def
    by (sep_auto simp: valid_graph.succ_no_node_empty list_set_autoref_empty)

  definition nodes_impl :: "'w::heap graph_impl \<Rightarrow> nat list Heap"
    where "nodes_impl Gi \<equiv> do {
    l \<leftarrow> Array.len Gi;
    return [0..<l]
  }"

  lemma node_list_rel_id: "\<forall>x\<in>set l. x<n \<Longrightarrow> (l,l)\<in>\<langle>node_rel n\<rangle>list_rel"
    by (induction l) auto

  lemma [sepref_fr_rules]: "hn_refine
    (hn_ctxt (is_graph n R) G Gi)
    (nodes_impl Gi)
    (hn_ctxt (is_graph n R) G Gi)
    (pure (\<langle>node_rel n\<rangle>list_set_rel))
    (RETURN$(nodes$G))"
    apply rule
    unfolding hn_ctxt_def pure_def is_graph_def nodes_impl_def
    apply (sep_auto simp: list_set_rel_def br_def intro!: relcompI node_list_rel_id)
    done

  sepref_register succ nodes

  definition cr_graph
    :: "nat \<Rightarrow> (nat \<times> nat \<times> 'w) list \<Rightarrow> 'w::heap graph_impl Heap"
  where
    "cr_graph numV Es \<equiv> do {
      a \<leftarrow> Array.new numV [];
      a \<leftarrow> imp_nfoldli Es (\<lambda>_. return True) (\<lambda>(u,v,w) a. do {
        l \<leftarrow> Array.nth a u;
        let l = (w,v)#l;
        a \<leftarrow> Array.upd u l a;
        return a
      }) a;
      return a
    }"

  export_code cr_graph checking SML_imp

end


(*  Title:      POPLmark/POPLmarkRecordCtxt.thy
    Author:     Stefan Berghofer, TU Muenchen, 2005
*)

theory POPLmarkRecordCtxt
imports POPLmarkRecord
begin

section \<open>Evaluation contexts\<close>

text \<open>
\label{sec:evaluation-ctxt}
In this section, we present a different way of formalizing the evaluation relation.
Rather than using additional congruence rules, we first formalize a set \<open>ctxt\<close>
of evaluation contexts, describing the locations in a term where reductions
can occur. We have chosen a higher-order formalization of evaluation contexts as
functions from terms to terms. We define simultaneously a set \<open>rctxt\<close>
of evaluation contexts for records represented as functions from terms to lists
of fields.
\<close>

inductive_set
  ctxt :: "(trm \<Rightarrow> trm) set"
  and rctxt :: "(trm \<Rightarrow> rcd) set"
where
  C_Hole: "(\<lambda>t. t) \<in> ctxt"
| C_App1: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. E t \<bullet> u) \<in> ctxt"
| C_App2: "v \<in> value \<Longrightarrow> E \<in> ctxt \<Longrightarrow> (\<lambda>t. v \<bullet> E t) \<in> ctxt"
| C_TApp: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. E t \<bullet>\<^sub>\<tau> T) \<in> ctxt"
| C_Proj: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. E t..l) \<in> ctxt"
| C_Rcd: "E \<in> rctxt \<Longrightarrow> (\<lambda>t. Rcd (E t)) \<in> ctxt"
| C_Let: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. LET p = E t IN u) \<in> ctxt"
| C_hd: "E \<in> ctxt \<Longrightarrow> (\<lambda>t. (l, E t) \<Colon> fs) \<in> rctxt"
| C_tl: "v \<in> value \<Longrightarrow> E \<in> rctxt \<Longrightarrow> (\<lambda>t. (l, v) \<Colon> E t) \<in> rctxt"

lemmas rctxt_induct = ctxt_rctxt.inducts(2)
  [of _ "\<lambda>x. True", simplified True_simps, consumes 1, case_names C_hd C_tl]

lemma rctxt_labels:
  assumes H: "E \<in> rctxt"
  shows "E t\<langle>l\<rangle>\<^sub>? = \<bottom> \<Longrightarrow> E t'\<langle>l\<rangle>\<^sub>? = \<bottom>" using H
  by (induct rule: rctxt_induct) auto

text \<open>
The evaluation relation \<open>t \<longmapsto>\<^sub>c t'\<close> is now characterized by the rule \<open>E_Ctxt\<close>,
which allows reductions in arbitrary contexts, as well as the rules \<open>E_Abs\<close>,
\<open>E_TAbs\<close>, \<open>E_LetV\<close>, and \<open>E_ProjRcd\<close> describing the ``immediate''
reductions, which have already been presented in \secref{sec:evaluation} and
\secref{sec:evaluation-rcd}.
\<close>

inductive
  eval :: "trm \<Rightarrow> trm \<Rightarrow> bool"  (infixl "\<longmapsto>\<^sub>c" 50)
where
  E_Ctxt: "t \<longmapsto>\<^sub>c t' \<Longrightarrow> E \<in> ctxt \<Longrightarrow> E t \<longmapsto>\<^sub>c E t'"
| E_Abs: "v\<^sub>2 \<in> value \<Longrightarrow> (\<lambda>:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet> v\<^sub>2 \<longmapsto>\<^sub>c t\<^sub>1\<^sub>2[0 \<mapsto> v\<^sub>2]"
| E_TAbs: "(\<lambda><:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet>\<^sub>\<tau> T\<^sub>2 \<longmapsto>\<^sub>c t\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]"
| E_LetV: "v \<in> value \<Longrightarrow> \<turnstile> p \<rhd> v \<Rightarrow> ts \<Longrightarrow> (LET p = v IN t) \<longmapsto>\<^sub>c t[0 \<mapsto>\<^sub>s ts]"
| E_ProjRcd: "fs\<langle>l\<rangle>\<^sub>? = \<lfloor>v\<rfloor> \<Longrightarrow> v \<in> value \<Longrightarrow> Rcd fs..l \<longmapsto>\<^sub>c v"

text \<open>
In the proof of the preservation theorem, the case corresponding to the rule \<open>E_Ctxt\<close>
requires a lemma stating that replacing
a term @{term t} in a well-typed term of the form @{term "E t"}, where @{term E} is
a context, by a term @{term t'} of the same type does not change the type of the
resulting term @{term "E t'"}.
The proof is by mutual induction on the typing derivations for terms and records.
\<close>

lemma context_typing: \<comment> \<open>A.18\<close>
  "\<Gamma> \<turnstile> u : T \<Longrightarrow> E \<in> ctxt \<Longrightarrow> u = E t \<Longrightarrow>
     (\<And>T\<^sub>0. \<Gamma> \<turnstile> t : T\<^sub>0 \<Longrightarrow> \<Gamma> \<turnstile> t' : T\<^sub>0) \<Longrightarrow> \<Gamma> \<turnstile> E t' : T"
  "\<Gamma> \<turnstile> fs [:] fTs \<Longrightarrow> E\<^sub>r \<in> rctxt \<Longrightarrow> fs = E\<^sub>r t \<Longrightarrow>
     (\<And>T\<^sub>0. \<Gamma> \<turnstile> t : T\<^sub>0 \<Longrightarrow> \<Gamma> \<turnstile> t' : T\<^sub>0) \<Longrightarrow> \<Gamma> \<turnstile> E\<^sub>r t' [:] fTs"
proof (induct arbitrary: E t t' and E\<^sub>r t t' set: typing typings)
  case (T_Var \<Gamma> i U T E t t')
  from \<open>E \<in> ctxt\<close>
  have "E = (\<lambda>t. t)" using T_Var by cases simp_all
  with T_Var show ?case by (blast intro: typing_typings.intros)
next
  case (T_Abs T\<^sub>1 T\<^sub>2 \<Gamma> t\<^sub>2 E t t')
  from \<open>E \<in> ctxt\<close>
  have "E = (\<lambda>t. t)" using T_Abs by cases simp_all
  with T_Abs show ?case by (blast intro: typing_typings.intros)
next
  case (T_App \<Gamma> t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 t\<^sub>2 E t t')
  from \<open>E \<in> ctxt\<close>
  show ?case using T_App
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_TAbs T\<^sub>1 \<Gamma> t\<^sub>2 T\<^sub>2 E t t')
  from \<open>E \<in> ctxt\<close>
  have "E = (\<lambda>t. t)" using T_TAbs by cases simp_all
  with T_TAbs show ?case by (blast intro: typing_typings.intros)
next
  case (T_TApp \<Gamma> t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2 E t t')
  from \<open>E \<in> ctxt\<close>
  show ?case using T_TApp
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_Sub \<Gamma> t S T E ta t')
  thus ?case by (blast intro: typing_typings.intros)
next
  case (T_Let \<Gamma> t\<^sub>1 T\<^sub>1 p \<Delta> t\<^sub>2 T\<^sub>2 E t t')
  from \<open>E \<in> ctxt\<close>
  show ?case using T_Let
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_Rcd \<Gamma> fs fTs E t t')
  from \<open>E \<in> ctxt\<close>
  show ?case using T_Rcd
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_Proj \<Gamma> t fTs l T E ta t')
  from \<open>E \<in> ctxt\<close>
  show ?case using T_Proj
    by cases (simp_all, (blast intro: typing_typings.intros)+)
next
  case (T_Nil \<Gamma> E t t')
  from \<open>E \<in> rctxt\<close>
  show ?case using T_Nil
    by cases simp_all
next
  case (T_Cons \<Gamma> t T fs fTs l E ta t')
  from \<open>E \<in> rctxt\<close>
  show ?case using T_Cons
    by cases (blast intro: typing_typings.intros rctxt_labels)+
qed

text \<open>
The fact that immediate reduction preserves the types of terms is
proved in several parts. The proof of each statement is by induction
on the typing derivation.
\<close>

theorem Abs_preservation: \<comment> \<open>A.19(1)\<close>
  assumes H: "\<Gamma> \<turnstile> (\<lambda>:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet> t\<^sub>2 : T"
  shows "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto> t\<^sub>2] : T"
  using H
proof (induct \<Gamma> "(\<lambda>:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet> t\<^sub>2" T arbitrary: T\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 t\<^sub>2 rule: typing_induct)
  case (T_App \<Gamma> T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 t\<^sub>2 T\<^sub>1\<^sub>1' t\<^sub>1\<^sub>2)
  from \<open>\<Gamma> \<turnstile> (\<lambda>:T\<^sub>1\<^sub>1'. t\<^sub>1\<^sub>2) : T\<^sub>1\<^sub>1 \<rightarrow> T\<^sub>1\<^sub>2\<close>
  obtain S'
    where T\<^sub>1\<^sub>1: "\<Gamma> \<turnstile> T\<^sub>1\<^sub>1 <: T\<^sub>1\<^sub>1'"
    and t\<^sub>1\<^sub>2: "VarB T\<^sub>1\<^sub>1' \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : S'"
    and S': "\<Gamma> \<turnstile> S'[0 \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau> <: T\<^sub>1\<^sub>2" by (rule Abs_type' [simplified]) blast
  from \<open>\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<^sub>1\<close>
  have "\<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>1\<^sub>1'" using T\<^sub>1\<^sub>1 by (rule T_Sub)
  with t\<^sub>1\<^sub>2 have "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto> t\<^sub>2] : S'[0 \<mapsto>\<^sub>\<tau> Top]\<^sub>\<tau>"
    by (rule subst_type [where \<Delta>="[]", simplified])
  then show ?case using S' by (rule T_Sub)
next
  case T_Sub
  thus ?case by (blast intro: typing_typings.intros)
qed

theorem TAbs_preservation: \<comment> \<open>A.19(2)\<close>
  assumes H: "\<Gamma> \<turnstile> (\<lambda><:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet>\<^sub>\<tau> T\<^sub>2 : T"
  shows "\<Gamma> \<turnstile> t\<^sub>1\<^sub>2[0 \<mapsto>\<^sub>\<tau> T\<^sub>2] : T"
  using H
proof (induct \<Gamma> "(\<lambda><:T\<^sub>1\<^sub>1. t\<^sub>1\<^sub>2) \<bullet>\<^sub>\<tau> T\<^sub>2" T arbitrary: T\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 T\<^sub>2 rule: typing_induct)
  case (T_TApp \<Gamma> T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2 T\<^sub>1\<^sub>1' t\<^sub>1\<^sub>2)
  from \<open>\<Gamma> \<turnstile> (\<lambda><:T\<^sub>1\<^sub>1'. t\<^sub>1\<^sub>2) : (\<forall><:T\<^sub>1\<^sub>1. T\<^sub>1\<^sub>2)\<close>
  obtain S'
    where "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : S'"
    and "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> S' <: T\<^sub>1\<^sub>2" by (rule TAbs_type') blast
  hence "TVarB T\<^sub>1\<^sub>1 \<Colon> \<Gamma> \<turnstile> t\<^sub>1\<^sub>2 : T\<^sub>1\<^sub>2" by (rule T_Sub)
  then show ?case using \<open>\<Gamma> \<turnstile> T\<^sub>2 <: T\<^sub>1\<^sub>1\<close>
    by (rule substT_type [where \<Delta>="[]", simplified])
next
  case T_Sub
  thus ?case by (blast intro: typing_typings.intros)
qed

theorem Let_preservation: \<comment> \<open>A.19(3)\<close>
  assumes H: "\<Gamma> \<turnstile> (LET p = t\<^sub>1 IN t\<^sub>2) : T"
  shows "\<turnstile> p \<rhd> t\<^sub>1 \<Rightarrow> ts \<Longrightarrow> \<Gamma> \<turnstile> t\<^sub>2[0 \<mapsto>\<^sub>s ts] : T"
  using H
proof (induct \<Gamma> "LET p = t\<^sub>1 IN t\<^sub>2" T arbitrary: p t\<^sub>1 t\<^sub>2 ts rule: typing_induct)
  case (T_Let \<Gamma> t\<^sub>1 T\<^sub>1 p \<Delta> t\<^sub>2 T\<^sub>2 ts)
  from \<open>\<turnstile> p : T\<^sub>1 \<Rightarrow> \<Delta>\<close> \<open>\<Gamma> \<turnstile> t\<^sub>1 : T\<^sub>1\<close> \<open>\<Delta> @ \<Gamma> \<turnstile> t\<^sub>2 : T\<^sub>2\<close> \<open>\<turnstile> p \<rhd> t\<^sub>1 \<Rightarrow> ts\<close>
  show ?case
    by (rule match_type(1) [of _ _ _ _ _ "[]", simplified])
next
  case T_Sub
  thus ?case by (blast intro: typing_typings.intros)
qed

theorem Proj_preservation: \<comment> \<open>A.19(4)\<close>
  assumes H: "\<Gamma> \<turnstile> Rcd fs..l : T"
  shows "fs\<langle>l\<rangle>\<^sub>? = \<lfloor>v\<rfloor> \<Longrightarrow> \<Gamma> \<turnstile> v : T"
  using H
proof (induct \<Gamma> "Rcd fs..l" T arbitrary: fs l v rule: typing_induct)
  case (T_Proj \<Gamma> fTs l T fs v)
  from \<open>\<Gamma> \<turnstile> Rcd fs : RcdT fTs\<close>
  have "\<forall>(l, U)\<in>set fTs. \<exists>u. fs\<langle>l\<rangle>\<^sub>? = \<lfloor>u\<rfloor> \<and> \<Gamma> \<turnstile> u : U"
    by (rule Rcd_type1')
  with T_Proj show ?case by (fastforce dest: assoc_set)
next
  case T_Sub
  thus ?case by (blast intro: typing_typings.intros)
qed

theorem preservation: \<comment> \<open>A.20\<close>
  assumes H: "t \<longmapsto>\<^sub>c t'"
  shows "\<Gamma> \<turnstile> t : T \<Longrightarrow> \<Gamma> \<turnstile> t' : T" using H
proof (induct arbitrary: \<Gamma> T)
  case (E_Ctxt t t' E \<Gamma> T)
  from E_Ctxt(4,3) refl E_Ctxt(2)
  show ?case by (rule context_typing)
next
  case (E_Abs v\<^sub>2 T\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 \<Gamma> T)
  from E_Abs(2)
  show ?case by (rule Abs_preservation)
next
  case (E_TAbs T\<^sub>1\<^sub>1 t\<^sub>1\<^sub>2 T\<^sub>2 \<Gamma> T)
  thus ?case by (rule TAbs_preservation)
next
  case (E_LetV v p ts t \<Gamma> T)
  from E_LetV(3,2)
  show ?case by (rule Let_preservation)
next
  case (E_ProjRcd fs l v \<Gamma> T)
  from E_ProjRcd(3,1)
  show ?case by (rule Proj_preservation)
qed

text \<open>
For the proof of the progress theorem, we need a lemma stating that each well-typed,
closed term @{term t} is either a canonical value, or can be decomposed into an
evaluation context @{term E} and a term @{term "t\<^sub>0"} such that @{term "t\<^sub>0"} is a redex.
The proof of this result, which is called the {\it decomposition lemma}, is again
by induction on the typing derivation.
A similar property is also needed for records.
\<close>

theorem context_decomp: \<comment> \<open>A.15\<close>
  "[] \<turnstile> t : T \<Longrightarrow>
     t \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')"
  "[] \<turnstile> fs [:] fTs \<Longrightarrow>
     (\<forall>(l, t) \<in> set fs. t \<in> value) \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> rctxt \<and> fs = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')"
proof (induct "[]::env" t T and "[]::env" fs fTs set: typing typings)
  case T_Var
  thus ?case by simp
next
  case T_Abs
  from value.Abs show ?case ..
next
  case (T_App t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 t\<^sub>2)
  from \<open>t\<^sub>1 \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')\<close>
  show ?case
  proof
    assume t\<^sub>1_val: "t\<^sub>1 \<in> value"
    with T_App obtain t S where t\<^sub>1: "t\<^sub>1 = (\<lambda>:S. t)"
      by (auto dest!: Fun_canonical)
    from \<open>t\<^sub>2 \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>2 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')\<close>
    show ?thesis
    proof
      assume "t\<^sub>2 \<in> value"
      with t\<^sub>1 have "t\<^sub>1 \<bullet> t\<^sub>2 \<longmapsto>\<^sub>c t[0 \<mapsto> t\<^sub>2]"
        by simp (rule eval.intros)
      thus ?thesis by (iprover intro: C_Hole)
    next
      assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>2 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
      with t\<^sub>1_val show ?thesis by (iprover intro: ctxt_rctxt.intros)
    qed
  next
    assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
    thus ?thesis by (iprover intro: ctxt_rctxt.intros)
  qed
next
  case T_TAbs
  from value.TAbs show ?case ..
next
  case (T_TApp t\<^sub>1 T\<^sub>1\<^sub>1 T\<^sub>1\<^sub>2 T\<^sub>2)
  from \<open>t\<^sub>1 \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')\<close>
  show ?case
  proof
    assume "t\<^sub>1 \<in> value"
    with T_TApp obtain t S where "t\<^sub>1 = (\<lambda><:S. t)"
      by (auto dest!: TyAll_canonical)
    hence "t\<^sub>1 \<bullet>\<^sub>\<tau> T\<^sub>2 \<longmapsto>\<^sub>c t[0 \<mapsto>\<^sub>\<tau> T\<^sub>2]" by simp (rule eval.intros)
    thus ?thesis by (iprover intro: C_Hole)
  next
    assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
    thus ?thesis by (iprover intro: ctxt_rctxt.intros)
  qed
next
  case (T_Sub t S T)
  show ?case by (rule T_Sub)
next
  case (T_Let t\<^sub>1 T\<^sub>1 p \<Delta> t\<^sub>2 T\<^sub>2)
  from \<open>t\<^sub>1 \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')\<close>
  show ?case
  proof
    assume t\<^sub>1: "t\<^sub>1 \<in> value"
    with T_Let have "\<exists>ts. \<turnstile> p \<rhd> t\<^sub>1 \<Rightarrow> ts"
      by (auto intro: ptyping_match)
    with t\<^sub>1 show ?thesis by (iprover intro: eval.intros C_Hole)
  next
    assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t\<^sub>1 = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
    thus ?thesis by (iprover intro: ctxt_rctxt.intros)
  qed
next
  case (T_Rcd fs fTs)
  thus ?case by (blast intro: value.intros eval.intros ctxt_rctxt.intros)
next
  case (T_Proj t fTs l T)
  from \<open>t \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')\<close>
  show ?case
  proof
    assume tv: "t \<in> value"
    with T_Proj obtain fs where
      t: "t = Rcd fs" and fs: "\<forall>(l, t) \<in> set fs. t \<in> value"
      by (auto dest: RcdT_canonical)
    with T_Proj have "[] \<turnstile> Rcd fs : RcdT fTs" by simp
    hence "\<forall>(l, U)\<in>set fTs. \<exists>u. fs\<langle>l\<rangle>\<^sub>? = \<lfloor>u\<rfloor> \<and> [] \<turnstile> u : U"
      by (rule Rcd_type1')
    with T_Proj obtain u where u: "fs\<langle>l\<rangle>\<^sub>? = \<lfloor>u\<rfloor>" by (blast dest: assoc_set)
    with fs have "u \<in> value" by (blast dest: assoc_set)
    with u t show ?thesis by (iprover intro: eval.intros C_Hole)
  next
    assume "\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0'"
    thus ?case by (iprover intro: ctxt_rctxt.intros)
  qed
next
  case T_Nil
  show ?case by simp
next
  case (T_Cons t T fs fTs l)
  thus ?case by (auto intro: ctxt_rctxt.intros)
qed

theorem progress: \<comment> \<open>A.16\<close>
  assumes H: "[] \<turnstile> t : T"
  shows "t \<in> value \<or> (\<exists>t'. t \<longmapsto>\<^sub>c t')"
proof -
  from H have "t \<in> value \<or> (\<exists>E t\<^sub>0 t\<^sub>0'. E \<in> ctxt \<and> t = E t\<^sub>0 \<and> t\<^sub>0 \<longmapsto>\<^sub>c t\<^sub>0')"
    by (rule context_decomp)
  thus ?thesis by (iprover intro: eval.intros)
qed

text \<open>
Finally, we prove that the two definitions of the evaluation relation
are equivalent. The proof that @{term "t \<longmapsto>\<^sub>c t'"} implies @{term "t \<longmapsto> t'"}
requires a lemma stating that \<open>\<longmapsto>\<close> is compatible with evaluation contexts.
\<close>

lemma ctxt_imp_eval:
  "E \<in> ctxt \<Longrightarrow> t \<longmapsto> t' \<Longrightarrow> E t \<longmapsto> E t'"
  "E\<^sub>r \<in> rctxt \<Longrightarrow> t \<longmapsto> t' \<Longrightarrow> E\<^sub>r t [\<longmapsto>] E\<^sub>r t'"
  by (induct rule: ctxt_rctxt.inducts) (auto intro: eval_evals.intros)

lemma eval_evalc_eq: "(t \<longmapsto> t') = (t \<longmapsto>\<^sub>c t')"
proof
  fix ts ts'
  have r: "t \<longmapsto> t' \<Longrightarrow> t \<longmapsto>\<^sub>c t'" and
    "ts [\<longmapsto>] ts' \<Longrightarrow> \<exists>E t t'. E \<in> rctxt \<and> ts = E t \<and> ts' = E t' \<and> t \<longmapsto>\<^sub>c t'"
    by (induct rule: eval_evals.inducts) (iprover intro: ctxt_rctxt.intros eval.intros)+
  assume "t \<longmapsto> t'"
  thus "t \<longmapsto>\<^sub>c t'" by (rule r)
next
  assume "t \<longmapsto>\<^sub>c t'"
  thus "t \<longmapsto> t'"
    by induct (auto intro: eval_evals.intros ctxt_imp_eval)
qed

end


theory Submission
  imports Defs
begin

fun inv_plus'_filter :: "bound \<Rightarrow> bound \<Rightarrow> bound \<Rightarrow> bool"  where
  "inv_plus'_filter NegInf NegInf NegInf = True" |
  "inv_plus'_filter NegInf NegInf Real = True" |
  "inv_plus'_filter NegInf Real NegInf = True" |
  "inv_plus'_filter PosInf PosInf PosInf = True" |
  "inv_plus'_filter PosInf PosInf Real = True" |
  "inv_plus'_filter PosInf Real PosInf = True" |
  "inv_plus'_filter NaN NegInf PosInf = True" |
  "inv_plus'_filter NaN PosInf NegInf = True" |
  "inv_plus'_filter NaN NaN _ = True" |
  "inv_plus'_filter NaN _ NaN = True" |
  "inv_plus'_filter Real Real Real = True" |
  "inv_plus'_filter _ _ _ = False"

fun inv_plus' :: "bounds \<Rightarrow> bounds \<Rightarrow> bounds \<Rightarrow> (bounds * bounds)"  where
  "inv_plus' (B b) (B b1) (B b2) =
  (B {bb1 \<in> b1. \<exists>bb \<in> b. \<exists>bb2 \<in> b2. inv_plus'_filter bb bb1 bb2},
  B {bb2 \<in> b2. \<exists>bb \<in> b. \<exists>bb1 \<in> b1. inv_plus'_filter bb bb1 bb2})"

fun inv_less'_helper :: "bool \<Rightarrow> bound \<Rightarrow> bound \<Rightarrow> (bound * bound) option" where
  "inv_less'_helper _ NaN _ = None" |
  "inv_less'_helper _ _ NaN = None" |
  "inv_less'_helper _ Real Real = Some (Real, Real)" |
  "inv_less'_helper True PosInf _ = None" |
  "inv_less'_helper True x PosInf = Some (x, PosInf)" |
  "inv_less'_helper True _ NegInf = None" |
  "inv_less'_helper True NegInf x = Some (NegInf, x)" |
  "inv_less'_helper False PosInf x = Some (PosInf, x)" |
  "inv_less'_helper False _ PosInf = None" |
  "inv_less'_helper False x NegInf = Some (x, NegInf)" |
  "inv_less'_helper False NegInf _ = None"

fun inv_less'_filter :: "bool option \<Rightarrow> bound \<Rightarrow> bound \<Rightarrow> bool" where
  "inv_less'_filter None NaN _ = True" |
  "inv_less'_filter None _ NaN = True" |
  "inv_less'_filter (Some _) NaN _ = False" |
  "inv_less'_filter (Some _) _ NaN = False" |
  "inv_less'_filter (Some _) Real Real = True" |
  "inv_less'_filter (Some True) PosInf _ = False" |
  "inv_less'_filter (Some True) _ PosInf = True" |
  "inv_less'_filter (Some True) _ NegInf = False" |
  "inv_less'_filter (Some True) NegInf _ = True" |
  "inv_less'_filter (Some False) PosInf _ = True" |
  "inv_less'_filter (Some False) _ NegInf = True" |
  "inv_less'_filter _ _ _ = False"

fun inv_less' :: "bool option \<Rightarrow> bounds \<Rightarrow> bounds \<Rightarrow> (bounds * bounds)"  where
  "inv_less' b (B b1) (B b2) =
  (B {bb1 \<in> b1. \<exists>bb2 \<in> b2. inv_less'_filter b bb1 bb2},
  B {bb2 \<in> b2. \<exists>bb1 \<in> b1. inv_less'_filter b bb1 bb2})"

value "inv_plus' (B {NaN}) (B {\<infinity>\<^sup>+}) (B {\<infinity>\<^sup>-, Real}) = (B {\<infinity>\<^sup>+}, B {\<infinity>\<^sup>-})"
value "inv_plus' (B {\<infinity>\<^sup>+,\<infinity>\<^sup>-}) (B {\<infinity>\<^sup>+, NaN}) (B {\<infinity>\<^sup>-, Real, \<infinity>\<^sup>+}) = (B {\<infinity>\<^sup>+}, B {\<infinity>\<^sup>+, Real})"
value "inv_less' (Some True) (B {\<infinity>\<^sup>+, \<infinity>\<^sup>-}) (B {\<infinity>\<^sup>+}) = (B {\<infinity>\<^sup>-}, B {\<infinity>\<^sup>+})"

lemma inv_plus'_sub:
  assumes "inv_plus' (B A) (B A1) (B A2) = (B A1', B A2')"
  shows "A1' \<subseteq> A1" "A2' \<subseteq> A2" using assms by auto

lemma inv_plus'_sound:
    assumes "inv_plus' (B A) (B A1) (B A2) = (B A1', B A2')"
      and "i1 \<in> \<gamma>_bounds (B A1)"
      and "i2 \<in> \<gamma>_bounds (B A2)"
      and "(case (i1,i2) of
             (None, _) \<Rightarrow> None \<in> \<gamma>_bounds (B A)
           | (_, None) \<Rightarrow> None \<in> \<gamma>_bounds (B A)
           | (Some PInfty, Some MInfty) \<Rightarrow> None \<in> \<gamma>_bounds (B A)
           | (Some MInfty, Some PInfty) \<Rightarrow> None \<in> \<gamma>_bounds (B A)
           | (Some i1, Some i2) \<Rightarrow> Some (i1+i2) \<in> \<gamma>_bounds (B A))"
    shows "i1 \<in> \<gamma>_bounds (B A1') \<and> i2 \<in> \<gamma>_bounds (B A2')"
  apply(cases i1; cases i2)
proof(goal_cases)
  case 1
  with assms show ?case by fastforce
next
  case (2 a)
  with assms show ?case by fastforce
next
  case (3 a)
  with assms(4) have "None \<in> \<gamma>_bounds (B A)" by(cases a, auto)
  then have "NaN \<in> A" by auto
  with assms have "NaN \<in> A2'"
    apply (auto simp: 3(2))
    using \<gamma>_bound.cases inv_plus'_filter.simps by metis
  with 3(2) have "i2 \<in> \<gamma>_bounds (B A2')" by auto
  moreover
  have "\<forall>x. inv_plus'_filter NaN x NaN"
    using inv_plus'_filter.elims(3) by blast
  then have "\<forall>x. \<exists>bb \<in> A. \<exists>bb2 \<in> A2. inv_plus'_filter bb x bb2"
    using \<open>NaN \<in> A\<close> \<open>NaN \<in> A2'\<close>  inv_plus'_sub assms(1) by blast
  then obtain v where v_def:
    "v = (case a of ereal r \<Rightarrow> Real | PInfty \<Rightarrow> PosInf | MInfty \<Rightarrow> NegInf)" by blast
  with assms 3 have "v \<in> A1" by(cases a, auto)
  then have "v \<in> A1'"
    using assms(1) \<open>\<forall>x. \<exists>bb \<in> A. \<exists>bb2 \<in> A2. inv_plus'_filter bb x bb2\<close> by auto
  then have "i1 \<in> \<gamma>_bounds (B A1')" by(cases a, auto simp: v_def 3(1))
  ultimately show ?case by simp
next
  case (4 a aa)
  with assms show ?case apply(cases a; cases aa, auto)
    using inv_plus'_filter.simps by blast+
qed

lemma inv_less'_sub:
  assumes "inv_less' bv (B A1) (B A2) = (B A1', B A2')"
  shows "A1' \<subseteq> A1" "A2' \<subseteq> A2" using assms by auto

lemma inv_less'_sound:
    assumes "inv_less' bv (B A1) (B A2) = (B A1',B A2')"
      and "i1 \<in> \<gamma>_bounds (B A1)"
      and "i2 \<in> \<gamma>_bounds (B A2)"
      and "(case (i1,i2) of
             (None, _) \<Rightarrow> None = bv
           | (_, None) \<Rightarrow> None = bv
           | (Some i1, Some i2) \<Rightarrow> Some (i1<i2) = bv)"
  shows "i1 \<in> \<gamma>_bounds (B A1') \<and> i2 \<in> \<gamma>_bounds (B A2')" using assms
 apply(cases i1; cases i2)
proof(goal_cases)
  case 1
  with assms show ?case by fastforce
next
  case (2 a)
  with assms show ?case by fastforce
next
  case (3 a)
  with assms(4) have "None = bv" by(cases a, auto)
  with assms have "NaN \<in> A2'"
    apply (auto simp: 3(10))
    using \<gamma>_bound.cases inv_less'_filter.simps by metis
  with 3(10) have "i2 \<in> \<gamma>_bounds (B A2')" by auto
  moreover
  have "\<forall>x. inv_less'_filter None x NaN"
    using inv_less'_filter.elims(3) by blast
  then have "\<forall>x. \<exists>bb2 \<in> A2. inv_less'_filter bv x bb2"
    using \<open>None = bv\<close> \<open>NaN \<in> A2'\<close>  inv_less'_sub assms(1) by blast
  then obtain v where v_def:
    "v = (case a of ereal r \<Rightarrow> Real | PInfty \<Rightarrow> PosInf | MInfty \<Rightarrow> NegInf)" by blast
  with assms 3 have "v \<in> A1" by(cases a, auto)
  then have "v \<in> A1'"
    using assms(1) \<open>\<forall>x. \<exists>bb2 \<in> A2. inv_less'_filter bv x bb2\<close> by auto
  then have "i1 \<in> \<gamma>_bounds (B A1')" by(cases a, auto simp: v_def 3(5))
  ultimately show ?case by simp
next
  case (4 a aa)
  with assms show ?case apply(cases a; cases aa, auto)
    using inv_less'_filter.simps by blast+
qed

end


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

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

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

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

 (* Positive introspection principles are implied *)
 lemma WM2ab': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> \<^bold>K\<^sub>b (\<^sup>Aws a))\<^bold>\<rfloor>" using WM2ab group_S5 unfolding Defs by (smt (z3))
 lemma WM2ac': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> \<^bold>K\<^sub>c (\<^sup>Aws a))\<^bold>\<rfloor>" using WM2ac group_S5 unfolding Defs by (smt (z3))
 lemma WM2aD': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws a) \<^bold>\<rightarrow> \<^bold>K\<^sub>d (\<^sup>Aws a))\<^bold>\<rfloor>" using WM2ad group_S5 unfolding Defs by (smt (z3))
 lemma WM2ba': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> \<^bold>K\<^sub>a (\<^sup>Aws b))\<^bold>\<rfloor>" using WM2ba group_S5 unfolding Defs by (smt (z3))
 lemma WM2bc': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> \<^bold>K\<^sub>c (\<^sup>Aws b))\<^bold>\<rfloor>" using WM2bc group_S5 unfolding Defs by (smt (z3))
 lemma WM2bd': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws b) \<^bold>\<rightarrow> \<^bold>K\<^sub>d (\<^sup>Aws b))\<^bold>\<rfloor>" using WM2bd group_S5 unfolding Defs by (smt (z3))
 lemma WM2ca': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> \<^bold>K\<^sub>a (\<^sup>Aws c))\<^bold>\<rfloor>" using WM2ca group_S5 unfolding Defs by (smt (z3))
 lemma WM2cb': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> \<^bold>K\<^sub>b (\<^sup>Aws c))\<^bold>\<rfloor>" using WM2cb group_S5 unfolding Defs by (smt (z3))
 lemma WM2cd': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws c) \<^bold>\<rightarrow> \<^bold>K\<^sub>d (\<^sup>Aws c))\<^bold>\<rfloor>" using WM2cd group_S5 unfolding Defs by (smt (z3))
 lemma WM2da': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws d) \<^bold>\<rightarrow> \<^bold>K\<^sub>a (\<^sup>Aws d))\<^bold>\<rfloor>" using WM2da group_S5 unfolding Defs by (smt (z3))
 lemma WM2db': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws d) \<^bold>\<rightarrow> \<^bold>K\<^sub>b (\<^sup>Aws d))\<^bold>\<rfloor>" using WM2db group_S5 unfolding Defs by (smt (z3))
 lemma WM2dc': "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> ((\<^sup>Aws d) \<^bold>\<rightarrow> \<^bold>K\<^sub>c (\<^sup>Aws d))\<^bold>\<rfloor>" using WM2dc group_S5 unfolding Defs by (smt (z3))

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

 theorem whitespot_d':
     "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>a (\<^sup>Aws a)) \<^bold>\<or> (\<^bold>K\<^sub>a (\<^bold>\<not>\<^sup>Aws a)))\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>b (\<^sup>Aws b)) \<^bold>\<or> (\<^bold>K\<^sub>b (\<^bold>\<not>\<^sup>Aws b)))\<^bold>](
        \<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>c (\<^sup>Aws c)) \<^bold>\<or> (\<^bold>K\<^sub>c (\<^bold>\<not>\<^sup>Aws c)))\<^bold>](\<^bold>K\<^sub>d (\<^sup>Aws d))))\<^bold>\<rfloor>"
   using whitespot_d
   unfolding Defs sledgehammer[verbose]() (* finds proof *)
   (* reconstruction timeout *)
   oops

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


section \<open> Proof of the chain selection property \<close>

theory Chain_Selection_Property
  imports Main
begin

subsection \<open> Introduction \<close>

text \<open>
  In this work we formally verify an implementation of the Ouroboros chain selection rule. It is
  important to note that this work does not take into account the condition that a candidate chain
  must not fork more than \<open>k\<close> blocks from the current local chain. The reason for this omission is
  that, should we include that extra condition, the verification would not be possible. To see this,
  consider the following counterexample: Assume that \<open>k = 2\<close>, the local chain \<open>\<C>\<close> is \<open>\<G>-A-B-C\<close>, and
  the candidate chains \<open>\<C>\<^sub>1\<close> and \<open>\<C>\<^sub>2\<close> are \<open>\<G>-A-B-D-E-F\<close> and \<open>\<G>-A-B-G-H-I-J\<close>, respectively, and
  received in that order. Let $\mathsf{maxvalid}_p$ denote the pairwise comparison version of the
  usual $\mathsf{maxvalid}$ function as defined in the Ouroboros paper. Thus, we have that
  $\mathsf{maxvalid}$\<open>(\<C>, [\<C>\<^sub>1, \<C>\<^sub>2]) = \<C>\<^sub>2\<close> (since \<open>\<C>\<^sub>1\<close> and \<open>\<C>\<^sub>2\<close> are valid forks of \<open>\<C>\<close> and \<open>\<C>\<^sub>2\<close> is the
  longest one), but $\mathsf{maxvalid}_p$\<open>(\<C>, \<C>\<^sub>1) = \<C>\<^sub>1\<close> (since \<open>\<C>\<^sub>1\<close> is a valid fork of \<open>\<C>\<close> plus it is
  longer) and $\mathsf{maxvalid}_p$\<open>(\<C>\<^sub>1, \<C>\<^sub>2) = \<C>\<^sub>1\<close> (since \<open>\<C>\<^sub>2\<close> forks from \<open>\<C>\<^sub>1\<close> by 3 blocks).
\<close>

subsection \<open> Preliminaries \<close>

text \<open>
  We define the type of chains as an abstract type.
\<close>

typedecl chain

consts length :: "chain \<Rightarrow> nat" ("|_|")

subsection \<open> Specification \<close>

text \<open>
  In this section we specify the desired abstract behavior of an implementation that solves the
  chain selection problem:

    \<^item> Collect the set of all chains broadcast in the current slot.

    \<^item> Have also the current chain available.

    \<^item> Pick a longest chain. If the current chain is a longest one, pick this one; otherwise resolve
      arbitrarily.
\<close>

text \<open>
  We define a predicate to tell whether a given chain \<open>\<C>\<close> is a longest chain with respect to a
  given set of chains \<open>\<CC>\<close>.
\<close>
abbreviation is_a_longest_chain :: "chain \<Rightarrow> chain set \<Rightarrow> bool" where
  "is_a_longest_chain \<C> \<CC> \<equiv> \<forall>\<C>' \<in> \<CC>. |\<C>| \<ge> |\<C>'|"

text \<open>
  We define an abbreviation for the subset of a given set of chains \<open>\<CC>\<close> comprised by all longest
  chains in \<open>\<CC>\<close>.
\<close>
abbreviation max_chains :: "chain set \<Rightarrow> chain set" where
  "max_chains \<CC> \<equiv> {\<C> \<in> \<CC>. is_a_longest_chain \<C> \<CC>}"

text \<open>
  We define a specification function: Given a set \<open>\<CC>\<close> of collected chains throughout a slot, if \<open>\<C>\<close>
  is a longest chain then an implementation must pick \<open>\<C>\<close>, otherwise it must pick a longest one in
  \<open>\<CC>\<close>.
\<close>

definition spec :: "chain \<Rightarrow> chain set \<Rightarrow> chain set" where
  "spec \<C> \<CC> = (if is_a_longest_chain \<C> \<CC> then {\<C>} else max_chains \<CC>)"

subsection \<open> Implementation \<close>

text \<open>
  In this section we give an implementation that solves the chain selection problem. The implemented
  behavior is the following:

  \<^item> Repeatedly receive a new chain throughout the slot.

  \<^item> Update the current chain to the received one if the received one is longer.
\<close>

text \<open>
  We define a binary maximum function with a bias towards the first argument.
\<close>

fun max_chain :: "chain \<Rightarrow> chain \<Rightarrow> chain" where
  "max_chain \<C> \<C>' = (if |\<C>| \<ge> |\<C>'| then \<C> else \<C>')"

text \<open>
  We define the implementation function: Given a list \<open>\<CC>\<close> of chains modeling the arrival order of
  such chains throughout the slot and an initial current chain \<open>\<C>\<close>, this implementation processes
  \<open>\<CC>\<close> sequentially to calculate the new current chain. Since ties are broken in favor of the current
  chain, the result is the leftmost longest chain.
\<close>

definition impl :: "chain \<Rightarrow> chain list \<Rightarrow> chain" where
  "impl \<C> \<CC> = foldl max_chain \<C> \<CC>"

subsection \<open> Verification \<close>

text \<open>
  In this section we formally verify the implementation above, that is, we prove that the
  implementation satisfies the specification in the following sense: Given a list \<open>\<CC>\<close> of chains
  modeling the arrival order of such chains throughout the slot and a current chain \<open>\<C>\<close>, the choice
  of the new current chain made by the implementation after processing \<open>\<CC>\<close> meets the specification,
  i.e. if \<open>\<C>\<close> is a longest chain then the implementation picks \<open>\<C>\<close>, otherwise it picks a longest one
  in \<open>\<CC>\<close>, namely the leftmost longest one. In the latter case, this holds since the leftmost longest
  chain in \<open>\<CC>\<close> is certainly a longest one in the set comprised by the chains in \<open>\<CC>\<close>.
\<close>

theorem max_chain_choice:
  shows "impl \<C> \<CC> \<in> spec \<C> (set \<CC>)"
proof (induction \<CC> arbitrary: \<C>)
  case Nil
  then show ?case
    unfolding spec_def and impl_def by simp
next
  case (Cons \<C>' \<CC>')
  have "impl \<C> (\<C>' # \<CC>') = impl (max_chain \<C> \<C>') \<CC>'"
    unfolding impl_def by simp
  also from Cons.IH have "\<dots> \<in> spec (max_chain \<C> \<C>') (set \<CC>')"
    by blast
  also have "\<dots> \<subseteq> spec \<C> (set (\<C>' # \<CC>'))"
  proof (cases "is_a_longest_chain (max_chain \<C> \<C>') (set \<CC>')")
    case True
    then have *: "spec (max_chain \<C> \<C>') (set \<CC>') = {max_chain \<C> \<C>'}"
      unfolding spec_def by simp
    also have "\<dots> \<subseteq> spec \<C> (set (\<C>' # \<CC>'))"
    proof (cases "|\<C>| \<ge> |\<C>'|")
      case True
      with * have "spec \<C> (set (\<C>' # \<CC>')) = {\<C>}"
        unfolding spec_def
        (* TODO: Find a nicer proof. *)
        by (metis (no_types, lifting) insert_iff list.simps(15) max_chain.elims mem_Collect_eq order_refl)
      with True show ?thesis
        by simp
    next
      case False
      then have "spec \<C> (set (\<C>' # \<CC>')) = max_chains (set (\<C>' # \<CC>'))"
        unfolding spec_def by simp
      with True show ?thesis
        unfolding spec_def by auto
    qed
    finally show ?thesis .
  next
    case False
    then have **: "spec (max_chain \<C> \<C>') (set \<CC>') = max_chains (set \<CC>')"
      unfolding spec_def by auto
    also have "\<dots> \<subseteq> spec \<C> (set (\<C>' # \<CC>'))"
    proof (cases "|\<C>| \<ge> |\<C>'|")
      case True
      with False have "spec \<C> (set (\<C>' # \<CC>')) = max_chains (set (\<C>' # \<CC>'))"
        unfolding spec_def by auto
      moreover from False have "\<not>is_a_longest_chain \<C> (set (\<C>' # \<CC>'))"
        by auto
      ultimately show ?thesis
        (* TODO: Find a nicer proof. *)
        by (smt Collect_mono_iff True dual_order.trans insert_iff linear list.simps(15))
    next
      case False
      then have "spec \<C> (set (\<C>' # \<CC>')) = max_chains (set (\<C>' # \<CC>'))"
        unfolding spec_def by simp
      with ** show ?thesis
        unfolding spec_def
        (* TODO: Find a nicer proof. *)
        by (smt Ball_Collect CollectD dual_order.trans linear max_chain.simps set_ConsD set_subset_Cons singletonD subsetCE)
    qed
    finally show ?thesis .
  qed
  finally show ?case
    by blast
qed

end