theory TTC_Soundness
  imports TTC_Calculus

begin

type_synonym Structure = "nat \<Rightarrow> string set"
(* \<omega>-sequence of states of strings, each repr. all the true atoms *)

definition suffix :: "Structure \<Rightarrow> nat \<Rightarrow> Structure"
  where "suffix \<sigma> n = (\<lambda>i.(\<sigma> (n+i)))"

lemma suffix0 [simp]: "suffix \<sigma> 0 = \<sigma>"
  by (simp add: suffix_def)

lemma suffix_add [simp]: "suffix (suffix \<sigma> m) n = suffix \<sigma> (m+n)"
  by (simp add: suffix_def add_ac)

primrec holds :: "Structure \<Rightarrow> PLTL_formula \<Rightarrow> bool"  ("(_ \<Turnstile> _)" [60,60] 59)
  where
  "\<sigma> \<Turnstile> F = False" |
  "\<sigma> \<Turnstile> T = True" |
  "\<sigma> \<Turnstile> V s = (s \<in> (\<sigma> 0))" |
  "\<sigma> \<Turnstile> .\<not> \<phi>  = (\<not>(\<sigma> \<Turnstile> \<phi>))" |
  "\<sigma> \<Turnstile> \<phi> .\<and> \<psi> = (\<sigma> \<Turnstile> \<phi> \<and>  \<sigma> \<Turnstile> \<psi>)" |
  "\<sigma> \<Turnstile> \<phi> .\<or> \<psi> = (\<sigma> \<Turnstile> \<phi> \<or>  \<sigma> \<Turnstile> \<psi>)" |
  "\<sigma> \<Turnstile> \<phi> .\<longrightarrow> \<psi> = (\<sigma> \<Turnstile> \<phi> \<longrightarrow>  \<sigma> \<Turnstile> \<psi>)" |
  "\<sigma> \<Turnstile> \<box> \<phi>  = (\<forall>i. suffix \<sigma> i  \<Turnstile> \<phi>)" |
  "\<sigma> \<Turnstile> \<circle> \<phi>  = (suffix \<sigma> 1  \<Turnstile> \<phi>)" |
  "\<sigma> \<Turnstile> \<dieresis>\<circle>\<dieresis> \<phi>  = (suffix \<sigma> 1  \<Turnstile> \<phi>)" |
  "\<sigma> \<Turnstile> \<phi> \<U> \<psi> = (\<exists>i. suffix \<sigma> i  \<Turnstile> \<psi> \<and> (\<forall>j<i. suffix \<sigma> j  \<Turnstile> \<phi>))" |
  "\<sigma> \<Turnstile> \<diamond> \<phi>  = (\<exists>i. suffix \<sigma> i  \<Turnstile> \<phi>)" |
  "\<sigma> \<Turnstile> \<phi> \<R> \<psi> = (\<not>(\<exists>i.(\<not>(suffix \<sigma> i  \<Turnstile> \<psi>) \<and> (\<forall>j<i. \<not>(suffix \<sigma> j  \<Turnstile> \<phi>)))))" |
  "\<sigma> \<Turnstile> \<phi> \<dieresis>\<U>\<dieresis> \<psi> = (\<exists>i. suffix \<sigma> i  \<Turnstile> \<psi> \<and> (\<forall>j<i. suffix \<sigma> j  \<Turnstile> \<phi>))"

definition models :: "Structure \<Rightarrow> PLTL_formula list \<Rightarrow> bool" ("(_ \<TTurnstile> _)" [60,60] 59)
  where "models \<sigma> \<Phi> = (\<forall>\<phi>. (\<phi> .\<in> \<Phi> \<longrightarrow> \<sigma> \<Turnstile> \<phi>))"

definition sat :: "PLTL_formula list \<Rightarrow> bool"
  where "sat \<Delta> = (\<exists>\<sigma>. \<sigma> \<TTurnstile> \<Delta>)"

definition unSat :: "PLTL_formula list \<Rightarrow> bool"
  where "unSat \<Delta> = (\<not>(sat \<Delta>))"

  (******************** Some auxiliar lemmas **************)

    lemma equiv_NNF [simp]:
      shows "(\<not>(\<sigma> \<Turnstile> \<phi>)) = (\<sigma> \<Turnstile> \<sim>nnf \<phi>)"
      by (induct \<phi> arbitrary: \<sigma>) auto

    lemma equiv_order [simp]:
      shows "\<phi> .\<in> (\<psi>  \<bullet>  \<Delta>) = \<phi> .\<in> (\<psi> # \<Delta>)"
      by (induct \<Delta>) auto

    lemma unfold_not_unSat [simp]:
      shows "(\<not>(unSat \<Delta>)) =  (\<exists>\<sigma>. \<forall>\<delta>. \<delta>.\<in> \<Delta> \<longrightarrow> \<sigma> \<Turnstile> \<delta>)"
    proof -
      show ?thesis using models_def sat_def unSat_def by blast
    qed

    lemma models_list [simp]:
      shows "\<sigma> \<TTurnstile> (\<psi>  \<bullet>  \<Delta>) = (\<sigma> \<Turnstile> \<psi> \<and> \<sigma> \<TTurnstile> \<Delta>)"
      using models_def by auto

(* We will prove (one-by-one) the soundness of each inference rule in the TTC_Calculus ****)

(******************** TTC_Ctd1 soundness ***************)

lemma TTC_Ctd1_Sound:
  assumes "\<phi> .\<in> \<Delta>"
  assumes "\<sim>nnf \<phi> .\<in> \<Delta>"
  shows "unSat \<Delta>"
proof (rule ccontr)
  assume "\<not>(unSat \<Delta>)"
  hence "\<exists>\<sigma>. \<sigma> \<TTurnstile> \<Delta> "  by (simp add: models_def)
  then have "\<exists> \<sigma>. \<sigma> \<Turnstile>\<sim>nnf \<phi>  \<and> \<sigma> \<Turnstile> \<phi>" using models_def assms by auto
  then show "False" using equiv_NNF by blast
qed

(******************** TTC_Ctd2 soundness ***************)

lemma TTC_Ctd2_Sound:
  assumes "F .\<in> \<Delta>"
  shows "unSat \<Delta>"
proof -
  from assms have "\<forall>\<sigma>. F.\<in> \<Delta> \<and> \<not>(\<sigma> \<Turnstile> F)" by auto
  thus ?thesis using unfold_not_unSat by blast
qed

(******************** TTC_T soundness *****************)

lemma TTC_T_Sound [simp]:
  assumes "unSat \<Delta>"
  shows "unSat (T # \<Delta>)"
proof -
  from assms have "\<not>(sat(T # \<Delta>))" by (simp add: models_def unSat_def sat_def)
  then show ?thesis by (simp add: unSat_def)
qed

(******************** TTC_And soundness ****************)

lemma TTC_And_Sound:
  assumes "unSat(\<phi> \<bullet> \<psi> \<bullet> \<Delta>)"
  shows "unSat((\<phi> .\<and> \<psi>) # \<Delta>)"
proof (rule ccontr)
  assume "\<not>(unSat((\<phi> .\<and> \<psi>) # \<Delta>))"
  then have "\<not>(unSat(\<phi> \<bullet> \<psi> \<bullet> \<Delta>))" by auto
  with assms show False by simp
qed

(******************** TTC_Or soundness ****************)

lemma TTC_Or_Sound:
  assumes "unSat(\<phi> \<bullet> \<Delta>)"
  assumes "unSat(\<psi> \<bullet> \<Delta>)"
  shows "unSat((\<phi> .\<or> \<psi>) # \<Delta>)"
proof (rule ccontr)
  assume "\<not>(unSat((\<phi> .\<or> \<psi>) # \<Delta>))"
  hence "\<exists>\<sigma>.((\<sigma> \<TTurnstile> \<phi> \<bullet> \<Delta>) \<or> (\<sigma> \<TTurnstile> \<psi> \<bullet> \<Delta>))" using models_def
         by (metis holds.simps(6) inlist.simps(2) models_list sat_def unSat_def)
  with assms show False using models_def sat_def unSat_def by blast
qed

(******************** TTC_Imp soundness ****************)

lemma TTC_Imp_Sound:
  assumes "unSat((\<sim>nnf \<phi>) \<bullet> \<Delta>)"
  assumes "unSat((\<psi> \<bullet> \<Delta>))"
  shows "unSat((\<phi> .\<longrightarrow> \<psi>) # \<Delta>)"
proof (rule ccontr)
  assume "\<not>(unSat(\<phi> .\<longrightarrow> \<psi> # \<Delta>))"
  hence "\<exists>\<sigma>. (\<not>(\<sigma> \<Turnstile> \<phi>) \<or> \<sigma> \<Turnstile> \<psi>) \<and> (\<sigma> \<TTurnstile> \<Delta>)"
         by (meson holds.simps(7) inlist.simps(2) models_def sat_def unSat_def)
  then have "\<exists>\<sigma>. \<sigma> \<TTurnstile> ((\<sim>nnf \<phi>) \<bullet> \<Delta>) \<or>  \<sigma> \<TTurnstile> (\<psi> \<bullet> \<Delta>)" by auto
  with assms show False using models_def sat_def unSat_def by blast
qed

(******************** TTC_Alw soundness ****************)

lemma TTC_Alw_Sound:
  assumes "unSat(\<phi> \<bullet> (\<circle>(\<box> \<phi>)) \<bullet> \<Delta>)"
  shows "unSat((\<box> \<phi>) #  \<Delta>)"
proof (rule ccontr)
  assume "\<not>(unSat((\<box> \<phi>) #  \<Delta>))"
  then have "\<exists>\<sigma>.((\<forall>i. suffix \<sigma> i  \<Turnstile> \<phi>) \<and>  \<sigma> \<TTurnstile> \<Delta>)"
             using  models_def sat_def unSat_def
             by (meson holds.simps(8) inlist.simps(2))
  hence "\<exists>\<sigma>.(suffix \<sigma> 0 \<Turnstile> \<phi> \<and> (\<forall>i. suffix \<sigma> (i+1) \<Turnstile> \<phi>) \<and>  \<sigma> \<TTurnstile> \<Delta>)" by blast
  then have "\<not>(unSat(\<phi> \<bullet> (\<circle>(\<box> \<phi>)) \<bullet> \<Delta>))" by (simp add: sat_def unSat_def)
  with assms show False by simp
qed

(******************** TTC_U soundness ****************)

lemma TTC_U_Sound [simp]:
  assumes "unSat(\<psi> \<bullet> \<Delta>)"
  assumes "unSat(\<phi> \<bullet> (\<circle>(\<phi> \<U> \<psi>)) \<bullet> \<Delta>)"
  shows "unSat((\<phi> \<U> \<psi>) # \<Delta>)"
proof (rule ccontr)
  assume "\<not>(unSat((\<phi> \<U> \<psi>) # \<Delta>))"
  then obtain \<sigma> where "\<sigma> \<TTurnstile>((\<phi> \<U> \<psi>) # \<Delta>)" using sat_def unSat_def by blast
  then obtain i:: nat where hyp:
        "suffix \<sigma> i  \<Turnstile> \<psi> \<and> (\<forall>j<i. suffix \<sigma> j  \<Turnstile> \<phi>) \<and> \<sigma> \<TTurnstile> \<Delta>" using models_def by auto
  then have "sat(\<psi> \<bullet> \<Delta>) \<or> sat(\<phi> \<bullet> (\<circle>(\<phi> \<U> \<psi>)) \<bullet> \<Delta>)"
  proof (cases)
    assume  "i = 0"
    then show ?thesis using hyp by (auto simp add: models_def sat_def)
  next
    assume "\<not>(i = 0)"
    then have "i > 0 \<and> \<sigma> \<Turnstile> \<phi> \<and>
              suffix (suffix \<sigma> (i-1)) 1 \<Turnstile> \<psi> \<and>
              (\<forall>j<i. suffix \<sigma> j  \<Turnstile> \<phi>) \<and>
               \<sigma> \<TTurnstile> \<Delta>" using hyp by auto
    then have  "\<sigma> \<Turnstile> \<phi> \<and> \<sigma> \<Turnstile>  \<circle>(\<phi> \<U> \<psi>) \<and> \<sigma> \<TTurnstile> \<Delta>" by auto
    thus ?thesis  by (auto simp add: models_def sat_def)
  qed
  with assms show False using sat_def unSat_def by blast
qed

(*************** TTC_Evt soundness by equivalence \<diamond>\<phi> \<equiv> T\<U>\<phi> ***********)

lemma TTC_Evt_Sound_by_equiv:
  assumes "unSat(\<phi> \<bullet> \<Delta>)"
  assumes "unSat((\<circle> (\<diamond> \<phi>)) \<bullet> \<Delta>)"
  shows "unSat((\<diamond> \<phi>) # \<Delta>)"
