(*
  File:     PAPP_Impossibility_Base_Case.thy
  Author:   Manuel Eberl, University of Innsbruck
*)
section \<open>The Base Case of the Impossibility\<close>
theory PAPP_Impossibility_Base_Case
  imports Anonymous_PAPP SAT_Replay
begin

text \<open>
  In this section, we will prove the base case of our P-APP impossibility result, namely that
  there exists no anonymous P-APP rule \<open>f\<close> for 6 voters, 4 parties, and committee size 3 that
  satisfies Weak Representation and Cardinality Strategyproofness.

  The proof works by looking at some (comparatively small) set of preference profiles and the
  set of all 20 possible output committees. Each proposition $f(A) = C$ (where \<open>A\<close> is a profile
  from our set and \<open>C\<close> is one of the 20 possible output committees) is considered as a Boolean
  variable.

  All the conditions arising on these variables based on the fact that \<open>f\<close> is a function
  and the additional properties (Representation, Strategyproofness) are encoded as SAT clauses.
  This SAT problem is then proven unsatisfiable by an external SAT solver and the resulting
  proof re-imported into Isabelle/HOL.
\<close>

subsection \<open>Auxiliary Material\<close>

text \<open>
  We define the set of committees of the given size \<open>k\<close> for a given set of parties \<open>P\<close>.
\<close>
definition committees :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a multiset set" where
  "committees k P = {W. set_mset W \<subseteq> P \<and> size W = k}"

text \<open>
  We now prove a recurrence for this set so that we can more easily compute the set of all
  possible committees:
\<close>
lemma committees_0 [simp]: "committees 0 P = {{#}}"
  by (auto simp: committees_def)

lemma committees_Suc:
  "committees (Suc n) P = (\<Union>x\<in>P. \<Union>W\<in>committees n P. {{#x#} + W})"
