(*
  Title:    Social_Choice_Functions.thy
  Author:   Manuel Eberl, TU München

  Definitions of Social Choice Functions, their properties, and related concepts
*)

section \<open>Social Choice Functions\<close>

theory Social_Choice_Functions
imports
  "Randomised_Social_Choice.Preference_Profile_Cmd"
begin

subsection \<open>Weighted majority graphs\<close>

definition supporters :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt \<Rightarrow> 'alt \<Rightarrow> 'agent set" where
  supporters_auxdef: "supporters R x y = {i. x \<succeq>[R i] y}"

definition weighted_majority :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt \<Rightarrow> 'alt \<Rightarrow> int" where
  "weighted_majority R x y = int (card (supporters R x y)) - int (card (supporters R y x))"

lemma weighted_majority_refl [simp]: "weighted_majority R x x = 0"
  by (simp add: weighted_majority_def)

lemma weighted_majority_swap: "weighted_majority R x y = -weighted_majority R y x"
  by (simp add: weighted_majority_def)

lemma eval_set_filter:
  "Set.filter P {} = {}"
  "P x \<Longrightarrow> Set.filter P (insert x A) = insert x (Set.filter P A)"
  "\<not>P x \<Longrightarrow> Set.filter P (insert x A) = Set.filter P A"
  unfolding Set.filter_def by auto

context election
begin

lemma supporters_def:
  assumes "is_pref_profile R"
  shows   "supporters R x y = {i\<in>agents. x \<succeq>[R i] y}"
proof -
  interpret pref_profile_wf agents alts R by fact
  show ?thesis using not_outside unfolding supporters_auxdef by blast
qed

lemma supporters_nonagent1:
  assumes "is_pref_profile R" "x \<notin> alts"
  shows   "supporters R x y = {}"
proof -
  interpret pref_profile_wf agents alts R by fact
  from assms show ?thesis by (auto simp: supporters_def dest: not_outside)
qed

lemma supporters_nonagent2:
  assumes "is_pref_profile R" "y \<notin> alts"
  shows   "supporters R x y = {}"
proof -
  interpret pref_profile_wf agents alts R by fact
  from assms show ?thesis by (auto simp: supporters_def dest: not_outside)
qed

lemma weighted_majority_nonagent1:
  assumes "is_pref_profile R" "x \<notin> alts"
  shows   "weighted_majority R x y = 0"
  using assms by (simp add: weighted_majority_def supporters_nonagent1 supporters_nonagent2)

lemma weighted_majority_nonagent2:
  assumes "is_pref_profile R" "y \<notin> alts"
  shows   "weighted_majority R x y = 0"
  using assms by (simp add: weighted_majority_def supporters_nonagent1 supporters_nonagent2)

lemma weighted_majority_eq_iff:
  assumes "is_pref_profile R1" "is_pref_profile R2"
  shows   "weighted_majority R1 = weighted_majority R2 \<longleftrightarrow>
             (\<forall>x\<in>alts. \<forall>y\<in>alts. weighted_majority R1 x y = weighted_majority R2 x y)"
proof (intro iffI ext)
  fix x y :: 'alt
  assume "\<forall>x\<in>alts. \<forall>y\<in>alts. weighted_majority R1 x y = weighted_majority R2 x y"
  with assms show "weighted_majority R1 x y = weighted_majority R2 x y"
    by (cases "x \<in> alts"; cases "y \<in> alts")
       (auto simp: fun_eq_iff weighted_majority_nonagent1 weighted_majority_nonagent2)
qed auto

end

subsection \<open>Definition of Social Choice Functions\<close>

locale social_choice_function = election agents alts
  for agents :: "'agent set" and alts :: "'alt set" +
  fixes scf :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt set"
  assumes scf_nonempty: "is_pref_profile R \<Longrightarrow> scf R \<noteq> {}"
  assumes scf_alts: "is_pref_profile R \<Longrightarrow> scf R \<subseteq> alts"

subsection \<open>Anonymity\<close>

text \<open>
  An SCF is anonymous if permuting the agents in the input does not change the result.
\<close>
locale anonymous_scf = social_choice_function agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf +
  assumes anonymous: "\<pi> permutes agents \<Longrightarrow> is_pref_profile R \<Longrightarrow> scf (R \<circ> \<pi>) = scf R"
begin

lemma anonymous':
  assumes "anonymous_profile R1 = anonymous_profile R2"
  assumes "is_pref_profile R1" "is_pref_profile R2"
  shows   "scf R1 = scf R2"
proof -
  from anonymous_profile_agent_permutation[OF assms finite_agents]
    obtain \<pi> where "\<pi> permutes agents" "R1 = R2 \<circ> \<pi>" by blast
  with anonymous[of \<pi> R2] assms show ?thesis by simp
qed

lemma anonymity_prefs_from_table:
  assumes "prefs_from_table_wf agents alts xs" "prefs_from_table_wf agents alts ys"
  assumes "mset (map snd xs) = mset (map snd ys)"
  shows   "scf (prefs_from_table xs) = scf (prefs_from_table ys)"
proof -
  from prefs_from_table_agent_permutation[OF assms] guess \<pi> .
  with anonymous[of \<pi>, of "prefs_from_table xs"] assms(1) show ?thesis
    by (simp add: pref_profile_from_tableI)
qed

context
begin
qualified lemma anonymity_prefs_from_table_aux:
  assumes "R1 = prefs_from_table xs" "prefs_from_table_wf agents alts xs"
  assumes "R2 = prefs_from_table ys" "prefs_from_table_wf agents alts ys"
  assumes "mset (map snd xs) = mset (map snd ys)"
  shows   "scf R1 = scf R2" unfolding assms(1,3)
  by (rule anonymity_prefs_from_table) (simp_all add: assms del: mset_map)
end

end

subsection \<open>Neutrality\<close>

text \<open>
  An SCF is neutral if permuting the alternatives in the input does not change the
  result, modulo the equivalent permutation in the output lottery.
\<close>
locale neutral_scf = social_choice_function agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf +
  assumes neutral: "\<sigma> permutes alts \<Longrightarrow> is_pref_profile R \<Longrightarrow>
                        scf (permute_profile \<sigma> R) = \<sigma> ` scf R"
begin

text \<open>
  Alternative formulation of neutrality that shows that our definition is
  equivalent to that in the paper.
\<close>
lemma neutral':
  assumes "\<sigma> permutes alts"
  assumes "is_pref_profile R"
  assumes "a \<in> alts"
  shows   "\<sigma> a \<in> scf (permute_profile \<sigma> R) \<longleftrightarrow> a \<in> scf R"
proof -
  have *: "x = y" if "\<sigma> x = \<sigma> y" for x y
    using permutes_inj[OF assms(1)] that by (auto dest: injD)
  from assms show ?thesis by (auto simp: neutral dest!: *)
qed

end

locale an_scf =
  anonymous_scf agents alts scf + neutral_scf agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf
begin

lemma scf_anonymous_neutral:
  assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R1" "is_pref_profile R2"
  assumes eq: "anonymous_profile R1 =
                 image_mset (map (\<lambda>A. \<sigma> ` A)) (anonymous_profile R2)"
  shows   "scf R1 = \<sigma> ` scf R2"