proof -
  have E1: "unSat((\<circle>(\<diamond> \<phi>)) \<bullet> \<Delta>) = unSat(T \<bullet> (\<circle>(T \<U> \<phi>)) \<bullet> \<Delta>)"
       by (auto simp add: models_def unSat_def sat_def)
  have E2: "unSat((\<diamond> \<phi>) # \<Delta>) = unSat((T \<U> \<phi>) # \<Delta>)"
       by (auto simp add: models_def unSat_def sat_def)
  from assms show ?thesis using E1 E2 TTC_U_Sound[where  \<phi> = T]  by simp
  qed

(******************** TTC_R soundness ****************)

lemma TTC_R_Sound:
  assumes "unSat(\<phi> \<bullet> \<psi> \<bullet>  \<Delta>)"
  assumes "unSat(\<psi> \<bullet> (\<circle>(\<phi> \<R> \<psi>)) \<bullet> \<Delta>)"
  shows "unSat((\<phi> \<R> \<psi>) # \<Delta>)"
proof (rule ccontr)
  assume "\<not>unSat((\<phi> \<R> \<psi>) # \<Delta>)"
  then obtain \<sigma> where P1: "(\<not>(\<exists>i. \<not>(suffix \<sigma> i  \<Turnstile> \<psi>) \<and>
                            (\<forall>j<i. \<not>(suffix \<sigma> j  \<Turnstile> \<phi>)))) \<and>
                             \<sigma> \<TTurnstile> \<Delta>"
                           using models_def sat_def unSat_def
                           by (metis holds.simps(13) inlist.simps(2))
  then have "sat(\<phi> \<bullet> \<psi> \<bullet>  \<Delta>) \<or> sat(\<psi> \<bullet> (\<circle>(\<phi> \<R> \<psi>)) \<bullet> \<Delta>)"
  proof (cases)
    assume "suffix \<sigma> 0  \<Turnstile> \<psi> \<and> suffix \<sigma> 0  \<Turnstile> \<phi>"
    then show ?thesis using P1 by (auto simp add: models_def sat_def unSat_def)
  next
    assume "\<not>(suffix \<sigma> 0  \<Turnstile> \<psi> \<and> suffix \<sigma> 0  \<Turnstile> \<phi>)"
    then have P2: "\<not>(suffix \<sigma> 0  \<Turnstile> \<phi>) \<and> suffix  \<sigma> 0  \<Turnstile> \<psi>" using P1 by blast
    then have "sat(\<psi> \<bullet> (\<circle>(\<phi> \<R> \<psi>)) \<bullet> \<Delta>)"
      proof (cases)
        assume "\<forall>i. suffix \<sigma> i  \<Turnstile> \<psi>"
        then have "\<forall>i. suffix \<sigma> i \<Turnstile> \<psi> \<and> suffix \<sigma> i \<Turnstile> \<circle>(\<phi> \<R> \<psi>)" by auto
        then have "suffix \<sigma> 0 \<Turnstile> \<psi> \<and> suffix \<sigma> 0 \<Turnstile> \<circle>(\<phi> \<R> \<psi>)" by blast
        then show ?thesis using P1 by (auto simp add: models_def sat_def unSat_def)
      next
        assume "\<not>(\<forall>i. suffix \<sigma> i  \<Turnstile> \<psi>)"
        then obtain n::nat where "n =  (LEAST k. (\<not>(suffix  \<sigma> k \<Turnstile> \<psi>)))" by blast
        then have "(\<not>(suffix  \<sigma> n \<Turnstile> \<psi>)) \<and>
                    (\<forall>j<n. (suffix \<sigma> j \<Turnstile>  \<psi>))"
          by (smt LeastI \<open>\<not> (\<forall>i. suffix \<sigma> i \<Turnstile> \<psi>)\<close> P1 not_less_Least)
        then have "(\<exists>j<n. (j>0 \<and> (suffix \<sigma> j  \<Turnstile> \<phi>) \<and>
                   (\<forall>k<n. (suffix \<sigma> k  \<Turnstile>  \<psi>) )))"  using P1 P2 by (metis gr0I)
        then have "suffix \<sigma> 1 \<Turnstile> \<phi> \<R> \<psi>"
             by (smt One_nat_def Suc_leI add.commute add.left_neutral add_Suc_right
                     add_mono_thms_linordered_semiring(1) gr0_conv_Suc holds.simps(13)
                     le_imp_less_Suc less_imp_add_positive not_less suffix_add)
        then have "\<sigma> \<Turnstile> \<psi> \<and> \<sigma> \<Turnstile>  \<circle>(\<phi> \<R> \<psi>)" using P2 by auto
        then show ?thesis using P1 by (auto simp add: models_def sat_def unSat_def)
      qed
      then show ?thesis by auto
  qed
  with assms show False using sat_def unSat_def by blast
qed

(*
In order to prove the soundness of the rule TTC_U_Plus,
we firstly prove the soundness of a similar rule that we call TTC_U_Plus_Pure
(which is really the (\<U>)^+ rule introduced in the paper
"Dual Systems of Tableaux and Sequents for PLTL" ),
TTC_U_Plus_Pure uses the negation of the full context i.e. it also adds the
negation of the always-formulas in the context,
whereas in the TTC_U_Plus these formulas are filtered out.
Also, TTC_U_Plus uses subsumption in the negation of the context.
After proving the soundness of TTC_U_Plus_Pure, we will extend the result to both
improvements: the filtering of always-formulas and the subsumption.
*)

(************ TTC_U_Plus_Pure_Sound **************)

(******* Auxiliary lemmas ************)

lemma disjNeg_l2r_Lemma:
  assumes "\<sigma> \<Turnstile> disjNeg \<Phi>"
  shows "\<exists>\<phi>. \<phi> .\<in> \<Phi> \<and> \<sigma> \<Turnstile> \<sim>nnf \<phi>"
proof -
  from assms show ?thesis  by (induct \<Phi> rule: disjNeg.induct) (auto simp add: models_def)
qed

lemma disjNeg_r2l_Lemma:
  assumes "\<phi> .\<in> \<Phi>"
  assumes "\<sigma> \<Turnstile> \<sim>nnf \<phi>"
  shows "\<sigma> \<Turnstile> disjNeg \<Phi>"
proof -
  from assms have "\<not>(\<sigma> \<Turnstile> \<phi>)" by simp
  then have "\<not>(\<sigma> \<TTurnstile> \<Phi>)" using assms models_def by blast
  then show ?thesis by (induct \<Phi> rule: disjNeg.induct)  (auto simp add: models_def)
qed

lemma disjNeg_Lemma:
  shows "(\<sigma> \<Turnstile> disjNeg \<Phi>) \<longleftrightarrow> (\<exists>\<phi>. \<phi> .\<in> \<Phi> \<and> \<sigma> \<Turnstile> \<sim>nnf \<phi>)"
  using disjNeg_l2r_Lemma disjNeg_r2l_Lemma by blast

lemma all_context_Lemma:
  assumes "\<not>(\<sigma> \<TTurnstile> \<Delta>)"
  shows "\<sigma> \<Turnstile> (disjNeg \<Delta>)"
  using assms models_def disjNeg_Lemma equiv_NNF  by auto

(************* soundness of TTC_U_Plus_Pure *****************)

lemma TTC_U_Plus_Pure_Sound:
  assumes "sat((\<phi> \<U> \<psi>) # \<Delta>)"
  shows "sat(\<psi> \<bullet>  \<Delta>) \<or>
         sat(\<phi> \<bullet> (\<circle>((\<phi> .\<and> disjNeg(\<Delta>)) \<U> \<psi>)) \<bullet> \<Delta>)"