proof safe
  fix C assume C: "C \<in> committees (Suc n) P"
  hence "size C = Suc n"
    by (auto simp: committees_def)
  hence "C \<noteq> {#}"
    by auto
  then obtain x where x: "x \<in># C"
    by auto
  define C' where "C' = C - {#x#}"
  have "C = {#x#} + C'" "x \<in> P" "C' \<in> committees n P"
    using C x  by (auto simp: committees_def C'_def size_Diff_singleton dest: in_diffD)
  thus "C \<in> (\<Union>x\<in>P. \<Union>W\<in>committees n P. {{#x#} + W})"
    by blast
qed (auto simp: committees_def)

text \<open>
  The following function takes a list $[a_1, \ldots, a_n]$ and computes the list of all pairs
  of the form $(a_i, a_j)$ with $i < j$:
\<close>
fun pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
  "pairs [] = []"
| "pairs (x # xs) = map (\<lambda>y. (x, y)) xs @ pairs xs"

lemma distinct_conv_pairs: "distinct xs \<longleftrightarrow> list_all (\<lambda>(x,y). x \<noteq> y) (pairs xs)"
  by (induction xs) (auto simp: list_all_iff)

lemma list_ex_unfold: "list_ex P (x # y # xs) \<longleftrightarrow> P x \<or> list_ex P (y # xs)" "list_ex P [x] \<longleftrightarrow> P x"
  by simp_all

lemma list_all_unfold: "list_all P (x # y # xs) \<longleftrightarrow> P x \<and> list_all P (y # xs)" "list_all P [x] \<longleftrightarrow> P x"
  by simp_all

subsection \<open>Setup for the Base Case\<close>

text \<open>
  We define a locale for an anonymous P-APP rule for 6 voters, 4 parties, and committee size 3
  that satisfies weak representation and cardinality strategyproofness. Our goal is to prove
  the theorem \<^term>\<open>False\<close> inside this locale.
\<close>

locale papp_impossibility_base_case =
  card_stratproof_weak_rep_anon_papp 6 parties 3 r
  for parties :: "'a set" and r +
  assumes card_parties: "card parties = 4"
begin

text \<open>
  A slightly more convenient version of Weak Representation:
\<close>
lemma weak_representation':
  assumes "is_pref_profile A" "A' \<equiv> A" "\<forall>z\<in>Z. count A {z} \<ge> 2" "\<not>Z \<subseteq> set_mset W"
  shows   "r A' \<noteq> W"
  using weak_representation[OF assms(1)] assms(2-4) by auto

text \<open>
  The following lemma (Lemma~2 in the appendix of the paper) is a strengthening of Weak
  Representation and Strategyproofness in our concrete setting:

  Let \<open>A\<close> be a preference profile containing approval lists \<open>X\<close> and
  let \<open>Z\<close> be a set of parties such that each element of \<open>Z\<close> is uniquely approved by at least two
  voters in \<open>A\<close>. Due to Weak Representation, at least \<open>|X \<inter> Z|\<close> members of the committee are then
  approved by \<open>X\<close>.

  What the lemma now says is that if there exists another voter with approval list \<open>Y \<subseteq> X\<close> and
  $Y \nsubseteq Z$, then there is an additional committee member that is approved by \<open>X\<close>.

  This lemma will be used both in our symmetry-breaking argument and as a means to add more
  clauses to the SAT instance. Since these clauses are logical consequences of Strategyproofness
  and Weak Representation, they are technically redundant -- but their presence allows us to
  use consider a smaller set of profiles and still get a contradiction. Without using the lemma,
  we would need to feed more profiles to the SAT solver to obtain the same information.
\<close>
lemma lemma2:
  assumes A: "is_pref_profile A"
  assumes "X \<in># A" and "Y \<in># A - {#X#}" and "Y \<subseteq> X" and "\<not>Y \<subseteq> Z"
  assumes Z: "\<forall>z\<in>Z. count A {z} \<ge> 2"
  shows   "size (filter_mset (\<lambda>x. x \<in> X) (r A)) > card (X \<inter> Z)"
proof (rule ccontr)
  text \<open>
    For the sake of contradiction, suppose the number of elements approved by \<open>X\<close> were
    no larger than \<open>|X \<inter> Z|\<close>.
  \<close>
  assume "\<not>size (filter_mset (\<lambda>x. x \<in> X) (r A)) > card (X \<inter> Z)"
  hence le: "size (filter_mset (\<lambda>x. x \<in> X) (r A)) \<le> card (X \<inter> Z)"
    by linarith
  interpret anon_papp_profile 6 parties 3 A
    by fact
  have "Z \<subseteq> parties"
    using assms(1,6) by (meson is_committee_def order.trans rule_wf weak_representation')
  have [simp]: "finite Z"
    by (rule finite_subset[OF _ finite_parties]) fact

  text \<open>
    Due to Weak Representation, each member of \<open>X \<inter> Z\<close> must be chosen at least once. But due
    to the above, it cannot be chosen more than once. So it has to be chosen exactly once.
  \<close>
  have X_approved_A_eq: "filter_mset (\<lambda>x. x \<in> X) (r A) = mset_set (X \<inter> Z)"
  proof -
    have "mset_set Z \<subseteq># r A"
      using Z weak_representation[OF A] by (subst mset_set_subset_iff) auto
    hence "size (filter_mset (\<lambda>x. x \<in> X) (mset_set Z)) \<le> size (filter_mset (\<lambda>x. x \<in> X) (r A))"
      by (intro size_mset_mono multiset_filter_mono)
    also have "filter_mset (\<lambda>x. x \<in> X) (mset_set Z) = mset_set {x\<in>Z. x \<in> X}"
      by simp
    also have "{x\<in>Z. x \<in> X} = X \<inter> Z"
      by auto
    also have "size (mset_set (X \<inter> Z)) = card (X \<inter> Z)"
      by simp
    finally have "size (filter_mset (\<lambda>x. x \<in> X) (r A)) = card (X \<inter> Z)"
      using le by linarith
    moreover have "mset_set (X \<inter> Z) \<subseteq># filter_mset (\<lambda>x. x \<in> X) (r A)"
      using Z weak_representation[OF A] by (subst mset_set_subset_iff) auto
    ultimately show "filter_mset (\<lambda>x. x \<in> X) (r A) = mset_set (X \<inter> Z)"
      by (intro mset_subset_size_ge_imp_eq [symmetric]) auto
  qed

  have count_eq_1: "count (r A) x = 1" if "x \<in> X \<inter> Z" for x
    using that X_approved_A_eq
    by (metis \<open>finite Z\<close> count_filter_mset count_mset_set' diff_is_0_eq diff_zero
              finite_subset inf_le2 not_one_le_zero)

  text \<open>
    Let \<open>x\<close> be some element of \<open>Y\<close> that is not in \<open>Z\<close>.
  \<close>
  obtain x where x: "x \<in> Y - Z"
    using \<open>\<not>Y \<subseteq> Z\<close> by blast
  with assms have x': "x \<in> X - Z"
    by auto
  have [simp]: "x \<in> parties"
    using A_subset assms(2) x' by blast

  text \<open>
    Let \<open>A'\<close> be the preference profile obtained by having voter \<open>X\<close> lying and pretending
    she only approves \<open>x\<close>.
  \<close>
  define A' where "A' = A - {#X#} + {#{x}#}"
  have A': "is_pref_profile A'"
    using is_pref_profile_replace[OF A \<open>X \<in># A\<close>, of "{x}"] by (auto simp: A'_def)

  text \<open>
    We now show that even with this manipulated profile, the committee members approved by \<open>X\<close>
    are exactly the same as before:
  \<close>
  have X_approved_A'_eq: "filter_mset (\<lambda>x. x \<in> X) (r A') = mset_set (X \<inter> Z)"
  proof -
    text \<open>
      Every element of \<open>Z\<close> must still be in the result committee due to Weak Representation.
    \<close>
    have "mset_set Z \<subseteq># r A'"
    proof (subst mset_set_subset_iff)
      show "Z \<subseteq> set_mset (r A')"
      proof
        fix z assume z: "z \<in> Z"
        from x' z have [simp]: "x \<noteq> z"
          by auto
        have [simp]: "X \<noteq> {z}"
          using x' by auto
        show "z \<in># r A'"
          using Z weak_representation[OF A', of z] z x x' by (auto simp: A'_def)
      qed
    qed auto

    text \<open>
      Thus the parties in \<open>X \<inter> Z\<close> must be in the committee (and they are approved by \<open>X\<close>).
    \<close>
    have "mset_set (X \<inter> Z) \<subseteq># filter_mset (\<lambda>x. x \<in> X) (r A')"
    proof -
      have "filter_mset (\<lambda>x. x \<in> X) (mset_set Z) \<subseteq># filter_mset (\<lambda>x. x \<in> X) (r A')"
        using \<open>mset_set Z \<subseteq># r A'\<close> by (intro multiset_filter_mono) auto
      also have "filter_mset (\<lambda>x. x \<in> X) (mset_set Z) = mset_set (X \<inter> Z)"
        by auto
      finally show "mset_set (X \<inter> Z) \<subseteq># filter_mset (\<lambda>x. x \<in> X) (r A')" .
    qed

    text \<open>
      Due to Strategyproofness, no additional committee members can be approved by \<open>X\<close>,
      so indeed only \<open>X \<inter> Z\<close> is approved by \<open>X\<close>, and they each occur only once.
    \<close>
    moreover have "\<not>card_manipulable A X {x}"
      using not_manipulable by blast
    hence "size (mset_set (X \<inter> Z)) \<ge> size (filter_mset (\<lambda>x. x \<in> X) (r A'))" using assms
      by (simp add: card_manipulable_def A'_def strong_committee_preference_iff not_less
                    X_approved_A_eq)
    ultimately show "filter_mset (\<lambda>x. x \<in> X) (r A') = mset_set (X \<inter> Z)"
      by (metis mset_subset_size_ge_imp_eq)
  qed

  text \<open>
    Next, we show that the set of committee members approved by \<open>Y\<close> in the committee returned for
    the manipulated profile is exactly \<open>Y \<inter> Z\<close> (and again, each party only occurs once).
  \<close>
  have Y_approved_A'_eq: "filter_mset (\<lambda>x. x \<in> Y) (r A') = mset_set (Y \<inter> Z)"
  proof -
    have "filter_mset (\<lambda>x. x \<in> Y) (filter_mset (\<lambda>x. x \<in> X) (r A')) =
           filter_mset (\<lambda>x. x \<in> Y) (mset_set (X \<inter> Z))"
      by (simp only: X_approved_A'_eq)
    also have "filter_mset (\<lambda>x. x \<in> Y) (filter_mset (\<lambda>x. x \<in> X) (r A')) =
               filter_mset (\<lambda>x. x \<in> Y \<and> x \<in> X) (r A')"
      by (simp add: filter_filter_mset conj_commute)
    also have "(\<lambda>x. x \<in> Y \<and> x \<in> X) = (\<lambda>x. x \<in> Y)"
      using assms by auto
    also have "filter_mset (\<lambda>x. x \<in> Y) (mset_set (X \<inter> Z)) = mset_set (Y \<inter> Z)"
      using assms by auto
    finally show ?thesis .
  qed

  text \<open>
    Next, define the profile \<open>A''\<close> obtained from \<open>A'\<close> by also having \<open>Y\<close> pretend to approve
    only \<open>x\<close>.
  \<close>
  define A'' where "A'' = A' - {#Y#} + {#{x}#}"
  have "Y \<in># A'"
    using assms by (auto simp: A'_def)
  hence A'': "is_pref_profile A''"
    using is_pref_profile_replace[OF A', of Y "{x}"] by (auto simp: A''_def)

  text \<open>
    Again, the elements of \<open>Z\<close> must be chosen due to Weak Representation.
  \<close>
  have "Z \<subseteq> set_mset (r A'')"
  proof
    fix z assume z: "z \<in> Z"
    from x' z have [simp]: "x \<noteq> z"
      by auto
    have [simp]: "X \<noteq> {z}" "Y \<noteq> {z}"
      using x x' by auto
    show "z \<in># r A''"
      using Z weak_representation[OF A'', of z] z x x'
      by (auto simp: A''_def A'_def)
  qed

  text \<open>
    But now additionally, \<open>x\<close> must be chosen, since both \<open>X\<close> and \<open>Y\<close> uniquely approve it.
  \<close>
  moreover have "x \<in># r A''"
    using x x' \<open>Y \<in># A - {#X#}\<close> by (intro weak_representation A'') (auto simp: A''_def A'_def)
  ultimately have "insert x (Y \<inter> Z) \<subseteq> set_mset (r A'') \<inter> Y"
    using x by blast

  text \<open>
    Now we have a contradiction due to Strategyproofness, since \<open>Y\<close> can force the additional
    member \<open>x\<close> into the committee by lying.
  \<close>
  hence "mset_set (insert x (Y \<inter> Z)) \<subseteq># filter_mset (\<lambda>w. w \<in> Y) (r A'')"
    by (subst mset_set_subset_iff) auto
  hence "size (mset_set (insert x (Y \<inter> Z))) \<le> size (filter_mset (\<lambda>w. w \<in> Y) (r A''))"
    by (rule size_mset_mono)
  hence "size (filter_mset (\<lambda>x. x \<in> Y) (r A'')) > size (filter_mset (\<lambda>x. x \<in> Y) (r A'))"
    using x by (simp add: Y_approved_A'_eq)
  hence "card_manipulable A' Y {x}"
    using A' x \<open>Y \<in># A'\<close>
    unfolding card_manipulable_def strong_committee_preference_iff A''_def by auto
  thus False
    using not_manipulable by blast
qed

text \<open>
  The following are merely reformulation of the above lemma for technical reasons.
\<close>
lemma lemma2':
  assumes "is_pref_profile A"
  assumes "\<forall>z\<in>Z. count A {z} \<ge> 2"
  assumes "X \<in># A \<and> (\<exists>Y. Y \<in># A - {#X#} \<and> Y \<subseteq> X \<and> \<not>Y \<subseteq> Z)"
  shows   "\<not>filter_mset (\<lambda>x. x \<in> X) (r A) \<subseteq># mset_set (X \<inter> Z)"
proof
  assume subset: "filter_mset (\<lambda>x. x \<in> X) (r A) \<subseteq># mset_set (X \<inter> Z)"
  from assms(3) obtain Y where Y: "X \<in># A" "Y \<in># A - {#X#}" "Y \<subseteq> X" "\<not>Y \<subseteq> Z"
    by blast
  have "card (X \<inter> Z) < size {#x \<in># r A. x \<in> X#}"
    by (rule lemma2[where Y = Y]) (use Y assms(1,2) in auto)
  with size_mset_mono[OF subset] show False
    by simp
qed

lemma lemma2'':
  assumes "is_pref_profile A"
  assumes "A' \<equiv> A"
  assumes "\<forall>z\<in>Z. count A {z} \<ge> 2"
  assumes "X \<in># A \<and> (\<exists>Y\<in>set_mset (A - {#X#}). Y \<subseteq> X \<and> \<not>Y \<subseteq> Z)"
  assumes "filter_mset (\<lambda>x. x \<in> X) W \<subseteq># mset_set (X \<inter> Z)"
  shows   "r A' \<noteq> W"
  using lemma2'[of A Z X] assms by auto

subsection \<open>Symmetry Breaking\<close>

text \<open>
  In the following, we formalize the symmetry-breaking argument that shows that we can
  reorder the four alternatives $C_1$ to $C_4$ in such a way that the preference profile
  \[ \{C_1\}\ \ \{C_2\}\ \  \{C_1, C_2\}\ \  \{C_3\}\ \  \{C_3\}\ \  \{C_3, C_4\} \]
  is mapped to one of the committees $[C_1, C_1, C_3]$ or $[C_1, C_2, C_3]$.

  We start with a simple technical lemma that states that if we have a multiset $A$ of size 3
  consisting of the elements $x$ and $y$ and $x$ occurs at least as often as $y$, then
  $A = [x, x, y]$.
\<close>

lemma papp_multiset_3_aux:
  assumes "size A = 3" "x \<in># A" "y \<in># A" "set_mset A \<subseteq> {x, y}" "x \<noteq> y" "count A x \<ge> count A y"
  shows   "A = {#x, x, y#}"
proof -
  have "count A x > 0"
    using assms by force
  have "size A = (\<Sum>z\<in>set_mset A. count A z)"
    by (rule size_multiset_overloaded_eq)
  also have "set_mset A = {x, y}"
    using assms by auto
  also have "(\<Sum>z\<in>\<dots>. count A z) = count A x + count A y"
    using assms by auto
  finally have "count A x + count A y = 3"
    by (simp add: assms(1))
  moreover from assms have "count A x > 0" "count A y > 0"
    by auto
  ultimately have *: "count A x = 2 \<and> count A y = 1"
    using \<open>count A x \<ge> count A y\<close> by linarith
  show ?thesis
  proof (rule multiset_eqI)
    fix z show "count A z = count {#x, x, y#} z"
    proof (cases "z \<in> {x, y}")
      case False
      with assms have "z \<notin> set_mset A"
        by auto
      hence "count A z = 0"
        by (simp add: Multiset.not_in_iff)
      thus ?thesis
        using False by auto
    qed (use * in auto)
  qed
qed

text \<open>
  The following is the main symmetry-breaking result. It shows that we can find parties
  $C_1$ to $C_4$ with the desired property.

  This is a somewhat ad-hoc argument; in the appendix of the paper this is done more
  systematically in Lemma~3.
\<close>
lemma symmetry_break_aux:
  obtains C1 C2 C3 C4 where
    "parties = {C1, C2, C3, C4}" "distinct [C1, C2, C3, C4]"
    "r ({#{C1}, {C2}, {C1, C2}, {C3}, {C4}, {C3, C4}#}) \<in> {{#C1, C1, C3#}, {#C1, C2, C3#}}"
proof -
  note I = that
  have "\<exists>xs. set xs = parties \<and> distinct xs"
    using finite_distinct_list[of parties] by blast
  then obtain xs where xs: "set xs = parties" "distinct xs"
    by blast
  from xs have "length xs = 4"
    using card_parties distinct_card[of xs] by auto
  then obtain C1 C2 C3 C4 where xs_eq: "xs = [C1, C2, C3, C4]"
    by (auto simp: eval_nat_numeral length_Suc_conv)
  have parties_eq: "parties = {C1, C2, C3, C4}"
    by (subst xs(1) [symmetric], subst xs_eq) auto
  have [simp]:
       "C1 \<noteq> C2" "C1 \<noteq> C3" "C1 \<noteq> C4"
       "C2 \<noteq> C1" "C2 \<noteq> C3" "C2 \<noteq> C4"
       "C3 \<noteq> C1" "C3 \<noteq> C2" "C3 \<noteq> C4"
       "C4 \<noteq> C1" "C4 \<noteq> C2" "C4 \<noteq> C3"
    using \<open>distinct xs\<close> unfolding xs_eq by auto

  define A where "A = {#{C1}, {C2}, {C1, C2}, {C3}, {C4}, {C3, C4}#}"
  define m where "m = Max (count (r A) ` parties)"

  have A: "is_pref_profile A"
    unfolding A_def is_pref_profile_iff by (simp add: parties_eq)
  hence "is_committee (r A)"
    by (rule rule_wf)
  hence rA: "size (r A) = 3" "set_mset (r A) \<subseteq> parties"
    unfolding is_committee_def by auto
  define X where "X = set_mset (r A)"
  have "X \<noteq> {}" "X \<subseteq> parties"
    using rA by (auto simp: X_def)

  have "m > 0"
  proof -
    obtain x where "x \<in> X"
      using \<open>X \<noteq> {}\<close> by blast
    with \<open>X \<subseteq> parties\<close> have "C1 \<in> X \<or> C2 \<in> X \<or> C3 \<in> X \<or> C4 \<in> X"
      unfolding parties_eq by blast
    thus ?thesis
      unfolding m_def X_def by (subst Max_gr_iff) (auto simp: parties_eq)
  qed

  have "m \<le> 3"
  proof -
    have "m \<le> size (r A)"
      unfolding m_def by (subst Max_le_iff) (auto simp: count_le_size)
    also have "\<dots> = 3"
      by fact
    finally show ?thesis .
  qed

  have "m \<in> (count (r A) ` parties)"
    unfolding m_def by (intro Max_in) auto
  then obtain C1' where C1': "count (r A) C1' = m" "C1' \<in> parties"
    by blast
  have "C1' \<in># r A"
    using \<open>m > 0\<close> C1'(1) by auto

  have "\<exists>C2'\<in>parties-{C1'}. {C1', C2'} \<in># A"
    using C1' unfolding A_def parties_eq
    by (elim insertE; simp add: insert_Diff_if insert_commute)
  then obtain C2' where C2': "C2' \<in> parties - {C1'}" "{C1', C2'} \<in># A"
    by blast
  have [simp]: "C1' \<noteq> C2'" "C2' \<noteq> C1'"
    using C2' by auto
  have disj: "C1' = C1 \<and> C2' = C2 \<or> C1' = C2 \<and> C2' = C1 \<or> C1' = C3 \<and> C2' = C4 \<or> C1' = C4 \<and> C2' = C3"
    using C1'(2) C2' unfolding A_def parties_eq
    by (elim insertE; force simp: insert_commute)

  obtain C3' where C3': "C3' \<in> parties-{C1', C2'}"
    using C1'(2) C2' unfolding parties_eq by (fastforce simp: insert_Diff_if)
  obtain C4' where C4': "C4' \<in> parties-{C1', C2', C3'}"
    using C1'(2) C2' C3' unfolding parties_eq by (fastforce simp: insert_Diff_if)
  have A_eq: "A = {#{C1'}, {C2'}, {C1', C2'}, {C3'}, {C4'}, {C3', C4'}#}"
    using disj C3' C4'
    by (elim disjE) (auto simp: A_def parties_eq insert_commute)
  have distinct:
       "C1' \<noteq> C2'" "C1' \<noteq> C3'" "C1' \<noteq> C4'"
       "C2' \<noteq> C1'" "C2' \<noteq> C3'" "C2' \<noteq> C4'"
       "C3' \<noteq> C1'" "C3' \<noteq> C2'" "C3' \<noteq> C4'"
       "C4' \<noteq> C1'" "C4' \<noteq> C2'" "C4' \<noteq> C3'"
    using C1' C2' C3' C4' by blast+
  have parties_eq': "parties = {C1', C2', C3', C4'}"
    using C1'(2) C2'(1) C3' C4' distinct unfolding parties_eq by (elim insertE) auto

  have "\<not>{#x \<in># r A. x \<in> {C3', C4'}#} \<subseteq># mset_set ({C3', C4'} \<inter> {})"
    by (rule lemma2'[OF A]) (auto simp: A_eq)
  hence C34': "C3' \<in># r A \<or> C4' \<in># r A"
    by auto
  then consider "C3' \<in># r A" "C4' \<in># r A" | "C3' \<in># r A" "C4' \<notin># r A" | "C3' \<notin># r A" "C4' \<in># r A"
    by blast

  thus ?thesis
  proof cases
    assume *: "C3' \<in># r A" "C4' \<in># r A"
    have "r A = {#C3', C4', C1'#}"
      by (rule sym, rule mset_subset_size_ge_imp_eq)
         (use * \<open>C1' \<in># r A\<close> distinct in
            \<open>auto simp: \<open>size (r A) = 3\<close> Multiset.insert_subset_eq_iff in_diff_multiset_absorb2\<close>)
    thus ?thesis using distinct
      by (intro that[of C3' C4' C1' C2'])
         (auto simp: parties_eq' A_eq add_mset_commute insert_commute)

  next

    assume *: "C3' \<in># r A" "C4' \<notin># r A"
    show ?thesis
    proof (cases "C2' \<in># r A")
      case True
      have "r A = {#C1', C2', C3'#}"
        by (rule sym, rule mset_subset_size_ge_imp_eq)
           (use * \<open>C1' \<in># r A\<close> distinct True in
              \<open>auto simp: \<open>size (r A) = 3\<close> Multiset.insert_subset_eq_iff in_diff_multiset_absorb2\<close>)
      thus ?thesis using distinct
        by (intro that[of C1' C2' C3' C4'])
           (auto simp: parties_eq' A_eq add_mset_commute insert_commute)
    next
      case False
      have "r A = {#C1', C1', C3'#}"
      proof (rule papp_multiset_3_aux)
        show "set_mset (r A) \<subseteq> {C1', C3'}"
          using \<open>set_mset (r A) \<subseteq> _\<close> * False unfolding parties_eq' by auto
      next
        have "count (r A) C3' \<le> m"
          unfolding m_def by (subst Max_ge_iff) (auto simp: parties_eq')
        also have "m = count (r A) C1'"
          by (simp add: C1')
        finally show "count (r A) C3' \<le> count (r A) C1'" .
      qed (use C1' * False \<open>C1' \<in># r A\<close> distinct in \<open>auto simp: \<open>size (r A) = 3\<close>\<close>)
      thus ?thesis using distinct
        by (intro that[of C1' C2' C3' C4'])
           (auto simp: parties_eq' insert_commute add_mset_commute A_eq)
    qed

  next

    assume *: "C3' \<notin># r A" "C4' \<in># r A"
    show ?thesis
    proof (cases "C2' \<in># r A")
      case True
      have "r A = {#C1', C2', C4'#}"
        by (rule sym, rule mset_subset_size_ge_imp_eq)
           (use * \<open>C1' \<in># r A\<close> distinct True in
              \<open>auto simp: \<open>size (r A) = 3\<close> Multiset.insert_subset_eq_iff in_diff_multiset_absorb2\<close>)
      thus ?thesis using distinct
        by (intro that[of C1' C2' C4' C3'])
           (auto simp: parties_eq' A_eq add_mset_commute insert_commute)
    next
      case False
      have "r A = {#C1', C1', C4'#}"
      proof (rule papp_multiset_3_aux)
        show "set_mset (r A) \<subseteq> {C1', C4'}"
          using \<open>set_mset (r A) \<subseteq> _\<close> * False unfolding parties_eq' by auto
      next
        have "count (r A) C4' \<le> m"
          unfolding m_def by (subst Max_ge_iff) (auto simp: parties_eq')
        also have "m = count (r A) C1'"
          by (simp add: C1')
        finally show "count (r A) C4' \<le> count (r A) C1'" .
      qed (use C1' * False \<open>C1' \<in># r A\<close> distinct in \<open>auto simp: \<open>size (r A) = 3\<close>\<close>)
      thus ?thesis using distinct
        by (intro that[of C1' C2' C4' C3'])
           (auto simp: parties_eq' insert_commute add_mset_commute A_eq)
    qed
  qed
qed

text \<open>
  We now use the choice operator to get our hands on such values $C_1$ to $C_4$.
\<close>
definition C1234 where
  "C1234 = (SOME xs. set xs = parties \<and> distinct xs \<and>
              (case xs of [C1, C2, C3, C4] \<Rightarrow>
              r ({#{C1}, {C2}, {C1, C2}, {C3}, {C4}, {C3, C4}#}) \<in> {{#C1, C1, C3#}, {#C1, C2, C3#}}))"

definition C1 where "C1 = C1234 ! 0"
definition C2 where "C2 = C1234 ! 1"
definition C3 where "C3 = C1234 ! 2"
definition C4 where "C4 = C1234 ! 3"

lemma distinct: "distinct [C1, C2, C3, C4]"
  and parties_eq:  "parties = {C1, C2, C3, C4}"
  and symmetry_break:
        "r ({#{C1}, {C2}, {C1, C2}, {C3}, {C4}, {C3, C4}#}) \<in> {{#C1, C1, C3#}, {#C1, C2, C3#}}"
proof -
  have C1234:
        "set C1234 = parties \<and> distinct C1234 \<and>
        (case C1234 of [C1', C2', C3', C4'] \<Rightarrow>
            r ({#{C1'}, {C2'}, {C1', C2'}, {C3'}, {C4'}, {C3', C4'}#}) \<in>
              {{#C1', C1', C3'#}, {#C1', C2', C3'#}})"
    unfolding C1234_def
  proof (rule someI_ex)
    obtain C1' C2' C3' C4' where *:
      "parties = {C1', C2', C3', C4'}" "distinct [C1', C2', C3', C4']"
      "r ({#{C1'}, {C2'}, {C1', C2'}, {C3'}, {C4'}, {C3', C4'}#}) \<in>
         {{#C1', C1', C3'#}, {#C1', C2', C3'#}}"
      using symmetry_break_aux by blast
    show "\<exists>xs. set xs = parties \<and> distinct xs \<and>
            (case xs of [C1', C2', C3', C4'] \<Rightarrow>
              r ({#{C1'}, {C2'}, {C1', C2'}, {C3'}, {C4'}, {C3', C4'}#}) \<in>
                {{#C1', C1', C3'#}, {#C1', C2', C3'#}})"
      by (intro exI[of _ "[C1', C2', C3', C4']"]) (use * in auto)
  qed

  have "length C1234 = 4"
    using C1234 card_parties distinct_card[of C1234] by simp
  then obtain C1' C2' C3' C4' where C1234_eq: "C1234 = [C1', C2', C3', C4']"
    by (auto simp: eval_nat_numeral length_Suc_conv)
  show "distinct [C1, C2, C3, C4]" "parties = {C1, C2, C3, C4}"
       "r ({#{C1}, {C2}, {C1, C2}, {C3}, {C4}, {C3, C4}#}) \<in> {{#C1, C1, C3#}, {#C1, C2, C3#}}"
    using C1234 by (simp_all add: C1234_eq C1_def C2_def C3_def C4_def)
qed

lemma distinct' [simp]:
   "C1 \<noteq> C2" "C1 \<noteq> C3" "C1 \<noteq> C4" "C2 \<noteq> C1" "C2 \<noteq> C3" "C2 \<noteq> C4"
   "C3 \<noteq> C1" "C3 \<noteq> C2" "C3 \<noteq> C4" "C4 \<noteq> C1" "C4 \<noteq> C2" "C4 \<noteq> C3"
  using distinct by auto

lemma in_parties [simp]: "C1 \<in> parties" "C2 \<in> parties" "C3 \<in> parties" "C4 \<in> parties"
  by (subst (2) parties_eq; simp; fail)+

subsection \<open>The Set of Possible Committees\<close>

text \<open>
  Next, we compute the set of the 20 possible committees.
\<close>

abbreviation COM where "COM \<equiv> committees 3 parties"

definition COM' where "COM' =
  [{#C1, C1, C1#}, {#C1, C1, C2#}, {#C1, C1, C3#}, {#C1, C1, C4#},
   {#C1, C2, C2#}, {#C1, C2, C3#}, {#C1, C2, C4#}, {#C1, C3, C3#},
   {#C1, C3, C4#}, {#C1, C4, C4#}, {#C2, C2, C2#}, {#C2, C2, C3#},
   {#C2, C2, C4#}, {#C2, C3, C3#}, {#C2, C3, C4#}, {#C2, C4, C4#},
   {#C3, C3, C3#}, {#C3, C3, C4#}, {#C3, C4, C4#},
   {#C4, C4, C4#}]"

lemma distinct_COM': "distinct COM'"
  by (simp add: COM'_def add_mset_neq)

lemma COM_eq: "COM = set COM'"
  by (subst parties_eq)
     (simp_all add: COM'_def numeral_3_eq_3 committees_Suc add_ac insert_commute add_mset_commute)

lemma r_in_COM:
  assumes "is_pref_profile A"
  shows   "r A \<in> COM"
  using rule_wf[OF assms] unfolding committees_def is_committee_def by auto

lemma r_in_COM':
  assumes "is_pref_profile A" "A' \<equiv> A"
  shows   "list_ex (\<lambda>W. r A' = W) COM'"
  using r_in_COM[OF assms(1)] assms(2) by (auto simp: list_ex_iff COM_eq)

lemma r_right_unique:
  "list_all (\<lambda>(W1,W2). r A \<noteq> W1 \<or> r A \<noteq> W2) (pairs COM')"
proof -
  have "list_all (\<lambda>(W1,W2). W1 \<noteq> W2) (pairs COM')"
    using distinct_COM' unfolding distinct_conv_pairs by blast
  thus ?thesis
    unfolding list_all_iff by blast
qed

end

subsection \<open>Generating Clauses and Replaying the SAT Proof\<close>

text \<open>
  We now employ some custom-written ML code to generate all the SAT clauses arising from the
  given profiles (read from an external file) as Isabelle/HOL theorems. From these, we then
  derive \<^term>\<open>False\<close> by replaying an externally found SAT proof (also written from an external
  file).

  The proof was found with the glucose SAT solver, which outputs proofs in the DRUP format
  (a subset of the more powerful DRAT format). We then used the \<^emph>\<open>DRAT-trim\<close> tool by
  Wetzler et al.~\cite{wetzler_drat_trim} to make the proof smaller. This was done repeatedly
  until the proof size did not decrease any longer. Then, the proof was converted into the \<^emph>\<open>GRAT\<close>
  format introduced by Lammich~\cite{lammich_grat}, which is easier to check (or in our case
  replay) than the less explicit DRAT (or DRUP) format.
\<close>

external_file "sat_data/profiles"
external_file "sat_data/papp_impossibility.grat.xz"

context papp_impossibility_base_case
begin

ML_file \<open>papp_impossibility.ML\<close>

text \<open>
  This invocation proves a theorem called \<^emph>\<open>contradiction\<close> whose statement is \<^term>\<open>False\<close>.
  Note that the DIMACS version of the SAT file that is being generated can be viewed by
  clicking on ``See theory exports'' in the messages output by the invocation below.

  On a 2021 desktop PC with 12 cores, proving all the clauses takes 8.4\,s (multithreaded;
  CPU time 55\,s). Replaying the proof takes 130\,s (singlethreaded).
\<close>

local_setup \<open>fn lthy =>
  let
    val thm =
      PAPP_Impossibility.derive_false lthy
        (\<^master_dir> + \<^path>\<open>sat_data/profiles\<close>)
        (\<^master_dir> + \<^path>\<open>sat_data/papp_impossibility.grat.xz\<close>)
  in
    Local_Theory.note ((\<^binding>\<open>contradiction\<close>, []), [thm]) lthy |> snd
  end
\<close>

end

text \<open>
  With this, we can now prove the impossibility result:
\<close>
lemma papp_impossibility_base_case:
  assumes "card parties = 4"
  shows   "\<not>card_stratproof_weak_rep_anon_papp 6 parties 3 r"
proof
  assume "card_stratproof_weak_rep_anon_papp 6 parties 3 r"
  then interpret card_stratproof_weak_rep_anon_papp 6 parties 3 r .
  interpret papp_impossibility_base_case parties r
    by unfold_locales fact+
  show False
    by (rule contradiction)
qed

end


(*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
    License: BSD
*)

section \<open>The exponential on extended real numbers.\<close>

theory Eexp_Eln
  imports Library_Complements
begin

text \<open>To define the distance on the Gromov completion of hyperbolic spaces, we need to use
the exponential on extended real numbers. We can not use the symbol \verb+exp+, as this symbol
is already used in Banach algebras, so we use \verb+ennexp+ instead. We prove its basic
properties (together with properties of the logarithm) here. We also use it to define the square
root on ennreal. Finally, we also define versions from ereal to ereal.\<close>

function ennexp::"ereal \<Rightarrow> ennreal" where
"ennexp (ereal r) = ennreal (exp r)"
| "ennexp (\<infinity>) = \<infinity>"
| "ennexp (-\<infinity>) = 0"
by (auto intro: ereal_cases)
termination by standard (rule wf_empty)

lemma ennexp_0 [simp]:
  "ennexp 0 = 1"
by (auto simp add: zero_ereal_def one_ennreal_def)

function eln::"ennreal \<Rightarrow> ereal" where
"eln (ennreal r) = (if r \<le> 0 then -\<infinity> else ereal (ln r))"
| "eln (\<infinity>) = \<infinity>"
by (auto intro: ennreal_cases, metis ennreal_eq_0_iff, simp add: ennreal_neg)
termination by standard (rule wf_empty)

lemma eln_simps [simp]:
  "eln 0 = -\<infinity>"
  "eln 1 = 0"
  "eln top = \<infinity>"
apply (simp only: eln.simps ennreal_0[symmetric], simp)
apply (simp only: eln.simps ennreal_1[symmetric], simp)
using eln.simps(2) by auto

lemma eln_real_pos:
  assumes "r > 0"
  shows "eln (ennreal r) = ereal (ln r)"
using eln.simps assms by auto

lemma eln_ennexp [simp]:
  "eln (ennexp x) = x"
apply (cases x) using eln.simps by auto

lemma ennexp_eln [simp]:
  "ennexp (eln x) = x"
apply (cases x) using eln.simps by auto

lemma ennexp_strict_mono:
  "strict_mono ennexp"
proof -
  have "ennexp x < ennexp y" if "x < y" for x y
    apply (cases x, cases y)
    using that apply (auto simp add: ennreal_less_iff)
    by (cases y, auto)
  then show ?thesis unfolding strict_mono_def by auto
qed

lemma ennexp_mono:
  "mono ennexp"
using ennexp_strict_mono by (simp add: strict_mono_mono)

lemma ennexp_strict_mono2 [mono_intros]:
  assumes "x < y"
  shows "ennexp x < ennexp y"
using ennexp_strict_mono assms unfolding strict_mono_def by auto

lemma ennexp_mono2 [mono_intros]:
  assumes "x \<le> y"
  shows "ennexp x \<le> ennexp y"
using ennexp_mono assms unfolding mono_def by auto

lemma ennexp_le1 [simp]:
  "ennexp x \<le> 1 \<longleftrightarrow> x \<le> 0"
by (metis ennexp_0 ennexp_mono2 ennexp_strict_mono eq_iff le_cases strict_mono_eq)

lemma ennexp_ge1 [simp]:
  "ennexp x \<ge> 1 \<longleftrightarrow> x \<ge> 0"
by (metis ennexp_0 ennexp_mono2 ennexp_strict_mono eq_iff le_cases strict_mono_eq)

lemma eln_strict_mono:
  "strict_mono eln"
by (metis ennexp_eln strict_monoI ennexp_strict_mono strict_mono_less)

lemma eln_strict_mono2 [mono_intros]:
  assumes "x < y"
  shows "eln x < eln y"
using eln_strict_mono assms unfolding strict_mono_def by auto

lemma eln_mono2 [mono_intros]:
  assumes "x \<le> y"
  shows "eln x \<le> eln y"
using eln_mono assms unfolding mono_def by auto

lemma eln_le0 [simp]:
  "eln x \<le> 0 \<longleftrightarrow> x \<le> 1"
by (metis ennexp_eln ennexp_le1)

lemma eln_ge0 [simp]:
  "eln x \<ge> 0 \<longleftrightarrow> x \<ge> 1"
by (metis ennexp_eln ennexp_ge1)

lemma bij_ennexp:
  "bij ennexp"
by (auto intro!: bij_betw_byWitness[of _ eln])

lemma bij_eln:
  "bij eln"
by (auto intro!: bij_betw_byWitness[of _ ennexp])

lemma ennexp_continuous:
  "continuous_on UNIV ennexp"
apply (rule continuous_onI_mono)
using ennexp_mono unfolding mono_def by (auto simp add: bij_ennexp bij_is_surj)

lemma ennexp_tendsto [tendsto_intros]:
  assumes "((\<lambda>n. u n) \<longlongrightarrow> l) F"
  shows "((\<lambda>n. ennexp(u n)) \<longlongrightarrow> ennexp l) F"
using ennexp_continuous assms by (metis UNIV_I continuous_on tendsto_compose)

lemma eln_continuous:
  "continuous_on UNIV eln"
apply (rule continuous_onI_mono)
using eln_mono unfolding mono_def by (auto simp add: bij_eln bij_is_surj)

lemma eln_tendsto [tendsto_intros]:
  assumes "((\<lambda>n. u n) \<longlongrightarrow> l) F"
  shows "((\<lambda>n. eln(u n)) \<longlongrightarrow> eln l) F"
using eln_continuous assms by (metis UNIV_I continuous_on tendsto_compose)

lemma ennexp_special_values [simp]:
  "ennexp x = 0 \<longleftrightarrow> x = -\<infinity>"
  "ennexp x = 1 \<longleftrightarrow> x = 0"
  "ennexp x = \<infinity> \<longleftrightarrow> x = \<infinity>"
  "ennexp x = top \<longleftrightarrow> x = \<infinity>"
by auto (metis eln_ennexp eln_simps)+

lemma eln_special_values [simp]:
  "eln x = -\<infinity> \<longleftrightarrow> x = 0"
  "eln x = 0 \<longleftrightarrow> x = 1"
  "eln x = \<infinity> \<longleftrightarrow> x = \<infinity>"
apply auto
apply (metis ennexp.simps ennexp_eln ennexp_0)+
by (metis ennexp.simps(2) ennexp_eln infinity_ennreal_def)

lemma ennexp_add_mult:
  assumes "\<not>((a = \<infinity> \<and> b = -\<infinity>) \<or> (a = -\<infinity> \<and> b = \<infinity>))"
  shows "ennexp(a+b) = ennexp a * ennexp b"
apply (cases a, cases b)
using assms by (auto simp add: ennreal_mult'' exp_add ennreal_top_eq_mult_iff)

lemma eln_mult_add:
  assumes "\<not>((a = \<infinity> \<and> b = 0) \<or> (a = 0 \<and> b = \<infinity>))"
  shows "eln(a * b) = eln a + eln b"
by (smt assms ennexp.simps(2) ennexp.simps(3) ennexp_add_mult ennexp_eln eln_ennexp)

text \<open>We can also define the square root on ennreal using the above exponential.\<close>

definition ennsqrt::"ennreal \<Rightarrow> ennreal"
  where "ennsqrt x = ennexp(eln x/2)"

lemma ennsqrt_square [simp]:
  "(ennsqrt x) * (ennsqrt x) = x"
proof -
  have "y/2 + y/2 = y" for y::ereal
    by (cases y, auto)
  then show ?thesis
    unfolding ennsqrt_def by (subst ennexp_add_mult[symmetric], auto)
qed

lemma ennsqrt_simps [simp]:
  "ennsqrt 0 = 0"
  "ennsqrt 1 = 1"
  "ennsqrt \<infinity> = \<infinity>"
  "ennsqrt top = top"
unfolding ennsqrt_def by auto

lemma ennsqrt_mult:
  "ennsqrt(a * b) = ennsqrt a * ennsqrt b"
proof -
  have [simp]: "z/ereal 2 = -\<infinity> \<longleftrightarrow> z = -\<infinity>" for z
    by (auto simp add: ereal_divide_eq)

  consider "a = 0" | "b = 0" | "a > 0 \<and> b > 0"
    using zero_less_iff_neq_zero by auto
  then show ?thesis
    apply (cases, auto)
    apply (cases a, cases b, auto simp add: ennreal_mult_top ennreal_top_mult)
    unfolding ennsqrt_def apply (subst ennexp_add_mult[symmetric], auto)
    apply (subst eln_mult_add, auto)
    done
qed

lemma ennsqrt_square2 [simp]:
  "ennsqrt (x * x) = x"
  unfolding ennsqrt_mult by auto

lemma ennsqrt_eq_iff_square:
  "ennsqrt x = y \<longleftrightarrow> x = y * y"
by auto

lemma ennsqrt_bij:
  "bij ennsqrt"
by (rule bij_betw_byWitness[of _ "\<lambda>x. x * x"], auto)

lemma ennsqrt_strict_mono:
  "strict_mono ennsqrt"
  unfolding ennsqrt_def
  apply (rule strict_mono_compose[OF ennexp_strict_mono])
  apply (rule strict_mono_compose[OF _ eln_strict_mono])
  by (auto simp add: ereal_less_divide_pos ereal_mult_divide strict_mono_def)

lemma ennsqrt_mono:
  "mono ennsqrt"
using ennsqrt_strict_mono by (simp add: strict_mono_mono)

lemma ennsqrt_mono2 [mono_intros]:
  assumes "x \<le> y"
  shows "ennsqrt x \<le> ennsqrt y"
using ennsqrt_mono assms unfolding mono_def by auto

lemma ennsqrt_continuous:
  "continuous_on UNIV ennsqrt"
apply (rule continuous_onI_mono)
using ennsqrt_mono unfolding mono_def by (auto simp add: ennsqrt_bij bij_is_surj)

lemma ennsqrt_tendsto [tendsto_intros]:
  assumes "((\<lambda>n. u n) \<longlongrightarrow> l) F"
  shows "((\<lambda>n. ennsqrt(u n)) \<longlongrightarrow> ennsqrt l) F"
using ennsqrt_continuous assms by (metis UNIV_I continuous_on tendsto_compose)

lemma ennsqrt_ennreal_ennreal_sqrt [simp]:
  assumes "t \<ge> (0::real)"
  shows "ennsqrt (ennreal t) = ennreal (sqrt t)"
proof -
  have "ennreal t = ennreal (sqrt t) * ennreal(sqrt t)"
    apply (subst ennreal_mult[symmetric]) using assms by auto
  then show ?thesis
    by auto
qed

lemma ennreal_sqrt2:
  "ennreal (sqrt 2) = ennsqrt 2"
using ennsqrt_ennreal_ennreal_sqrt[of 2] by auto

lemma ennsqrt_4 [simp]:
  "ennsqrt 4 = 2"
by (metis ennreal_numeral ennsqrt_ennreal_ennreal_sqrt real_sqrt_four zero_le_numeral)

lemma ennsqrt_le [simp]:
  "ennsqrt x \<le> ennsqrt y \<longleftrightarrow> x \<le> y"
proof
  assume "ennsqrt x \<le> ennsqrt y"
  then have "ennsqrt x * ennsqrt x \<le> ennsqrt y * ennsqrt y"
    by (intro mult_mono, auto)
  then show "x \<le> y" by auto
qed (auto intro: mono_intros)

text \<open>We can also define the square root on ereal using the square root on ennreal, and $0$
for negative numbers.\<close>

definition esqrt::"ereal \<Rightarrow> ereal"
  where "esqrt x = enn2ereal(ennsqrt (e2ennreal x))"

lemma esqrt_square [simp]:
  assumes "x \<ge> 0"
  shows "(esqrt x) * (esqrt x) = x"
unfolding esqrt_def times_ennreal.rep_eq[symmetric] ennsqrt_square[of "e2ennreal x"]
using assms enn2ereal_e2ennreal by auto

lemma esqrt_nonneg [simp]:
  "esqrt x \<ge> 0"
unfolding esqrt_def by auto

lemma esqrt_eq_iff_square [simp]:
  assumes "x \<ge> 0" "y \<ge> 0"
  shows "esqrt x = y \<longleftrightarrow> x = y * y"
using esqrt_def esqrt_square assms apply auto
by (metis e2ennreal_enn2ereal ennsqrt_square2 eq_onp_same_args ereal_ennreal_cases leD times_ennreal.abs_eq)

lemma esqrt_simps [simp]:
  "esqrt 0 = 0"
  "esqrt 1 = 1"
  "esqrt \<infinity> = \<infinity>"
  "esqrt top = top"
  "esqrt (-\<infinity>) = 0"
by (auto simp: top_ereal_def)

lemma esqrt_mult:
  assumes "a \<ge> 0"
  shows "esqrt(a * b) = esqrt a * esqrt b"
proof (cases "b \<ge> 0")
  case True
  show ?thesis
    unfolding esqrt_def apply (subst times_ennreal.rep_eq[symmetric])
    apply (subst ennsqrt_mult[of "e2ennreal a" "e2ennreal b", symmetric])
    apply (subst times_ennreal.abs_eq)
    using assms True by (auto simp add: eq_onp_same_args)
next
  case False
  then have "a * b \<le> 0" using assms ereal_mult_le_0_iff by auto
  then have "esqrt(a * b) = 0" by auto
  moreover have "esqrt b = 0" using False by auto
  ultimately show ?thesis by auto
qed

lemma esqrt_square2 [simp]:
  "esqrt(x * x) = abs(x)"
proof -
  have "esqrt(x * x) = esqrt(abs x * abs x)"
    by (metis (no_types, hide_lams) abs_ereal_ge0 ereal_abs_mult ereal_zero_le_0_iff linear)
  also have "... = abs x"
    by (auto simp add: esqrt_mult)
  finally show ?thesis by auto
qed

lemma esqrt_mono:
  "mono esqrt"
unfolding esqrt_def mono_def by (auto intro: mono_intros)

lemma esqrt_mono2 [mono_intros]:
  assumes "x \<le> y"
  shows "esqrt x \<le> esqrt y"
using esqrt_mono assms unfolding mono_def by auto

lemma esqrt_continuous:
  "continuous_on UNIV esqrt"
unfolding esqrt_def apply (rule continuous_on_compose2[of UNIV enn2ereal], intro continuous_on_enn2ereal)
by (rule continuous_on_compose2[of UNIV ennsqrt], auto intro!: ennsqrt_continuous continuous_on_e2ennreal)

lemma esqrt_tendsto [tendsto_intros]:
  assumes "((\<lambda>n. u n) \<longlongrightarrow> l) F"
  shows "((\<lambda>n. esqrt(u n)) \<longlongrightarrow> esqrt l) F"
using esqrt_continuous assms by (metis UNIV_I continuous_on tendsto_compose)

lemma esqrt_ereal_ereal_sqrt [simp]:
  assumes "t \<ge> (0::real)"
  shows "esqrt (ereal t) = ereal (sqrt t)"
proof -
  have "ereal t = ereal (sqrt t) * ereal(sqrt t)"
    using assms by auto
  then show ?thesis
    using assms ereal_less_eq(5) esqrt_mult esqrt_square real_sqrt_ge_zero by presburger
qed

lemma ereal_sqrt2:
  "ereal (sqrt 2) = esqrt 2"
using esqrt_ereal_ereal_sqrt[of 2] by auto

lemma esqrt_4 [simp]:
  "esqrt 4 = 2"
by auto

lemma esqrt_le [simp]:
  "esqrt x \<le> esqrt y \<longleftrightarrow> (x \<le> 0 \<or> x \<le> y)"
apply (auto simp add: esqrt_mono2)
by (metis eq_iff ereal_zero_times esqrt_mono2 esqrt_square le_cases)

text \<open>Finally, we define eexp, as the composition of ennexp and the injection of ennreal in ereal.\<close>

definition eexp::"ereal \<Rightarrow> ereal" where
  "eexp x = enn2ereal (ennexp x)"

lemma eexp_special_values [simp]:
  "eexp 0 = 1"
  "eexp (\<infinity>) = \<infinity>"
  "eexp(-\<infinity>) = 0"
unfolding eexp_def by (auto simp add: zero_ennreal.rep_eq one_ennreal.rep_eq)

lemma eexp_strict_mono:
  "strict_mono eexp"
unfolding eexp_def using ennexp_strict_mono unfolding strict_mono_def by (auto intro: mono_intros)

lemma eexp_mono:
  "mono eexp"
using eexp_strict_mono by (simp add: strict_mono_mono)

lemma eexp_strict_mono2 [mono_intros]:
  assumes "x < y"
  shows "eexp x < eexp y"
using eexp_strict_mono assms unfolding strict_mono_def by auto

lemma eexp_mono2 [mono_intros]:
  assumes "x \<le> y"
  shows "eexp x \<le> eexp y"
using eexp_mono assms unfolding mono_def by auto

lemma eexp_le_eexp_iff_le:
  "eexp x \<le> eexp y \<longleftrightarrow> x \<le> y"
using eexp_strict_mono2 not_le by (auto intro: mono_intros)

lemma eexp_lt_eexp_iff_lt:
  "eexp x < eexp y \<longleftrightarrow> x < y"
using eexp_mono2 not_le by (auto intro: mono_intros)

lemma eexp_special_values_iff [simp]:
  "eexp x = 0 \<longleftrightarrow> x = -\<infinity>"
  "eexp x = 1 \<longleftrightarrow> x = 0"
  "eexp x = \<infinity> \<longleftrightarrow> x = \<infinity>"
  "eexp x = top \<longleftrightarrow> x = \<infinity>"
unfolding eexp_def apply (auto simp add: zero_ennreal.rep_eq one_ennreal.rep_eq top_ereal_def)
apply (metis e2ennreal_enn2ereal ennexp.simps(3) ennexp_strict_mono strict_mono_eq zero_ennreal_def)
by (metis e2ennreal_enn2ereal eln_ennexp eln_simps(2) one_ennreal_def)

lemma eexp_ineq_iff [simp]:
  "eexp x \<le> 1 \<longleftrightarrow> x \<le> 0"
  "eexp x \<ge> 1 \<longleftrightarrow> x \<ge> 0"
  "eexp x > 1 \<longleftrightarrow> x > 0"
  "eexp x < 1 \<longleftrightarrow> x < 0"
  "eexp x \<ge> 0"
  "eexp x > 0 \<longleftrightarrow> x \<noteq> - \<infinity>"
  "eexp x < \<infinity> \<longleftrightarrow> x \<noteq> \<infinity>"
apply (metis eexp_le_eexp_iff_le eexp_lt_eexp_iff_lt eexp_special_values)+
apply (simp add: eexp_def)
using eexp_strict_mono2 apply (force)
by simp

lemma eexp_ineq [mono_intros]:
  "x \<le> 0 \<Longrightarrow> eexp x \<le> 1"
  "x < 0 \<Longrightarrow> eexp x < 1"
  "x \<ge> 0 \<Longrightarrow> eexp x \<ge> 1"
  "x > 0 \<Longrightarrow> eexp x > 1"
  "eexp x \<ge> 0"
  "x > -\<infinity> \<Longrightarrow> eexp x > 0"
  "x < \<infinity> \<Longrightarrow> eexp x < \<infinity>"
by auto

lemma eexp_continuous:
  "continuous_on UNIV eexp"
unfolding eexp_def by (rule continuous_on_compose2[of UNIV enn2ereal], auto simp: continuous_on_enn2ereal ennexp_continuous)

lemma eexp_tendsto' [simp]:
  "((\<lambda>n. eexp(u n)) \<longlongrightarrow> eexp l) F \<longleftrightarrow> ((\<lambda>n. u n) \<longlongrightarrow> l) F"
proof
  assume H: "((\<lambda>n. eexp (u n)) \<longlongrightarrow> eexp l) F"
  have "((\<lambda>n. eln (e2ennreal (eexp (u n)))) \<longlongrightarrow> eln (e2ennreal (eexp l))) F"
    by (intro tendsto_intros H)
  then show "(u \<longlongrightarrow> l) F"
    unfolding eexp_def by auto
next
  assume "(u \<longlongrightarrow> l) F"
  then show "((\<lambda>n. eexp(u n)) \<longlongrightarrow> eexp l) F"
    using eexp_continuous by (metis UNIV_I continuous_on tendsto_compose)
qed

lemma eexp_tendsto [tendsto_intros]:
  assumes "((\<lambda>n. u n) \<longlongrightarrow> l) F"
  shows "((\<lambda>n. eexp(u n)) \<longlongrightarrow> eexp l) F"
using assms by auto

lemma eexp_add_mult:
  assumes "\<not>((a = \<infinity> \<and> b = -\<infinity>) \<or> (a = -\<infinity> \<and> b = \<infinity>))"
  shows "eexp(a+b) = eexp a * eexp b"
using ennexp_add_mult[OF assms] unfolding eexp_def by (simp add: times_ennreal.rep_eq)

lemma eexp_ereal [simp]:
  "eexp(ereal x) = ereal(exp x)"
by (simp add: eexp_def)

end (*of theory Eexp_Eln*)


section \<open>Counterclockwise\<close>
theory Counterclockwise
imports "~~/src/HOL/Analysis/Analysis"
begin
text \<open>\label{sec:counterclockwise}\<close>

subsection \<open>Auxiliary Lemmas\<close>

lemma convex3_alt:
  fixes x y z::"'a::real_vector"
  assumes "0 \<le> a" "0 \<le> b" "0 \<le> c" "a + b + c = 1"
  obtains u v  where "a *\<^sub>R x + b *\<^sub>R y + c *\<^sub>R z = x + u *\<^sub>R (y - x) + v *\<^sub>R (z - x)"
    and "0 \<le> u" "0 \<le> v" "u + v \<le> 1"
proof -
  from convex_hull_3[of x y z] have "a *\<^sub>R x + b *\<^sub>R y + c *\<^sub>R z \<in> convex hull {x, y, z}"
    using assms by auto
  also note convex_hull_3_alt
  finally obtain u v where "a *\<^sub>R x + b *\<^sub>R y + c *\<^sub>R z = x + u *\<^sub>R (y - x) + v *\<^sub>R (z - x)"
    and uv: "0 \<le> u" "0 \<le> v" "u + v \<le> 1"
    by auto
  thus ?thesis ..
qed

lemma (in ordered_ab_group_add) add_nonpos_eq_0_iff:
  assumes x: "0 \<ge> x" and y: "0 \<ge> y"
  shows "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
proof -
  from add_nonneg_eq_0_iff[of "-x" "-y"] assms
  have "- (x + y) = 0 \<longleftrightarrow> - x = 0 \<and> - y = 0"
    by simp
  also have "(- (x + y) = 0) = (x + y = 0)" unfolding neg_equal_0_iff_equal ..
  finally show ?thesis by simp
qed

lemma sum_nonpos_eq_0_iff:
  fixes f :: "'a \<Rightarrow> 'b::ordered_ab_group_add"
  shows "\<lbrakk>finite A; \<forall>x\<in>A. f x \<le> 0\<rbrakk> \<Longrightarrow> sum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
  by (induct set: finite) (simp_all add: add_nonpos_eq_0_iff sum_nonpos)

lemma fold_if_in_set:
  "fold (\<lambda>x m. if P x m then x else m) xs x \<in> set (x#xs)"
  by (induct xs arbitrary: x) auto

subsection \<open>Sort Elements of a List\<close>

locale linorder_list0 = fixes LE::"'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

definition "MIN a b = (if LE a b then a else b)"

lemma MIN_in[simp]: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> MIN x y \<in> S"
  by (auto simp: MIN_def)

lemma fold_min_eqI1: "fold MIN ys y \<notin> set ys \<Longrightarrow> fold MIN ys y = y"
  using fold_if_in_set[of _ ys y]
  by (auto simp: MIN_def[abs_def])

function selsort where
  "selsort [] = []"
| "selsort (y#ys) = (let
      xm = fold MIN ys y;
      xs' = List.remove1 xm (y#ys)
    in (xm#selsort xs'))"
  by pat_completeness auto
termination
  by (relation "Wellfounded.measure length")
    (auto simp: length_remove1 intro!: fold_min_eqI1 dest!: length_pos_if_in_set)

lemma in_set_selsort_eq: "x \<in> set (selsort xs) \<longleftrightarrow> x \<in> (set xs)"
  by (induct rule: selsort.induct) (auto simp: Let_def intro!: fold_min_eqI1)

lemma set_selsort[simp]: "set (selsort xs) = set xs"
  using in_set_selsort_eq by blast

lemma length_selsort[simp]: "length (selsort xs) = length xs"
proof (induct xs rule: selsort.induct)
  case (2 x xs)
  from 2[OF refl refl]
  show ?case
    unfolding selsort.simps
    by (auto simp: Let_def length_remove1
      simp del: selsort.simps split: if_split_asm
      intro!: Suc_pred
      dest!: fold_min_eqI1)
qed simp

lemma distinct_selsort[simp]: "distinct (selsort xs) = distinct xs"
  by (auto intro!: card_distinct dest!: distinct_card)

lemma selsort_eq_empty_iff[simp]: "selsort xs = [] \<longleftrightarrow> xs = []"
  by (cases xs) (auto simp: Let_def)

inductive sortedP :: "'a list \<Rightarrow> bool" where
  Nil: "sortedP []"
| Cons: "\<forall>y\<in>set ys. LE x y \<Longrightarrow> sortedP ys \<Longrightarrow> sortedP (x # ys)"

inductive_cases
  sortedP_Nil: "sortedP []" and
  sortedP_Cons: "sortedP (x#xs)"
inductive_simps
  sortedP_Nil_iff: "sortedP Nil" and
  sortedP_Cons_iff: "sortedP (Cons x xs)"

lemma sortedP_append_iff:
  "sortedP (xs @ ys) = (sortedP xs & sortedP ys & (\<forall>x \<in> set xs. \<forall>y \<in> set ys. LE x y))"
  by (induct xs) (auto intro!: Nil Cons elim!: sortedP_Cons)

lemma sortedP_appendI:
  "sortedP xs \<Longrightarrow> sortedP ys \<Longrightarrow> (\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> LE x y) \<Longrightarrow> sortedP (xs @ ys)"
  by (induct xs) (auto intro!: Nil Cons elim!: sortedP_Cons)

lemma sorted_nth_less: "sortedP xs \<Longrightarrow> i < j \<Longrightarrow> j < length xs \<Longrightarrow> LE (xs ! i) (xs ! j)"
  by (induct xs arbitrary: i j) (auto simp: nth_Cons split: nat.split elim!: sortedP_Cons)

lemma sorted_butlastI[intro, simp]: "sortedP xs \<Longrightarrow> sortedP (butlast xs)"
  by (induct xs) (auto simp: elim!: sortedP_Cons intro!: sortedP.Cons dest!: in_set_butlastD)

lemma sortedP_right_of_append1:
  assumes "sortedP (zs@[z])"
  assumes "y \<in> set zs"
  shows "LE y z"
  using assms
  by (induct zs arbitrary: y z) (auto elim!: sortedP_Cons)

lemma sortedP_right_of_last:
  assumes "sortedP zs"
  assumes "y \<in> set zs" "y \<noteq> last zs"
  shows "LE y (last zs)"
  using assms
  apply (intro sortedP_right_of_append1[of "butlast zs" "last zs" y])
  subgoal by (metis append_is_Nil_conv list.distinct(1) snoc_eq_iff_butlast split_list)
  subgoal by (metis List.insert_def append_butlast_last_id insert_Nil list.distinct(1) rotate1.simps(2)
    set_ConsD set_rotate1)
  done

lemma selsort_singleton_iff: "selsort xs = [x] \<longleftrightarrow> xs = [x]"
  by (induct xs) (auto simp: Let_def)

lemma hd_last_sorted:
  assumes "sortedP xs" "length xs > 1"
  shows "LE (hd xs) (last xs)"
proof (cases xs)
  case (Cons y ys)
  note ys = this
  thus ?thesis
    using ys assms
    by (auto elim!: sortedP_Cons)
qed (insert assms, simp)

end

lemma (in comm_monoid_add) sum_list_distinct_selsort:
  assumes "distinct xs"
  shows "sum_list (linorder_list0.selsort LE xs) = sum_list xs"
  using assms
  apply (simp add: distinct_sum_list_conv_Sum linorder_list0.distinct_selsort)
  apply (rule sum.cong)
  subgoal by (simp add: linorder_list0.set_selsort)
  subgoal by simp
  done

declare linorder_list0.sortedP_Nil_iff[code]
  linorder_list0.sortedP_Cons_iff[code]
  linorder_list0.selsort.simps[code]
  linorder_list0.MIN_def[code]

locale linorder_list = linorder_list0 LE for LE::"'a::ab_group_add \<Rightarrow> _" +
  fixes S
  assumes order_refl: "a \<in> S \<Longrightarrow> LE a a"
  assumes trans': "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> c \<in> S \<Longrightarrow> a \<noteq> b \<Longrightarrow> b \<noteq> c \<Longrightarrow> a \<noteq> c \<Longrightarrow>
    LE a b \<Longrightarrow> LE b c \<Longrightarrow> LE a c"
  assumes antisym: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> LE a b \<Longrightarrow> LE b a \<Longrightarrow> a = b"
  assumes linear': "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> a \<noteq> b \<Longrightarrow> LE a b \<or> LE b a"
begin

lemma trans: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> c \<in> S \<Longrightarrow> LE a b \<Longrightarrow> LE b c \<Longrightarrow> LE a c"
  by (cases "a = b" "b = c" "a = c"
    rule: bool.exhaust[case_product bool.exhaust[case_product bool.exhaust]])
    (auto simp: order_refl intro: trans')

lemma linear: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> LE a b \<or> LE b a"
  by (cases "a = b") (auto simp: linear' order_refl)

lemma MIN_le1: "w \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> LE (MIN w y) y"
  and MIN_le2: "w \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> LE (MIN w y) w"
  using linear
  by (auto simp: MIN_def refl)

lemma fold_min:
  assumes "set xs \<subseteq> S"
  shows "list_all (\<lambda>y. LE (fold MIN (tl xs) (hd xs)) y) xs"
proof (cases xs)
  case (Cons y ys)
  hence subset: "set (y#ys) \<subseteq> S" using assms
    by auto
  show ?thesis
    unfolding Cons list.sel
    using subset
  proof (induct ys arbitrary: y)
    case (Cons z zs)
    hence IH: "\<And>y. y \<in> S \<Longrightarrow> list_all (LE (fold MIN zs y)) (y # zs)"
      by simp
    let ?f = "fold MIN zs (MIN z y)"
    have "?f \<in> set ((MIN z y)#zs)"
      unfolding MIN_def[abs_def]
      by (rule fold_if_in_set)
    also have "\<dots> \<subseteq> S" using Cons.prems by auto
    finally have "?f \<in> S" .

    have "LE ?f (MIN z y)"
      using IH[of "MIN z y"] Cons.prems
      by auto
    moreover have "LE (MIN z y) y" "LE (MIN z y) z" using Cons.prems
      by (auto intro!: MIN_le1 MIN_le2)
    ultimately have "LE ?f y" "LE ?f z" using Cons.prems \<open>?f \<in> S\<close>
      by (auto intro!: trans[of ?f "MIN z y"])
    thus ?case
      using IH[of "MIN z y"]
      using Cons.prems
      by auto
  qed (simp add: order_refl)
qed simp

lemma
  sortedP_selsort:
  assumes "set xs \<subseteq> S"
  shows "sortedP (selsort xs)"
  using assms
proof (induction xs rule: selsort.induct)
  case (2 z zs)
  from this fold_min[of "z#zs"]
  show ?case
    by (cases "fold MIN zs z = z")
      (fastforce simp: list_all_iff Let_def
        simp del: remove1.simps
        intro: Cons intro!: 2(1)[OF refl refl]
        dest!: set_rev_mp[OF _ set_remove1_subset])+
qed (auto intro!: Nil)

end

subsection \<open>Abstract CCW Systems\<close>

locale ccw_system0 =
  fixes ccw::"'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
    and S::"'a set"
begin

abbreviation "indelta t p q r \<equiv> ccw t q r \<and> ccw p t r \<and> ccw p q t"
abbreviation "insquare p q r s \<equiv> ccw p q r \<and> ccw q r s \<and> ccw r s p \<and> ccw s p q"

end

abbreviation "distinct3 p q r \<equiv> \<not>(p = q \<or> p = r \<or> q = r)"
abbreviation "distinct4 p q r s \<equiv> \<not>(p = q \<or> p = r \<or> p = s \<or> \<not> distinct3 q r s)"
abbreviation "distinct5 p q r s t \<equiv> \<not>(p = q \<or> p = r \<or> p = s \<or> p = t \<or> \<not> distinct4 q r s t)"

abbreviation "in3 S p q r \<equiv> p \<in> S \<and> q \<in> S \<and> r \<in> S"
abbreviation "in4 S p q r s \<equiv> in3 S p q r \<and> s \<in> S"
abbreviation "in5 S p q r s t \<equiv> in4 S p q r s \<and> t \<in> S"

locale ccw_system12 = ccw_system0 +
  assumes cyclic: "ccw p q r \<Longrightarrow> ccw q r p"
  assumes ccw_antisym: "distinct3 p q r \<Longrightarrow> in3 S p q r \<Longrightarrow> ccw p q r \<Longrightarrow> \<not> ccw p r q"

locale ccw_system123 = ccw_system12 +
  assumes nondegenerate: "distinct3 p q r \<Longrightarrow> in3 S p q r \<Longrightarrow> ccw p q r \<or> ccw p r q"
begin

lemma not_ccw_eq: "distinct3 p q r \<Longrightarrow> in3 S p q r \<Longrightarrow> \<not> ccw p q r \<longleftrightarrow> ccw p r q"
  using ccw_antisym nondegenerate by blast

end

locale ccw_system4 = ccw_system123 +
  assumes interior:
    "distinct4 p q r t \<Longrightarrow> in4 S p q r t \<Longrightarrow> ccw t q r \<Longrightarrow> ccw p t r \<Longrightarrow> ccw p q t \<Longrightarrow> ccw p q r"
begin

lemma interior':
  "distinct4 p q r t \<Longrightarrow> in4 S p q r t \<Longrightarrow> ccw p q t \<Longrightarrow> ccw q r t \<Longrightarrow> ccw r p t \<Longrightarrow> ccw p q r"
  by (metis ccw_antisym cyclic interior nondegenerate)

end

locale ccw_system1235' = ccw_system123 +
  assumes dual_transitive:
    "distinct5 p q r s t \<Longrightarrow> in5 S p q r s t \<Longrightarrow>
      ccw s t p \<Longrightarrow> ccw s t q \<Longrightarrow> ccw s t r \<Longrightarrow> ccw t p q \<Longrightarrow> ccw t q r \<Longrightarrow> ccw t p r"

locale ccw_system1235 = ccw_system123 +
  assumes transitive: "distinct5 p q r s t \<Longrightarrow> in5 S p q r s t \<Longrightarrow>
    ccw t s p \<Longrightarrow> ccw t s q \<Longrightarrow> ccw t s r \<Longrightarrow> ccw t p q \<Longrightarrow> ccw t q r \<Longrightarrow> ccw t p r"
begin

lemmas ccw_axioms = cyclic nondegenerate ccw_antisym transitive

sublocale ccw_system1235'
proof (unfold_locales, rule ccontr, goal_cases)
  case prems: (1 p q r s t)
  hence "ccw s p q \<Longrightarrow> ccw s r p"
    by (metis ccw_axioms prems)
  moreover
  have "ccw s r p \<Longrightarrow> ccw s q r"
    by (metis ccw_axioms prems)
  moreover
  have "ccw s q r \<Longrightarrow> ccw s p q"
    by (metis ccw_axioms prems)
  ultimately
  have "ccw s p q \<and> ccw s r p \<and> ccw s q r \<or> ccw s q p \<and> ccw s p r \<and> ccw s r q"
    by (metis ccw_axioms prems)
  thus False
    by (metis ccw_axioms prems)
qed

end

locale ccw_system = ccw_system1235 + ccw_system4

end


(*<*) theory ex2_3 imports Main begin (*>*)

text {* Let's work with skeletons of binary trees where neither the leaves
(``tip'') nor the nodes contain any information: *}

datatype tree = Tp | Nd tree tree

text {* Define a function @{term tips} that counts the tips of a tree, and a
function @{term height} that computes the height of a tree. *}
primrec tips ::"tree \<Rightarrow> nat"
  where "tips Tp=1"
  |"tips (Nd x y) = (tips x)+ tips y"
primrec height ::"tree \<Rightarrow> nat"
  where "height Tp=0"
  |"height (Nd x y) = 1+  max(height x) (height y)"

text {* Complete binary trees of a given height are generated as follows: *}

primrec cbt :: "nat \<Rightarrow> tree" where
"cbt 0       = Tp" |
"cbt (Suc n) = Nd (cbt n) (cbt n)"

text {* We will now focus on these complete binary trees.

Instead of generating complete binary trees, we can also \emph{test} if a
binary tree is complete.  Define a function @{term "iscbt f"} (where @{term f}
is a function on trees) that checks for completeness:  @{term Tp} is complete,
and @{term"Nd l r"} is complete iff @{term l} and @{term r} are complete and
@{prop"f l = f r"}. *}

primrec iscbt  ::"(tree\<Rightarrow>nat) \<Rightarrow>tree \<Rightarrow> bool" where
"iscbt f Tp = True"
|"iscbt f (Nd x y) = ((f x = f y) \<and>(iscbt f x)\<and>(iscbt f y))"

theorem one:"iscbt height t = iscbt tips t"
  apply (induct t)
  apply auto
  done
lemma [simp]: "iscbt tips t --> tips t =1+size t"
  apply (induct t)
  apply auto
  done
theorem two:"iscbt tips t = iscbt size t"
  apply (induct t)
  apply auto
  done

theorem "iscbt height t = iscbt size t"
  apply( simp add:one two)
  done

theorem "iscbt height t = (t = cbt (height t))"
  apply (induct t)
   apply auto
  done

text {* We now have 3 functions on trees, namely @{term tips}, @{term height}
and @{term size}.  The latter is defined automatically -- look it up in the
tutorial.  Thus we also have 3 kinds of completeness:  complete wrt.\ @{term
tips}, complete wrt.\ @{term height} and complete wrt.\ @{term size}.  Show
that
\begin{itemize}
\item the 3 notions are the same (e.g.\ @{prop "iscbt tips t = iscbt size t"}),
      and
\item the 3 notions describe exactly the trees generated by @{term cbt}:  the
      result of @{term cbt} is complete (in the sense of @{term iscbt}, wrt.\
      any function on trees), and if a tree is complete in the sense of @{term
      iscbt}, it is the result of @{term cbt} (applied to a suitable number~--
      which one?).
\end{itemize}

Hints:
\begin{itemize}
\item Work out and prove suitable relationships between @{term tips}, @{term
      height} und @{term size}.

\item If you need lemmas dealing only with the basic arithmetic operations
      (@{text"+"}, @{text"*"}, @{text"^"} etc), you may ``prove'' them with the
      command @{text sorry}, if neither @{text arith} nor you can find a proof.
      Not @{text "apply sorry"}, just @{text sorry}.

\item You do not need to show that every notion is equal to every other notion.
      It suffices to show that $A = C$ und $B = C$ -- $A = B$ is a trivial
      consequence.  However, the difficulty of the proof will depend on which
      of the equivalences you prove.

\item There is @{text"\<and>"} and @{text"\<longrightarrow>"}.
\end{itemize} *}

text {* Find a function @{term f} such that @{term "iscbt f"} is different from
@{term "iscbt size"}. *}

theorem "iscbt height t = iscbt (\<lambda> x. 0) t "
  quickcheck oops

(*<*) end (*>*)


(*  Title:      CCL/Gfp.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Greatest fixed points\<close>

theory Gfp
imports Lfp
begin

definition
  gfp :: "['a set\<Rightarrow>'a set] \<Rightarrow> 'a set" where \<comment> "greatest fixed point"
  "gfp(f) == Union({u. u <= f(u)})"

(* gfp(f) is the least upper bound of {u. u <= f(u)} *)

lemma gfp_upperbound: "A <= f(A) \<Longrightarrow> A <= gfp(f)"
  unfolding gfp_def by blast

lemma gfp_least: "(\<And>u. u <= f(u) \<Longrightarrow> u <= A) \<Longrightarrow> gfp(f) <= A"
  unfolding gfp_def by blast

lemma gfp_lemma2: "mono(f) \<Longrightarrow> gfp(f) <= f(gfp(f))"
  by (rule gfp_least, rule subset_trans, assumption, erule monoD,
    rule gfp_upperbound, assumption)

lemma gfp_lemma3: "mono(f) \<Longrightarrow> f(gfp(f)) <= gfp(f)"
  by (rule gfp_upperbound, frule monoD, rule gfp_lemma2, assumption+)

lemma gfp_Tarski: "mono(f) \<Longrightarrow> gfp(f) = f(gfp(f))"
  by (rule equalityI gfp_lemma2 gfp_lemma3 | assumption)+

(*** Coinduction rules for greatest fixed points ***)

(*weak version*)
lemma coinduct: "\<lbrakk>a: A;  A <= f(A)\<rbrakk> \<Longrightarrow> a : gfp(f)"
  by (blast dest: gfp_upperbound)

lemma coinduct2_lemma: "\<lbrakk>A <= f(A) Un gfp(f); mono(f)\<rbrakk> \<Longrightarrow> A Un gfp(f) <= f(A Un gfp(f))"
  apply (rule subset_trans)
   prefer 2
   apply (erule mono_Un)
  apply (rule subst, erule gfp_Tarski)
  apply (erule Un_least)
  apply (rule Un_upper2)
  done

(*strong version, thanks to Martin Coen*)
lemma coinduct2: "\<lbrakk>a: A; A <= f(A) Un gfp(f); mono(f)\<rbrakk> \<Longrightarrow> a : gfp(f)"
  apply (rule coinduct)
   prefer 2
   apply (erule coinduct2_lemma, assumption)
  apply blast
  done

(***  Even Stronger version of coinduct  [by Martin Coen]
         - instead of the condition  A <= f(A)
                           consider  A <= (f(A) Un f(f(A)) ...) Un gfp(A) ***)

lemma coinduct3_mono_lemma: "mono(f) \<Longrightarrow> mono(\<lambda>x. f(x) Un A Un B)"
  by (rule monoI) (blast dest: monoD)

lemma coinduct3_lemma:
  assumes prem: "A <= f(lfp(\<lambda>x. f(x) Un A Un gfp(f)))"
    and mono: "mono(f)"
  shows "lfp(\<lambda>x. f(x) Un A Un gfp(f)) <= f(lfp(\<lambda>x. f(x) Un A Un gfp(f)))"
  apply (rule subset_trans)
   apply (rule mono [THEN coinduct3_mono_lemma, THEN lfp_lemma3])
  apply (rule Un_least [THEN Un_least])
    apply (rule subset_refl)
   apply (rule prem)
  apply (rule mono [THEN gfp_Tarski, THEN equalityD1, THEN subset_trans])
  apply (rule mono [THEN monoD])
  apply (subst mono [THEN coinduct3_mono_lemma, THEN lfp_Tarski])
  apply (rule Un_upper2)
  done

lemma coinduct3:
  assumes 1: "a:A"
    and 2: "A <= f(lfp(\<lambda>x. f(x) Un A Un gfp(f)))"
    and 3: "mono(f)"
  shows "a : gfp(f)"
  apply (rule coinduct)
   prefer 2
   apply (rule coinduct3_lemma [OF 2 3])
  apply (subst lfp_Tarski [OF coinduct3_mono_lemma, OF 3])
  using 1 apply blast
  done

subsection \<open>Definition forms of \<open>gfp_Tarski\<close>, to control unfolding\<close>

lemma def_gfp_Tarski: "\<lbrakk>h == gfp(f); mono(f)\<rbrakk> \<Longrightarrow> h = f(h)"
  apply unfold
  apply (erule gfp_Tarski)
  done

lemma def_coinduct: "\<lbrakk>h == gfp(f); a:A; A <= f(A)\<rbrakk> \<Longrightarrow> a: h"
  apply unfold
  apply (erule coinduct)
  apply assumption
  done

lemma def_coinduct2: "\<lbrakk>h == gfp(f); a:A; A <= f(A) Un h; mono(f)\<rbrakk> \<Longrightarrow> a: h"
  apply unfold
  apply (erule coinduct2)
   apply assumption
  apply assumption
  done

lemma def_coinduct3: "\<lbrakk>h == gfp(f); a:A; A <= f(lfp(\<lambda>x. f(x) Un A Un h)); mono(f)\<rbrakk> \<Longrightarrow> a: h"
  apply unfold
  apply (erule coinduct3)
   apply assumption
  apply assumption
  done

(*Monotonicity of gfp!*)
lemma gfp_mono: "\<lbrakk>mono(f); \<And>Z. f(Z) <= g(Z)\<rbrakk> \<Longrightarrow> gfp(f) <= gfp(g)"
  apply (rule gfp_upperbound)
  apply (rule subset_trans)
   apply (rule gfp_lemma2)
   apply assumption
  apply (erule meta_spec)
  done

end