proof -
  interpret R1: pref_profile_wf agents alts R1 by fact
  interpret R2: pref_profile_wf agents alts R2 by fact
  from perm have wf': "is_pref_profile (permute_profile \<sigma> R2)"
    by (rule R2.wf_permute_alts)
  from eq perm have "anonymous_profile R1 = anonymous_profile (permute_profile \<sigma> R2)"
    by (simp add: R2.anonymous_profile_permute)
  from anonymous_profile_agent_permutation[OF this wf(1) wf']
    obtain \<pi> where "\<pi> permutes agents" "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by auto
  have "scf (permute_profile \<sigma> R2 \<circ> \<pi>) = scf (permute_profile \<sigma> R2)"
    by (rule anonymous) fact+
  also have "\<dots> = \<sigma> ` scf R2"
    by (rule neutral) fact+
  also have "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by fact
  finally show ?thesis .
qed

lemma scf_anonymous_neutral':
  assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R1" "is_pref_profile R2"
  assumes eq: "anonymous_profile R1 =
                 image_mset (map (\<lambda>A. \<sigma> ` A)) (anonymous_profile R2)"
  shows   "\<sigma> x \<in> scf R1 \<longleftrightarrow> x \<in> scf R2"
proof -
  have "scf R1 = \<sigma> ` scf R2" by (intro scf_anonymous_neutral) fact+
  also have "\<sigma> x \<in> \<dots> \<longleftrightarrow> x \<in> scf R2"
    by (blast dest: injD[OF permutes_inj[OF perm]])
  finally show ?thesis .
qed

lemma scf_automorphism:
  assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R"
  assumes eq: "image_mset (map (\<lambda>A. \<sigma> ` A)) (anonymous_profile R) = anonymous_profile R"
  shows   "\<sigma> ` scf R = scf R"
  using scf_anonymous_neutral[OF perm wf wf eq [symmetric]] ..

end

lemma an_scf_automorphism_aux:
  assumes wf: "prefs_from_table_wf agents alts yss" "R \<equiv> prefs_from_table yss"
  assumes an: "an_scf agents alts scf"
  assumes eq: "mset (map ((map (\<lambda>A. permutation_of_list xs ` A)) \<circ> snd) yss) = mset (map snd yss)"
  assumes perm: "set (map fst xs) \<subseteq> alts" "set (map snd xs) = set (map fst xs)"
                "distinct (map fst xs)"
      and x: "x \<in> alts" "y = permutation_of_list xs x"
  shows   "x \<in> scf R \<longleftrightarrow> y \<in> scf R"
proof -
  note perm = list_permutesI[OF perm]
  let ?\<sigma> = "permutation_of_list xs"
  note perm' = permutation_of_list_permutes [OF perm]
  from wf have wf': "pref_profile_wf agents alts R" by (simp add: pref_profile_from_tableI)
  then interpret R: pref_profile_wf agents alts R .
  from perm' interpret R': pref_profile_wf agents alts "permute_profile ?\<sigma> R"
    by (simp add: R.wf_permute_alts)
  from an interpret an_scf agents alts scf .

  from eq wf have eq': "image_mset (map (\<lambda>A. ?\<sigma> ` A)) (anonymous_profile R) = anonymous_profile R"
    by (simp add: anonymise_prefs_from_table mset_map multiset.map_comp)
  have "x \<in> scf R \<longleftrightarrow> ?\<sigma> x \<in> ?\<sigma> ` scf R"
    by (blast dest: injD[OF permutes_inj[OF perm']])
  also from eq' x wf' perm' have "?\<sigma> ` scf R = scf R"
    by (intro scf_automorphism)
       (simp_all add: R.anonymous_profile_permute pref_profile_from_tableI)
  finally show ?thesis using x by simp
qed

subsection \<open>Weighted-majoritarian SCFs\<close>

locale pairwise_scf = social_choice_function agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf +
  assumes pairwise:
    "is_pref_profile R1 \<Longrightarrow> is_pref_profile R2 \<Longrightarrow> weighted_majority R1 = weighted_majority R2 \<Longrightarrow>
       scf R1 = scf R2"

subsection \<open>Pareto efficiency\<close>

locale pareto_efficient_scf = social_choice_function agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf +
  assumes pareto_efficient:
    "is_pref_profile R \<Longrightarrow> scf R \<inter> pareto_losers R = {}"
begin

lemma pareto_efficient'':
  assumes "is_pref_profile R" "i \<in> agents"  "\<forall>i\<in>agents. y \<succeq>[R i] x" "\<not>y \<preceq>[R i] x"
  shows   "x \<notin> scf R"
proof -
  from assms(1) interpret pref_profile_wf agents alts R .
  from assms(2-) show ?thesis
    by (intro pareto_efficient'[OF assms(1), of _ y])
       (auto simp: Pareto_iff strongly_preferred_def)
qed

end

subsection \<open>Set extensions\<close>

type_synonym 'alt set_extension = "'alt relation \<Rightarrow> 'alt set relation"

definition Kelly :: "'alt set_extension" where
  "A \<succeq>[Kelly(R)] B \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>B. a \<succeq>[R] b)"

lemma Kelly_strict_iff: "A \<succ>[Kelly(R)] B \<longleftrightarrow> ((\<forall>a\<in>A. \<forall>b\<in>B. R b a) \<and> \<not> (\<forall>a\<in>B. \<forall>b\<in>A. R b a))"
  unfolding strongly_preferred_def Kelly_def ..

lemmas Kelly_eval = Kelly_def Kelly_strict_iff

definition Fishb :: "'alt set_extension" where
  "A \<succeq>[Fishb(R)] B \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>B-A. a \<succeq>[R] b) \<and> (\<forall>a\<in>A-B. \<forall>b\<in>B. a \<succeq>[R] b)"

lemma Fishb_strict_iff:
  "A \<succ>[Fishb(R)] B \<longleftrightarrow>
     ((\<forall>a\<in>A. \<forall>b\<in>B - A. R b a) \<and> (\<forall>a\<in>A - B. \<forall>b\<in>B. R b a)) \<and>
     \<not> ((\<forall>a\<in>B. \<forall>b\<in>A - B. R b a) \<and> (\<forall>a\<in>B - A. \<forall>b\<in>A. R b a))"
  unfolding strongly_preferred_def Fishb_def ..

lemmas Fishb_eval = Fishb_def Fishb_strict_iff

subsection \<open>Strategyproofness\<close>

locale strategyproof_scf =
  social_choice_function agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf +
  fixes set_ext :: "'alt set_extension"
  assumes strategyproof:
    "is_pref_profile R \<Longrightarrow> total_preorder_on alts Ri' \<Longrightarrow> i \<in> agents \<Longrightarrow>
       \<not> scf (R(i := Ri')) \<succ>[set_ext(R i)] scf R"

locale strategyproof_anonymous_scf =
  anonymous_scf agents alts scf + strategyproof_scf agents alts scf set_ext
  for agents :: "'agent set" and alts :: "'alt set" and scf and set_ext
begin

lemma strategyproof':
  assumes "is_pref_profile R1" "is_pref_profile R2" "i \<in> agents" "j \<in> agents"
  assumes "anonymous_profile R2 = anonymous_profile R1 -
             {#weak_ranking (R1 i)#} + {#weak_ranking (R2 j)#}"
  shows   "\<not>scf R2 \<succ>[set_ext (R1 i)] scf R1"
proof -
  let ?R3 = "R1(i := R2 j)"
  interpret R1: pref_profile_wf agents alts R1 by fact
  interpret R2: pref_profile_wf agents alts R2 by fact
  from \<open>j \<in> agents\<close> have "total_preorder_on alts (R2 j)" by simp
  from strategyproof[OF assms(1) this \<open>i \<in> agents\<close>]
    have "\<not>scf ?R3 \<succ>[set_ext (R1 i)] scf R1" .
  also from assms have "scf ?R3 = scf R2"
    by (intro anonymous') (simp_all add: R1.anonymous_profile_update)
  finally show ?thesis .
qed

end

context preorder_on
begin

lemma strict_not_outside:
  assumes "x \<prec>[le] y"
  shows   "x \<in> carrier" "y \<in> carrier"
  using assms not_outside[of x y] unfolding strongly_preferred_def by blast+

end

subsection \<open>Lifting preferences\<close>

text \<open>
  Preference profiles can be lifted to a setting with more agents and alternatives by padding
  them with dummy agents and alternatives in such a way that every original agent prefers and
  original alternative over any dummy alternative and is indifferent between the dummy alternatives.
  Moreover, every dummy agent is completely indifferent.
\<close>

definition lift_prefs ::
    "'alt set \<Rightarrow> 'alt set \<Rightarrow> 'alt relation \<Rightarrow> 'alt relation" where
  "lift_prefs alts alts' R = (\<lambda>x y.
     x \<in> alts' \<and> y \<in> alts' \<and> (x = y \<or> x \<notin> alts \<or> (y \<in> alts \<and> R x y)))"

lemma lift_prefs_wf:
  assumes "total_preorder_on alts R" "alts \<subseteq> alts'"
  shows   "total_preorder_on alts' (lift_prefs alts alts' R)"
proof -
  interpret R: total_preorder_on alts R by fact
  show ?thesis
    by standard (insert R.total, auto dest: R.trans simp: lift_prefs_def)
qed

definition lift_pref_profile ::
    "'agent set \<Rightarrow> 'alt set \<Rightarrow> 'agent set \<Rightarrow> 'alt set \<Rightarrow>
       ('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) pref_profile" where
  "lift_pref_profile agents alts agents' alts' R = (\<lambda>i x y.
     x \<in> alts' \<and> y \<in> alts' \<and> i \<in> agents' \<and>
     (x = y \<or> x \<notin> alts \<or> i \<notin> agents \<or> (y \<in> alts \<and> R i x y)))"

lemma lift_pref_profile_conv_vector:
  assumes "i \<in> agents" "i \<in> agents'"
  shows   "lift_pref_profile agents alts agents' alts' R i = lift_prefs alts alts' (R i)"
  using assms by (auto simp: lift_pref_profile_def lift_prefs_def)

lemma lift_pref_profile_wf:
  assumes "pref_profile_wf agents alts R"
  assumes "agents \<subseteq> agents'" "alts \<subseteq> alts'" "finite alts'"
  defines "R' \<equiv> lift_pref_profile agents alts agents' alts' R"
  shows   "pref_profile_wf agents' alts' R'"
proof -
  from assms interpret R: pref_profile_wf agents alts by simp
  have "finite_total_preorder_on alts' (R' i)"
    if i: "i \<in> agents'" for i
  proof (cases "i \<in> agents")
    case True
    then interpret finite_total_preorder_on alts "R i" by simp
    from True assms show ?thesis
      by unfold_locales (auto simp: lift_pref_profile_def dest: total intro: trans)
  next
    case False
    with assms i show ?thesis
      by unfold_locales (simp_all add: lift_pref_profile_def)
  qed
  moreover have "R' i = (\<lambda>_ _. False)" if "i \<notin> agents'" for i
    unfolding lift_pref_profile_def R'_def using that by simp
  ultimately show ?thesis unfolding pref_profile_wf_def using assms by auto
qed

lemma lift_pref_profile_permute_agents:
  assumes "\<pi> permutes agents" "agents \<subseteq> agents'"
  shows   "lift_pref_profile agents alts agents' alts' (R \<circ> \<pi>) =
             lift_pref_profile agents alts agents' alts' R \<circ> \<pi>"
  using assms permutes_subset[OF assms]
  by (auto simp add: lift_pref_profile_def o_def permutes_in_image)

lemma lift_pref_profile_permute_alts:
  assumes "\<sigma> permutes alts" "alts \<subseteq> alts'"
  shows   "lift_pref_profile agents alts agents' alts' (permute_profile \<sigma> R) =
             permute_profile \<sigma> (lift_pref_profile agents alts agents' alts' R)"
proof -
  from assms have inv: "inv \<sigma> permutes alts" by (intro permutes_inv)
  from this assms(2) have "inv \<sigma> permutes alts'" by (rule permutes_subset)
  with inv show ?thesis using assms permutes_inj[OF \<open>inv \<sigma> permutes alts\<close>]
    by (fastforce simp add: lift_pref_profile_def permutes_in_image
          permute_profile_def fun_eq_iff dest: injD)
qed

context
  fixes agents alts R agents' alts' R'
  assumes R_wf: "pref_profile_wf agents alts R"
  assumes election: "agents \<subseteq> agents'" "alts \<subseteq> alts'" "alts \<noteq> {}" "agents \<noteq> {}" "finite alts'"
  defines "R' \<equiv> lift_pref_profile agents alts agents' alts' R"
begin

interpretation R: pref_profile_wf agents alts R by fact
interpretation R': pref_profile_wf agents' alts' R'
  using election R_wf by (simp add: R'_def lift_pref_profile_wf)

lemma lift_pref_profile_strict_iff:
  "x \<prec>[lift_pref_profile agents alts agents' alts' R i] y \<longleftrightarrow>
     i \<in> agents \<and> ((y \<in> alts \<and> x \<in> alts' - alts) \<or> x \<prec>[R i] y)"
proof (cases "i \<in> agents")
  case True
  then interpret total_preorder_on alts "R i" by simp
  show ?thesis using not_outside election
    by (auto simp: lift_pref_profile_def strongly_preferred_def)
qed (simp_all add: lift_pref_profile_def strongly_preferred_def)

lemma preferred_alts_lift_pref_profile:
  assumes i: "i \<in> agents'" and x: "x \<in> alts'"
  shows   "preferred_alts (R' i) x =
             (if i \<in> agents \<and> x \<in> alts then preferred_alts (R i) x else alts')"
proof (cases "i \<in> agents")
  assume i: "i \<in> agents"
  then interpret Ri: total_preorder_on alts "R i" by simp
  show ?thesis
  using i x election Ri.not_outside
    by (auto simp: preferred_alts_def R'_def lift_pref_profile_def Ri.refl)
qed (auto simp: preferred_alts_def R'_def lift_pref_profile_def i x)

lemma lift_pref_profile_Pareto_iff:
  "x \<preceq>[Pareto(R')] y \<longleftrightarrow> x \<in> alts' \<and> y \<in> alts' \<and> (x \<notin> alts \<or> x \<preceq>[Pareto(R)] y)"
proof -
  from R.nonempty_agents obtain i where i: "i \<in> agents" by blast
  then interpret Ri: finite_total_preorder_on alts "R i" by simp
  show ?thesis unfolding R'.Pareto_iff R.Pareto_iff unfolding R'_def lift_pref_profile_def
    using election i by (auto simp: preorder_on.refl[OF R.in_dom]
      simp del: R.nonempty_alts R.nonempty_agents  intro: Ri.not_outside)
qed

lemma lift_pref_profile_Pareto_strict_iff:
  "x \<prec>[Pareto(R')] y \<longleftrightarrow> x \<in> alts' \<and> y \<in> alts' \<and> (x \<notin> alts \<and> y \<in> alts \<or> x \<prec>[Pareto(R)] y)"
  by (auto simp: strongly_preferred_def lift_pref_profile_Pareto_iff R.Pareto.not_outside)

lemma pareto_losers_lift_pref_profile:
  shows   "pareto_losers R' = pareto_losers R \<union> (alts' - alts)"
proof -
  have A: "x \<in> alts" "y \<in> alts" if "x \<prec>[Pareto(R)] y" for x y
    using that R.Pareto.not_outside unfolding strongly_preferred_def by auto
  have B: "x \<in> alts'" if "x \<in> alts" for x using election that by blast
  from R.nonempty_alts obtain x where x: "x \<in> alts" by blast
  thus ?thesis unfolding pareto_losers_def lift_pref_profile_Pareto_strict_iff [abs_def]
    by (auto dest: A B)
qed

end

subsection \<open>Lowering SCFs\<close>

text \<open>
  Using the preference lifting, we can now \emph{lower} an SCF to a setting with fewer agents
  and alternatives under mild conditions to the original SCF. This preserves many nice properties,
  such as anonymity, neutrality, and strategyproofness.
\<close>

locale scf_lowering =
  pareto_efficient_scf agents alts scf
  for agents :: "'agent set" and alts :: "'alt set" and scf +
  fixes agents' alts'
  assumes agents'_subset: "agents' \<subseteq> agents" and alts'_subset: "alts' \<subseteq> alts"
      and agents'_nonempty [simp]: "agents' \<noteq> {}" and alts'_nonempty [simp]: "alts' \<noteq> {}"
begin

lemma finite_agents' [simp]: "finite agents'"
  using agents'_subset finite_agents by (rule finite_subset)

lemma finite_alts' [simp]: "finite alts'"
  using alts'_subset finite_alts by (rule finite_subset)

abbreviation lift :: "('agent, 'alt) pref_profile \<Rightarrow> ('agent, 'alt) pref_profile" where
  "lift \<equiv> lift_pref_profile agents' alts' agents alts"

definition lowered :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt set" where
  "lowered = scf \<circ> lift"

lemma lift_wf [simp, intro]:
  "pref_profile_wf agents' alts' R \<Longrightarrow> is_pref_profile (lift R)"
  using alts'_subset agents'_subset by (intro lift_pref_profile_wf) simp_all

sublocale lowered: election agents' alts'
  by unfold_locales simp_all

lemma preferred_alts_lift:
  "lowered.is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> x \<in> alts \<Longrightarrow>
     preferred_alts (lift R i) x =
       (if i \<in> agents' \<and> x \<in> alts' then preferred_alts (R i) x else alts)"
  using alts'_subset agents'_subset
  by (intro preferred_alts_lift_pref_profile) simp_all

lemma pareto_losers_lift:
  "lowered.is_pref_profile R \<Longrightarrow> pareto_losers (lift R) = pareto_losers R \<union> (alts - alts')"
  using agents'_subset alts'_subset by (intro pareto_losers_lift_pref_profile) simp_all

sublocale lowered: social_choice_function agents' alts' lowered
proof
  fix R assume R_wf: "pref_profile_wf agents' alts' R"
  from R_wf have R'_wf: "pref_profile_wf agents alts (lift R)" by (rule lift_wf)
  show "lowered R \<subseteq> alts'"
  proof safe
    fix x assume "x \<in> lowered R"
    hence "x \<in> scf (lift R)" by (auto simp: o_def lowered_def)
    moreover have "scf (lift R) \<inter> pareto_losers (lift R) = {}"
      by (intro pareto_efficient R'_wf)
    ultimately show "x \<in> alts'" using scf_alts[of "lift R"]
      by (auto simp: pareto_losers_lift R_wf R'_wf)
  qed
  show "lowered R \<noteq> {}"
    using R'_wf by (auto simp: lowered_def scf_nonempty)
qed

sublocale lowered: pareto_efficient_scf agents' alts' lowered
proof
  fix R assume R_wf: "pref_profile_wf agents' alts' R"
  from R_wf have R'_wf: "pref_profile_wf agents alts (lift R)" by (rule lift_wf)
  have "lowered R \<inter> pareto_losers (lift R) = {}" unfolding lowered_def o_def
    by (intro pareto_efficient R'_wf)
  with R_wf show "lowered R \<inter> pareto_losers R = {}"
    by (auto simp: pareto_losers_lift)
qed

end

locale scf_lowering_anonymous =
  anonymous_scf agents alts scf +
  scf_lowering agents alts scf agents' alts'
  for agents :: "'agent set" and alts :: "'alt set" and scf agents' alts'
begin

sublocale lowered: anonymous_scf agents' alts' lowered
proof
  fix \<pi> R
  assume "\<pi> permutes agents'" and "lowered.is_pref_profile R"
  thus "lowered (R \<circ> \<pi>) = lowered R" using agents'_subset
    by (auto simp: lowered_def lift_pref_profile_permute_agents anonymous permutes_subset)
qed

end

locale scf_lowering_neutral =
  neutral_scf agents alts scf +
  scf_lowering agents alts scf agents' alts'
  for agents :: "'agent set" and alts :: "'alt set" and scf agents' alts'
begin

sublocale lowered: neutral_scf agents' alts' lowered
proof
  fix \<sigma> R
  assume "\<sigma> permutes alts'" and "lowered.is_pref_profile R"
  thus "lowered (permute_profile \<sigma> R) = \<sigma> ` lowered R" using alts'_subset
    by (auto simp: lowered_def lift_pref_profile_permute_alts neutral permutes_subset)
qed

end

text \<open>
  The following is a technical condition that we need from a set extensions in order for
  strategyproofness to survive the lowering. The condition could probably be weakened a bit,
  but it is good enough for our purposes the way it is.
\<close>
locale liftable_set_extension =
  fixes alts' alts :: "'alt set" and set_ext :: "'alt relation \<Rightarrow> 'alt set relation"
  assumes set_ext_strong_lift:
    "total_preorder_on alts' R \<Longrightarrow> A \<noteq> {} \<Longrightarrow> B \<noteq> {} \<Longrightarrow> A \<subseteq> alts' \<Longrightarrow> B \<subseteq> alts' \<Longrightarrow>
       A \<prec>[set_ext R] B \<Longrightarrow> A \<prec>[set_ext (lift_prefs alts' alts R)] B"

lemma liftable_set_extensionI_weak:
  assumes "\<And>R A B. total_preorder_on alts' R \<Longrightarrow> A \<noteq> {} \<Longrightarrow> B \<noteq> {} \<Longrightarrow>
                      A \<subseteq> alts' \<Longrightarrow> B \<subseteq> alts' \<Longrightarrow>
              A \<preceq>[set_ext R] B \<longleftrightarrow> A \<preceq>[set_ext (lift_prefs alts' alts R)] B"
  shows   "liftable_set_extension alts' alts set_ext"
proof (standard, goal_cases)
  case (1 R A B)
  from assms[of R A B] and assms[of R B A] and 1 show ?case
    by (auto simp: strongly_preferred_def)
qed

lemma Kelly_liftable:
  assumes "alts' \<subseteq> alts"
  shows   "liftable_set_extension alts' alts Kelly"
proof (rule liftable_set_extensionI_weak, goal_cases)
  case (1 R A B)
  interpret R: total_preorder_on alts' R by fact
  from 1(2-5) show ?case using assms  R.refl
    by (force simp: Kelly_def lift_prefs_def)
qed

lemma Fishburn_liftable:
  assumes "alts' \<subseteq> alts"
  shows   "liftable_set_extension alts' alts Fishb"
proof (rule liftable_set_extensionI_weak, goal_cases)
  case (1 R A B)
  interpret R: total_preorder_on alts' R by fact
  have conj_cong: "P1 \<and> Q1 \<longleftrightarrow> P2 \<and> Q2" if "P1 \<longleftrightarrow> P2" "Q1 \<longleftrightarrow> Q2" for P1 P2 Q1 Q2
    using that by blast
  from 1(2-5) show ?case using assms
    unfolding Fishb_def lift_prefs_def by (intro conj_cong ball_cong refl) auto
qed

locale scf_lowering_strategyproof =
  strategyproof_scf agents alts scf set_ext +
  liftable_set_extension alts' alts set_ext +
  scf_lowering agents alts scf agents' alts'
  for agents :: "'agent set" and alts :: "'alt set" and scf agents' alts' set_ext
begin

sublocale lowered: strategyproof_scf agents' alts' lowered
proof
  fix R Ri' i
  assume R_wf: "lowered.is_pref_profile R" and Ri'_wf: "total_preorder_on alts' Ri'"
     and i: "i \<in> agents'"
  interpret R: pref_profile_wf agents' alts' R by fact
  interpret Ri': total_preorder_on alts' Ri' by fact
  from R_wf have R'_wf: "is_pref_profile (lift R)" by (rule lift_wf)

  \<comment> \<open>We lift the alternative preference for the agent @{term i} in @{term R} to
      preferences in the lifted profile. \<close>
  define Ri'' where "Ri'' = lift_prefs alts' alts Ri'"

  have "\<not>scf (lift R) \<prec>[set_ext (lift R i)] scf ((lift R)(i := Ri''))"
    using i agents'_subset alts'_subset unfolding Ri''_def
    by (intro strategyproof R'_wf Ri'_wf lift_prefs_wf) auto
  also have "(lift R)(i := Ri'') = lift (R(i := Ri'))" using i agents'_subset
    by (auto simp: fun_eq_iff Ri''_def lift_pref_profile_def lift_prefs_def)
  finally have not_less: "\<not>scf (lift R) \<prec>[set_ext (lift R i)] scf (lift (R(i := Ri')))" .

  show "\<not>lowered R \<prec>[set_ext (R i)] lowered (R(i := Ri'))"
  proof
    assume "lowered R \<prec>[set_ext (R i)] lowered (R(i := Ri'))"
    hence "lowered R \<prec>[set_ext (lift_prefs alts' alts (R i))] lowered (R(i := Ri'))"
      by (intro set_ext_strong_lift R.prefs_wf'(1) i lowered.scf_nonempty lowered.scf_alts
                R.wf_update R_wf Ri'_wf)
    also have "lift_prefs alts' alts (R i) = lift R i"
      using agents'_subset i by (subst lift_pref_profile_conv_vector) auto
    finally show False using not_less unfolding lowered_def o_def by contradiction
  qed
qed

end

end


theory HW10
  imports Main
begin

text\<open> 'blast' is invoked four times, once in the proof of each of
      lemmas E1, F1, G1, and H1 below \<close>

(* lemma E1 is the same in Exercise 2.3.9 (e), page 161, in [LCS] *)
lemma E1 : "\<forall> x. (P x \<or> Q x) \<Longrightarrow> (\<forall> x. P x) \<or> (\<exists> x. Q x)"
  apply clarify
  apply (erule allE)
  apply (erule disjE)
   apply assumption
  apply (erule notE)
  apply (rule exI)
  apply assumption
  done

(* lemma F1 is the same in Exercise 2.3.9 (f), page 161, in [LCS] *)
lemma F1 : "\<forall> x. \<exists> y. (P x \<or> Q y) \<Longrightarrow> \<exists> y. \<forall> x. (P x \<or> Q y)"
  apply (rule exCI)
  apply (rule allI)
  apply (erule_tac x="x" in allE)
  apply (rotate_tac 1, erule exE)
  apply (erule_tac x="y" in allE)
  apply (erule disjE, rule disjI1, assumption)
  apply (rule disjI2, erule notE, rule allI)
  apply (rule disjI2, assumption)
  done

(* lemma G1 is the same in Exercise 2.3.9 (g), page 161, in [LCS] *)
lemma G1 : "\<forall> x. (\<not> P x \<and> Q x) \<Longrightarrow> (\<forall> x. P x \<longrightarrow> Q x)"
  apply (rule allI)
  apply (rule impI)
  apply (erule allE)
  apply (erule conjE)
  apply assumption
  done

(* lemma H1 is the same in Exercise 2.3.9 (h), page 161, in [LCS] *)
lemma H1 : "\<forall> x. (P x \<and> Q x) \<Longrightarrow> (\<forall> x. P x \<longrightarrow> Q x)"
  apply (rule allI)
  apply (rule impI)
  apply (erule allE)
  apply (erule conjE)
  apply assumption
  done

end


(*  Title:      ZF/Induct/Mutil.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section \<open>The Mutilated Chess Board Problem, formalized inductively\<close>

theory Mutil imports ZF begin

text \<open>
  Originator is Max Black, according to J A Robinson.  Popularized as
  the Mutilated Checkerboard Problem by J McCarthy.
\<close>

consts
  domino :: i
  tiling :: "i \<Rightarrow> i"

inductive
  domains "domino" \<subseteq> "Pow(nat \<times> nat)"
  intros
    horiz: "\<lbrakk>i \<in> nat;  j \<in> nat\<rbrakk> \<Longrightarrow> {\<langle>i,j\<rangle>, <i,succ(j)>} \<in> domino"
    vertl: "\<lbrakk>i \<in> nat;  j \<in> nat\<rbrakk> \<Longrightarrow> {\<langle>i,j\<rangle>, <succ(i),j>} \<in> domino"
  type_intros empty_subsetI cons_subsetI PowI SigmaI nat_succI

inductive
  domains "tiling(A)" \<subseteq> "Pow(\<Union>(A))"
  intros
    empty: "0 \<in> tiling(A)"
    Un: "\<lbrakk>a \<in> A;  t \<in> tiling(A);  a \<inter> t = 0\<rbrakk> \<Longrightarrow> a \<union> t \<in> tiling(A)"
  type_intros empty_subsetI Union_upper Un_least PowI
  type_elims PowD [elim_format]

definition
  evnodd :: "[i, i] \<Rightarrow> i"  where
  "evnodd(A,b) \<equiv> {z \<in> A. \<exists>i j. z = \<langle>i,j\<rangle> \<and> (i #+ j) mod 2 = b}"

subsection \<open>Basic properties of evnodd\<close>

lemma evnodd_iff: "\<langle>i,j\<rangle>: evnodd(A,b) \<longleftrightarrow> \<langle>i,j\<rangle>: A \<and> (i#+j) mod 2 = b"
  by (unfold evnodd_def) blast

lemma evnodd_subset: "evnodd(A, b) \<subseteq> A"
  by (unfold evnodd_def) blast

lemma Finite_evnodd: "Finite(X) \<Longrightarrow> Finite(evnodd(X,b))"
  by (rule lepoll_Finite, rule subset_imp_lepoll, rule evnodd_subset)

lemma evnodd_Un: "evnodd(A \<union> B, b) = evnodd(A,b) \<union> evnodd(B,b)"
  by (simp add: evnodd_def Collect_Un)

lemma evnodd_Diff: "evnodd(A - B, b) = evnodd(A,b) - evnodd(B,b)"
  by (simp add: evnodd_def Collect_Diff)

lemma evnodd_cons [simp]:
  "evnodd(cons(\<langle>i,j\<rangle>,C), b) =
    (if (i#+j) mod 2 = b then cons(\<langle>i,j\<rangle>, evnodd(C,b)) else evnodd(C,b))"
  by (simp add: evnodd_def Collect_cons)

lemma evnodd_0 [simp]: "evnodd(0, b) = 0"
  by (simp add: evnodd_def)

subsection \<open>Dominoes\<close>

lemma domino_Finite: "d \<in> domino \<Longrightarrow> Finite(d)"
  by (blast intro!: Finite_cons Finite_0 elim: domino.cases)

lemma domino_singleton:
    "\<lbrakk>d \<in> domino; b<2\<rbrakk> \<Longrightarrow> \<exists>i' j'. evnodd(d,b) = {<i',j'>}"
  apply (erule domino.cases)
   apply (rule_tac [2] k1 = "i#+j" in mod2_cases [THEN disjE])
     apply (rule_tac k1 = "i#+j" in mod2_cases [THEN disjE])
       apply (rule add_type | assumption)+
      (*Four similar cases: case (i#+j) mod 2 = b, 2#-b, ...*)
      apply (auto simp add: mod_succ succ_neq_self dest: ltD)
  done

subsection \<open>Tilings\<close>

text \<open>The union of two disjoint tilings is a tiling\<close>

lemma tiling_UnI:
    "t \<in> tiling(A) \<Longrightarrow> u \<in> tiling(A) \<Longrightarrow> t \<inter> u = 0 \<Longrightarrow> t \<union> u \<in> tiling(A)"
  apply (induct set: tiling)
   apply (simp add: tiling.intros)
  apply (simp add: Un_assoc subset_empty_iff [THEN iff_sym])
  apply (blast intro: tiling.intros)
  done

lemma tiling_domino_Finite: "t \<in> tiling(domino) \<Longrightarrow> Finite(t)"
  apply (induct set: tiling)
   apply (rule Finite_0)
  apply (blast intro!: Finite_Un intro: domino_Finite)
  done

lemma tiling_domino_0_1: "t \<in> tiling(domino) \<Longrightarrow> |evnodd(t,0)| = |evnodd(t,1)|"
  apply (induct set: tiling)
   apply (simp add: evnodd_def)
  apply (rule_tac b1 = 0 in domino_singleton [THEN exE])
    prefer 2
    apply simp
   apply assumption
  apply (rule_tac b1 = 1 in domino_singleton [THEN exE])
    prefer 2
    apply simp
   apply assumption
  apply safe
  apply (subgoal_tac "\<forall>p b. p \<in> evnodd (a,b) \<longrightarrow> p\<notin>evnodd (t,b)")
   apply (simp add: evnodd_Un Un_cons tiling_domino_Finite
     evnodd_subset [THEN subset_Finite] Finite_imp_cardinal_cons)
  apply (blast dest!: evnodd_subset [THEN subsetD] elim: equalityE)
  done

lemma dominoes_tile_row:
    "\<lbrakk>i \<in> nat;  n \<in> nat\<rbrakk> \<Longrightarrow> {i} * (n #+ n) \<in> tiling(domino)"
  apply (induct_tac n)
   apply (simp add: tiling.intros)
  apply (simp add: Un_assoc [symmetric] Sigma_succ2)
  apply (rule tiling.intros)
    prefer 2 apply assumption
   apply (rename_tac n')
   apply (subgoal_tac (*seems the easiest way of turning one to the other*)
     "{i}*{succ (n'#+n') } \<union> {i}*{n'#+n'} =
       {<i,n'#+n'>, <i,succ (n'#+n') >}")
    prefer 2 apply blast
  apply (simp add: domino.horiz)
  apply (blast elim: mem_irrefl mem_asym)
  done

lemma dominoes_tile_matrix:
    "\<lbrakk>m \<in> nat;  n \<in> nat\<rbrakk> \<Longrightarrow> m * (n #+ n) \<in> tiling(domino)"
  apply (induct_tac m)
   apply (simp add: tiling.intros)
  apply (simp add: Sigma_succ1)
  apply (blast intro: tiling_UnI dominoes_tile_row elim: mem_irrefl)
  done

lemma eq_lt_E: "\<lbrakk>x=y; x<y\<rbrakk> \<Longrightarrow> P"
  by auto

theorem mutil_not_tiling: "\<lbrakk>m \<in> nat;  n \<in> nat;
         t = (succ(m)#+succ(m))*(succ(n)#+succ(n));
         t' = t - {\<langle>0,0\<rangle>} - {<succ(m#+m), succ(n#+n)>}\<rbrakk>
      \<Longrightarrow> t' \<notin> tiling(domino)"
  apply (rule notI)
  apply (drule tiling_domino_0_1)
  apply (erule_tac x = "|A|" for A in eq_lt_E)
  apply (subgoal_tac "t \<in> tiling (domino)")
   prefer 2 (*Requires a small simpset that won't move the succ applications*)
   apply (simp only: nat_succI add_type dominoes_tile_matrix)
  apply (simp add: evnodd_Diff mod2_add_self mod2_succ_succ
    tiling_domino_0_1 [symmetric])
  apply (rule lt_trans)
   apply (rule Finite_imp_cardinal_Diff,
     simp add: tiling_domino_Finite Finite_evnodd Finite_Diff,
     simp add: evnodd_iff nat_0_le [THEN ltD] mod2_add_self)+
  done

end


section \<open> UTP Predicates \<close>

theory utp_pred
  imports
    "HOL-Library.Order_Continuity"
    "Z_Toolkit.Z_Toolkit"
    "Shallow-Expressions.Shallow_Expressions"
begin

unbundle Expression_Syntax Z_Syntax

subsection \<open> Core Definitions \<close>

text \<open> We collect all definitional equations in a theorem attribute, to aid proof automation. \<close>

named_theorems pred

type_synonym 's pred = "'s \<Rightarrow> bool"

definition true_pred :: "'s pred" ("true") where [pred]: "true_pred = (True)\<^sub>e"
definition false_pred :: "'s pred" ("false") where [pred]: "false_pred = (False)\<^sub>e"

definition conj_pred :: "'s pred \<Rightarrow> 's pred \<Rightarrow> 's pred" where
[pred]: "conj_pred = inf"

definition disj_pred :: "'s pred \<Rightarrow> 's pred \<Rightarrow> 's pred" where
[pred]: "disj_pred = sup"

definition not_pred :: "'s pred \<Rightarrow> 's pred" where
[pred]: "not_pred = uminus"

definition diff_pred :: "'s pred \<Rightarrow> 's pred \<Rightarrow> 's pred" where
[pred]: "diff_pred = minus"

definition impl_pred :: "'s pred \<Rightarrow> 's pred \<Rightarrow> 's pred" where
[pred]: "impl_pred P Q = (\<lambda>s. P s \<longrightarrow> Q s)"

subsection \<open> Syntax \<close>

text \<open> We want to remain as close as possible to the mathematical UTP syntax, but also
       want to be conservative with HOL. For this reason we chose not to steal syntax
       from HOL, but where possible use polymorphism to allow selection of the appropriate
       operator (UTP vs. HOL). Thus we will first remove the standard syntax for conjunction,
       disjunction, and negation, and replace these with overloaded definitions. We
       similarly use polymorphic constants for the other predicate calculus operators. \<close>

consts
  uconj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  udisj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  unot  :: "'a \<Rightarrow> 'a"
  uimplies :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"

adhoc_overloading
  uconj conj and uconj conj_pred and
  udisj disj and udisj disj_pred and
  unot Not and unot not_pred and
  uimplies implies and uimplies impl_pred

text \<open> The following bundle sets up the syntax for our overloaded operators, following the same
  syntax provide in HOL. \<close>

bundle UTP_Logic_Syntax
begin

no_notation
  conj (infixr "\<and>" 35) and
  disj (infixr "\<or>" 30) and
  Not ("\<not> _" [40] 40) and
  implies (infixr "\<longrightarrow>" 25)

notation
  uconj (infixr "\<and>" 35) and
  udisj (infixr "\<or>" 30) and
  unot ("\<not> _" [40] 40) and
  uimplies (infixr "\<longrightarrow>" 25)

end

unbundle UTP_Logic_Syntax

subsection \<open> Proof Strategy \<close>

lemma pred_refine_iff: "P \<sqsubseteq> Q \<longleftrightarrow> (\<forall> s. Q s \<longrightarrow> P s)"
  by (simp add: ref_by_bool_def ref_by_fun_def)

lemma pred_ref_iff_le: "(f :: 's pred) \<sqsubseteq> g \<longleftrightarrow> g \<le> f"
  by (simp add: le_fun_def pred_refine_iff)

method pred_simp uses assms add = (insert assms, (simp add: pred expr_simps add)?; expr_simp add: pred_refine_iff add)
method pred_auto uses assms add = (insert assms, (simp add: pred expr_simps add)?; expr_auto add: pred_refine_iff add)

declare expr_if_def [pred]

subsection \<open> Algebraic Structures \<close>

interpretation pred_ba: boolean_algebra diff_pred not_pred conj_pred "(\<sqsupseteq>)" "(\<sqsupset>)"
  disj_pred false_pred true_pred
  by (unfold_locales; pred_auto add: sref_by_fun_def)

lemmas ref_antisym = pred_ba.order.antisym

interpretation ref_lattice: complete_lattice Sup Inf sup "(\<sqsubseteq>)" "(\<sqsubset>)" inf true_pred false_pred
  by (unfold_locales, pred_auto)+

lemma ref_by_pred_is_leq: "((\<sqsubseteq>) :: 'a pred \<Rightarrow> 'a pred \<Rightarrow> bool) = (\<ge>)"
  by (simp add: fun_eq_iff pred_ref_iff_le)

subsection \<open> Lattice syntax \<close>

text \<open> In accordance with \cite{hoare1998}, we turn the lattice operators upside down \<close>

bundle utp_lattice_syntax
begin

notation
  bot ("\<top>") and
  top ("\<bottom>") and
  inf  (infixl "\<squnion>" 70) and
  sup  (infixl "\<sqinter>" 65) and
  Inf  ("\<Squnion> _" [900] 900) and
  Sup  ("\<Sqinter> _" [900] 900)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)

end

unbundle utp_lattice_syntax

subsection \<open> Substitution Laws \<close>

lemma subst_pred [usubst]:
  "\<sigma> \<dagger> true = true"
  "\<sigma> \<dagger> false = false"
  "\<sigma> \<dagger> (P \<and> Q) = ((\<sigma> \<dagger> P) \<and> (\<sigma> \<dagger> Q))"
  "\<sigma> \<dagger> (P \<or> Q) = ((\<sigma> \<dagger> P) \<or> (\<sigma> \<dagger> Q))"
  "\<sigma> \<dagger> (P \<longrightarrow> Q) = ((\<sigma> \<dagger> P) \<longrightarrow> (\<sigma> \<dagger> Q))"
  "\<sigma> \<dagger> (\<not> P) = (\<not> (\<sigma> \<dagger> P))"
  by pred_auto+

lemma subst_INF_SUP [usubst]:
  "\<sigma> \<dagger> (\<Sqinter> i. P(i)) = (\<Sqinter> i. \<sigma> \<dagger> P(i))"
  "\<sigma> \<dagger> (\<Sqinter> i\<in>I. P(i)) = (\<Sqinter> i\<in>I. \<sigma> \<dagger> P(i))"
  "\<sigma> \<dagger> (\<Squnion> i. P(i)) = (\<Squnion> i. \<sigma> \<dagger> P(i))"
  "\<sigma> \<dagger> (\<Squnion> i\<in>I. P(i)) = (\<Squnion> i\<in>I. \<sigma> \<dagger> P(i))"
  by (pred_auto add: image_image)+

subsection \<open> Unrestriction Laws \<close>

lemma unrest_pred [unrest]:
  "a \<sharp> true" "a \<sharp> false"
  "\<lbrakk> a \<sharp> P; a \<sharp> Q \<rbrakk> \<Longrightarrow> a \<sharp> P \<and> Q"
  "\<lbrakk> a \<sharp> P; a \<sharp> Q \<rbrakk> \<Longrightarrow> a \<sharp> P \<or> Q"
  "\<lbrakk> a \<sharp> P; a \<sharp> Q \<rbrakk> \<Longrightarrow> a \<sharp> P \<longrightarrow> Q"
  "a \<sharp> P \<Longrightarrow> a \<sharp> \<not> P"
  by (pred_auto+)

lemma unrest_INF_SUP [unrest]:
  "\<lbrakk> \<And> i. a \<sharp> P(i) \<rbrakk> \<Longrightarrow> a \<sharp> (\<Sqinter> i. P(i))"
  "\<lbrakk> \<And> i. i \<in> I \<Longrightarrow> a \<sharp> P(i) \<rbrakk> \<Longrightarrow> a \<sharp> (\<Sqinter> i\<in>I. P(i))"
  "\<lbrakk> \<And> i. a \<sharp> P(i) \<rbrakk> \<Longrightarrow> a \<sharp> (\<Squnion> i. P(i))"
  "\<lbrakk> \<And> i. i \<in> I \<Longrightarrow> a \<sharp> P(i) \<rbrakk> \<Longrightarrow> a \<sharp> (\<Squnion> i\<in>I. P(i))"
  by (pred_auto add: image_image)+

end


section \<open>Compatibility with the Graph Theory Package\<close>

theory Graph_TheoryCompatibility
imports
  ParityGame
  Graph_Theory.Digraph
  Graph_Theory.Digraph_Isomorphism
begin

text \<open>
  In this section, we show that our @{locale Digraph} locale is compatible to the
  @{locale nomulti_digraph} locale from the graph theory package from the Archive of Formal Proofs.

  For this, we will define two functions converting between the different types and show that with
  these conversion functions the locales interpret each other.  Together, this indicates that our
  definition of digraph is reasonable.
\<close>

subsection \<open>To Graph Theory\<close>

text \<open>We can easily convert our graphs into @{type pre_digraph} objects.\<close>
definition to_pre_digraph :: "('a, 'b) Graph_scheme \<Rightarrow> ('a, 'a \<times> 'a) pre_digraph"
  where "to_pre_digraph G \<equiv> \<lparr>
    pre_digraph.verts = Graph.verts G,
    pre_digraph.arcs = Graph.arcs G,
    tail = fst,
    head = snd
  \<rparr>"

text \<open>
  With this conversion function, our @{locale Digraph} locale contains the locale
  @{locale nomulti_digraph} from the graph theory package.
\<close>
context Digraph begin
interpretation is_nomulti_digraph: nomulti_digraph "to_pre_digraph G" proof
  fix e assume *: "e \<in> pre_digraph.arcs (to_pre_digraph G)"
  show "tail (to_pre_digraph G) e \<in> pre_digraph.verts (to_pre_digraph G)"
    by (metis * edges_are_in_V(1) pre_digraph.ext_inject pre_digraph.surjective prod.collapse to_pre_digraph_def)
  show "head (to_pre_digraph G) e \<in> pre_digraph.verts (to_pre_digraph G)"
    by (metis * edges_are_in_V(2) pre_digraph.ext_inject pre_digraph.surjective prod.collapse to_pre_digraph_def)
qed (simp add: arc_to_ends_def to_pre_digraph_def)
end

subsection \<open>From Graph Theory\<close>

text \<open>We can also convert in the other direction.\<close>
definition from_pre_digraph :: "('a, 'b) pre_digraph \<Rightarrow> 'a Graph"
  where "from_pre_digraph G \<equiv> \<lparr>
    Graph.verts = pre_digraph.verts G,
    Graph.arcs = arcs_ends G
  \<rparr>"

context nomulti_digraph begin
interpretation is_Digraph: Digraph "from_pre_digraph G" proof-
  {
    fix v w assume "(v,w) \<in> E\<^bsub>from_pre_digraph G\<^esub>"
    then obtain e where e: "e \<in> pre_digraph.arcs G" "tail G e = v" "head G e = w"
      unfolding from_pre_digraph_def by auto
    hence "(v,w) \<in> V\<^bsub>from_pre_digraph G\<^esub> \<times> V\<^bsub>from_pre_digraph G\<^esub>"
      unfolding from_pre_digraph_def by auto
  }
  thus "Digraph (from_pre_digraph G)" by (simp add: Digraph.intro subrelI)
qed
end

subsection \<open>Isomorphisms\<close>

text \<open>
  We also show that our conversion functions make sense.  That is, we show that they are nearly
  inverses of each other.  Unfortunately, @{const from_pre_digraph} irretrievably loses information
  about the arcs, and only keeps tail/head intact, so the best we can get for this case is that the
  back-and-forth converted graphs are isomorphic.
\<close>

lemma graph_conversion_bij: "G = from_pre_digraph (to_pre_digraph G)"
  unfolding to_pre_digraph_def from_pre_digraph_def arcs_ends_def arc_to_ends_def by auto

lemma (in nomulti_digraph) graph_conversion_bij2: "digraph_iso G (to_pre_digraph (from_pre_digraph G))"
proof-
  define iso
    where "iso = \<lparr>
      iso_verts = id :: 'a \<Rightarrow> 'a,
      iso_arcs = arc_to_ends G,
      iso_head = snd,
      iso_tail = fst
    \<rparr>"

  have "inj_on (iso_verts iso) (pre_digraph.verts G)" unfolding iso_def by auto
  moreover have "inj_on (iso_arcs iso) (pre_digraph.arcs G)"
    unfolding iso_def arc_to_ends_def by (simp add: arc_to_ends_def inj_onI no_multi_arcs)
  moreover have "\<forall>a \<in> pre_digraph.arcs G.
    iso_verts iso (tail G a) = iso_tail iso (iso_arcs iso a)
    \<and> iso_verts iso (head G a) = iso_head iso (iso_arcs iso a)"
    unfolding iso_def by (simp add: arc_to_ends_def)

  ultimately have "digraph_isomorphism iso"
    unfolding digraph_isomorphism_def using arc_to_ends_def wf_digraph_axioms by blast

  moreover have "to_pre_digraph (from_pre_digraph G) = app_iso iso G"
      unfolding to_pre_digraph_def from_pre_digraph_def iso_def app_iso_def by (simp_all add: arcs_ends_def)

  ultimately show ?thesis unfolding digraph_iso_def by blast
qed

end


(*  Title:      CoW_Lyndon.Lyndon_Addition
    Author:     Štěpán Holub, Charles University
    Author:     Štěpán Starosta, CTU in Prague

Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
*)

theory Lyndon_Addition
  imports Lyndon Szpilrajn.Szpilrajn

begin

subsection "The minimal relation"

text \<open>We define the minimal relation which guarantees the lexicographic minimality of w compared to its
nontrivial conjugates.\<close>

inductive_set rotate_rel :: "'a list \<Rightarrow> 'a rel" for w
  where  "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> (mismatch_pair w (rotate n w)) \<in> rotate_rel w"

text\<open>A word is Lyndon iff the corresponding order of letters is compatible with  @{term "rotate_rel w"}.\<close>

lemma (in linorder) rotate_rel_iff: assumes "w \<noteq> \<epsilon>"
  shows  "Lyndon w \<longleftrightarrow> rotate_rel w \<subseteq> {(x,y). x < y}" (is "?L \<longleftrightarrow> ?R")
proof
  assume "Lyndon w" show "rotate_rel w \<subseteq> {(x,y). x < y}"
  proof
    fix  x assume "x \<in> rotate_rel w"
    then obtain n where "x = mismatch_pair w (rotate n w)" and "0 < n" and "n < \<^bold>|w\<^bold>|"
      using rotate_rel.cases by blast
    have "w <lex rotate n w"
      using LyndonD[OF \<open>Lyndon w\<close> \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>].
    from this[unfolded lexordp_conv_lexord]
      prim_no_rotate[OF Lyndon_prim[OF \<open>Lyndon w\<close>] \<open>0 < n\<close>  \<open>n < \<^bold>|w\<^bold>|\<close>]
    show "x \<in> {(a, b). a < b}"
      using lexord_mismatch[of w "rotate n w" "{(a,b). a < b}", folded \<open>x = mismatch_pair w (rotate n w)\<close>]
        \<open>rotate n w \<noteq> w\<close> rotate_comp_eq[of w n]
      unfolding irrefl_def by blast
  qed
next
  assume "?R"
  show "?L"
    unfolding Lyndon.simps
  proof(simp add: assms)
    have "w <lex rotate n w" if "0 < n"  "n < \<^bold>|w\<^bold>|" for n
    proof-
      have "\<not> w \<bowtie> rotate n w"
        using rotate_comp_eq[of w n] subsetD[OF \<open>?R\<close>, OF rotate_rel.intros[OF \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>]]
          mismatch_pair_lcp[of w "rotate n w"] by fastforce
      from mismatch_lexord_linorder[OF this subsetD[OF \<open>?R\<close>, OF rotate_rel.intros[OF \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>]]]
      show "w <lex rotate n w".
    qed
    thus "\<forall>n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w"  by blast
  qed
qed

text\<open>It is well known that an acyclic order can be extended to a total strict linear order. This means that
a word is Lyndon with respect to some order iff its @{term "rotate_rel w"} is acyclic.
\<close>
lemma Lyndon_rotate_rel_iff:
  "acyclic (rotate_rel w) \<longleftrightarrow> (\<exists> r. strict_linear_order r \<and> rotate_rel w \<subseteq> r)" (is "?L \<longleftrightarrow> ?R")
proof
  assume "?R" thus "?L"
    unfolding strict_linear_order_on_def acyclic_def irrefl_def
    using trancl_id trancl_mono by metis
next
  assume "?L" thus "?R"
    using acyclic_order_extension by auto
qed

lemma slo_linorder: "strict_linear_order r \<Longrightarrow> class.linorder (\<lambda> a b. (a,b) \<in> r\<^sup>=) (\<lambda> a b. (a,b) \<in> r)"
    unfolding strict_linear_order_on_def strict_partial_order_def irrefl_def trans_def total_on_def
    by unfold_locales blast+

text\<open>Application examples\<close>

lemma assumes "w \<noteq> \<epsilon>" and "acyclic (rotate_rel w)" shows "primitive w"
proof-
  obtain r where "strict_linear_order r" and "rotate_rel w \<subseteq> r"
    using Lyndon_rotate_rel_iff assms by auto

  interpret r: linorder "\<lambda> a b. (a,b) \<in> r\<^sup>=" "\<lambda> a b. (a,b) \<in> r"
    using slo_linorder[OF \<open>strict_linear_order r\<close>].

  have "r.Lyndon w"
    using r.rotate_rel_iff[OF \<open>w \<noteq> \<epsilon>\<close>] \<open>rotate_rel w \<subseteq> r\<close> by blast

  from r.Lyndon_prim[OF this]
  show "primitive w".

qed

lemma assumes "w \<noteq> \<epsilon>" and "acyclic (rotate_rel w)" shows "\<not> bordered w"
proof-
  obtain r where "strict_linear_order r" and "rotate_rel w \<subseteq> r"
    using Lyndon_rotate_rel_iff assms by auto

  interpret r: linorder "\<lambda> a b. (a,b) \<in> r\<^sup>=" "\<lambda> a b. (a,b) \<in> r"
    using slo_linorder[OF \<open>strict_linear_order r\<close>].

  have "r.Lyndon w"
    using r.rotate_rel_iff[OF \<open>w \<noteq> \<epsilon>\<close>] \<open>rotate_rel w \<subseteq> r\<close> by blast

  from r.Lyndon_unbordered[OF this]
  show "\<not> bordered w".
qed

end


(* original Author: Martin Desharnais
    updated to version 2016 by Michaël Noël Divo
*)
(*<*)
theory Untyped_Arithmetic_Expressions
imports Main
begin
(*>*)

section {* Untyped Arithmetic Expressions *}
text {* \label{sec:untyped-arith-expr} *}

text {*
The language of untyped arithmetic expressions consists of Boolean expressions, containing the
constants \texttt{true} and \texttt{false} and conditionals as primitives, and natural numbers,
containing the constant \texttt{zero}, the successor and predecessor functions and an operation to
test equality with zero as primitives. Following the book, we start with a subset containing only
the Boolean expression and carry on with fully fledged arithmetic expressions.
*}

subsection {* Booleans *}

text \<open>
The syntax of this language is defined, in the book, in the following way:
\begin{align*}
  t ::= & \\
    & \text{true} && \text{constant true} \\
    & \text{false} && \text{constant false} \\
    & \text{if } t \text{ then } t \text{ else } t && \text{conditional}
\end{align*}

Its counterpart, using Isabelle/HOL's syntax, is a recursive datatype: \footnote{To prevent
name clashes with Isabelle's predefined types and constants of the same name, our types and type
constructors are prefixed with \texttt{b}, which stand for \emph{Booleans}. Functions use a suffix
for the same purpose.}
\<close>

datatype bterm =
  BTrue |
  BFalse |
  BIf bterm bterm bterm

text \<open>
The semantics of the language is defined using the small-step operational semantics which consists
of an evaluation relation that performs the smallest possible step towards the final value. Values
are a subset of terms that are considered as the final output of a computation. For the Booleans,
the only values are the constants @{term BTrue} and @{term BFalse}. To describe these, the book uses
the following notation:
\begin{align*}
  t ::= & \\
    & \text{true} && \text{true value} \\
    & \text{false} && \text{false value}
\end{align*}

We translate this in Isabelle/HOL using an inductive predicate that returns true if its argument is
a value:
\<close>

inductive is_value_B :: "bterm \<Rightarrow> bool" where
  "is_value_B BTrue" |
  "is_value_B BFalse"

text \<open>
The evaluation relation is concerned with the way a conditional expression will be reduced. The book
uses the standard mathematical notation for inference rules:
\begin{gather}
  \inferrule {}{\text{if true then } t_2 \text{ else } t_3 \implies t_2} \\[0.8em]
  \inferrule {}{\text{if false then } t_2 \text{ else } t_3 \implies t_3} \\[0.8em]
  \inferrule {t_1 \implies t_1'}
    {\text{if } t_1 \text{ then } t_2 \text{ else } t_3
      \implies \text{if } t_1' \text{ then } t_2 \text{ else } t_3}
\end{gather}

The first rule states that the evaluation of a conditional with a true condition leads to the
``then'' branch, the second rule states that the evaluation of a conditional with a false condition
leads to the ``else'' branch and the third rule states that, if the condition is not a Boolean
constant, it must be itself evaluated. These rules translate easily into another inductive predicate
that returns true if the first argument can be reduced in one step to the second argument:
\<close>

inductive eval1_B :: "bterm \<Rightarrow> bterm \<Rightarrow> bool" where
  eval1_BIf_BTrue:
    "eval1_B (BIf BTrue t2 t3) t2" |
  eval1_BIf_BFalse:
    "eval1_B (BIf BFalse t2 t3) t3" |
  eval1_BIf:
    "eval1_B t1 t1' \<Longrightarrow> eval1_B (BIf t1 t2 t3) (BIf t1' t2 t3)"

(*<*)
(* Example of definition 3.5.3 *)

lemma
  assumes
    s: "s = BIf BTrue BFalse BFalse" and
    t: "t = BIf s BTrue BTrue" and
    u: "u = BIf BFalse BTrue BTrue"
  shows "eval1_B (BIf t BFalse BFalse) (BIf u BFalse BFalse)"
proof -
  have "eval1_B s BFalse" unfolding s by (rule eval1_BIf_BTrue)
  hence "eval1_B t u" unfolding t u by (rule eval1_BIf)
  thus ?thesis by (rule eval1_BIf)
qed
(*>*)
(* subsubsection {* Theorem 3.5.4 *} *)

text {*
With these basic definitions, we can turn to the first theorem: the determinacy of one-step
evaluation. This theorem states that the evaluation relation is deterministic (i.e. there is only
one way in which a given term can be evaluate). The focus of this paper being on the definitions and
theorems, we can skim over the proof, just highlighting that it goes by induction over the
evaluation relation and that it involves some case analyses:
*}

theorem eval1_B_determinacy:
  "eval1_B t t' \<Longrightarrow> eval1_B t t'' \<Longrightarrow> t' = t''"
proof (induction t t' arbitrary: t'' rule: eval1_B.induct)
  case (eval1_BIf_BTrue t1 t2)
  thus ?case by (auto elim: eval1_B.cases)
next
  case (eval1_BIf_BFalse t1 t2)
  thus ?case by (auto elim: eval1_B.cases)
next
  case (eval1_BIf t1 t1' t2 t3)
  from eval1_BIf.prems eval1_BIf.hyps show ?case
    by (auto dest: eval1_BIf.IH elim: eval1_B.cases)
qed

(* subsubsection {* Theorem 3.5.7 *} *)

text {*
A key concept is that of normal form, for which the book gives the following definition:
\begin{quotation}
  \noindent A term $t$ is in \emph{normal form} if no evaluation rule applies to it --- i.e.,
  if there is no $t'$ such that $t \to t'$.
\end{quotation}
Since this definition mainly introduces some standard terminology for a property of terms with
respect to the single-step evaluation relation, we translate it using a simple definition:
\newpage
*}

definition is_normal_form_B :: "bterm \<Rightarrow> bool" where
  "is_normal_form_B t \<longleftrightarrow> (\<forall>t'. \<not> eval1_B t t')"

text {*
We continue by proving that every value is in normal form:
*}

theorem value_imp_normal_form:
  "is_value_B t \<Longrightarrow> is_normal_form_B t"
by (auto elim: is_value_B.cases eval1_B.cases simp: is_normal_form_B_def)

(* subsubsection {* Theorem 3.5.8 *} *)

text {*
For this simple language, the converse is also true: every term in normal form is a value. Our proof
follows the book and use contradiction, structural induction over @{term t} and case analysis over
the possible values.
*}

theorem normal_form_imp_value:
  "is_normal_form_B t \<Longrightarrow> is_value_B t"
by (rule ccontr, induction t rule: bterm.induct)
  (auto
    intro: eval1_B.intros is_value_B.intros
    elim: is_value_B.cases
    simp: is_normal_form_B_def)

(* subsubsection {* Definition 3.5.9 *} *)

text {*
The one-step evaluation is a useful representation of the semantic of a language, but it does not
represent what really interests us: the final value of an evaluation. To this end, the book defines
a multi-step evaluation relation based on the single-step one:

\begin{quotation}
  \noindent The \emph{multi-step evaluation} relation $\to^*$ is the reflexive, transitive closure
  of one-step evaluation. That is, it is the smallest relation such that (1)~if t $t \to t'$ then
  $t \to^* t'$, (2)~$t \to^* t$ for all $t$, and (3)~if $t \to^* t'$ and $t' \to^* t''$, then
  $t \to^* t''$.
\end{quotation}

A direct translation to Isabelle/HOL would lead to the following definition:
*}

inductive eval_direct :: "bterm \<Rightarrow> bterm \<Rightarrow> bool" where
  e_once:
    "eval1_B t t' \<Longrightarrow> eval_direct t t'" |
  e_self:
    "eval_direct t t" |
  e_transitive:
    "eval_direct t t' \<Longrightarrow> eval_direct t' t'' \<Longrightarrow> eval_direct t t''"

text {*
However, this definition is inconvenient for theorem proving because it requires us to consider
three cases for each induction on a evaluation relation. Instead, we choose to define the multi-step
evaluation relation using a shape similar to a list of one-step evaluations. The inductive
definition consists of a base case, the reflexive application, and of an inductive case where one
step of evaluation is performed:
\newpage
*}

inductive eval_B :: "bterm \<Rightarrow> bterm \<Rightarrow> bool" where
  eval_B_base:
    "eval_B t t" |
  eval_B_step:
    "eval1_B t t' \<Longrightarrow> eval_B t' t'' \<Longrightarrow> eval_B t t''"

text {*
We then prove that this definition is equivalent to the direct translation of the definition found
in the book:
*}

lemma eval_B_once:
  "eval1_B t t' \<Longrightarrow> eval_B t t'"
by (simp add: eval_B.intros)

lemma eval_B_transitive:
  "eval_B t t' \<Longrightarrow> eval_B t' t'' \<Longrightarrow> eval_B t t''"
by (induction t t' rule: eval_B.induct) (auto intro: eval_B.intros)

lemma eval_direct_eq_eval_B:
  "eval_direct = eval_B"
proof ((rule ext)+, rule iffI)
  fix t t'
  assume "eval_direct t t'"
  thus "eval_B t t'"
    by (auto intro: eval_B.intros elim: eval_direct.induct eval_B_once eval_B_transitive)
next
  fix t t'
  assume "eval_B t t'"
  thus "eval_direct t t'"
    by (auto intro: e_self dest!: e_once elim: eval_B.induct e_transitive)
qed

(* subsubsection {* Corollary 3.5.11 *} *)

text {*
The next theorem we consider is the uniqueness of normal form, which is a corollary of the
determinacy of the single-step evaluation:
*}

corollary uniqueness_of_normal_form:
  "eval_B t u \<Longrightarrow> is_normal_form_B u \<Longrightarrow>
  eval_B t u' \<Longrightarrow> is_normal_form_B u' \<Longrightarrow>
  u = u'"
by (induction t u rule: eval_B.induct)
  (metis eval_B.cases is_normal_form_B_def eval1_B_determinacy)+

text {*
The last theorem we consider is the termination of evaluation. To prove it, we need first to add a
helper lemma, which was implicitly assumed in the book, about the size of terms after evaluation:
\newline
*}
(*<*)
(* subsubsection {* Theorem 3.5.12 *} *)

primrec size_B :: "bterm \<Rightarrow> nat" where
  "size_B BTrue = 1" |
  "size_B BFalse = 1" |
  "size_B (BIf t1 t2 t3) = 1 + size_B t1 + size_B t2 + size_B t3"
(*>*)
lemma eval_once_size_B:
  "eval1_B t t' \<Longrightarrow> size_B t > size_B t'"
by (induction t t' rule: eval1_B.induct) simp_all

theorem termination_of_evaluation:
  "\<exists>t'. eval_B t t' \<and> is_normal_form_B t'"
by (induction rule: measure_induct_rule[of size_B])
  (metis eval_B.intros eval_once_size_B is_normal_form_B_def)

subsection {* Arithmetic Expressions *}

text {*
We now turn to the fully fledged arithmetic expression language. The syntax is defined in the same
way as for Booleans:\footnote{The prefix \emph{nb} stands for \emph{numeric and Booleans}.}
*}

datatype nbterm =
  NBTrue |
  NBFalse |
  NBIf nbterm nbterm nbterm |
  NBZero |
  NBSucc nbterm |
  NBPred nbterm |
  NBIs_zero nbterm
(*<*)

(* subsubsection {* Definition 3.3.1 *} *)

primrec const_NB :: "nbterm \<Rightarrow> nbterm set" where
  "const_NB NBTrue = {NBTrue}" |
  "const_NB NBFalse = {NBFalse}" |
  "const_NB NBZero = {NBZero}" |
  "const_NB (NBSucc t) = const_NB t" |
  "const_NB (NBPred t) = const_NB t" |
  "const_NB (NBIs_zero t) = const_NB t" |
  "const_NB (NBIf t1 t2 t3) = const_NB t1 \<union> const_NB t2 \<union> const_NB t3"

(* subsubsection {* Definition 3.3.2 *} *)

primrec size_NB :: "nbterm \<Rightarrow> nat" where
  "size_NB NBTrue = 1" |
  "size_NB NBFalse = 1" |
  "size_NB NBZero = 1" |
  "size_NB (NBSucc t) = size_NB t + 1" |
  "size_NB (NBPred t) = size_NB t + 1" |
  "size_NB (NBIs_zero t) = size_NB t + 1" |
  "size_NB (NBIf t1 t2 t3) = size_NB t1 + size_NB t2 + size_NB t3 + 1"

primrec depth_NB :: "nbterm \<Rightarrow> nat" where
  "depth_NB NBTrue = 1" |
  "depth_NB NBFalse = 1" |
  "depth_NB NBZero = 1" |
  "depth_NB (NBSucc t) = depth_NB t + 1" |
  "depth_NB (NBPred t) = depth_NB t + 1" |
  "depth_NB (NBIs_zero t) = depth_NB t + 1" |
  "depth_NB (NBIf t1 t2 t3) = max (depth_NB t1) (max (depth_NB t2) (depth_NB t3)) + 1"

(* subsubsection {* Lemma 3.3.3 *} *)

lemma card_union_leq_sum_card: "card (A \<union> B) \<le> card A + card B"
  by (cases "finite A \<and> finite B") (simp only: card_Un_Int, auto)

lemma "card (const_NB t) \<le> size_NB t"
proof (induction t)
  case (NBIf t1 t2 t3)
  show ?case
  proof -
    let ?t1 = "const_NB t1"
    let ?t2 = "const_NB t2"
    let ?t3 = "const_NB t3"
    have "card (?t1 \<union> ?t2 \<union> ?t3) \<le> card ?t1 + card ?t2 + card ?t3"
      by (smt card_union_leq_sum_card add_le_imp_le_right le_antisym le_trans nat_le_linear)
    also have "\<dots> \<le> size_NB t1 + size_NB t2 + size_NB t3"
      using NBIf.IH by simp
    finally show ?thesis by simp
  qed
qed (simp_all add: le_SucI)

(* subsubsection {* Theorem 3.3.4 *} *)

(* changes: theorems command no longer exits in version 2016*)
lemmas induct_depth = measure_induct_rule[of depth_NB]
lemmas induct_size = measure_induct_rule [of size_NB]
lemmas structural_induction = nbterm.induct

(*>*)
text \<open>
Values now consist either of Booleans or numeric values, for which a separate inductive
definition is given. Here is the definition as found in the book:
\begin{align*}
  v ::= & \\
    & \text{true} && \text{true value} \\
    & \text{false} && \text{false value} \\
    & \text{nv} && \text{numeric value} \\
  nv ::= & \\
    & \text{0} && \text{zero value} \\
    & \text{succ nv} && \text{successor value}
\end{align*}

Our inductive definition is very similar, but contains explicit assumptions on the nature of
\texttt{nv}. The book uses naming conventions which define letters such as \texttt{t} as
always representing terms, letters such as \texttt{v} as always representing values and variants of
\texttt{nv} as always representing numeric values. In our formalization, such implicit assumption is
possible for \texttt{t} because Isabelle/HOL infers that @{term nberm} is the only type that could
be place at this position. Since values and numeric values do not have a proper type but
characterize a subset of terms, we must add assumptions to declare the nature of these variables:
\<close>

inductive is_numeric_value_NB :: "nbterm \<Rightarrow> bool" where
  "is_numeric_value_NB NBZero" |
  "is_numeric_value_NB nv \<Longrightarrow> is_numeric_value_NB (NBSucc nv)"

inductive is_value_NB :: "nbterm \<Rightarrow> bool" where
  "is_value_NB NBTrue" |
  "is_value_NB NBFalse" |
  "is_numeric_value_NB nv \<Longrightarrow> is_value_NB nv"

text {*
The single-step evaluation relation is a superset of the one defined for Booleans:
*}

inductive eval1_NB :: "nbterm \<Rightarrow> nbterm \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of Booleans\<close>
  eval1_NBIf_NBTrue:
    "eval1_NB (NBIf NBTrue t2 t3) t2" |
  eval1_NBIf_NBFalse:
    "eval1_NB (NBIf NBFalse t2 t3) t3" |
  eval1_NBIf:
    "eval1_NB t1 t1' \<Longrightarrow> eval1_NB (NBIf t1 t2 t3) (NBIf t1' t2 t3)" |

  \<comment> \<open>Rules relating to the evaluation of natural numbers\<close>
  eval1_NBSucc:
    "eval1_NB t t' \<Longrightarrow> eval1_NB (NBSucc t) (NBSucc t')" |
  eval1_NBPred_NBZero:
    "eval1_NB (NBPred NBZero) NBZero" |
  eval1_NBPred_NBSucc:
    "is_numeric_value_NB nv \<Longrightarrow> eval1_NB (NBPred (NBSucc nv)) nv" |
  eval1_NBPred:
    "eval1_NB t t' \<Longrightarrow> eval1_NB (NBPred t) (NBPred t')" |

  \<comment> \<open>Rules relating to the evaluation of the test for equality with zero\<close>
  eval1_NBIs_zero_NBZero:
    "eval1_NB (NBIs_zero NBZero) NBTrue" |
  eval1_NBIs_zero_NBSucc:
    "is_numeric_value_NB nv \<Longrightarrow> eval1_NB (NBIs_zero (NBSucc nv)) NBFalse" |
  eval1_NBIs_zero:
    "eval1_NB t t' \<Longrightarrow> eval1_NB (NBIs_zero t) (NBIs_zero t')"

text {*
The multi-step evaluation relation and the definition of normal form are perfectly analogous to
these for Booleans:
\newpage
*}

inductive eval_NB :: "nbterm \<Rightarrow> nbterm \<Rightarrow> bool" where
  eval_NB_base:
    "eval_NB t t" |
  eval_NB_step:
    "eval1_NB t t' \<Longrightarrow> eval_NB t' t'' \<Longrightarrow> eval_NB t t''"

definition is_normal_form_NB :: "nbterm \<Rightarrow> bool" where
  "is_normal_form_NB t \<longleftrightarrow> (\<forall>t'. \<not> eval1_NB t t')"

text {*
The reason is that all the actual work is performed by the single-step evaluation relation.

In the book, the section covering this fully fledged arithmetic expression language is mainly an
explanation of the constructions not present in the Boolean expression language and does not
contains any proper theorems. Nevertheless, we revisit the properties introduced for the language of
Booleans and either prove that they are still theorems or disprove them.
*}

(*<*)
(* Usefull lemmas *)

lemma eval1_NB_impl_eval_NB:
  "eval1_NB t t' \<Longrightarrow> eval_NB t t'"
by (simp add: eval_NB.intros)

lemma eval_NB_transitive:
  "eval_NB t t' \<Longrightarrow> eval_NB t' t'' \<Longrightarrow> eval_NB t t''"
by (induction t t' rule: eval_NB.induct) (auto intro: eval_NB.intros)

lemma not_eval_once_numeric_value:
  "is_numeric_value_NB nv \<Longrightarrow> eval1_NB nv t \<Longrightarrow> P"
by (induction nv arbitrary: t rule: is_numeric_value_NB.induct)
  (auto elim: eval1_NB.cases)

(* subsubsection {* Theorem 3.5.4 for Arithmetic Expressions *} *)
(*>*)

text {*
The determinacy of the single-step evaluation still holds:
*}

theorem eval1_NB_determinacy:
  "eval1_NB t t' \<Longrightarrow> eval1_NB t t'' \<Longrightarrow> t' = t''"
proof (induction t t' arbitrary: t'' rule: eval1_NB.induct)
  case (eval1_NBIf t1 t1' t2 t3)
  from eval1_NBIf.prems eval1_NBIf.hyps show ?case
    by (auto intro: eval1_NB.cases dest: eval1_NBIf.IH)
next
  case (eval1_NBSucc t1 t2)
  from eval1_NBSucc.prems eval1_NBSucc.IH show ?case
    by (auto elim: eval1_NB.cases)
next
  case (eval1_NBPred_NBSucc nv1)
  from eval1_NBPred_NBSucc.prems eval1_NBPred_NBSucc.hyps show ?case
    by (cases rule: eval1_NB.cases)
      (auto
        intro: is_numeric_value_NB.intros
        elim: not_eval_once_numeric_value[rotated])
next
  case (eval1_NBPred t1 t2)
  from eval1_NBPred.hyps eval1_NBPred.prems show ?case
    by (auto
      intro: eval1_NBPred.IH is_numeric_value_NB.intros
      elim: eval1_NB.cases
      dest: not_eval_once_numeric_value)
next
  case (eval1_NBIs_zero_NBSucc nv)
  thus ?case by (auto
    intro: eval1_NB.cases not_eval_once_numeric_value is_numeric_value_NB.intros)
next
  case (eval1_NBIs_zero t1 t2)
  from eval1_NBIs_zero.prems eval1_NBIs_zero.hyps show ?case
    by (cases rule: eval1_NB.cases) (auto
      elim: eval1_NB.cases
      intro: eval1_NBIs_zero.IH is_numeric_value_NB.intros
      elim: not_eval_once_numeric_value[rotated])
qed (auto elim: eval1_NB.cases)

(* subsubsection {* Theorem 3.5.7 for Arithmetic Expressions *} *)

text {*
Every value is in normal form:
*}

theorem value_imp_normal_form_NB:
  "is_value_NB t \<Longrightarrow> is_normal_form_NB t"
by (auto
  intro: not_eval_once_numeric_value
  elim: eval1_NB.cases is_value_NB.cases
  simp: is_normal_form_NB_def)

(* subsubsection {* Theorem 3.5.8 does not hold for Arithmetic Expressions *} *)

text {*
But, unlike for Boolean expressions, some terms that are in normal form are not values. An example
of such term is @{term "NBSucc NBTrue"}.
*}

theorem not_normal_form_imp_value_NB:
  "\<exists>t. is_normal_form_NB t \<and> \<not> is_value_NB t" (is "\<exists>t. ?P t")
proof
  have a: "is_normal_form_NB (NBSucc NBTrue)"
    by (auto elim: eval1_NB.cases simp: is_normal_form_NB_def)
  have b: "\<not> is_value_NB (NBSucc NBTrue)"
    by (auto elim: is_numeric_value_NB.cases simp: is_value_NB.simps)
  from a b show "?P (NBSucc NBTrue)" by simp
qed

(* subsubsection {* Corollary 3.5.11 for Arithmetic Expressions *} *)

text {*
The uniqueness of normal form still holds:
*}

(*changes: oneline proof*)
corollary uniqueness_of_normal_form_NB:
  "eval_NB t u \<Longrightarrow> eval_NB t u' \<Longrightarrow> is_normal_form_NB u \<Longrightarrow> is_normal_form_NB u' \<Longrightarrow> u = u'"
by (induction t u arbitrary: u' rule: eval_NB.induct)
    ((metis eval_NB.cases is_normal_form_NB_def eval1_NB_determinacy)+)

(* subsubsection {* Theorem 3.5.12 for Arithmetic Expressions *} *)

text {*
So does the termination of the evaluation function:
*}
(*<*)

lemma eval_once_size_NB:
  "eval1_NB t t' \<Longrightarrow> size_NB t > size_NB t'"
by (induction t t' rule: eval1_NB.induct) auto

(*>*)
(*changes: oneline proof and no more apply*)
theorem eval_NB_always_terminate:
  "\<exists>t'. eval_NB t t' \<and> is_normal_form_NB t'"
by (induction rule: induct_size)
   (meson eval1_NB_impl_eval_NB eval_NB_base eval_NB_transitive eval_once_size_NB is_normal_form_NB_def)
(*<*)
end
(*>*)


(*  Title:      HOL/Isar_Examples/Expr_Compiler.thy
    Author:     Markus Wenzel, TU Muenchen

Correctness of a simple expression/stack-machine compiler.
*)

section \<open>Correctness of a simple expression compiler\<close>

theory Expr_Compiler
imports Main
begin

text \<open>This is a (rather trivial) example of program verification.
  We model a compiler for translating expressions to stack machine
  instructions, and prove its correctness wrt.\ some evaluation
  semantics.\<close>

subsection \<open>Binary operations\<close>

text \<open>Binary operations are just functions over some type of values.
  This is both for abstract syntax and semantics, i.e.\ we use a
  ``shallow embedding'' here.\<close>

type_synonym 'val binop = "'val \<Rightarrow> 'val \<Rightarrow> 'val"

subsection \<open>Expressions\<close>

text \<open>The language of expressions is defined as an inductive type,
  consisting of variables, constants, and binary operations on
  expressions.\<close>

datatype (dead 'adr, dead 'val) expr =
    Variable 'adr
  | Constant 'val
  | Binop "'val binop" "('adr, 'val) expr" "('adr, 'val) expr"

text \<open>Evaluation (wrt.\ some environment of variable assignments) is
  defined by primitive recursion over the structure of expressions.\<close>

primrec eval :: "('adr, 'val) expr \<Rightarrow> ('adr \<Rightarrow> 'val) \<Rightarrow> 'val"
where
  "eval (Variable x) env = env x"
| "eval (Constant c) env = c"
| "eval (Binop f e1 e2) env = f (eval e1 env) (eval e2 env)"

subsection \<open>Machine\<close>

text \<open>Next we model a simple stack machine, with three
  instructions.\<close>

datatype (dead 'adr, dead 'val) instr =
    Const 'val
  | Load 'adr
  | Apply "'val binop"

text \<open>Execution of a list of stack machine instructions is easily
  defined as follows.\<close>

primrec exec :: "(('adr, 'val) instr) list \<Rightarrow> 'val list \<Rightarrow> ('adr \<Rightarrow> 'val) \<Rightarrow> 'val list"
where
  "exec [] stack env = stack"
| "exec (instr # instrs) stack env =
    (case instr of
      Const c \<Rightarrow> exec instrs (c # stack) env
    | Load x \<Rightarrow> exec instrs (env x # stack) env
    | Apply f \<Rightarrow> exec instrs (f (hd stack) (hd (tl stack))
                   # (tl (tl stack))) env)"

definition execute :: "(('adr, 'val) instr) list \<Rightarrow> ('adr \<Rightarrow> 'val) \<Rightarrow> 'val"
  where "execute instrs env = hd (exec instrs [] env)"

subsection \<open>Compiler\<close>

text \<open>We are ready to define the compilation function of expressions
  to lists of stack machine instructions.\<close>

primrec compile :: "('adr, 'val) expr \<Rightarrow> (('adr, 'val) instr) list"
where
  "compile (Variable x) = [Load x]"
| "compile (Constant c) = [Const c]"
| "compile (Binop f e1 e2) = compile e2 @ compile e1 @ [Apply f]"

text \<open>The main result of this development is the correctness theorem
  for @{text compile}.  We first establish a lemma about @{text exec}
  and list append.\<close>

lemma exec_append:
  "exec (xs @ ys) stack env =
    exec ys (exec xs stack env) env"
proof (induct xs arbitrary: stack)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (induct x)
    case Const
    from Cons show ?case by simp
  next
    case Load
    from Cons show ?case by simp
  next
    case Apply
    from Cons show ?case by simp
  qed
qed

theorem correctness: "execute (compile e) env = eval e env"
proof -
  have "\<And>stack. exec (compile e) stack env = eval e env # stack"
  proof (induct e)
    case Variable
    show ?case by simp
  next
    case Constant
    show ?case by simp
  next
    case Binop
    then show ?case by (simp add: exec_append)
  qed
  then show ?thesis by (simp add: execute_def)
qed

text \<open>\bigskip In the proofs above, the @{text simp} method does
  quite a lot of work behind the scenes (mostly ``functional program
  execution'').  Subsequently, the same reasoning is elaborated in
  detail --- at most one recursive function definition is used at a
  time.  Thus we get a better idea of what is actually going on.\<close>

lemma exec_append':
  "exec (xs @ ys) stack env = exec ys (exec xs stack env) env"
proof (induct xs arbitrary: stack)
  case (Nil s)
  have "exec ([] @ ys) s env = exec ys s env"
    by simp
  also have "\<dots> = exec ys (exec [] s env) env"
    by simp
  finally show ?case .
next
  case (Cons x xs s)
  show ?case
  proof (induct x)
    case (Const val)
    have "exec ((Const val # xs) @ ys) s env = exec (Const val # xs @ ys) s env"
      by simp
    also have "\<dots> = exec (xs @ ys) (val # s) env"
      by simp
    also from Cons have "\<dots> = exec ys (exec xs (val # s) env) env" .
    also have "\<dots> = exec ys (exec (Const val # xs) s env) env"
      by simp
    finally show ?case .
  next
    case (Load adr)
    from Cons show ?case
      by simp -- \<open>same as above\<close>
  next
    case (Apply fn)
    have "exec ((Apply fn # xs) @ ys) s env =
        exec (Apply fn # xs @ ys) s env" by simp
    also have "\<dots> =
        exec (xs @ ys) (fn (hd s) (hd (tl s)) # (tl (tl s))) env"
      by simp
    also from Cons have "\<dots> =
        exec ys (exec xs (fn (hd s) (hd (tl s)) # tl (tl s)) env) env" .
    also have "\<dots> = exec ys (exec (Apply fn # xs) s env) env"
      by simp
    finally show ?case .
  qed
qed

theorem correctness': "execute (compile e) env = eval e env"
proof -
  have exec_compile: "\<And>stack. exec (compile e) stack env = eval e env # stack"
  proof (induct e)
    case (Variable adr s)
    have "exec (compile (Variable adr)) s env = exec [Load adr] s env"
      by simp
    also have "\<dots> = env adr # s"
      by simp
    also have "env adr = eval (Variable adr) env"
      by simp
    finally show ?case .
  next
    case (Constant val s)
    show ?case by simp -- \<open>same as above\<close>
  next
    case (Binop fn e1 e2 s)
    have "exec (compile (Binop fn e1 e2)) s env =
        exec (compile e2 @ compile e1 @ [Apply fn]) s env"
      by simp
    also have "\<dots> = exec [Apply fn]
        (exec (compile e1) (exec (compile e2) s env) env) env"
      by (simp only: exec_append)
    also have "exec (compile e2) s env = eval e2 env # s"
      by fact
    also have "exec (compile e1) \<dots> env = eval e1 env # \<dots>"
      by fact
    also have "exec [Apply fn] \<dots> env =
        fn (hd \<dots>) (hd (tl \<dots>)) # (tl (tl \<dots>))"
      by simp
    also have "\<dots> = fn (eval e1 env) (eval e2 env) # s"
      by simp
    also have "fn (eval e1 env) (eval e2 env) =
        eval (Binop fn e1 e2) env"
      by simp
    finally show ?case .
  qed

  have "execute (compile e) env = hd (exec (compile e) [] env)"
    by (simp add: execute_def)
  also from exec_compile have "exec (compile e) [] env = [eval e env]" .
  also have "hd \<dots> = eval e env"
    by simp
  finally show ?thesis .
qed

end


(* Author: Joshua Schneider, ETH Zurich *)

section \<open>Formalisation of idiomatic terms and lifting\<close>

subsection \<open>Immediate joinability under a relation\<close>

theory Joinable
imports Main
begin

subsubsection \<open>Definition and basic properties\<close>

definition joinable :: "('a \<times> 'b) set \<Rightarrow> ('a \<times> 'a) set"
where "joinable R = {(x, y). \<exists>z. (x, z) \<in> R \<and> (y, z) \<in> R}"

lemma joinable_simp: "(x, y) \<in> joinable R \<longleftrightarrow> (\<exists>z. (x, z) \<in> R \<and> (y, z) \<in> R)"
unfolding joinable_def by simp

lemma joinableI: "(x, z) \<in> R \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, y) \<in> joinable R"
unfolding joinable_simp by blast

lemma joinableD: "(x, y) \<in> joinable R \<Longrightarrow> \<exists>z. (x, z) \<in> R \<and> (y, z) \<in> R"
unfolding joinable_simp .

lemma joinableE:
  assumes "(x, y) \<in> joinable R"
  obtains z where "(x, z) \<in> R" and "(y, z) \<in> R"
using assms unfolding joinable_simp by blast

lemma refl_on_joinable: "refl_on {x. \<exists>y. (x, y) \<in> R} (joinable R)"
by (auto intro!: refl_onI simp only: joinable_simp)

lemma refl_joinable_iff: "(\<forall>x. \<exists>y. (x, y) \<in> R) = refl (joinable R)"
by (auto intro!: refl_onI dest: refl_onD simp add: joinable_simp)

lemma refl_joinable: "refl R \<Longrightarrow> refl (joinable R)"
using refl_joinable_iff by (blast dest: refl_onD)

lemma joinable_refl: "refl R \<Longrightarrow> (x, x) \<in> joinable R"
using refl_joinable by (blast dest: refl_onD)

lemma sym_joinable: "sym (joinable R)"
by (auto intro!: symI simp only: joinable_simp)

lemma joinable_sym: "(x, y) \<in> joinable R \<Longrightarrow> (y, x) \<in> joinable R"
using sym_joinable by (rule symD)

lemma joinable_mono: "R \<subseteq> S \<Longrightarrow> joinable R \<subseteq> joinable S"
by (rule subrelI) (auto simp only: joinable_simp)

lemma refl_le_joinable:
  assumes "refl R"
  shows "R \<subseteq> joinable R"
proof (rule subrelI)
  fix x y
  assume "(x, y) \<in> R"
  moreover from \<open>refl R\<close> have "(y, y) \<in> R" by (blast dest: refl_onD)
  ultimately show "(x, y) \<in> joinable R" by (rule joinableI)
qed

lemma joinable_subst:
  assumes R_subst: "\<And>x y. (x, y) \<in> R \<Longrightarrow> (P x, P y) \<in> R"
  assumes joinable: "(x, y) \<in> joinable R"
  shows "(P x, P y) \<in> joinable R"
proof -
  from joinable obtain z where xz: "(x, z) \<in> R" and yz: "(y, z) \<in> R" by (rule joinableE)
  from R_subst xz have "(P x, P z) \<in> R" .
  moreover from R_subst yz have "(P y, P z) \<in> R" .
  ultimately show ?thesis by (rule joinableI)
qed

subsubsection \<open>Confluence\<close>

definition confluent :: "'a rel \<Rightarrow> bool"
where "confluent R \<longleftrightarrow> (\<forall>x y y'. (x, y) \<in> R \<and> (x, y') \<in> R \<longrightarrow> (y, y') \<in> joinable R)"

lemma confluentI:
  "(\<And>x y y'. (x, y) \<in> R \<Longrightarrow> (x, y') \<in> R \<Longrightarrow> \<exists>z. (y, z) \<in> R \<and> (y', z) \<in> R) \<Longrightarrow> confluent R"
unfolding confluent_def by (blast intro: joinableI)

lemma confluentD:
  "confluent R \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (x,y') \<in> R \<Longrightarrow> (y, y') \<in> joinable R"
unfolding confluent_def by blast

lemma confluentE:
  assumes "confluent R" and "(x, y) \<in> R" and "(x, y') \<in> R"
  obtains z where "(y, z) \<in> R" and "(y', z) \<in> R"
using assms unfolding confluent_def by (blast elim: joinableE)

lemma trans_joinable:
  assumes "trans R" and "confluent R"
  shows "trans (joinable R)"
proof (rule transI)
  fix x y z
  assume "(x, y) \<in> joinable R"
  then obtain u where xu: "(x, u) \<in> R" and yu: "(y, u) \<in> R" by (rule joinableE)
  assume "(y, z) \<in> joinable R"
  then obtain v where yv: "(y, v) \<in> R" and zv: "(z, v) \<in> R" by (rule joinableE)
  from yu yv \<open>confluent R\<close> obtain w where uw: "(u, w) \<in> R" and vw: "(v, w) \<in> R"
    by (blast elim: confluentE)
  from xu uw \<open>trans R\<close> have "(x, w) \<in> R" by (blast elim: transE)
  moreover from zv vw \<open>trans R\<close> have "(z, w) \<in> R" by (blast elim: transE)
  ultimately show "(x, z) \<in> joinable R" by (rule joinableI)
qed

subsubsection \<open>Relation to reflexive transitive symmetric closure\<close>

theorem joinable_eq_rtscl:
  assumes "confluent (R\<^sup>*)"
  shows "joinable (R\<^sup>*) = (R \<union> R\<inverse>)\<^sup>*"
proof
  show "joinable (R\<^sup>*) \<subseteq> (R \<union> R\<inverse>)\<^sup>*" using joinable_le_rtscl .
next
  show "joinable (R\<^sup>*) \<supseteq> (R \<union> R\<inverse>)\<^sup>*" proof (rule subrelI)
    fix x y
    assume "(x, y) \<in> (R \<union> R\<inverse>)\<^sup>*"
    thus "(x, y) \<in> joinable (R\<^sup>*)" proof (induction set: rtrancl)
      case base
      show "(x, x) \<in> joinable (R\<^sup>*)" using joinable_refl refl_rtrancl .
    next
      case (step y z)
      have "R \<subseteq> joinable (R\<^sup>*)" using refl_le_joinable refl_rtrancl by fast
      with \<open>(y, z) \<in> R \<union> R\<inverse>\<close> have "(y, z) \<in> joinable (R\<^sup>*)" using joinable_sym by fast
      with \<open>(x, y) \<in> joinable (R\<^sup>*)\<close> show "(x, z) \<in> joinable (R\<^sup>*)"
        using trans_joinable trans_rtrancl \<open>confluent (R\<^sup>*)\<close> by (blast dest: transD)
    qed
  qed
qed

subsubsection \<open>Predicate version\<close>

definition joinablep :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where "joinablep P x y \<longleftrightarrow> (\<exists>z. P x z \<and> P y z)"

lemma joinablep_joinable[pred_set_conv]:
  "joinablep (\<lambda>x y. (x, y) \<in> R) = (\<lambda>x y. (x, y) \<in> joinable R)"
by (fastforce simp only: joinablep_def joinable_simp)

lemma reflp_joinablep: "reflp P \<Longrightarrow> reflp (joinablep P)"
by (blast intro: reflpI joinable_refl[to_pred] refl_onI[to_pred] dest: reflpD)

lemma joinablep_refl: "reflp P \<Longrightarrow> joinablep P x x"
using reflp_joinablep by (rule reflpD)

lemma reflp_le_joinablep: "reflp P \<Longrightarrow> P \<le> joinablep P"
by (blast intro!: refl_le_joinable[to_pred] refl_onI[to_pred] dest: reflpD)

end


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Countable_Set_Extra.thy                                              *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Countable Sets: Extra functions and properties \<close>

theory Countable_Set_Extra
imports
  "HOL-Library.Countable_Set_Type"
  Sequence
  FSet_Extra
begin

subsection \<open> Extra syntax \<close>

notation cempty ("{}\<^sub>c")
notation cin (infix "\<in>\<^sub>c" 50)
notation cUn (infixl "\<union>\<^sub>c" 65)
notation cInt (infixl "\<inter>\<^sub>c" 70)
notation cDiff (infixl "-\<^sub>c" 65)
notation cUnion ("\<Union>\<^sub>c_" [900] 900)
notation cimage (infixr "`\<^sub>c" 90)

abbreviation csubseteq :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> bool" ("(_/ \<subseteq>\<^sub>c _)" [51, 51] 50)
where "A \<subseteq>\<^sub>c B \<equiv> A \<le> B"

abbreviation csubset :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> bool" ("(_/ \<subset>\<^sub>c _)" [51, 51] 50)
where "A \<subset>\<^sub>c B \<equiv> A < B"

subsection \<open> Countable set functions \<close>

setup_lifting type_definition_cset

lift_definition cnin :: "'a \<Rightarrow> 'a cset \<Rightarrow> bool" (infix "\<notin>\<^sub>c" 50) is "(\<notin>)" .

definition cBall :: "'a cset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"cBall A P = (\<forall>x. x \<in>\<^sub>c A \<longrightarrow> P x)"

definition cBex :: "'a cset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"cBex A P = (\<exists>x. x \<in>\<^sub>c A \<longrightarrow> P x)"

declare cBall_def [mono,simp]
declare cBex_def [mono,simp]

syntax
  "_cBall" :: "pttrn => 'a cset => bool => bool" ("(3\<forall> _\<in>\<^sub>c_./ _)" [0, 0, 10] 10)
  "_cBex"  :: "pttrn => 'a cset => bool => bool" ("(3\<exists> _\<in>\<^sub>c_./ _)" [0, 0, 10] 10)

translations
  "\<forall> x\<in>\<^sub>cA. P" == "CONST cBall A (%x. P)"
  "\<exists> x\<in>\<^sub>cA. P" == "CONST cBex  A (%x. P)"

definition cset_Collect :: "('a \<Rightarrow> bool) \<Rightarrow> 'a cset" where
"cset_Collect = (acset o Collect)"

lift_definition cset_Coll :: "'a cset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a cset" is "\<lambda> A P. {x \<in> A. P x}"
  by (auto)

lemma cset_Coll_equiv: "cset_Coll A P = cset_Collect (\<lambda> x. x \<in>\<^sub>c A \<and> P x)"
  by (simp add:cset_Collect_def cset_Coll_def cin_def)

declare cset_Collect_def [simp]

syntax
  "_cColl" :: "pttrn => bool => 'a cset" ("(1{_./ _}\<^sub>c)")

translations
  "{x . P}\<^sub>c" \<rightleftharpoons> "(CONST cset_Collect) (\<lambda> x . P)"

syntax (xsymbols)
  "_cCollect" :: "pttrn => 'a cset => bool => 'a cset"    ("(1{_ \<in>\<^sub>c/ _./ _}\<^sub>c)")
translations
  "{x \<in>\<^sub>c A. P}\<^sub>c" => "CONST cset_Coll A (\<lambda> x. P)"

lemma cset_CollectI: "P (a :: 'a::countable) \<Longrightarrow> a \<in>\<^sub>c {x. P x}\<^sub>c"
  by (simp add: cin_def)

lemma cset_CollI: "\<lbrakk> a \<in>\<^sub>c A; P a \<rbrakk> \<Longrightarrow> a \<in>\<^sub>c {x \<in>\<^sub>c A. P x}\<^sub>c"
  by (simp add: cin.rep_eq cset_Coll.rep_eq)

lemma cset_CollectD: "(a :: 'a::countable) \<in>\<^sub>c {x. P x}\<^sub>c \<Longrightarrow> P a"
  by (simp add: cin_def)

lemma cset_Collect_cong: "(\<And>x. P x = Q x) ==> {x. P x}\<^sub>c = {x. Q x}\<^sub>c"
  by simp

text \<open> Avoid eta-contraction for robust pretty-printing. \<close>

print_translation \<open>
 [Syntax_Trans.preserve_binder_abs_tr'
   @{const_syntax cset_Collect} @{syntax_const "_cColl"}]
\<close>

lift_definition cset_set :: "'a list \<Rightarrow> 'a cset" is set
  using countable_finite by blast

lemma countable_finite_power:
  "countable(A) \<Longrightarrow> countable {B. B \<subseteq> A \<and> finite(B)}"
  by (metis Collect_conj_eq Int_commute countable_Collect_finite_subset)

lift_definition cInter :: "'a cset cset \<Rightarrow> 'a cset"  ("\<Inter>\<^sub>c_" [900] 900)
  is "\<lambda>A. if A = {} then {} else \<Inter> A"
  using countable_INT [of _ _ id] by auto

abbreviation (input) cINTER :: "'a cset \<Rightarrow> ('a \<Rightarrow> 'b cset) \<Rightarrow> 'b cset"
  where "cINTER A f \<equiv> cInter (cimage f A)"

lift_definition cfinite :: "'a cset \<Rightarrow> bool" is finite .
lift_definition cInfinite :: "'a cset \<Rightarrow> bool" is infinite .
lift_definition clist :: "'a::linorder cset \<Rightarrow> 'a list" is sorted_list_of_set .
lift_definition ccard :: "'a cset \<Rightarrow> nat" is card .
lift_definition cPow :: "'a cset \<Rightarrow> 'a cset cset" is "\<lambda> A. {B. B \<subseteq>\<^sub>c A \<and> cfinite(B)}"
proof -
  fix A
  have "{B :: 'a cset. B \<subseteq>\<^sub>c A \<and> cfinite B} = acset ` {B :: 'a set. B \<subseteq> rcset A \<and> finite B}"
    apply (auto simp add: cfinite.rep_eq cin_def less_eq_cset_def countable_finite)
    using image_iff apply fastforce
    done

  moreover have "countable {B :: 'a set. B \<subseteq> rcset A \<and> finite B}"
    by (auto intro: countable_finite_power)

  ultimately show "countable {B. B \<subseteq>\<^sub>c A \<and> cfinite B}"
    by simp
qed

definition CCollect :: "('a \<Rightarrow> bool option) \<Rightarrow> 'a cset option" where
"CCollect p = (if (None \<notin> range p) then Some (cset_Collect (the \<circ> p)) else None)"

definition cset_mapM :: "'a option cset \<Rightarrow> 'a cset option" where
"cset_mapM A = (if (None \<in>\<^sub>c A) then None else Some (the `\<^sub>c A))"

lemma cset_mapM_Some_image [simp]:
  "cset_mapM (cimage Some A) = Some A"
  apply (auto simp add: cset_mapM_def)
  apply (metis cimage_cinsert cinsertI1 option.sel set_cinsert)
  done

definition CCollect_ext :: "('a \<Rightarrow> 'b option) \<Rightarrow> ('a \<Rightarrow> bool option) \<Rightarrow> 'b cset option" where
"CCollect_ext f p = do { xs \<leftarrow> CCollect p; cset_mapM (f `\<^sub>c xs) }"

lemma the_Some_image [simp]:
  "the ` Some ` xs = xs"
  by (auto simp add:image_iff)

lemma CCollect_ext_Some [simp]:
  "CCollect_ext Some xs = CCollect xs"
  apply (case_tac "CCollect xs")
   apply (auto simp add:CCollect_ext_def)
  done

lift_definition list_of_cset :: "'a :: linorder cset \<Rightarrow> 'a list" is sorted_list_of_set .

lift_definition fset_cset :: "'a fset \<Rightarrow> 'a cset" is id
  using uncountable_infinite by auto

definition cset_count :: "'a cset \<Rightarrow> 'a \<Rightarrow> nat" where
"cset_count A =
  (if (finite (rcset A))
   then (SOME f::'a\<Rightarrow>nat. inj_on f (rcset A))
   else (SOME f::'a\<Rightarrow>nat. bij_betw f (rcset A) UNIV))"

lemma cset_count_inj_seq:
  "inj_on (cset_count A) (rcset A)"
proof (cases "finite (rcset A)")
  case True note fin = this
  obtain count :: "'a \<Rightarrow> nat" where count_inj: "inj_on count (rcset A)"
    by (metis countable_def mem_Collect_eq rcset)
  with fin show ?thesis
    by (metis (poly_guards_query) cset_count_def someI_ex)
next
  case False note inf = this
  obtain count :: "'a \<Rightarrow> nat" where count_bij: "bij_betw count (rcset A) UNIV"
    by (metis countableE_infinite inf mem_Collect_eq rcset)
  with inf have "bij_betw (cset_count A) (rcset A) UNIV"
    by (metis (poly_guards_query) cset_count_def someI_ex)
  thus ?thesis
    by (metis bij_betw_imp_inj_on)
qed

lemma cset_count_infinite_bij:
  assumes "infinite (rcset A)"
  shows "bij_betw (cset_count A) (rcset A) UNIV"
proof -
  from assms obtain count :: "'a \<Rightarrow> nat" where count_bij: "bij_betw count (rcset A) UNIV"
    by (metis countableE_infinite mem_Collect_eq rcset)
  with assms show ?thesis
    by (metis (poly_guards_query) cset_count_def someI_ex)
qed

definition cset_seq :: "'a cset \<Rightarrow> (nat \<rightharpoonup> 'a)" where
"cset_seq A i = (if (i \<in> range (cset_count A) \<and> inv_into (rcset A) (cset_count A) i \<in>\<^sub>c A)
                 then Some (inv_into (rcset A) (cset_count A) i)
                 else None)"

lemma cset_seq_ran: "ran (cset_seq A) = rcset(A)"
  apply (auto simp add: ran_def cset_seq_def cin.rep_eq)
  apply (metis cset_count_inj_seq inv_into_f_f rangeI)
  done

lemma cset_seq_inj: "inj cset_seq"
proof (rule injI)
  fix A B :: "'a cset"
  assume "cset_seq A = cset_seq B"
  thus "A = B"
    by (metis cset_seq_ran rcset_inverse)
qed

lift_definition cset2seq :: "'a cset \<Rightarrow> 'a seq"
is "(\<lambda> A i. if (i \<in> cset_count A ` rcset A) then inv_into (rcset A) (cset_count A) i else (SOME x. x \<in>\<^sub>c A))" .

lemma range_cset2seq:
  "A \<noteq> {}\<^sub>c \<Longrightarrow> range (Rep_seq (cset2seq A)) = rcset A"
  by (force intro: someI2 simp add: cset2seq.rep_eq cset_count_inj_seq bot_cset.rep_eq cin.rep_eq)

lemma infinite_cset_count_surj: "infinite (rcset A) \<Longrightarrow> surj (cset_count A)"
  using bij_betw_imp_surj cset_count_infinite_bij by auto

lemma cset2seq_inj:
  "inj_on cset2seq {A. A \<noteq> {}\<^sub>c}"
  apply (rule inj_onI)
  apply (simp)
  apply (metis range_cset2seq rcset_inject)
  done

lift_definition nat_seq2set :: "nat seq \<Rightarrow> nat set" is
"\<lambda> f. prod_encode ` {(x, f x) | x. True}" .

lemma inj_nat_seq2set: "inj nat_seq2set"
proof (rule injI, transfer)
  fix f g
  assume "prod_encode ` {(x, f x) |x. True} = prod_encode ` {(x, g x) |x. True}"
  hence "{(x, f x) |x. True} = {(x, g x) |x. True}"
    by (simp add: inj_image_eq_iff[OF inj_prod_encode])
  thus "f = g"
    by (auto simp add: set_eq_iff)
qed

lift_definition bit_seq_of_nat_set :: "nat set \<Rightarrow> bool seq"
is "\<lambda> A i. i \<in> A" .

lemma bit_seq_of_nat_set_inj: "inj bit_seq_of_nat_set"
  apply (rule injI)
  apply transfer
  apply (auto simp add: fun_eq_iff)
  done

lemma bit_seq_of_nat_cset_bij: "bij bit_seq_of_nat_set"
  apply (rule bijI)
   apply (fact bit_seq_of_nat_set_inj)
  apply transfer
  apply (rule surjI)
  apply auto
  done

text \<open> This function is a partial injection from countable sets of natural sets to natural sets.
        When used with the Schroeder-Bernstein theorem, it can be used to conjure a total
        bijection between these two types. \<close>

definition nat_set_cset_collapse :: "nat set cset \<Rightarrow> nat set" where
"nat_set_cset_collapse = inv bit_seq_of_nat_set \<circ> seq_inj \<circ> cset2seq \<circ> (\<lambda> A. (bit_seq_of_nat_set `\<^sub>c A))"

lemma nat_set_cset_collapse_inj: "inj_on nat_set_cset_collapse {A. A \<noteq> {}\<^sub>c}"
proof -
  have "(`\<^sub>c) bit_seq_of_nat_set ` {A. A \<noteq> {}\<^sub>c} \<subseteq> {A. A \<noteq> {}\<^sub>c}"
    by (auto simp add:cimage.rep_eq)
  thus ?thesis
    apply (simp add: nat_set_cset_collapse_def)
    apply (rule comp_inj_on)
     apply (meson bit_seq_of_nat_set_inj cset.inj_map injD inj_onI)
    apply (rule comp_inj_on)
     apply (metis cset2seq_inj subset_inj_on)
    apply (rule comp_inj_on)
     apply (rule subset_inj_on)
      apply (rule seq_inj)
     apply (simp)
    apply (meson UNIV_I bij_imp_bij_inv bij_is_inj bit_seq_of_nat_cset_bij subsetI subset_inj_on)
    done
qed

lemma inj_csingle:
  "inj csingle"
  by (auto intro: injI simp add: cinsert_def bot_cset.rep_eq)

lemma range_csingle:
  "range csingle \<subseteq> {A. A \<noteq> {}\<^sub>c}"
  by (auto)

lift_definition csets :: "'a set \<Rightarrow> 'a cset set" is
"\<lambda> A. {B. B \<subseteq> A \<and> countable B}" by auto

lemma csets_finite: "finite A \<Longrightarrow> finite (csets A)"
  by (auto simp add: csets_def)

lemma csets_infinite: "infinite A \<Longrightarrow> infinite (csets A)"
  by (auto simp add: csets_def, metis csets.abs_eq csets.rep_eq finite_countable_subset finite_imageI)

lemma csets_UNIV:
  "csets (UNIV :: 'a set) = (UNIV :: 'a cset set)"
  by (auto simp add: csets_def, metis image_iff rcset rcset_inverse)

lemma infinite_nempty_cset:
  assumes "infinite (UNIV :: 'a set)"
  shows "infinite ({A. A \<noteq> {}\<^sub>c} :: 'a cset set)"
proof -
  have "infinite (UNIV :: 'a cset set)"
    by (metis assms csets_UNIV csets_infinite)
  hence "infinite ((UNIV :: 'a cset set) - {{}\<^sub>c})"
    by (rule infinite_remove)
  thus ?thesis
    by (auto)
qed

lemma nat_set_cset_partial_bij:
  obtains f :: "nat set cset \<Rightarrow> nat set" where "bij_betw f {A. A \<noteq> {}\<^sub>c} UNIV"
  using Schroeder_Bernstein[OF nat_set_cset_collapse_inj, of UNIV csingle, simplified, OF inj_csingle range_csingle]
  by (auto)

lemma nat_set_cset_bij:
  obtains f :: "nat set cset \<Rightarrow> nat set" where "bij f"
proof -
  obtain g :: "nat set cset \<Rightarrow> nat set" where "bij_betw g {A. A \<noteq> {}\<^sub>c} UNIV"
    using nat_set_cset_partial_bij by blast
  moreover obtain h :: "nat set cset \<Rightarrow> nat set cset" where "bij_betw h UNIV {A. A \<noteq> {}\<^sub>c}"
  proof -
    have "infinite (UNIV :: nat set cset set)"
      by (metis Finite_Set.finite_set csets_UNIV csets_infinite infinite_UNIV_char_0)
    then obtain h' :: "nat set cset \<Rightarrow> nat set cset" where "bij_betw h' UNIV (UNIV - {{}\<^sub>c})"
      using infinite_imp_bij_betw[of "UNIV :: nat set cset set" "{}\<^sub>c"] by auto
    moreover have "(UNIV :: nat set cset set) - {{}\<^sub>c} = {A. A \<noteq> {}\<^sub>c}"
      by (auto)
    ultimately show ?thesis
      using that by (auto)
  qed
  ultimately have "bij (g \<circ> h)"
    using bij_betw_trans by blast
  with that show ?thesis
    by (auto)
qed

definition "nat_set_cset_bij = (SOME f :: nat set cset \<Rightarrow> nat set. bij f)"

lemma bij_nat_set_cset_bij:
  "bij nat_set_cset_bij"
  by (metis nat_set_cset_bij nat_set_cset_bij_def someI_ex)

lemma inj_on_image_csets:
  "inj_on f A \<Longrightarrow> inj_on ((`\<^sub>c) f) (csets A)"
  by (fastforce simp add: inj_on_def cimage_def cin_def csets_def)

lemma image_csets_surj:
  "\<lbrakk> inj_on f A; f ` A = B \<rbrakk> \<Longrightarrow> (`\<^sub>c) f ` csets A = csets B"
  apply (auto simp add: cimage_def csets_def image_mono map_fun_def)
  apply (simp add: image_comp)
  apply (auto simp add: image_Collect)
  apply (erule subset_imageE)
  using countable_image_inj_on subset_inj_on by blast

lemma bij_betw_image_csets:
  "bij_betw f A B \<Longrightarrow> bij_betw ((`\<^sub>c) f) (csets A) (csets B)"
  by (simp add: bij_betw_def inj_on_image_csets image_csets_surj)
end