proof -
  from assms have "\<exists>\<sigma>.( \<exists>i.(suffix \<sigma> i  \<Turnstile> \<psi> \<and> (\<forall>j<i. suffix \<sigma> j  \<Turnstile> \<phi>))
                        \<and> \<sigma> \<TTurnstile> \<Delta> )"
                   by (simp add: models_def sat_def) blast
      then obtain \<sigma> and i::nat where Pi: "(\<sigma> \<TTurnstile> \<Delta>) \<and>  suffix \<sigma> i  \<Turnstile> \<psi> \<and>
                                          (\<forall>j<i. suffix \<sigma> j  \<Turnstile> \<phi>)" by auto
      then have ?thesis
      proof(cases)
        assume "i = 0"
        then show ?thesis using Pi by (auto simp add: models_def sat_def)
      next
        assume "\<not>(i = 0)"
        then obtain  k::"nat" where "k = (LEAST z::nat. (suffix \<sigma> z  \<Turnstile> \<psi>))" by blast
        then have Pk: "(suffix \<sigma> k  \<Turnstile> \<psi>) \<and> (\<forall>j<k. \<not>(suffix \<sigma> j  \<Turnstile> \<psi>))"
          by (meson LeastI not_less_Least Pi)
        also have "k \<ge>0" by blast
        then obtain h::"nat" where Ph: "h = (GREATEST z.(z \<le> k \<and> ((suffix \<sigma> z \<TTurnstile> \<Delta>))))"
                     by blast
             then have Pkh: "0 \<le> k \<and> h \<le> k \<and> (suffix \<sigma> h \<TTurnstile> \<Delta>)"
                        using Pi Pk Ph by (smt GreatestI_nat \<open>0 \<le> k\<close> le0 suffix0 zero_le)
             then have PhGreatest: "\<forall>j. ((j \<le> k \<and> suffix \<sigma> j \<TTurnstile> \<Delta>) \<longrightarrow> \<not>(h < j))"
                        by (metis (no_types, lifting) Greatest_le_nat Ph not_le)
             then have ?thesis
             proof(cases)
               assume "h = k"
               then have "(suffix \<sigma> k \<Turnstile> \<psi>) \<and> (suffix \<sigma> k \<TTurnstile> \<Delta>)"
                          using Pkh calculation models_def by blast
               then show ?thesis using Pk Ph models_def sat_def by auto
             next
               assume "\<not>(h = k)"
               then have "h < k" using Pkh by auto
               then have "\<forall>j. ( (h < j \<and> j < k) \<longrightarrow> (\<not>(suffix \<sigma> j \<TTurnstile> \<Delta>)))" using  PhGreatest by auto
               then have Pcontext: "\<forall>j.( (h < j \<and> j < k) \<longrightarrow> (suffix \<sigma> j \<Turnstile> (disjNeg \<Delta>)))"
                         using all_context_Lemma by auto
               then have Pphicontext: "\<forall>j. ((h < j \<and> j < k) \<longrightarrow> (suffix \<sigma> j) \<Turnstile> (\<phi> .\<and> disjNeg(\<Delta>)))"
                         using Pi Pk Pcontext
                         by (metis Suc_lessI holds.simps(5) less_trans not_less_eq)
               then have Puntil: "(suffix \<sigma> k) \<Turnstile> \<psi> \<and>
                                  (\<forall>j.( (h < j \<and> j < k) \<longrightarrow> (suffix \<sigma> j) \<Turnstile> (\<phi> .\<and> disjNeg(\<Delta>))))"
                                   using Pphicontext calculation by blast
               define \<sigma>':: "Structure" where "\<sigma>' = (suffix \<sigma> h)"
               define \<sigma>'':: "Structure" where "\<sigma>'' = (suffix \<sigma> (h+1))"
               then have "suffix \<sigma>'' (k-(h+1)) = (suffix \<sigma> k)"   using \<open>h < k\<close> by fastforce
               also have  "\<forall>j<(k-(h+1)).(\<exists>i.(h < i \<and> i < k \<and> (suffix \<sigma>'' j) = (suffix \<sigma> i)))"
                          using \<sigma>''_def
                          by (metis  One_nat_def Suc_pred add.commute add_Suc_right
                                     diff_add_inverse2  gr0_conv_Suc less_diff_conv
                                     plus_nat.simps(2) suffix_add  zero_less_diff)
                then have Psigma'': "(\<exists>i.(i = k-(h+1) \<and> suffix \<sigma>'' i  \<Turnstile> \<psi> \<and>
                                    (\<forall>j<i. ((suffix \<sigma>'' j)  \<Turnstile> (\<phi> .\<and> disjNeg(\<Delta>))))))"
                            using calculation Puntil by auto
                then have  "\<sigma>'' = (suffix \<sigma>' 1)" by (simp add: \<sigma>''_def \<sigma>'_def)
                then have  "\<sigma>' \<Turnstile> (\<circle>((\<phi> .\<and> disjNeg(\<Delta>)) \<U> \<psi>))"
                           using Psigma'' holds.simps(11) holds.simps(9) by blast
                then have  "\<sigma>' \<Turnstile> \<phi> \<and> \<sigma>' \<Turnstile> (\<circle>((\<phi> .\<and> disjNeg(\<Delta>)) \<U> \<psi>)) \<and>
                                   \<sigma>' \<TTurnstile> \<Delta>"
                            by (metis Pi Pk Pkh Suc_lessI \<open>h < k\<close> \<sigma>'_def less_trans not_less_eq)
               then have "\<sigma>' \<TTurnstile> \<phi> \<bullet> (\<circle>((\<phi> .\<and> disjNeg(\<Delta>)) \<U> \<psi>)) \<bullet> \<Delta>" by simp
               then show ?thesis  using sat_def by blast
             qed
             then show ?thesis by simp
           qed
           then show ?thesis by simp
         qed

(********************   TTC_U_Plus_Sound    **********************)

(*********** Auxiliary lemmas for the filtering out of always-formulas *************)

lemma forever_Lemma:
  assumes "\<sigma> \<TTurnstile> \<Phi>"
  shows "\<forall>\<alpha>.((\<box>\<alpha>) .\<in> \<Phi> \<longrightarrow> (\<forall>k.((suffix \<sigma> k) \<Turnstile> (\<box>\<alpha>))))"
  using assms models_def by auto

lemma member_of_list_Lemma :
  shows "(\<phi> .\<in> \<Delta>) = (\<phi> \<in> set \<Delta>)"
  by (induct \<Delta>) auto

lemma filterAlw_l2r_Lemma:
  shows "\<phi> .\<in> (filter (\<lambda>phi.(\<not>(isAlw phi))) \<Phi>) \<longrightarrow> (\<phi> .\<in> \<Phi> \<and> (\<forall>\<alpha>.(\<not>(\<phi> = \<box>\<alpha>))))"
proof(induct \<Phi>)
  case Nil
  then show ?case by simp
next
  case (Cons a \<Phi>)
  have "\<phi> .\<in> (filter (\<lambda>phi.(\<not>(isAlw phi))) (Cons a \<Phi>)) \<longrightarrow>
                       \<phi> .\<in>  \<Phi> \<or> (\<phi> = a \<or>  (\<lambda>phi.(\<not>(isAlw phi))) \<phi>)"
               by (metis Cons.hyps filter.simps(2) inlist.simps(2))
    then show ?case using Cons.hyps by auto
  qed

lemma filterAlw_r2l_Lemma:
  assumes "\<phi> .\<in> \<Phi>"
  assumes "\<forall>\<alpha>.(\<not>(\<phi> = \<box>\<alpha>))"
  shows "\<phi> .\<in> (filter (\<lambda>phi.(\<not>(isAlw phi))) \<Phi>)"
proof -
  have Pfilter: "(\<phi> \<in> set (filter (\<lambda>phi.(\<not>(isAlw phi))) \<Phi>))
                  \<longleftrightarrow> (\<phi> \<in> (set \<Phi>)  \<and> ((\<lambda>phi.(\<not>(isAlw phi))) \<phi>))" by simp
  from assms have "((\<lambda>phi.(\<not>(isAlw phi))) \<phi>) = True" using isAlw.elims(2) by auto
  then show ?thesis using member_of_list_Lemma  assms(1) by auto
qed

lemma filterAlw_Lemma:
  shows "\<phi> .\<in> (filter (\<lambda>phi.(\<not>(isAlw phi))) \<Phi>) \<longleftrightarrow> (\<phi> .\<in> \<Phi> \<and> (\<forall>\<alpha>.(\<not>(\<phi> = \<box>\<alpha>))))"
  using filterAlw_l2r_Lemma filterAlw_r2l_Lemma by blast

lemma negCtxt_Lemma:
  assumes "\<sigma> \<TTurnstile> \<Phi>"
  assumes "i \<ge> 1"
  assumes "(suffix \<sigma> i) \<Turnstile> (disjNeg \<Phi>)"
  shows "(suffix \<sigma> i) \<Turnstile> (negCtxt \<Phi>)"
proof -
  from assms(3) have "(\<exists>\<phi>. \<phi> .\<in> \<Phi> \<and> (suffix \<sigma> i) \<Turnstile> \<sim>nnf \<phi>)"
                     using disjNeg_Lemma by simp
  then have "\<not>(\<Phi> = []) \<and> (\<exists>\<phi>. \<phi> .\<in> \<Phi> \<and> \<not>((suffix \<sigma> i) \<Turnstile> \<phi>))" by auto
  then have P: "\<not>(\<Phi> = []) \<and> (\<exists>\<phi>.(\<phi> .\<in> \<Phi> \<and> \<not>((suffix \<sigma> i) \<Turnstile> \<phi>) \<and> (\<forall>\<alpha>.(\<not>(\<phi> =(\<box>\<alpha>))))))"
             using assms(1) forever_Lemma by blast
  then have "\<not>(\<Phi> = []) \<and> (\<exists>\<phi>.(\<phi> .\<in> (filter (\<lambda>phi.(\<not>(isAlw phi))) \<Phi>) \<and> \<not>((suffix \<sigma> i) \<Turnstile> \<phi>)))"
    using filterAlw_Lemma by blast
  then show ?thesis by (metis disjNeg_Lemma equiv_NNF negCtxt.elims)
qed

lemma reduced_Ctxt_Lemma:
  assumes "\<sigma> \<TTurnstile> \<Phi>"
  assumes "\<sigma> \<Turnstile> \<circle>((\<phi> .\<and> (disjNeg \<Phi>)) \<U> \<psi>)"
  shows "\<sigma> \<Turnstile> \<circle>((\<phi> .\<and> (negCtxt \<Phi>)) \<U> \<psi>)"
proof(cases)
  assume "\<sigma> \<Turnstile> \<circle>\<psi>"
  then show ?thesis by auto
next
  assume "\<not>(\<sigma> \<Turnstile> \<circle>\<psi>)"
  define \<sigma>' where "\<sigma>' = (suffix \<sigma> 1)"
  from assms have P: "\<exists>k.(k\<ge> 1 \<and> (suffix \<sigma>' k) \<Turnstile>  \<psi>
                       \<and> (\<forall>j<k.((suffix \<sigma>' j) \<Turnstile> (\<phi> .\<and> (disjNeg \<Phi>)))))"
                  using  \<open>\<not>(\<sigma> \<Turnstile> \<circle>\<psi>)\<close> \<sigma>'_def
                  by (metis (no_types, lifting) One_nat_def holds.simps(11) holds.simps(9)
                            le_simps(3) neq0_conv suffix0)
  then obtain k where  Q: "k\<ge> 1 \<and> (suffix \<sigma>' k) \<Turnstile>  \<psi>
                       \<and> (\<forall>j<k.((suffix \<sigma>' j) \<Turnstile> (\<phi> .\<and> (negCtxt \<Phi>))))"
                        using assms(1) \<sigma>'_def P negCtxt_Lemma
                        by (metis One_nat_def Suc_leI holds.simps(5) plus_nat.simps(2)
                                  suffix_add zero_less_Suc)
  then have R: "\<sigma>' \<Turnstile> (\<phi> .\<and> (negCtxt \<Phi>)) \<U> \<psi>" using Q holds.simps(11) by blast
  then show  "\<sigma> \<Turnstile> \<circle>((\<phi> .\<and> (negCtxt \<Phi>)) \<U> \<psi>)" using \<sigma>'_def by auto
qed

(*********** auxiliary lemmas for the  .\<sqinter>. ***************)

lemma disj2set_Lemma:
  shows "\<sigma> \<Turnstile> \<phi> \<longleftrightarrow> (\<exists>\<gamma>. \<gamma> \<in> (disj2set \<phi>) \<and> \<sigma> \<Turnstile> \<gamma>)"
  by (induct \<phi>) auto

lemma conj2setOfsets_Lemma:
  shows "\<sigma> \<Turnstile> \<phi> \<longleftrightarrow> (\<forall>\<Lambda>. \<Lambda> \<in> (conj2setOfsets \<phi>) \<longrightarrow> (\<exists>\<delta>. \<delta> \<in> \<Lambda> \<and> \<sigma> \<Turnstile> \<delta>))"
proof (induct \<phi>)
  case F
  then have "conj2setOfsets F =  (Set.insert (disj2set F) Set.empty)" by simp
  then show ?case by (metis disj2set.simps(2) insertI1 singletonD)
next
  case T
  then show ?case
    by (metis conj2setOfsets.simps(3) disj2set.simps(3) singletonD singletonI)
next
  case (Var x)
  then show ?case
    by (metis conj2setOfsets.simps(4) disj2set.simps(4) insertI1 singletonD)
next
  case (Not \<phi>)
  then show ?case
    by (metis conj2setOfsets.simps(5) disj2set.simps(5) insertI1 singletonD)
next
  case (And \<phi>1 \<phi>2)
  then show ?case
    by (metis (full_types) Un_iff conj2setOfsets.simps(1) holds.simps(5))
next
  case (Or \<phi>1 \<phi>2)
  then show ?case
    by (metis conj2setOfsets.simps(6) disj2set_Lemma insertI1 singletonD)
next
  case (Imp \<phi>1 \<phi>2)
  then show ?case
    by (metis conj2setOfsets.simps(7) disj2set.simps(7) singletonD singletonI)
next
  case (X \<phi>)
  then show ?case
    by (metis conj2setOfsets.simps(8) disj2set.simps(8) insertI1 singletonD)
next
  case (U \<phi>1 \<phi>2)
  then show ?case
    by (metis conj2setOfsets.simps(9) disj2set.simps(9) insertI1 singletonD)
next
  case (R \<phi>1 \<phi>2)
  then show ?case using conj2setOfsets.simps(10) singletonD
    by (metis disj2set.simps(10) singletonI)
next
  case (Alw \<phi>)
  then show ?case using conj2setOfsets.simps(11)
    by (metis disj2set.simps(11) singletonD singletonI)
next
  case (Evt \<phi>)
  then show ?case using conj2setOfsets.simps(12)
    by (metis disj2set.simps(12) insertI1 singletonD)
next
  case (SelX \<phi>)
  then show ?case using conj2setOfsets.simps(13)
    by (metis disj2set.simps(13) singletonD singletonI)
next
  case (SelU \<phi>1 \<phi>2)
  then show ?case  using conj2setOfsets.simps(14)
    by (metis disj2set.simps(14) insertI1 singletonD)
qed

lemma inclusion_Lemma:
  assumes  "\<sigma> \<Turnstile> \<phi>"
  assumes  "\<Lambda> \<in> (conj2setOfsets \<phi>)"
  assumes "\<Lambda> \<le> (disj2set \<psi>)"
  shows  "\<sigma> \<Turnstile> \<psi>"
proof -
  show ?thesis using assms conj2setOfsets_Lemma disj2set_Lemma by blast
qed

lemma subsumption_Lemma:
  assumes "(Bex (conj2setOfsets \<phi>) (\<lambda>S. S \<le> (disj2set \<psi>)))"
  assumes "\<sigma> \<Turnstile> \<phi>"
  shows  "\<sigma> \<Turnstile> \<phi> .\<and> \<psi>"
proof -
  from assms(1) have "\<exists>\<Lambda>.((\<Lambda> \<in> (conj2setOfsets \<phi>)) \<and>  (\<Lambda> \<le> (disj2set \<psi>)))" by auto
  then show ?thesis using inclusion_Lemma using assms(2) holds.simps(5) by blast
qed

lemma conjWSmp_Lemma:
  shows "\<sigma> \<Turnstile> \<phi> .\<and> \<psi> = \<sigma> \<Turnstile> \<phi> .\<sqinter>. \<psi>"
proof(cases "(Bex (conj2setOfsets \<phi>) (\<lambda>S. S \<le> (disj2set \<psi>)))")
  case True
  have "\<sigma> \<Turnstile> \<phi> .\<and> \<psi> \<longrightarrow> \<sigma> \<Turnstile> \<phi>" by auto
  then have "\<sigma> \<Turnstile> \<phi> .\<and> \<psi> = \<sigma> \<Turnstile> \<phi>" using subsumption_Lemma using True by blast
  then show ?thesis by simp
next
  case False
  then show ?thesis by simp
qed

(************* Soundness of TTC_U_Plus *************)

lemma TTC_U_Plus_Sound:
  assumes "unSat(\<psi> \<bullet>  \<Delta>)"
  assumes "unSat(\<phi> \<bullet> (\<circle>((\<phi> .\<sqinter>. negCtxt(\<Delta>)) \<U> \<psi>)) \<bullet> \<Delta>)"
  shows "unSat((\<phi> \<U> \<psi>) # \<Delta>)"
proof -
  have "sat(\<phi> \<bullet> (\<circle>((\<phi> .\<sqinter>. negCtxt(\<Delta>)) \<U> \<psi>)) \<bullet> \<Delta>)  = sat(\<phi> \<bullet> (\<circle>((\<phi> .\<and> negCtxt(\<Delta>)) \<U> \<psi>)) \<bullet> \<Delta>)"
    using conjWSmp_Lemma models_list sat_def by auto
  thus ?thesis
  using reduced_Ctxt_Lemma TTC_U_Plus_Pure_Sound assms models_list sat_def unSat_def
  by (metis (no_types, lifting))
qed

(************* TTC_Next_State_Sound *************)

lemma TTC_Next_State_Sound:
  assumes "unSat(next_state \<Delta>)"
  shows "unSat(\<Delta>)"
proof (rule ccontr)
  assume "\<not>unSat(\<Delta>)"
  then have "\<exists>\<sigma>.(\<sigma> \<TTurnstile> \<Delta>)" by (simp add: sat_def unSat_def)
  then obtain \<sigma> where  "\<sigma> \<TTurnstile> \<Delta>" by auto
  define \<sigma>' where "\<sigma>'= suffix  \<sigma> 1"
  then have "\<forall>\<phi>.((\<circle>\<phi>).\<in> \<Delta> \<or> (\<dieresis>\<circle>\<dieresis>\<phi>).\<in> \<Delta>) \<longrightarrow> (\<sigma>' \<Turnstile> \<phi>)" using \<open>\<sigma> \<TTurnstile> \<Delta>\<close> models_def by auto
  then have  "\<forall>\<phi>.(\<phi> .\<in>  map removeX (filter isX \<Delta>)) \<longrightarrow> (\<sigma>' \<Turnstile> \<phi>)"
    by (smt filter_set imageE isX.elims(2) member_filter member_of_list_Lemma
            removeX.simps(1) removeX.simps(2) set_map)
  then have "\<sigma>' \<TTurnstile> (next_state \<Delta>)"  by (simp add: models_def)
  then show "False" using assms sat_def unSat_def by blast
qed

(*****  Soundness of the additional rules for automation *********)

(******************  TTC_Interchange_Sound ***********************)

lemma  TTC_Interchange_Sound:
  shows "sat(sort \<Delta>) = sat(\<Delta>)"
proof -
  have Psort: "\<forall>\<sigma>.(\<sigma> \<TTurnstile> sort \<Delta> = \<sigma> \<TTurnstile> \<Delta>)"
proof (induct \<Delta>)
  case Nil
  then show ?case by auto
next
  case (Cons a \<Delta>)
  have  "\<sigma> \<TTurnstile> (insert \<psi> \<Delta>) = (\<sigma> \<Turnstile> \<psi> \<and> \<sigma> \<TTurnstile> \<Delta>)" by simp
  then show ?case using  models_def Cons.hyps by auto
qed
have "sat(sort \<Delta>) = sat (\<Delta>)" using Psort unSat_def sat_def models_def by simp
then show ?thesis by auto
qed

(************************  TTC_U_Sel_Sound ***********************)

lemma TTC_U_Sel_Sound:
  assumes "unSat(\<psi> \<bullet>  \<Delta>)"
  assumes "unSat(\<phi> \<bullet> (\<circle>((\<phi> .\<sqinter>. negCtxt(\<Delta>)) \<U> \<psi>)) \<bullet> \<Delta>)"
  shows "unSat((\<phi> \<dieresis>\<U>\<dieresis> \<psi>) # \<Delta>)"
proof -
  have "\<forall>\<sigma>.(\<sigma> \<Turnstile> \<phi> \<dieresis>\<U>\<dieresis> \<psi> = \<sigma> \<Turnstile> \<phi> \<U> \<psi>)" by auto
  then have  "unSat((\<phi> \<dieresis>\<U>\<dieresis> \<psi>) # \<Delta>) =  unSat((\<phi> \<U> \<psi>) # \<Delta>)"
       using unSat_def sat_def models_def by (metis inlist.simps(2) )
     thus ?thesis using unSat_def TTC_U_Plus_Sound assms by blast
   qed

(**********  TTC_U_Mark_Next and TTC_UnMark_Next are both sound ************)

lemma TTC_Mark_Next_and_TTC_Unmark_Next_Sound:
  shows "sat((\<dieresis>\<circle>\<dieresis> phi) \<bullet> \<Delta>) = sat((\<circle> phi) \<bullet> \<Delta>)"
by (simp add: sat_def)


section \<open>General purpose definitions and lemmas\<close>

theory Misc imports
  Main
begin

text \<open>A handy abbreviation when working with maps\<close>
abbreviation make_map :: "'a set \<Rightarrow> 'b \<Rightarrow> ('a \<rightharpoonup> 'b)" ("[ _ |=> _ ]")
where
  "[ks |=> v] \<equiv> \<lambda>k. if k \<in> ks then Some v else None"

text \<open>Projecting the components of a triple\<close>
definition "fst3 \<equiv> fst"
definition "snd3 \<equiv> fst \<circ> snd"
definition "thd3 \<equiv> snd \<circ> snd"

lemma fst3_simp [simp]: "fst3 (a,b,c) = a" by (simp add: fst3_def)
lemma snd3_simp [simp]: "snd3 (a,b,c) = b" by (simp add: snd3_def)
lemma thd3_simp [simp]: "thd3 (a,b,c) = c" by (simp add: thd3_def)

end


(*  Title:      HOL/HOLCF/Library/List_Cpo.thy
    Author:     Brian Huffman
*)

section \<open>Lists as a complete partial order\<close>

theory List_Cpo
imports HOLCF
begin

subsection \<open>Lists are a partial order\<close>

instantiation list :: (po) po
begin

definition
  "xs \<sqsubseteq> ys \<longleftrightarrow> list_all2 (op \<sqsubseteq>) xs ys"

instance proof
  fix xs :: "'a list"
  from below_refl show "xs \<sqsubseteq> xs"
    unfolding below_list_def
    by (rule list_all2_refl)
next
  fix xs ys zs :: "'a list"
  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> zs"
  with below_trans show "xs \<sqsubseteq> zs"
    unfolding below_list_def
    by (rule list_all2_trans)
next
  fix xs ys zs :: "'a list"
  assume "xs \<sqsubseteq> ys" and "ys \<sqsubseteq> xs"
  with below_antisym show "xs = ys"
    unfolding below_list_def
    by (rule list_all2_antisym)
qed

end

lemma below_list_simps [simp]:
  "[] \<sqsubseteq> []"
  "x # xs \<sqsubseteq> y # ys \<longleftrightarrow> x \<sqsubseteq> y \<and> xs \<sqsubseteq> ys"
  "\<not> [] \<sqsubseteq> y # ys"
  "\<not> x # xs \<sqsubseteq> []"
by (simp_all add: below_list_def)

lemma Nil_below_iff [simp]: "[] \<sqsubseteq> xs \<longleftrightarrow> xs = []"
by (cases xs, simp_all)

lemma below_Nil_iff [simp]: "xs \<sqsubseteq> [] \<longleftrightarrow> xs = []"
by (cases xs, simp_all)

lemma list_below_induct [consumes 1, case_names Nil Cons]:
  assumes "xs \<sqsubseteq> ys"
  assumes 1: "P [] []"
  assumes 2: "\<And>x y xs ys. \<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
  shows "P xs ys"
using \<open>xs \<sqsubseteq> ys\<close>
proof (induct xs arbitrary: ys)
  case Nil thus ?case by (simp add: 1)
next
  case (Cons x xs) thus ?case by (cases ys, simp_all add: 2)
qed

lemma list_below_cases:
  assumes "xs \<sqsubseteq> ys"
  obtains "xs = []" and "ys = []" |
    x y xs' ys' where "xs = x # xs'" and "ys = y # ys'"
using assms by (cases xs, simp, cases ys, auto)

text "Thanks to Joachim Breitner"

lemma list_Cons_below:
  assumes "a # as \<sqsubseteq> xs"
  obtains b and bs where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = b # bs"
  using assms by (cases xs, auto)

lemma list_below_Cons:
  assumes "xs \<sqsubseteq> b # bs"
  obtains a and as where "a \<sqsubseteq> b" and "as \<sqsubseteq> bs" and "xs = a # as"
  using assms by (cases xs, auto)

lemma hd_mono: "xs \<sqsubseteq> ys \<Longrightarrow> hd xs \<sqsubseteq> hd ys"
by (cases xs, simp, cases ys, simp, simp)

lemma tl_mono: "xs \<sqsubseteq> ys \<Longrightarrow> tl xs \<sqsubseteq> tl ys"
by (cases xs, simp, cases ys, simp, simp)

lemma ch2ch_hd [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. hd (S i))"
by (rule chainI, rule hd_mono, erule chainE)

lemma ch2ch_tl [simp]: "chain (\<lambda>i. S i) \<Longrightarrow> chain (\<lambda>i. tl (S i))"
by (rule chainI, rule tl_mono, erule chainE)

lemma below_same_length: "xs \<sqsubseteq> ys \<Longrightarrow> length xs = length ys"
unfolding below_list_def by (rule list_all2_lengthD)

lemma list_chain_induct [consumes 1, case_names Nil Cons]:
  assumes "chain S"
  assumes 1: "P (\<lambda>i. [])"
  assumes 2: "\<And>A B. chain A \<Longrightarrow> chain B \<Longrightarrow> P B \<Longrightarrow> P (\<lambda>i. A i # B i)"
  shows "P S"
using \<open>chain S\<close>
proof (induct "S 0" arbitrary: S)
  case Nil
  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF \<open>chain S\<close>])
  with Nil have "\<forall>i. S i = []" by simp
  thus ?case by (simp add: 1)
next
  case (Cons x xs)
  have "\<forall>i. S 0 \<sqsubseteq> S i" by (simp add: chain_mono [OF \<open>chain S\<close>])
  hence *: "\<forall>i. S i \<noteq> []" by (rule all_forward, insert Cons) auto
  have "chain (\<lambda>i. hd (S i))" and "chain (\<lambda>i. tl (S i))"
    using \<open>chain S\<close> by simp_all
  moreover have "P (\<lambda>i. tl (S i))"
    using \<open>chain S\<close> and \<open>x # xs = S 0\<close> [symmetric]
    by (simp add: Cons(1))
  ultimately have "P (\<lambda>i. hd (S i) # tl (S i))"
    by (rule 2)
  thus "P S" by (simp add: *)
qed

lemma list_chain_cases:
  assumes S: "chain S"
  obtains "S = (\<lambda>i. [])" |
    A B where "chain A" and "chain B" and "S = (\<lambda>i. A i # B i)"
using S by (induct rule: list_chain_induct) simp_all

subsection \<open>Lists are a complete partial order\<close>

lemma is_lub_Cons:
  assumes A: "range A <<| x"
  assumes B: "range B <<| xs"
  shows "range (\<lambda>i. A i # B i) <<| x # xs"
using assms
unfolding is_lub_def is_ub_def
by (clarsimp, case_tac u, simp_all)

instance list :: (cpo) cpo
proof
  fix S :: "nat \<Rightarrow> 'a list"
  assume "chain S" thus "\<exists>x. range S <<| x"
  proof (induct rule: list_chain_induct)
    case Nil thus ?case by (auto intro: is_lub_const)
  next
    case (Cons A B) thus ?case by (auto intro: is_lub_Cons cpo_lubI)
  qed
qed

subsection \<open>Continuity of list operations\<close>

lemma cont2cont_Cons [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. f x # g x)"
apply (rule contI)
apply (rule is_lub_Cons)
apply (erule contE [OF f])
apply (erule contE [OF g])
done

lemma lub_Cons:
  fixes A :: "nat \<Rightarrow> 'a::cpo"
  assumes A: "chain A" and B: "chain B"
  shows "(\<Squnion>i. A i # B i) = (\<Squnion>i. A i) # (\<Squnion>i. B i)"
by (intro lub_eqI is_lub_Cons cpo_lubI A B)

lemma cont2cont_case_list:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  assumes h1: "\<And>y ys. cont (\<lambda>x. h x y ys)"
  assumes h2: "\<And>x ys. cont (\<lambda>y. h x y ys)"
  assumes h3: "\<And>x y. cont (\<lambda>ys. h x y ys)"
  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
apply (rule cont_apply [OF f])
apply (rule contI)
apply (erule list_chain_cases)
apply (simp add: is_lub_const)
apply (simp add: lub_Cons)
apply (simp add: cont2contlubE [OF h2])
apply (simp add: cont2contlubE [OF h3])
apply (simp add: diag_lub ch2ch_cont [OF h2] ch2ch_cont [OF h3])
apply (rule cpo_lubI, rule chainI, rule below_trans)
apply (erule cont2monofunE [OF h2 chainE])
apply (erule cont2monofunE [OF h3 chainE])
apply (case_tac y, simp_all add: g h1)
done

lemma cont2cont_case_list' [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  assumes h: "cont (\<lambda>p. h (fst p) (fst (snd p)) (snd (snd p)))"
  shows "cont (\<lambda>x. case f x of [] \<Rightarrow> g x | y # ys \<Rightarrow> h x y ys)"
using assms by (simp add: cont2cont_case_list prod_cont_iff)

text \<open>The simple version (due to Joachim Breitner) is needed if the
  element type of the list is not a cpo.\<close>

lemma cont2cont_case_list_simple [simp, cont2cont]:
  assumes "cont (\<lambda>x. f1 x)"
  assumes "\<And>y ys. cont (\<lambda>x. f2 x y ys)"
  shows "cont (\<lambda>x. case l of [] \<Rightarrow> f1 x | y # ys \<Rightarrow> f2 x y ys)"
using assms by (cases l) auto

text \<open>Lemma for proving continuity of recursive list functions:\<close>

lemma list_contI:
  fixes f :: "'a::cpo list \<Rightarrow> 'b::cpo"
  assumes f: "\<And>x xs. f (x # xs) = g x xs (f xs)"
  assumes g1: "\<And>xs y. cont (\<lambda>x. g x xs y)"
  assumes g2: "\<And>x y. cont (\<lambda>xs. g x xs y)"
  assumes g3: "\<And>x xs. cont (\<lambda>y. g x xs y)"
  shows "cont f"
proof (rule contI2)
  obtain h where h: "\<And>x xs y. g x xs y = h\<cdot>x\<cdot>xs\<cdot>y"
  proof
    fix x xs y show "g x xs y = (\<Lambda> x xs y. g x xs y)\<cdot>x\<cdot>xs\<cdot>y"
    by (simp add: cont2cont_LAM g1 g2 g3)
  qed
  show mono: "monofun f"
    apply (rule monofunI)
    apply (erule list_below_induct)
    apply simp
    apply (simp add: f h monofun_cfun)
    done
  fix Y :: "nat \<Rightarrow> 'a list"
  assume "chain Y" thus "f (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. f (Y i))"
    apply (induct rule: list_chain_induct)
    apply simp
    apply (simp add: lub_Cons f h)
    apply (simp add: lub_APP ch2ch_monofun [OF mono])
    apply (simp add: monofun_cfun)
    done
qed

text \<open>Continuity rule for map\<close>

lemma cont2cont_map [simp, cont2cont]:
  assumes f: "cont (\<lambda>(x, y). f x y)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. map (\<lambda>y. f x y) (g x))"
using f
apply (simp add: prod_cont_iff)
apply (rule cont_apply [OF g])
apply (rule list_contI, rule list.map, simp, simp, simp)
apply (induct_tac y, simp, simp)
done

text \<open>There are probably lots of other list operations that also
deserve to have continuity lemmas.  I'll add more as they are
needed.\<close>

subsection \<open>Lists are a discrete cpo\<close>

instance list :: (discrete_cpo) discrete_cpo
proof
  fix xs ys :: "'a list"
  show "xs \<sqsubseteq> ys \<longleftrightarrow> xs = ys"
    by (induct xs arbitrary: ys, case_tac [!] ys, simp_all)
qed

subsection \<open>Compactness and chain-finiteness\<close>

lemma compact_Nil [simp]: "compact []"
apply (rule compactI2)
apply (erule list_chain_cases)
apply simp
apply (simp add: lub_Cons)
done

lemma compact_Cons: "\<lbrakk>compact x; compact xs\<rbrakk> \<Longrightarrow> compact (x # xs)"
apply (rule compactI2)
apply (erule list_chain_cases)
apply (auto simp add: lub_Cons dest!: compactD2)
apply (rename_tac i j, rule_tac x="max i j" in exI)
apply (drule (1) below_trans [OF _ chain_mono [OF _ max.cobounded1]])
apply (drule (1) below_trans [OF _ chain_mono [OF _ max.cobounded2]])
apply (erule (1) conjI)
done

lemma compact_Cons_iff [simp]:
  "compact (x # xs) \<longleftrightarrow> compact x \<and> compact xs"
apply (safe intro!: compact_Cons)
apply (simp only: compact_def)
apply (subgoal_tac "cont (\<lambda>x. x # xs)")
apply (drule (1) adm_subst, simp, simp)
apply (simp only: compact_def)
apply (subgoal_tac "cont (\<lambda>xs. x # xs)")
apply (drule (1) adm_subst, simp, simp)
done

instance list :: (chfin) chfin
proof
  fix Y :: "nat \<Rightarrow> 'a list" assume "chain Y"
  moreover have "\<And>(xs::'a list). compact xs"
    by (induct_tac xs, simp_all)
  ultimately show "\<exists>i. max_in_chain i Y"
    by (rule compact_imp_max_in_chain)
qed

subsection \<open>Using lists with fixrec\<close>

definition
  match_Nil :: "'a::cpo list \<rightarrow> 'b match \<rightarrow> 'b match"
where
  "match_Nil = (\<Lambda> xs k. case xs of [] \<Rightarrow> k | y # ys \<Rightarrow> Fixrec.fail)"

definition
  match_Cons :: "'a::cpo list \<rightarrow> ('a \<rightarrow> 'a list \<rightarrow> 'b match) \<rightarrow> 'b match"
where
  "match_Cons = (\<Lambda> xs k. case xs of [] \<Rightarrow> Fixrec.fail | y # ys \<Rightarrow> k\<cdot>y\<cdot>ys)"

lemma match_Nil_simps [simp]:
  "match_Nil\<cdot>[]\<cdot>k = k"
  "match_Nil\<cdot>(x # xs)\<cdot>k = Fixrec.fail"
unfolding match_Nil_def by simp_all

lemma match_Cons_simps [simp]:
  "match_Cons\<cdot>[]\<cdot>k = Fixrec.fail"
  "match_Cons\<cdot>(x # xs)\<cdot>k = k\<cdot>x\<cdot>xs"
unfolding match_Cons_def by simp_all

setup \<open>
  Fixrec.add_matchers
    [ (@{const_name Nil}, @{const_name match_Nil}),
      (@{const_name Cons}, @{const_name match_Cons}) ]
\<close>

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Normalising Word Numerals"

theory Norm_Words
  imports Bits_Int Signed_Words
begin

text \<open>
  Normalise word numerals, including negative ones apart from @{term "-1"}, to the
  interval \<open>[0..2^len_of 'a)\<close>. Only for concrete word lengths.
\<close>

lemma neg_num_bintr:
  "(- numeral x :: 'a::len word) =
  word_of_int (bintrunc (LENGTH('a)) (-numeral x))"
  by transfer simp

ML \<open>
  fun is_refl (Const (@{const_name Pure.eq}, _) $ x $ y) = (x = y)
    | is_refl _ = false;

  fun signed_dest_wordT (Type (@{type_name word}, [Type (@{type_name signed}, [T])])) = Word_Lib.dest_binT T
    | signed_dest_wordT T = Word_Lib.dest_wordT T

  fun typ_size_of t = signed_dest_wordT (type_of (Thm.term_of t));

  fun num_len (Const (@{const_name Num.Bit0}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.Bit1}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.One}, _)) = 1
    | num_len (Const (@{const_name numeral}, _) $ t) = num_len t
    | num_len (Const (@{const_name uminus}, _) $ t) = num_len t
    | num_len t = raise TERM ("num_len", [t])

  fun unsigned_norm is_neg _ ctxt ct =
  (if is_neg orelse num_len (Thm.term_of ct) > typ_size_of ct then let
      val btr = if is_neg
                then @{thm neg_num_bintr} else @{thm num_abs_bintr}
      val th = [Thm.reflexive ct, mk_eq btr] MRS transitive_thm

      (* will work in context of theory Word as well *)
      val ss = simpset_of (@{context} addsimps @{thms bintrunc_numeral})
      val cnv = simplify (put_simpset ss ctxt) th
    in if is_refl (Thm.prop_of cnv) then NONE else SOME cnv end
    else NONE)
  handle TERM ("num_len", _) => NONE
       | TYPE ("dest_binT", _, _) => NONE
\<close>

simproc_setup
  unsigned_norm ("numeral n::'a::len word") = \<open>unsigned_norm false\<close>

simproc_setup
  unsigned_norm_neg0 ("-numeral (num.Bit0 num)::'a::len word") = \<open>unsigned_norm true\<close>

simproc_setup
  unsigned_norm_neg1 ("-numeral (num.Bit1 num)::'a::len word") = \<open>unsigned_norm true\<close>

lemma minus_one_norm:
  "(-1 :: 'a :: len word) = of_nat (2 ^ LENGTH('a) - 1)"
  by (simp add:of_nat_diff)

lemmas minus_one_norm_num =
  minus_one_norm [where 'a="'b::len bit0"] minus_one_norm [where 'a="'b::len0 bit1"]

lemma "f (7 :: 2 word) = f 3" by simp

lemma "f (-2) = f (21 + 1 :: 3 word)" by simp

lemma "f (-2) = f (13 + 1 :: 'a::len word)"
  apply simp (* does not touch generic word length *)
  oops

lemma "f (-2) = f (0xFFFFFFFE :: 32 word)" by simp

lemma "(-1 :: 2 word) = 3" by simp

lemma "f (-2) = f (0xFFFFFFFE :: 32 signed word)" by simp

text \<open>
  We leave @{term "-1"} untouched by default, because it is often useful
  and its normal form can be large.
  To include it in the normalisation, add @{thm [source] minus_one_norm_num}.
  The additional normalisation is restricted to concrete numeral word lengths,
  like the rest.
\<close>
context
  notes minus_one_norm_num [simp]
begin

lemma "f (-1) = f (15 :: 4 word)" by simp

lemma "f (-1) = f (7 :: 3 word)" by simp

lemma "f (-1) = f (0xFFFF :: 16 word)" by simp

lemma "f (-1) = f (0xFFFF + 1 :: 'a::len word)"
  apply simp (* does not touch generic -1 *)
  oops

end

end


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

chapter \<open>Social-Choice Types\<close>

section \<open>Preference Relation\<close>

theory Preference_Relation
  imports Main
begin

text \<open>
  The very core of the composable modules voting framework: types and
  functions, derivations, lemmata, operations on preference relations, etc.
\<close>

subsection \<open>Definition\<close>

(*
  Each voter expresses pairwise relations between all alternatives,
  thereby inducing a linear order.
*)
type_synonym 'a Preference_Relation = "'a rel"

fun is_less_preferred_than ::
  "'a \<Rightarrow> 'a Preference_Relation \<Rightarrow> 'a \<Rightarrow> bool" ("_ \<preceq>\<^sub>_ _" [50, 1000, 51] 50) where
    "x \<preceq>\<^sub>r y = ((x, y) \<in> r)"

lemma lin_imp_antisym:
  assumes "linear_order_on A r"
  shows "antisym r"
  using assms
  unfolding linear_order_on_def partial_order_on_def
  by simp

lemma lin_imp_trans:
  assumes "linear_order_on A r"
  shows "trans r"
  using assms order_on_defs
  by blast

subsection \<open>Ranking\<close>

fun rank :: "'a Preference_Relation \<Rightarrow> 'a \<Rightarrow> nat" where
  "rank r x = card (above r x)"

lemma rank_gt_zero:
  assumes
    refl: "x \<preceq>\<^sub>r x" and
    fin:  "finite r"
  shows "rank r x \<ge> 1"
proof -
  have "x \<in> {y \<in> Field r. (x, y) \<in> r}"
    using FieldI2 refl
    by fastforce
  hence "{y \<in> Field r. (x, y) \<in> r} \<noteq> {}"
    by blast
  hence "card {y \<in> Field r. (x, y) \<in> r} \<noteq> 0"
    by (simp add: fin finite_Field)
  moreover have "card {y \<in> Field r. (x, y) \<in> r} \<ge> 0"
    using fin
    by auto
  ultimately show ?thesis
    using Collect_cong FieldI2 above_def
          less_one not_le_imp_less rank.elims
    by (metis (no_types, lifting))
qed

subsection \<open>Limited Preference\<close>

definition limited :: "'a set \<Rightarrow> 'a Preference_Relation \<Rightarrow> bool" where
  "limited A r \<equiv> r \<subseteq> A \<times> A"

lemma limitedI:
  "(\<And> x y. \<lbrakk> x \<preceq>\<^sub>r y \<rbrakk> \<Longrightarrow>  x \<in> A \<and> y \<in> A) \<Longrightarrow> limited A r"
  unfolding limited_def
  by auto

lemma limited_dest:
  "(\<And> x y. \<lbrakk> x \<preceq>\<^sub>r y; limited A r \<rbrakk> \<Longrightarrow>  x \<in> A \<and> y \<in> A)"
  unfolding limited_def
  by auto

fun limit :: "'a set \<Rightarrow> 'a Preference_Relation \<Rightarrow> 'a Preference_Relation" where
  "limit A r = {(a, b) \<in> r. a \<in> A \<and> b \<in> A}"

definition connex :: "'a set \<Rightarrow> 'a Preference_Relation \<Rightarrow> bool" where
  "connex A r \<equiv> limited A r \<and> (\<forall> x \<in> A. \<forall> y \<in> A. x \<preceq>\<^sub>r y \<or> y \<preceq>\<^sub>r x)"

lemma connex_imp_refl:
  assumes "connex A r"
  shows "refl_on A r"
proof
  from assms
  show "r \<subseteq> A \<times> A"
    unfolding connex_def limited_def
    by simp
next
  fix x :: "'a"
  assume "x \<in> A"
  with assms
  have "x \<preceq>\<^sub>r x"
    unfolding connex_def
    by metis
  thus "(x, x) \<in> r"
    by simp
qed

lemma lin_ord_imp_connex:
  assumes "linear_order_on A r"
  shows "connex A r"
proof (unfold connex_def limited_def, safe)
  fix
    a :: "'a" and
    b :: "'a"
  assume "(a, b) \<in> r"
  with assms
  show "a \<in> A"
    using partial_order_onD(1) order_on_defs(3) refl_on_domain
    by metis
next
  fix
    a :: "'a" and
    b :: "'a"
  assume "(a, b) \<in> r"
  with assms
  show "b \<in> A"
    using partial_order_onD(1) order_on_defs(3) refl_on_domain
    by metis
next
  fix
    x :: "'a" and
    y :: "'a"
  assume
    x_in_A: "x \<in> A" and
    y_in_A: "y \<in> A" and
    not_y_pref_r_x: "\<not> y \<preceq>\<^sub>r x"
  have "(y, x) \<notin> r"
    using not_y_pref_r_x
    by simp
  with x_in_A y_in_A
  have "(x, y) \<in> r"
    using assms partial_order_onD(1) refl_onD
    unfolding linear_order_on_def total_on_def
    by metis
  thus "x \<preceq>\<^sub>r y"
    by simp
qed

lemma connex_antsym_and_trans_imp_lin_ord:
  assumes
    connex_r: "connex A r" and
    antisym_r: "antisym r" and
    trans_r: "trans r"
  shows "linear_order_on A r"
proof (unfold connex_def linear_order_on_def partial_order_on_def
              preorder_on_def refl_on_def total_on_def, safe)
  fix
    a :: "'a" and
    b :: "'a"
  assume "(a, b) \<in> r"
  thus "a \<in> A"
    using connex_r refl_on_domain connex_imp_refl
    by metis
next
  fix
    a :: "'a" and
    b :: "'a"
  assume "(a, b) \<in> r"
  thus "b \<in> A"
    using connex_r refl_on_domain connex_imp_refl
    by metis
next
  fix x :: "'a"
  assume "x \<in> A"
  thus "(x, x) \<in> r"
    using connex_r connex_imp_refl refl_onD
    by metis
next
  from trans_r
  show "trans r"
    by simp
next
  from antisym_r
  show "antisym r"
    by simp
next
  fix
    x :: "'a" and
    y :: "'a"
  assume
    x_in_A: "x \<in> A" and
    y_in_A: "y \<in> A" and
    y_not_pref_r_x: "(y, x) \<notin> r"
  from x_in_A y_in_A
  have "x \<preceq>\<^sub>r y \<or> y \<preceq>\<^sub>r x"
    using connex_r
    unfolding connex_def
    by metis
  hence "(x, y) \<in> r \<or> (y, x) \<in> r"
    by simp
  thus "(x, y) \<in> r"
    using y_not_pref_r_x
    by metis
qed

lemma limit_to_limits: "limited A (limit A r)"
  unfolding limited_def
  by fastforce

lemma limit_presv_connex:
  assumes
    connex: "connex S r" and
    subset: "A \<subseteq> S"
  shows "connex A (limit A r)"
proof (unfold connex_def limited_def, simp, safe)
  let ?s = "{(a, b). (a, b) \<in> r \<and> a \<in> A \<and> b \<in> A}"
  fix
    x :: "'a" and
    y :: "'a" and
    a :: "'a" and
    b :: "'a"
  assume
    x_in_A: "x \<in> A" and
    y_in_A: "y \<in> A" and
    not_y_pref_r_x: "(y, x) \<notin> r"
  have "y \<preceq>\<^sub>r x \<or> x \<preceq>\<^sub>r y"
    using x_in_A y_in_A connex connex_def in_mono subset
    by metis
  hence
    "x \<preceq>\<^sub>?s y \<or> y \<preceq>\<^sub>?s x"
    using x_in_A y_in_A
    by auto
  hence "x \<preceq>\<^sub>?s y"
    using not_y_pref_r_x
    by simp
  thus "(x, y) \<in> r"
    by simp
qed

lemma limit_presv_antisym:
  assumes "antisym r"
  shows "antisym (limit A r)"
  using assms
  unfolding antisym_def
  by simp

lemma limit_presv_trans:
  assumes "trans r"
  shows "trans (limit A r)"
  unfolding trans_def
  using transE assms
  by auto

lemma limit_presv_lin_ord:
  assumes
    "linear_order_on S r" and
      "A \<subseteq> S"
    shows "linear_order_on A (limit A r)"
  using assms connex_antsym_and_trans_imp_lin_ord
            limit_presv_antisym limit_presv_connex
            limit_presv_trans lin_ord_imp_connex
            order_on_defs(1) order_on_defs(2)
            order_on_defs(3)
  by metis

lemma limit_presv_prefs1:
  assumes
    x_less_y: "x \<preceq>\<^sub>r y" and
    x_in_A: "x \<in> A" and
    y_in_A: "y \<in> A"
  shows "let s = limit A r in x \<preceq>\<^sub>s y"
  using x_in_A x_less_y y_in_A
  by simp

lemma limit_presv_prefs2:
  assumes "(x, y) \<in> limit A r"
  shows "x \<preceq>\<^sub>r y"
  using mem_Collect_eq assms
  by simp

lemma limit_trans:
  assumes "C \<subseteq> B"
  shows "limit C r = limit C (limit B r)"
  using assms
  by auto

lemma lin_ord_not_empty:
  assumes "r \<noteq> {}"
  shows "\<not> linear_order_on {} r"
  using assms connex_imp_refl lin_ord_imp_connex
        refl_on_domain subrelI
  by fastforce

lemma lin_ord_singleton: "\<forall> r. linear_order_on {a} r \<longrightarrow> r = {(a, a)}"
proof (clarify)
  fix r :: "'a Preference_Relation"
  assume lin_ord_r_a: "linear_order_on {a} r"
  hence "a \<preceq>\<^sub>r a"
    using lin_ord_imp_connex singletonI
    unfolding connex_def
    by metis
  moreover from lin_ord_r_a
  have "\<forall> (x, y) \<in> r. x = a \<and> y = a"
    using connex_imp_refl lin_ord_imp_connex
          refl_on_domain split_beta
    by fastforce
  ultimately show "r = {(a, a)}"
    by auto
qed

subsection \<open>Auxiliary Lemmata\<close>

lemma above_trans:
  assumes
    "trans r" and
    "(a, b) \<in> r"
  shows "above r b \<subseteq> above r a"
  using Collect_mono assms transE
  unfolding above_def
  by metis

lemma above_refl:
  assumes
    "refl_on A r" and
     "a \<in> A"
  shows "a \<in> above r a"
  using assms refl_onD
  unfolding above_def
  by simp

lemma above_subset_geq_one:
  assumes
    "linear_order_on A r \<and> linear_order_on A s" and
    "above r a \<subseteq> above s a" and
    "above s a = {a}"
  shows "above r a = {a}"
  using assms connex_imp_refl above_refl insert_absorb
        lin_ord_imp_connex mem_Collect_eq refl_on_domain
        singletonI subset_singletonD
  unfolding above_def
  by metis

lemma above_connex:
  assumes
    "connex A r" and
    "a \<in> A"
  shows "a \<in> above r a"
  using assms connex_imp_refl above_refl
  by metis

lemma pref_imp_in_above: "a \<preceq>\<^sub>r b \<longleftrightarrow> b \<in> above r a"
  unfolding above_def
  by simp

lemma limit_presv_above:
  assumes
    "b \<in> above r a" and
    "a \<in> A" and
    "b \<in> A"
  shows "b \<in> above (limit A r) a"
  using assms pref_imp_in_above limit_presv_prefs1
  by metis

lemma limit_presv_above2:
  assumes "b \<in> above (limit B r) a"
  shows "b \<in> above r a"
  using assms limit_presv_prefs2
        mem_Collect_eq pref_imp_in_above
  unfolding above_def
  by metis

lemma above_one:
  assumes
    lin_ord_r: "linear_order_on A r" and
    fin_ne_A: "finite A \<and> A \<noteq> {}"
  shows "\<exists> a \<in> A. above r a = {a} \<and> (\<forall> x \<in> A. above r x = {x} \<longrightarrow> x = a)"
proof -
  obtain n::nat where
    len_n_plus_one: "n + 1 = card A"
    using Suc_eq_plus1 antisym_conv2 fin_ne_A card_eq_0_iff
          gr0_implies_Suc le0
    by metis
  have
    "(linear_order_on A r \<and> finite A \<and> A \<noteq> {} \<and> n + 1 = card A)
          \<longrightarrow> (\<exists> a. a \<in> A \<and> above r a = {a})"
  proof (induction n arbitrary: A r)
    case 0
    show ?case
    proof (clarify)
      assume
        lin_ord_r: "linear_order_on A r" and
        len_A_is_one: "0 + 1 = card A"
      then obtain a where "{a} = A"
        using card_1_singletonE add.left_neutral
        by metis
      hence "a \<in> A \<and> above r a = {a}"
        using above_def lin_ord_r connex_imp_refl above_refl
              lin_ord_imp_connex refl_on_domain
        by fastforce
      thus "\<exists> a. a \<in> A \<and> above r a = {a}"
        by metis
    qed
  next
    case (Suc n)
    show ?case
    proof (clarify)
      assume
        lin_ord_r: "linear_order_on A r" and
        fin_A: "finite A" and
        A_not_empty: "A \<noteq> {}" and
        len_A_n_plus_one: " Suc n + 1 = card A"
      then obtain B where
        subset_B_card: "card B = n + 1 \<and> B \<subseteq> A"
        using Suc_inject add_Suc card.insert_remove finite.cases
              insert_Diff_single subset_insertI
        by (metis (mono_tags, lifting))
      then obtain a where
        a: "{a} = A - B"
        using Suc_eq_plus1 add_diff_cancel_left' fin_A len_A_n_plus_one
              card_1_singletonE card_Diff_subset finite_subset
        by metis
      have "\<exists> b \<in> B. above (limit B r) b = {b}"
        using subset_B_card Suc.IH add_diff_cancel_left' lin_ord_r card_eq_0_iff
              diff_le_self leD lessI limit_presv_lin_ord
        unfolding One_nat_def
        by metis
      then obtain b where
        alt_b: "above (limit B r) b = {b}"
        by blast
      hence b_above: "{a. (b, a) \<in> limit B r} = {b}"
        unfolding above_def
        by metis
      hence b_pref_b: "b \<preceq>\<^sub>r b"
        using CollectD limit_presv_prefs2 singletonI
        by (metis (lifting))
      show "\<exists> a. a \<in> A \<and> above r a = {a}"
      proof (cases)
        assume a_pref_r_b: "a \<preceq>\<^sub>r b"
        have refl_A:
          "\<forall> A r a a'.
            (refl_on A r \<and> (a::'a, a') \<in> r) \<longrightarrow> a \<in> A \<and> a' \<in> A"
          using refl_on_domain
          by metis
        have connex_refl:
          "\<forall> A r. connex (A::'a set) r \<longrightarrow> refl_on A r"
          using connex_imp_refl
          by metis
        have "\<forall> A r. linear_order_on (A::'a set) r \<longrightarrow> connex A r"
          by (simp add: lin_ord_imp_connex)
        hence "refl_on A r"
          using connex_refl lin_ord_r
          by metis
        hence "a \<in> A \<and> b \<in> A"
          using refl_A a_pref_r_b
          by simp
        hence b_in_r:
          "\<forall> a. a \<in> A \<longrightarrow> (b = a \<or> (b, a) \<in> r \<or> (a, b) \<in> r)"
          using lin_ord_r order_on_defs(3)
          unfolding total_on_def
          by metis
        have b_in_lim_B_r: "(b, b) \<in> limit B r"
          using alt_b mem_Collect_eq singletonI
          unfolding above_def
          by metis
        have b_wins:
          "{a. (b, a) \<in> limit B r} = {b}"
          using alt_b
          unfolding above_def
          by (metis (no_types))
        have ff2:
          "(b, b) \<in> {(a', a). (a', a) \<in> r \<and> a' \<in> B \<and> a \<in> B}"
          using b_in_lim_B_r
          by simp
        moreover have b_wins_B:
          "\<forall> x \<in> B. b \<in> above r x"
          using subset_B_card b_in_r b_wins ff2 CollectI
                Product_Type.Collect_case_prodD
          unfolding above_def
          by fastforce
        moreover have "b \<in> above r a"
          using a_pref_r_b pref_imp_in_above
          by metis
        ultimately have b_wins: "\<forall> x \<in> A. b \<in> above r x"
          using Diff_iff a empty_iff insert_iff
          by (metis (no_types))
        hence "\<forall> x \<in> A. x \<in> above r b \<longrightarrow> x = b"
          using CollectD lin_ord_r lin_imp_antisym
          unfolding above_def antisym_def
          by metis
        hence "\<forall> x \<in> A. x \<in> above r b \<longleftrightarrow> x = b"
          using b_wins
          by blast
        moreover have above_b_in_A: "above r b \<subseteq> A"
          using lin_ord_r connex_imp_refl lin_ord_imp_connex
                mem_Collect_eq refl_on_domain subsetI
          unfolding above_def
          by metis
        ultimately have "above r b = {b}"
          using alt_b
          unfolding above_def
          by fastforce
        thus ?thesis
          using above_b_in_A
          by blast
      next
        assume "\<not> a \<preceq>\<^sub>r b"
        hence b_smaller_a: "b \<preceq>\<^sub>r a"
          using subset_B_card DiffE a lin_ord_r alt_b limit_to_limits
                limited_dest singletonI subset_iff
                lin_ord_imp_connex pref_imp_in_above
          unfolding connex_def
          by metis
        hence b_smaller_a_0: "(b, a) \<in> r"
          by simp
        have lin_ord_subset_A:
          "\<forall> A r A'.
            (linear_order_on (A::'a set) r \<and> A' \<subseteq> A) \<longrightarrow>
              linear_order_on A' (limit A' r)"
          using limit_presv_lin_ord
          by metis
        have
          "{a. (b, a) \<in> limit B r} = {b}"
          using alt_b
          unfolding above_def
          by metis
        hence b_in_B: "b \<in> B"
          by auto
        have limit_B:
          "partial_order_on B (limit B r) \<and> total_on B (limit B r)"
          using lin_ord_subset_A subset_B_card lin_ord_r
          unfolding order_on_defs(3)
          by metis
        have
          "\<forall> A r.
            total_on A r = (\<forall> a. (a::'a) \<notin> A \<or>
              (\<forall> a'. (a' \<notin> A \<or> a = a') \<or> (a, a') \<in> r \<or> (a', a) \<in> r))"
          unfolding total_on_def
          by metis
        hence
          "\<forall> a. a \<notin> B \<or>
            (\<forall> a'. a' \<in> B \<longrightarrow>
              (a = a' \<or> (a, a') \<in> limit B r \<or> (a', a) \<in> limit B r))"
          using limit_B
          by simp
        hence "\<forall> x \<in> B. b \<in> above r x"
          using limit_presv_prefs2 pref_imp_in_above singletonD mem_Collect_eq
                lin_ord_r alt_b b_above b_pref_b subset_B_card b_in_B
          by (metis (lifting))
        hence
          "\<forall> x \<in> B. x \<preceq>\<^sub>r b"
          unfolding above_def
          by simp
        hence b_wins2:
          "\<forall> x \<in> B. (x, b) \<in> r"
          by simp
        have "trans r"
          using lin_ord_r lin_imp_trans
          by metis
        hence "\<forall> x \<in> B. (x, a) \<in> r"
          using transE b_smaller_a_0 b_wins2
          by metis
        hence "\<forall> x \<in> B. x \<preceq>\<^sub>r a"
          by simp
        hence nothing_above_a: "\<forall> x \<in> A. x \<preceq>\<^sub>r a"
          using a lin_ord_r lin_ord_imp_connex above_connex Diff_iff
                empty_iff insert_iff pref_imp_in_above
          by metis
        have "\<forall> x \<in> A. x \<in> above r a \<longleftrightarrow> x = a"
          using lin_ord_r lin_imp_antisym nothing_above_a pref_imp_in_above CollectD
          unfolding antisym_def above_def
          by metis
        moreover have above_a_in_A: "above r a \<subseteq> A"
          using lin_ord_r connex_imp_refl lin_ord_imp_connex
                mem_Collect_eq refl_on_domain
          unfolding above_def
          by fastforce
        ultimately have "above r a = {a}"
          using a
          unfolding above_def
          by blast
        thus ?thesis
          using above_a_in_A
          by blast
      qed
    qed
  qed
  hence "\<exists> a. a \<in> A \<and> above r a = {a}"
    using fin_ne_A lin_ord_r len_n_plus_one
    by blast
  thus ?thesis
    using assms lin_ord_imp_connex pref_imp_in_above singletonD
    unfolding connex_def
    by metis
qed

lemma above_one2:
  assumes
    lin_ord: "linear_order_on A r" and
    fin_not_emp: "finite A \<and> A \<noteq> {}" and
    above_a: "above r a = {a}" and
    above_b: "above r b = {b}"
  shows "a = b"
proof -
  have "a \<preceq>\<^sub>r a"
    using above_a singletonI pref_imp_in_above
    by metis
  also have "b \<preceq>\<^sub>r b"
    using above_b singletonI pref_imp_in_above
    by metis
  moreover have
    "\<exists> a \<in> A. above r a = {a} \<and>
      (\<forall> x \<in> A. above r x = {x} \<longrightarrow> x = a)"
    using lin_ord fin_not_emp
    by (simp add: above_one)
  moreover have "connex A r"
    using lin_ord
    by (simp add: lin_ord_imp_connex)
  ultimately show "a = b"
    using above_a above_b limited_dest
    unfolding connex_def
    by metis
qed

lemma above_presv_limit:
  shows "above (limit A r) x \<subseteq> A"
  unfolding above_def
  by auto

subsection \<open>Lifting Property\<close>

definition equiv_rel_except_a :: "'a set \<Rightarrow> 'a Preference_Relation \<Rightarrow>
                                    'a Preference_Relation \<Rightarrow> 'a \<Rightarrow> bool" where
  "equiv_rel_except_a A r s a \<equiv>
    linear_order_on A r \<and> linear_order_on A s \<and> a \<in> A \<and>
    (\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}. x \<preceq>\<^sub>r y \<longleftrightarrow> x \<preceq>\<^sub>s y)"

definition lifted :: "'a set \<Rightarrow> 'a Preference_Relation \<Rightarrow>
                        'a Preference_Relation \<Rightarrow> 'a \<Rightarrow> bool" where
  "lifted A r s a \<equiv>
    equiv_rel_except_a A r s a \<and> (\<exists> x \<in> A - {a}. a \<preceq>\<^sub>r x \<and> x \<preceq>\<^sub>s a)"

lemma trivial_equiv_rel:
  assumes "linear_order_on A p"
  shows "\<forall> a \<in> A. equiv_rel_except_a A p p a"
  unfolding equiv_rel_except_a_def
  using assms
  by simp

lemma lifted_imp_equiv_rel_except_a:
  assumes "lifted A r s a"
  shows "equiv_rel_except_a A r s a"
  using assms
  unfolding lifted_def equiv_rel_except_a_def
  by simp

lemma lifted_mono:
  assumes "lifted A r s a"
  shows "\<forall> x \<in> A - {a}. \<not>(x \<preceq>\<^sub>r a \<and> a \<preceq>\<^sub>s x)"
proof (safe)
  fix x :: "'a"
  assume
    x_in_A:   "x \<in> A" and
    x_exist:  "x \<notin> {}" and
    x_neq_a:  "x \<noteq> a" and
    x_pref_a: "x \<preceq>\<^sub>r a" and
    a_pref_x: "a \<preceq>\<^sub>s x"
  from x_pref_a have x_pref_a_0: "(x, a) \<in> r"
    by simp
  from a_pref_x have a_pref_x_0: "(a, x) \<in> s"
    by simp
  from assms have "antisym r"
    using lifted_imp_equiv_rel_except_a lin_imp_antisym
    unfolding equiv_rel_except_a_def
    by metis
  hence antisym_r:
    "(\<forall> x y. (x, y) \<in> r \<longrightarrow> (y, x) \<in> r \<longrightarrow> x = y)"
    unfolding antisym_def
    by metis
  hence imp_x_eq_a:
    "\<lbrakk>(x, a) \<in> r; (a, x) \<in> r\<rbrakk> \<Longrightarrow> x = a"
    by simp
  from assms have lift_ex: "\<exists> x \<in> A - {a}. a \<preceq>\<^sub>r x \<and> x \<preceq>\<^sub>s a"
    unfolding lifted_def
    by metis
  from lift_ex obtain y :: 'a where
    "y \<in> A - {a} \<and> a \<preceq>\<^sub>r y \<and> y \<preceq>\<^sub>s a"
    by metis
  hence y_eq_r_s_exc_a:
    "y \<in> A - {a} \<and> (a, y) \<in> r \<and> (y, a) \<in> s"
    by simp
  from assms have equiv_r_s_exc_a: "equiv_rel_except_a A r s a"
    unfolding lifted_def
    by metis
  hence "\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}. x \<preceq>\<^sub>r y \<longleftrightarrow> x \<preceq>\<^sub>s y"
    unfolding equiv_rel_except_a_def
    by metis
  hence equiv_r_s_exc_a_0:
    "\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}. (x, y) \<in> r \<longleftrightarrow> (x, y) \<in> s"
    by simp
  from equiv_r_s_exc_a have trans:
    "\<forall> x y z. (x, y) \<in> r \<longrightarrow> (y, z) \<in> r \<longrightarrow> (x, z) \<in> r"
    unfolding equiv_rel_except_a_def linear_order_on_def
              partial_order_on_def preorder_on_def trans_def
    by metis
  from x_in_A x_neq_a x_pref_a_0 y_eq_r_s_exc_a equiv_r_s_exc_a equiv_r_s_exc_a_0
  have x_pref_y_0: "(x, y) \<in> s"
    using insertE insert_Diff trans
    unfolding equiv_rel_except_a_def
    by metis
  from a_pref_x_0 x_pref_y_0 x_pref_a_0 imp_x_eq_a x_neq_a equiv_r_s_exc_a
  have "(a, y) \<in> s"
    using lin_imp_trans transE
    unfolding equiv_rel_except_a_def
    by metis
  with y_eq_r_s_exc_a equiv_r_s_exc_a
  show False
    using antisymD DiffD2 lin_imp_antisym singletonI
    unfolding equiv_rel_except_a_def
    by metis
qed

lemma lifted_mono2:
  assumes
    lifted: "lifted A r s a" and
    x_pref_a: "x \<preceq>\<^sub>r a"
  shows "x \<preceq>\<^sub>s a"
proof (simp)
  from x_pref_a have x_pref_a_0: "(x, a) \<in> r"
    by simp
  with lifted have x_in_A: "x \<in> A"
    using connex_imp_refl lin_ord_imp_connex refl_on_domain
    unfolding equiv_rel_except_a_def lifted_def
    by metis
  have "\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}. x \<preceq>\<^sub>r y \<longleftrightarrow> x \<preceq>\<^sub>s y"
    using lifted
    unfolding lifted_def equiv_rel_except_a_def
    by metis
  hence rest_eq:
    "\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}. (x, y) \<in> r \<longleftrightarrow> (x, y) \<in> s"
    by simp
  have "\<exists> x \<in> A - {a}. a \<preceq>\<^sub>r x \<and> x \<preceq>\<^sub>s a"
    using lifted
    unfolding lifted_def
    by metis
  hence ex_lifted: "\<exists> x \<in> A - {a}. (a, x) \<in> r \<and> (x, a) \<in> s"
    by simp
  show "(x, a) \<in> s"
  proof (cases "x = a")
    case True
    thus ?thesis
      using connex_imp_refl refl_onD lifted lin_ord_imp_connex
      unfolding equiv_rel_except_a_def lifted_def
      by metis
  next
    case False
    with x_pref_a_0 x_in_A rest_eq ex_lifted
    show ?thesis
      using insertE insert_Diff lifted lin_imp_trans
            lifted_imp_equiv_rel_except_a
      unfolding equiv_rel_except_a_def trans_def
      by metis
  qed
qed

lemma lifted_above:
  assumes "lifted A r s a"
  shows "above s a \<subseteq> above r a"
proof (unfold above_def, safe)
  fix x :: "'a"
  assume a_pref_x: "(a, x) \<in> s"
  from assms have "\<exists> x \<in> A - {a}. a \<preceq>\<^sub>r x \<and> x \<preceq>\<^sub>s a"
    unfolding lifted_def
    by metis
  hence lifted_r: "\<exists> x \<in> A - {a}. (a, x) \<in> r \<and> (x, a) \<in> s"
    by simp
  from assms have "\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}. x \<preceq>\<^sub>r y \<longleftrightarrow> x \<preceq>\<^sub>s y"
    unfolding lifted_def equiv_rel_except_a_def
    by metis
  hence rest_eq:
    "\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}. (x, y) \<in> r \<longleftrightarrow> (x, y) \<in> s"
    by simp
  from assms have trans_r:
    "\<forall> x y z. (x, y) \<in> r \<longrightarrow> (y, z) \<in> r \<longrightarrow> (x, z) \<in> r"
    using lin_imp_trans
    unfolding trans_def lifted_def equiv_rel_except_a_def
    by metis
  from assms have trans_s:
    "\<forall> x y z. (x, y) \<in> s \<longrightarrow> (y, z) \<in> s \<longrightarrow> (x, z) \<in> s"
    using lin_imp_trans
    unfolding trans_def lifted_def equiv_rel_except_a_def
    by metis
  from assms have refl_r: "(a, a) \<in> r"
    using connex_imp_refl lin_ord_imp_connex refl_onD
    unfolding equiv_rel_except_a_def lifted_def
    by metis
  from a_pref_x assms have "x \<in> A"
    using connex_imp_refl lin_ord_imp_connex refl_onD2
    unfolding equiv_rel_except_a_def lifted_def
    by metis
  with a_pref_x lifted_r rest_eq trans_r trans_s refl_r
  show "(a, x) \<in> r"
    using Diff_iff singletonD
    by (metis (full_types))
qed

lemma lifted_above2:
  assumes
    lifted_a: "lifted A r s a" and
    x_in_A_sub_a: "x \<in> A - {a}"
  shows "above r x \<subseteq> above s x \<union> {a}"
proof (safe, simp)
  fix y :: "'a"
  assume
    y_in_above_r: "y \<in> above r x" and
    y_not_in_above_s: "y \<notin> above s x"
  have "\<forall> z \<in> A - {a}. x \<preceq>\<^sub>r z \<longleftrightarrow> x \<preceq>\<^sub>s z"
    using x_in_A_sub_a lifted_a
    unfolding lifted_def equiv_rel_except_a_def
    by metis
  hence "\<forall> z \<in> A - {a}. (x, z) \<in> r \<longleftrightarrow> (x, z) \<in> s"
    by simp
  hence "\<forall> z \<in> A - {a}. z \<in> above r x \<longleftrightarrow> z \<in> above s x"
    unfolding above_def
    by simp
  hence "y \<in> above r x \<longleftrightarrow> y \<in> above s x"
    using lifted_a y_not_in_above_s lifted_mono2 limited_dest lifted_def
          lin_ord_imp_connex member_remove pref_imp_in_above
    unfolding equiv_rel_except_a_def remove_def connex_def
    by metis
  thus "y = a"
    using y_in_above_r y_not_in_above_s
    by simp
qed

lemma limit_lifted_imp_eq_or_lifted:
  assumes
    lifted: "lifted S r s a" and
    subset: "A \<subseteq> S"
  shows "limit A r = limit A s \<or> lifted A (limit A r) (limit A s) a"
proof -
  from lifted have
    "\<forall> x \<in> S - {a}. \<forall> y \<in> S - {a}. x \<preceq>\<^sub>r y \<longleftrightarrow> x \<preceq>\<^sub>s y"
    unfolding lifted_def equiv_rel_except_a_def
    by simp
  with subset have temp:
    "\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}. x \<preceq>\<^sub>r y \<longleftrightarrow> x \<preceq>\<^sub>s y"
    by auto
  hence eql_rs:
      "\<forall> x \<in> A - {a}. \<forall> y \<in> A - {a}.
      (x, y) \<in> (limit A r) \<longleftrightarrow> (x, y) \<in> (limit A s)"
    using DiffD1 limit_presv_prefs1 limit_presv_prefs2
    by simp
  from lifted subset have lin_ord_r_s:
    "linear_order_on A (limit A r) \<and> linear_order_on A (limit A s)"
    using lifted_def equiv_rel_except_a_def limit_presv_lin_ord
    by metis
  show ?thesis
  proof (cases)
    assume a_in_A: "a \<in> A"
    thus ?thesis
    proof (cases)
      assume "\<exists> x \<in> A - {a}. a \<preceq>\<^sub>r x \<and> x \<preceq>\<^sub>s a"
      with a_in_A have keep_lift:
        "\<exists> x \<in> A - {a}. (let q = limit A r in a \<preceq>\<^sub>q x) \<and>
            (let u = limit A s in x \<preceq>\<^sub>u a)"
        using DiffD1 limit_presv_prefs1
        by simp
      thus ?thesis
        using a_in_A temp lin_ord_r_s
        unfolding lifted_def equiv_rel_except_a_def
        by simp
    next
      assume "\<not>(\<exists> x \<in> A - {a}. a \<preceq>\<^sub>r x \<and> x \<preceq>\<^sub>s a)"
      hence strict_pref_to_a:
        "\<forall> x \<in> A - {a}. \<not>(a \<preceq>\<^sub>r x \<and> x \<preceq>\<^sub>s a)"
        by simp
      moreover have not_worse:
        "\<forall> x \<in> A - {a}. \<not>(x \<preceq>\<^sub>r a \<and> a \<preceq>\<^sub>s x)"
        using lifted subset lifted_mono
        by fastforce
      moreover have connex:
        "connex A (limit A r) \<and> connex A (limit A s)"
        using lifted subset limit_presv_lin_ord lin_ord_imp_connex
        unfolding lifted_def equiv_rel_except_a_def
        by metis
      moreover have connex1:
        "\<forall> A r. connex A r =
          (limited A r \<and> (\<forall>a. (a::'a) \<in> A \<longrightarrow>
            (\<forall> a'. a' \<in> A \<longrightarrow> a \<preceq>\<^sub>r a' \<or> a' \<preceq>\<^sub>r a)))"
        unfolding connex_def
        by (simp add: Ball_def_raw)
      hence limit1:
        "limited A (limit A r) \<and>
          (\<forall> a. a \<notin> A \<or>
            (\<forall> a'.
              a' \<notin> A \<or> (a, a') \<in> limit A r \<or>
                (a', a) \<in> limit A r ))"
        using connex connex1
        by simp
      have limit2:
        "\<forall> a a' A r. (a::'a, a') \<notin> limit A r \<or> a \<preceq>\<^sub>r a'"
        using limit_presv_prefs2
        by metis
      have
        "limited A (limit A s) \<and>
          (\<forall> a. a \<notin> A \<or>
            (\<forall> a'. a' \<notin> A \<or>
              (let q = limit A s in a \<preceq>\<^sub>q a' \<or> a' \<preceq>\<^sub>q a)))"
        using connex
        unfolding connex_def
        by metis
      hence connex2:
        "limited A (limit A s) \<and>
          (\<forall> a. a \<notin> A \<or>
            (\<forall> a'. a' \<notin> A \<or>
              ((a, a') \<in> limit A s \<or> (a', a) \<in> limit A s)))"
        by simp
      ultimately have
          "\<forall> x \<in> A - {a}. (a \<preceq>\<^sub>r x \<and> a \<preceq>\<^sub>s x) \<or> (x \<preceq>\<^sub>r a \<and> x \<preceq>\<^sub>s a)"
        using DiffD1 limit1 limit_presv_prefs2 a_in_A
        by metis
      hence r_eq_s_on_A_0:
        "\<forall> x \<in> A - {a}. ((a, x) \<in> r \<and> (a, x) \<in> s) \<or> ((x, a) \<in> r \<and> (x, a) \<in> s)"
        by simp
      have
        "\<forall> x \<in> A - {a}. (a, x) \<in> (limit A r) \<longleftrightarrow> (a, x) \<in> (limit A s)"
        using DiffD1 limit2 limit1 connex2 a_in_A strict_pref_to_a not_worse
        by metis
      hence
        "\<forall> x \<in> A - {a}.
          (let q = limit A r in a \<preceq>\<^sub>q x) \<longleftrightarrow> (let q = limit A s in a \<preceq>\<^sub>q x)"
        by simp
      moreover have
        "\<forall> x \<in> A - {a}. (x, a) \<in> (limit A r) \<longleftrightarrow> (x, a) \<in> (limit A s)"
        using a_in_A strict_pref_to_a not_worse DiffD1 limit_presv_prefs2 connex2 limit1
        by metis
      moreover have
        "(a, a) \<in> (limit A r) \<and> (a, a) \<in> (limit A s)"
        using a_in_A connex connex_imp_refl refl_onD
        by metis
      moreover have
        "limited A (limit A r) \<and> limited A (limit A s)"
        using limit_to_limits
        by metis
      ultimately have
        "\<forall> x y. (x, y) \<in> limit A r \<longleftrightarrow> (x, y) \<in> limit A s"
        using eql_rs
        by auto
      thus ?thesis
        by simp
    qed
  next
    assume "a \<notin> A"
    with eql_rs have
      "\<forall> x \<in> A. \<forall> y \<in> A. (x, y) \<in> (limit A r) \<longleftrightarrow> (x, y) \<in> (limit A s)"
      by simp
    thus ?thesis
      using limit_to_limits limited_dest subrelI subset_antisym
      by auto
  qed
qed

lemma negl_diff_imp_eq_limit:
  assumes
    change: "equiv_rel_except_a S r s a" and
    subset: "A \<subseteq> S" and
    notInA: "a \<notin> A"
  shows "limit A r = limit A s"
proof -
  have "A \<subseteq> S - {a}"
    unfolding subset_Diff_insert
    using notInA subset
    by simp
  hence "\<forall> x \<in> A. \<forall> y \<in> A. x \<preceq>\<^sub>r y \<longleftrightarrow> x \<preceq>\<^sub>s y"
    using change in_mono
    unfolding equiv_rel_except_a_def
    by metis
  thus ?thesis
    by auto
qed

theorem lifted_above_winner:
  assumes
    lifted_a: "lifted A r s a" and
    above_x: "above r x = {x}" and
    fin_A: "finite A"
  shows "above s x = {x} \<or> above s a = {a}"
proof cases
  assume "x = a"
  thus ?thesis
    using above_subset_geq_one lifted_a above_x lifted_above
    unfolding lifted_def equiv_rel_except_a_def
    by metis
next
  assume x_neq_a: "x \<noteq> a"
  thus ?thesis
  proof (cases)
    assume "above s x = {x}"
    thus ?thesis
      by simp
  next
    assume x_not_above: "above s x \<noteq> {x}"
    have "\<forall> y \<in> A. y \<preceq>\<^sub>r x"
    proof (safe)
      fix y :: "'a"
      assume y_in_A: "y \<in> A"
      hence alts_not_empty: "A \<noteq> {}"
        by blast
      have "linear_order_on A r"
        using lifted_a
        unfolding equiv_rel_except_a_def lifted_def
        by simp
      with alts_not_empty y_in_A
      show "y \<preceq>\<^sub>r x"
        using above_one above_one2 above_x fin_A lin_ord_imp_connex
              pref_imp_in_above singletonD
        unfolding connex_def
        by (metis (no_types))
    qed
    moreover have "equiv_rel_except_a A r s a"
      using lifted_a
      unfolding lifted_def
      by metis
    moreover have "x \<in> A - {a}"
      using above_one above_one2 x_neq_a assms calculation
            insert_not_empty member_remove insert_absorb
      unfolding equiv_rel_except_a_def remove_def
      by metis
    ultimately have "\<forall> y \<in> A - {a}. y \<preceq>\<^sub>s x"
      using DiffD1 lifted_a
      unfolding equiv_rel_except_a_def
      by metis
    hence not_others: "\<forall> y \<in> A - {a}. above s y \<noteq> {y}"
      using x_not_above empty_iff insert_iff pref_imp_in_above
      by metis
    hence "above s a = {a}"
      using Diff_iff all_not_in_conv lifted_a fin_A above_one singleton_iff
      unfolding lifted_def equiv_rel_except_a_def
      by metis
    thus ?thesis
      by simp
  qed
qed

theorem lifted_above_winner2:
  assumes
    "lifted A r s a" and
    "above r a = {a}" and
    "finite A"
  shows "above s a = {a}"
  using assms lifted_above_winner
  by metis

theorem lifted_above_winner3:
  assumes
    lifted_a: "lifted A r s a" and
    above_x: "above s x = {x}" and
    fin_A: "finite A" and
    x_not_a: "x \<noteq> a"
  shows "above r x = {x}"
proof (rule ccontr)
  assume not_above_x: "above r x \<noteq> {x}"
  then obtain y where y: "above r y = {y}"
    using lifted_a fin_A insert_Diff insert_not_empty above_one
    unfolding lifted_def equiv_rel_except_a_def
    by metis
  hence "above s y = {y} \<or> above s a = {a}"
    using lifted_a fin_A lifted_above_winner
    by metis
  moreover have "\<forall> b. above s b = {b} \<longrightarrow> b = x"
    using all_not_in_conv lifted_a above_x fin_A above_one2
    unfolding lifted_def equiv_rel_except_a_def
    by metis
  ultimately have "y = x"
    using x_not_a
    by presburger
  moreover have "y \<noteq> x"
    using not_above_x y
    by blast
  ultimately show False
    by simp
qed

end