(*<*)

(* Author: Kyndylan Nienhuis *)

theory Preamble

imports
  Main
  WordExtra
  "$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"
  "$ISABELLE_HOME/src/HOL/Eisbach/Eisbach_Tools"
begin

(*>*)
section \<open>Preamble\<close>

text \<open>In this theory we define simplification lemmas that can be used to rewrite definitions of
instructions (for example generated by L3 or Sail). Some of those lemmas will always simplify an
expression, in which case we add them to the simp set. Other lemmas will only simplify an expression
if it is in a certain shape, or when combined with other lemmas. We define a separate attribute
\<^emph>\<open>alt_def_simp\<close> for these lemmas, so we can use them to rewrite generated definitions, but they will
not affect other proof methods. Conversely, some simplification lemmas are unhelpful when we rewrite
generated definitions. To collect these lemmas we define the attribute \<^emph>\<open>alt_def_simp_del\<close>.\<close>

named_theorems alt_def_simp
named_theorems alt_def_simp_del

subsection \<open>Orders\<close>

subsubsection \<open>@{term Downclosed}\<close>

definition Downclosed :: "'a::preorder set \<Rightarrow> 'a set" where
  "Downclosed A \<equiv> {x. \<exists>y\<in>A. x \<le> y}"

lemma DownclosedI [elim]:
  assumes "y \<in> A"
      and "x \<le> y"
  shows "x \<in> Downclosed A"
using assms
unfolding Downclosed_def
by auto

lemma DownclosedI2 [elim!]:
  assumes "x \<in> A"
  shows "x \<in> Downclosed A"
using DownclosedI[OF assms]
by auto

lemma DownclosedE [elim]:
  assumes "x \<in> Downclosed A"
  obtains y where "y \<in> A"  and "x \<le> y"
using assms
unfolding Downclosed_def
by auto

definition IsDownclosed :: "'a::preorder set \<Rightarrow> bool" where
  "IsDownclosed A \<equiv> (\<forall>x y. x \<le> y \<and> y \<in> A \<longrightarrow> x \<in> A)"

lemma IsDownclosedI [intro]:
  assumes "\<And>x y. x \<le> y \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A"
  shows "IsDownclosed A"
using assms
unfolding IsDownclosed_def
by auto

lemma IsDownclosedE [elim]:
  assumes "IsDownclosed A"
      and "x \<le> y"
      and "y \<in> A"
  shows "x \<in> A"
using assms
unfolding IsDownclosed_def
by auto

lemma IsDownclosed_DownclosedIdem:
  shows "(Downclosed A = A) = IsDownclosed A"
proof
  assume "IsDownclosed A"
  show "Downclosed A = A"
    proof (intro equalityI subsetI)
      fix x
      assume "x \<in> Downclosed A"
      then obtain y where "x \<le> y" "y \<in> A" by auto
      thus "x \<in> A" using `IsDownclosed A` by auto
    qed auto
next
  assume "Downclosed A = A"
  show "IsDownclosed A"
    proof
      fix x y
      assume "x \<le> y" "y \<in> A"
      hence "x \<in> Downclosed A" by auto
      thus "x \<in> A" using `Downclosed A = A` by auto
    qed
qed

lemma DownclosedIdemI [intro!]:
  assumes "IsDownclosed A"
  shows "Downclosed A = A"
using assms IsDownclosed_DownclosedIdem
by metis

lemma DownclosedIsDownclosed [simp, intro!]:
  shows "IsDownclosed (Downclosed A)"
proof
  fix x y
  assume "x \<le> y" "y \<in> Downclosed A"
  then obtain z where "y \<le> z" "z \<in> A"
    by auto
  hence "x \<le> z"
    using `x \<le> y` order_trans by auto
  thus "x \<in> Downclosed A"
    using `z \<in> A` by auto
qed

lemma IdemDownclosed [simp]:
  shows "Downclosed (Downclosed A) = Downclosed A"
by auto

lemma DownclosedSubsetIff [simp]:
  shows "(Downclosed A \<subseteq> Downclosed B) = (A \<subseteq> Downclosed B)"
proof (intro iffI subsetI)
  fix x
  assume "x \<in> Downclosed A"
  then obtain y where "x \<le> y" "y \<in> A"
    by auto
  assume "A \<subseteq> Downclosed B"
  hence "y \<in> Downclosed B"
    using `y \<in> A` by auto
  note DownclosedI[OF this `x \<le> y`]
  thus "x \<in> Downclosed B"
    by auto
qed auto

lemma DownclosedSubsetE [elim]:
  assumes "A \<subseteq> Downclosed B"
      and "x \<in> Downclosed A"
  shows "x \<in> Downclosed B"
proof -
  have "Downclosed A \<subseteq> Downclosed B"
    using assms(1) by simp
  from subsetD[OF this assms(2)]
  show "x \<in> Downclosed B" .
qed

subsubsection \<open>Unfolding\<close>

thm case_bool_if
declare case_bool_if [alt_def_simp]

thm linorder_class.not_le
declare linorder_class.not_le [alt_def_simp]

thm linorder_class.not_less
declare linorder_class.not_less [alt_def_simp]

subsection \<open>Products\<close>

lemma prod_simps [simp]:
  shows "(case x of (a, b) \<Rightarrow> f a) = f (fst x)"
    and "(case x of (a, b) \<Rightarrow> g b) = g (snd x)"
by (auto split: prod.split)

lemma case_prod_of_case_prod [simp]:
  shows "(case case x of (a, b) \<Rightarrow> (f a b, f' a b) of (c, d) \<Rightarrow> g c d) =
         (case x of (a, b) \<Rightarrow> g (f a b) (f' a b))"
by (auto split: prod.split)

lemma projection_of_if_prod [simp]:
  shows "fst (if b then (x, y) else (x', y')) = (if b then x else x')"
  and   "snd (if b then (x, y) else (x', y')) = (if b then y else y')"
by simp_all

lemma projection_of_case_prod [simp]:
  shows "fst (case x of (a, b) \<Rightarrow> (f a b, f' a b)) = (case x of (a, b) \<Rightarrow> f a b)"
    and "snd (case x of (a, b) \<Rightarrow> (f a b, f' a b)) = (case x of (a, b) \<Rightarrow> f' a b)"
by (auto split: prod.split)

subsection \<open>Cases\<close>

lemma if_left_TrueI [intro!]:
  assumes "\<not> x \<Longrightarrow> Q"
  shows "if x then True else Q"
using assms
by auto

lemma if_right_TrueI [intro!]:
  assumes "x \<Longrightarrow> Q"
  shows "if x then Q else True"
using assms
by auto

lemma option_left_TrueI [intro!]:
  assumes "\<And>y. x = Some y \<Longrightarrow> Q y"
  shows "case x of None \<Rightarrow> True | Some y \<Rightarrow> Q y"
using assms
by (cases x) auto

lemma option_right_TrueI [intro!]:
  assumes "x = None \<Longrightarrow> Q"
  shows "case x of None \<Rightarrow> Q | Some y \<Rightarrow> True"
using assms
by (cases x) auto

lemma list_left_TrueI [intro!]:
  assumes "\<And>h t. x = h # t \<Longrightarrow> Q h t"
  shows "case x of [] \<Rightarrow> True | h # t \<Rightarrow> Q h t"
using assms
by (cases x) auto

lemma list_right_TrueI [intro!]:
  assumes "x = [] \<Longrightarrow> Q"
  shows "case x of [] \<Rightarrow> Q | h # t \<Rightarrow> True"
using assms
by (cases x) auto

lemmas ifD [dest] =
  if_splits(1)[where P="\<lambda>x. x", THEN iffD1]

lemmas optionD [dest] =
  option.splits(1)[where P="\<lambda>x. x", THEN iffD1]

lemmas listD [dest] =
  list.splits(1)[where P="\<lambda>x. x", THEN iffD1]

lemmas prodD [dest] =
  prod.splits(1)[where P="\<lambda>x. x", THEN iffD1]

subsection \<open>Natural numbers and integers\<close>

lemma less_diff_iff':
  fixes a b c d :: nat
  assumes "a \<le> c"
  shows "(c - a < c - b) = (b < a)"
using assms
by auto

subsection \<open>Words\<close>

declare ucast_shiftr [alt_def_simp]
declare ucast_shiftl [alt_def_simp]
declare ucast_not [alt_def_simp]
declare ucast_or [alt_def_simp]
declare ucast_and [alt_def_simp]
declare ucast_xor [alt_def_simp]
declare ucast_plus_down [alt_def_simp]
declare ucast_minus_down [alt_def_simp]

lemma scast_alt_def_sym [alt_def_simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('c) = LENGTH('a) + LENGTH('b)"
      and "m = LENGTH('a) - 1"
  shows "(word_cat (if x !! m then max_word else 0::'b::len word) x) =
         (scast x::'c::len word)"
using assms
by (simp add: scast_alt_def)

(* If child theories also import \<^emph>\<open>Words\<close> then it is undefined whether @{const bin_to_bl_def} will
be in the simp set or not (see the Isabelle Tutorial 3.1.2). We therefore need to delete is again
from any such child theory. *)

thm bin_to_bl_def
declare bin_to_bl_def [simp del]

lemma if_1_word_0th [simp]:
  shows "(if b then (1 :: 1 word) else 0) !! 0 = b"
by simp

lemma scast_scast_shiftl_unat [alt_def_simp]:
  fixes x :: "'a::len word"
    and y :: "'b::len word"
  assumes "LENGTH('a) + 2 ^ LENGTH('b) - 1 \<le> LENGTH('c)"
  shows "scast ((scast x::'c::len word) << (unat y)) = scast x << (unat y)"
proof -
  have "unat y \<le> 2 ^ LENGTH('b) - 1"
    using unat_lt2p[where x=y]
    by arith
  from add_left_mono[where c="LENGTH('a)", OF this]
  have "LENGTH('a) + unat y \<le> LENGTH('c)"
    using assms
    by auto
  from scast_scast_shiftl[OF this]
  show ?thesis .
qed

paragraph \<open>Folding\<close>

lemmas sym_ucast_def [alt_def_simp] =
  ucast_def[THEN sym]

lemmas sym_uint_nat [alt_def_simp] =
  uint_nat[THEN sym]

lemmas sym_unat_def [alt_def_simp] =
  unat_def[THEN sym]

paragraph \<open>Word case split\<close>

text \<open>The definitions of some instructions contain a conditional branch that can never be taken
(since @{typ "2 word"} can only be 0, 1, 2 or 3) and that branch is @{term undefined}. This makes
the proofs more difficult, so we simplify those expressions.\<close>

lemma twoWord_if [alt_def_simp]:
  fixes t :: "2 word"
  shows "(if t = 0 then m0
          else if t = 1 then m1
          else if t = 2 then m2
          else if t = 3 then m3
          else m4) =
         (if t = 0 then m0
          else if t = 1 then m1
          else if t = 2 then m2
          else m3)"
proof -
  obtain n where t: "t = of_nat n" and "n < 4"
    by (cases t) auto
  hence "n = 0 \<or> n = 1 \<or> n = 2 \<or> n = 3"
    by auto
  thus ?thesis
    using t by auto
qed

lemma threeWord_if [alt_def_simp]:
  fixes t :: "3 word"
  shows "(if t = 0 then m0
          else if t = 1 then m1
          else if t = 2 then m2
          else if t = 3 then m3
          else if t = 4 then m4
          else if t = 5 then m5
          else if t = 6 then m6
          else if t = 7 then m7
          else m8) =
         (if t = 0 then m0
          else if t = 1 then m1
          else if t = 2 then m2
          else if t = 3 then m3
          else if t = 4 then m4
          else if t = 5 then m5
          else if t = 6 then m6
          else m7)"
proof -
  obtain n where t: "t = of_nat n" and "n < 8"
    by (cases t) auto
  hence "n = 0 \<or> n = 1 \<or> n = 2 \<or> n = 3 \<or> n = 4 \<or> n = 5 \<or> n = 6 \<or> n = 7"
    by auto
  thus ?thesis
    using t by auto
qed

lemma word_twoWord_if [alt_def_simp]:
  fixes t :: "1 word"
    and s :: "2 word"
  shows "(if t = 0 \<and> s = 0 then m0
          else if t = 0 \<and> s = 1 then m1
          else if t = 0 \<and> s = 2 then m2
          else if t = 0 \<and> s = 3 then m3
          else if t = 1 \<and> s = 0 then m4
          else if t = 1 \<and> s = 1 then m5
          else if t = 1 \<and> s = 2 then m6
          else if t = 1 \<and> s = 3 then m7
          else m8) =
         (if t = 0 \<and> s = 0 then m0
          else if t = 0 \<and> s = 1 then m1
          else if t = 0 \<and> s = 2 then m2
          else if t = 0 \<and> s = 3 then m3
          else if t = 1 \<and> s = 0 then m4
          else if t = 1 \<and> s = 1 then m5
          else if t = 1 \<and> s = 2 then m6
          else m7)"
proof -
  obtain n where t: "t = of_nat n" and "n < 2"
    by (cases t) auto
  hence n: "n = 0 \<or> n = 1"
    by auto
  hence t2: "t = 0 \<or> t = 1"
    using t by auto
  obtain m where s: "s = of_nat m" and "m < 4"
    by (cases s) auto
  hence m: "m = 0 \<or> m = 1 \<or> m = 2 \<or> m = 3"
    by auto
  hence s2: "s = 0 \<or> s = 1 \<or> s = 2 \<or> s = 3"
    using s by auto
  thus ?thesis
    using t2 s2 by auto
qed

(*<*)
end
(*>*)


(*
  File: Circle_Area.thy
  Author: Manuel Eberl <eberlm@in.tum.de>

  An proof that the area of a circle with radius R is R²\<pi>.
  The proof uses integration by substitution on interval integrals.
*)
theory Circle_Area
imports Complex_Main Interval_Integral
begin

section {* Auxiliary lemmas *}

lemma plus_emeasure':
  assumes "A \<in> sets M" "B \<in> sets M" "A \<inter> B \<in> null_sets M"
  shows "emeasure M A + emeasure M B = emeasure M (A \<union> B)"
proof-
  let ?C = "A \<inter> B"
  have "A \<union> B = A \<union> (B - ?C)" by blast
  with assms have "emeasure M (A \<union> B) = emeasure M A + emeasure M (B - ?C)"
    by (subst plus_emeasure) auto
  also from assms(3,2) have "emeasure M (B - ?C) = emeasure M B"
    by (rule emeasure_Diff_null_set)
  finally show ?thesis ..
qed

lemma real_sqrt_square:
  "x \<ge> 0 \<Longrightarrow> sqrt (x^2) = (x::real)" by simp

section {* Circle area theorems *}

lemma unit_circle_area_aux:
  "LBINT x=-1..1. 2 * sqrt (1 - x^2) = pi"
proof-
  have "LBINT x=-1..1. 2 * sqrt (1 - x^2) =
            LBINT x=ereal (sin (-pi/2))..ereal (sin (pi/2)). 2 * sqrt (1 - x^2)"
    by (simp_all add: one_ereal_def)
  also have "... = LBINT x=-pi/2..pi/2. cos x *\<^sub>R (2 * sqrt (1 - (sin x)\<^sup>2))"
    by (rule interval_integral_substitution_finite[symmetric])
       (auto intro: DERIV_subset[OF DERIV_sin] intro!: continuous_intros)
  also have "... = LBINT x=-pi/2..pi/2. 2 * cos x * sqrt ((cos x)^2)"
    by (simp add: cos_squared_eq field_simps)
  also {
    fix x assume "x \<in> {-pi/2<..<pi/2}"
    hence "cos x \<ge> 0" by (intro cos_ge_zero) simp_all
    hence "sqrt ((cos x)^2) = cos x" by simp
  } note A = this
  have "LBINT x=-pi/2..pi/2. 2 * cos x * sqrt ((cos x)^2) = LBINT x=-pi/2..pi/2. 2 * (cos x)^2"
    by (intro interval_integral_cong, subst A) (simp_all add: min_def max_def power2_eq_square)
  also let ?F = "\<lambda>x. x + sin x * cos x"
   {
    fix x A
    have "(?F has_real_derivative 1 - (sin x)^2 + (cos x)^2) (at x)"
      by (auto simp: power2_eq_square intro!: derivative_eq_intros)
    also have "1 - (sin x)^2 + (cos x)^2 = 2 * (cos x)^2" by (simp add: cos_squared_eq)
    finally have "(?F has_real_derivative 2 * (cos x)^2) (at x within A)"
      by (rule DERIV_subset) simp
  }
  hence "LBINT x=-pi/2..pi/2. 2 * (cos x)^2 = ?F (pi/2) - ?F (-pi/2)"
    by (intro interval_integral_FTC_finite)
       (auto simp: has_field_derivative_iff_has_vector_derivative intro!: continuous_intros)
  also have "... = pi" by simp
  finally show ?thesis .
qed

lemma unit_circle_area:
  "emeasure lborel {z::real\<times>real. norm z \<le> 1} = pi" (is "emeasure _ ?A = _")
proof-
  let ?A1 = "{(x,y)\<in>?A. y \<ge> 0}" and ?A2 = "{(x,y)\<in>?A. y \<le> 0}"
  have [measurable]: "(\<lambda>x. snd (x :: real \<times> real)) \<in> measurable borel borel"
    by (simp add: borel_prod[symmetric])

  have "?A1 = ?A \<inter> {x\<in>space lborel. snd x \<ge> 0}" by auto
  also have "?A \<inter> {x\<in>space lborel. snd x \<ge> 0} \<in> sets borel"
    by (intro sets.Int pred_Collect_borel) simp_all
  finally have A1_in_sets: "?A1 \<in> sets lborel" by (subst sets_lborel)

  have "?A2 = ?A \<inter> {x\<in>space lborel. snd x \<le> 0}" by auto
  also have "... \<in> sets borel"
    by (intro sets.Int pred_Collect_borel) simp_all
  finally have A2_in_sets: "?A2 \<in> sets lborel" by (subst sets_lborel)

  have A12: "?A = ?A1 \<union> ?A2" by auto
  have sq_le_1_iff: "\<And>x. x\<^sup>2 \<le> 1 \<longleftrightarrow> abs (x::real) \<le> 1" using real_abs_le_square_iff[of _ 1] by simp
  have "?A1 \<inter> ?A2 = {x. abs x \<le> 1} \<times> {0}" by (auto simp: norm_Pair field_simps sq_le_1_iff)
  also have "... \<in> null_sets lborel"
    by (subst lborel_prod[symmetric]) (auto simp: lborel.emeasure_pair_measure_Times)
  finally have "emeasure lborel ?A = emeasure lborel ?A1 + emeasure lborel ?A2"
    by (subst A12, rule plus_emeasure'[OF A1_in_sets A2_in_sets, symmetric])

  also have "emeasure lborel ?A1 = \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A1 (x,y) \<partial>lborel \<partial>lborel"
    by (subst lborel_prod[symmetric], subst lborel.emeasure_pair_measure)
       (simp_all only: lborel_prod A1_in_sets)
  also have "emeasure lborel ?A2 = \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A2 (x,y) \<partial>lborel \<partial>lborel"
    by (subst lborel_prod[symmetric], subst lborel.emeasure_pair_measure)
       (simp_all only: lborel_prod A2_in_sets)
  also have "distr lborel lborel uminus = (lborel :: real measure)"
    by (subst (3) lborel_real_affine[of "-1" 0])
       (simp_all add: one_ereal_def[symmetric] density_1 cong: distr_cong)
  hence "(\<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A2 (x,y) \<partial>lborel \<partial>lborel) =
             \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A2 (x,y) \<partial>distr lborel lborel uminus \<partial>lborel" by simp
  also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A2 (x,-y) \<partial>lborel \<partial>lborel"
    apply (intro nn_integral_cong nn_integral_distr, simp)
    apply (intro measurable_compose[OF _ borel_measurable_indicator[OF A2_in_sets]], simp)
    done
  also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A1 (x,y) \<partial>lborel \<partial>lborel"
    by (intro nn_integral_cong) (auto split: split_indicator simp: norm_Pair)
  also have "... + ... = (1+1) * ..." by (subst ereal_left_distrib) simp_all
  also have "... = \<integral>\<^sup>+x. 2 * \<integral>\<^sup>+y. indicator ?A1 (x,y) \<partial>lborel \<partial>lborel"
    by (subst nn_integral_cmult) simp_all
  also {
    fix x y :: real assume "x \<notin> {-1..1}"
    hence "abs x > 1" by auto
    also have "norm (x,y) \<ge> abs x" by (simp add: norm_Pair)
    finally have "(x,y) \<notin> ?A1" by auto
  }
  hence "... = \<integral>\<^sup>+x. 2 * (\<integral>\<^sup>+y. indicator ?A1 (x,y) \<partial>lborel) * indicator {-1..1} x \<partial>lborel"
    by (intro nn_integral_cong) (auto split: split_indicator)
  also {
    fix x :: real assume "x \<in> {-1..1}"
    hence x: "1 - x\<^sup>2 \<ge> 0" by (simp add: field_simps sq_le_1_iff abs_real_def)
    have "\<And>y. (y::real) \<ge> 0 \<Longrightarrow> norm (x,y) \<le> 1 \<longleftrightarrow> y \<le> sqrt (1-x\<^sup>2)"
      by (subst (5) real_sqrt_square[symmetric], simp, subst real_sqrt_le_iff)
         (simp_all add: norm_Pair field_simps)
    hence "(\<integral>\<^sup>+y. indicator ?A1 (x,y) \<partial>lborel) = (\<integral>\<^sup>+y. indicator {0..sqrt (1-x\<^sup>2)} y \<partial>lborel)"
      by (intro nn_integral_cong) (auto split: split_indicator)
    also from x have "... = sqrt (1-x\<^sup>2)" using x by simp
    finally have "(\<integral>\<^sup>+y. indicator ?A1 (x,y) \<partial>lborel) = sqrt (1-x\<^sup>2)" .
  }
  hence "(\<integral>\<^sup>+x. 2 * (\<integral>\<^sup>+y. indicator ?A1 (x,y) \<partial>lborel) * indicator {-1..1} x \<partial>lborel) =
            \<integral>\<^sup>+x. 2 * sqrt (1-x\<^sup>2) * indicator {-1..1} x \<partial>lborel"
    by (intro nn_integral_cong) (simp split: split_indicator)
  also have A: "\<And>x. -1 \<le> x \<Longrightarrow> x \<le> 1 \<Longrightarrow> \<not>x^2 > (1::real)"
    by (subst not_less, subst sq_le_1_iff) (simp add: abs_real_def)
  have "integrable lborel (\<lambda>x. 2 * sqrt (1-x\<^sup>2) * indicator {-1..1::real} x)"
    apply (rule integrable_bound[OF integrable_indicator[of "{-1..1}"], of _ _ "2::real"],
           simp, simp, simp)
    apply (rule AE_I2, auto simp: abs_real_def power2_eq_square field_simps
                            dest: A split: split_indicator)
    done
  hence "(\<integral>\<^sup>+x. 2 * sqrt (1-x\<^sup>2) * indicator {-1..1} x \<partial>lborel) =
             ereal (\<integral>x. 2 * sqrt (1-x\<^sup>2) * indicator {-1..1} x \<partial>lborel)"
    by (intro nn_integral_eq_integral AE_I2)
       (auto split: split_indicator simp: field_simps sq_le_1_iff)
  also have "(\<integral>x. 2 * sqrt (1-x\<^sup>2) * indicator {-1..1} x \<partial>lborel) =
               LBINT x:{-1..1}. 2 * sqrt (1-x\<^sup>2)" by (simp add: field_simps)
  also have "... = LBINT x=-1..1. 2 * sqrt (1-x\<^sup>2)"
    by (subst interval_integral_Icc[symmetric]) (simp_all add: one_ereal_def)
  also have "... = pi" by (rule unit_circle_area_aux)
  finally show ?thesis .
qed

lemma circle_sets_borel:
  "{z::real\<times>real. norm z \<le> R} \<in> sets borel" by simp

lemma circle_area:
  assumes "R \<ge> 0"
  shows "emeasure lborel {z::real\<times>real. norm z \<le> R} = R^2 * pi" (is "emeasure _ ?A = _")
proof (cases "R = 0")
  assume "R \<noteq> 0"
  with assms have R: "R > 0" by simp
  let ?A' = "{z::real\<times>real. norm z \<le> 1}"
  have "emeasure lborel ?A = \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A (x,y) \<partial>lborel \<partial>lborel"
    by (subst lborel_prod[symmetric], subst lborel.emeasure_pair_measure, subst lborel_prod)
       simp_all
  also have "... = \<integral>\<^sup>+x. R * \<integral>\<^sup>+y. indicator ?A (x,R*y) \<partial>lborel \<partial>lborel"
  proof (rule nn_integral_cong)
    fix x from R show "(\<integral>\<^sup>+y. indicator ?A (x,y) \<partial>lborel) = R * \<integral>\<^sup>+y. indicator ?A (x,R*y) \<partial>lborel"
      by (subst nn_integral_real_affine[OF _ `R \<noteq> 0`, of _ 0]) simp_all
  qed
  also have "... = R * \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A (x,R*y) \<partial>lborel \<partial>lborel"
    using R by (intro nn_integral_cmult) simp_all
  also from R have "(\<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A (x,R*y) \<partial>lborel \<partial>lborel) =
                        R * \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A (R*x,R*y) \<partial>lborel \<partial>lborel"
    by (subst nn_integral_real_affine[OF _ `R \<noteq> 0`, of _ 0]) simp_all
  also {
    fix x y
    have A: "(R*x, R*y) = R *\<^sub>R (x,y)" by simp
    from R have "norm (R*x, R*y) = R * norm (x,y)" by (subst A, subst norm_scaleR) simp_all
    with R have "(R*x, R*y) \<in> ?A \<longleftrightarrow> (x, y) \<in> ?A'" by (auto simp: field_simps)
  }
  hence "(\<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A (R*x,R*y) \<partial>lborel \<partial>lborel) =
               \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator ?A' (x,y) \<partial>lborel \<partial>lborel"
    by (intro nn_integral_cong) (simp split: split_indicator)
  also have "... = emeasure lborel ?A'"
    by (subst lborel_prod[symmetric], subst lborel.emeasure_pair_measure, subst lborel_prod)
       simp_all
  also have "... = pi" by (rule unit_circle_area)
  finally show ?thesis by (simp add: power2_eq_square)
qed simp

end


theory tree_sort_SortPermutes2
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype 'a Tree = Node "'a Tree" "'a" "'a Tree" | Nil2

datatype Nat = Z | S "Nat"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'a list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun flatten :: "'a Tree => 'a list => 'a list" where
"flatten (Node q z q2) y = flatten q (Cons2 z (flatten q2 y))"
| "flatten (Nil2) y = y"

fun equal2 :: "Nat => Nat => bool" where
"equal2 (Z) (Z) = True"
| "equal2 (Z) (S z) = False"
| "equal2 (S x2) (Z) = False"
| "equal2 (S x2) (S y2) = equal2 x2 y2"

fun elem :: "Nat => Nat list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (equal2 x z) (elem x ys)"

fun delete :: "Nat => Nat list => Nat list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if equal2 x z then ys else Cons2 z (delete x ys))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "Nat list => Nat list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

fun add :: "Nat => Nat Tree => Nat Tree" where
"add x (Node q z q2) =
   (if le x z then Node (add x q) z q2 else Node q z (add x q2))"
| "add x (Nil2) = Node (Nil2) x (Nil2)"

fun toTree :: "Nat list => Nat Tree" where
"toTree (Nil2) = Nil2"
| "toTree (Cons2 y xs) = add y (toTree xs)"

fun tsort :: "Nat list => Nat list" where
"tsort x = flatten (toTree x) (Nil2)"

(*hipster or2
          null
          le
          flatten
          equal2
          elem
          delete
          and2
          isPermutation
          add
          toTree
          tsort *)

theorem x0 :
  "!! (x :: Nat list) . isPermutation (tsort x) x"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory nunion
imports Main
        "../data/Natu"
        "../data/list"
        "../funcs/equal"
        "$HIPSTER_HOME/IsaHipster"

begin

datatype NList = NNil | NCons Nat NList

fun elemN :: "Nat => NList => bool" where
  "elemN x (NNil) = False"
| "elemN x (NCons z xs) = (if equal2 x z then True else elemN x xs)"

fun union :: "NList => NList => NList" where
  "union (NNil) y = y"
| "union (NCons z xs) y =
     (if elemN z y then union xs y else NCons z (union xs y))"

lemma xu : "union (NCons y ys) (NCons y ys) = NCons y (union ys ys)"
apply(induction ys)
apply simp+
oops

(*lemma xw : "elemN x ys \<Longrightarrow> elemN x (union xs ys)"
by (hipster_induct_schemes elemN.simps union.simps equal2.simps)*)

(*lemma xz : "elemN x (union (NCons x xs) ys)"
by (hipster_induct_schemes xw elemN.simps union.simps equal2.simps)*)

lemma xy : "elemN x xs \<Longrightarrow> elemN x (union xs ys)"
by (hipster_induct_schemes  elemN.simps union.simps equal2.simps)

lemma xv: "\<And>xs. (ALL elemN x xs. elemN x ys \<Longrightarrow> union xs ys = ys)"
apply(induction)
apply simp_all
oops

end


theory Why3_List
imports Why3_Setup
begin

section {* Length of a list *}

why3_open "list/Length.xml"

why3_vc lengthqtdef by (cases l) simp_all

why3_vc Length_nil by simp

why3_vc Length_nonnegative by simp

why3_end

section {* Membership in a list *}

why3_open "list/Mem.xml"

why3_vc memqtdef by (simp split: list.split)

why3_end

section {* Nth element of a list *}

why3_open "list/Nth.xml"

lemma nth_eq: "0 \<le> i \<Longrightarrow> nat i < length xs \<Longrightarrow> nth i xs = Some (xs ! nat i)"
  by (induct xs arbitrary: i) (auto simp add: nat_diff_distrib)

why3_vc is_noneqtspec
  by (simp add: is_none_def split: option.split)

why3_end

why3_open "list/NthNoOpt.xml"

why3_vc nth_cons_0 by simp

why3_vc nth_cons_n
  using assms
  by (simp add: nat_diff_distrib)

why3_end

why3_open "list/NthLength.xml"

why3_vc nth_none_1
  using assms
  by (induct l arbitrary: i) simp_all

why3_vc nth_none_2
  using assms
  by (induct l arbitrary: i) simp_all

why3_vc nth_none_3
  using assms
proof (induct l arbitrary: i)
  case Nil
  then show ?case by simp arith
next
  case (Cons x xs)
  show ?case
  proof (cases "i < 0")
    case False
    with Cons have "0 < i" by (simp split: if_split_asm)
    with Cons have "Nth.nth (i - 1) xs = None" by simp
    then have "i - 1 < 0 \<or> int (length xs) \<le> i - 1"
      by (rule Cons)
    with `0 < i` show ?thesis by auto
  qed simp
qed

why3_vc is_noneqtspec
  by (simp add: is_none_def split: option.split)

why3_end

section {* Head and tail *}

why3_open "list/HdTl.xml"

why3_vc is_noneqtspec
  by (simp add: is_none_def split: option.split)

why3_end

why3_open "list/HdTlNoOpt.xml"

why3_vc hd_cons by simp

why3_vc tl_cons by simp

why3_end

section {* Relation between head, tail, and nth *}

why3_open "list/NthHdTl.xml"

why3_vc Nth_tl
  using assms
  by (simp add: tl_def split: list.split_asm)

why3_vc Nth0_head
  by (simp add: hd_def split: list.split)

why3_vc is_noneqtspec
  by (simp add: is_none_def split: option.split)

why3_end

section {* Appending two lists *}

why3_open "list/Append.xml"

why3_vc infix_plplqtdef by (simp split: list.split)

why3_vc Append_assoc by simp

why3_vc Append_l_nil by simp

why3_vc Append_length by simp

why3_vc mem_append by simp

why3_vc mem_decomp
  using assms
  by (simp add: in_set_conv_decomp)

why3_end

why3_open "list/NthLengthAppend.xml"

why3_vc nth_append_1
proof (cases "0 \<le> i")
  case True
  with assms have "nat i < length l1" by simp
  with True show ?thesis
    by (simp add: nth_eq nth_append)
next
  case False
  then show ?thesis by (simp add: nth_none_1)
qed

why3_vc nth_append_2
proof (cases "nat i < length (l1 @ l2)")
  case True
  with assms show ?thesis
    by (auto simp add: nth_eq nth_append nat_diff_distrib)
next
  case False
  with assms show ?thesis by (simp add: nth_none_2)
qed

why3_vc is_noneqtspec
  by (simp add: is_none_def split: option.split)

why3_end

section {* Reversing a list *}

why3_open "list/Reverse.xml"

why3_vc reverseqtdef by (simp split: list.split)

why3_vc Reverse_length by simp

why3_vc reverse_append by simp

why3_vc reverse_reverse by simp

why3_vc reverse_mem by simp

why3_vc reverse_cons by simp

why3_vc cons_reverse by simp

why3_end

section {* Reverse append *}

why3_open "list/RevAppend.xml"

why3_vc rev_append_append_l
  by (induct r arbitrary: t) simp_all

why3_vc rev_append_append_r
proof (induct s arbitrary: r)
  case (Cons x xs)
  show ?case by (simp add: Cons [symmetric])
qed simp

why3_vc rev_append_length
  by (induct s arbitrary: t) simp_all

why3_vc rev_append_def
  by (induct r arbitrary: s) simp_all

why3_end

section {* Zip *}

why3_open "list/Combine.xml"

why3_end

section {* List with pairwise distinct elements *}

why3_open "list/Distinct.xml"

why3_vc distinct_zero by simp

why3_vc distinct_one by simp

why3_vc distinct_many using assms by simp

why3_vc distinct_append using assms by auto

why3_end

section {* Number of occurrences in a list *}

why3_open "list/NumOcc.xml"

why3_vc Num_Occ_NonNeg
  by (induct l) simp_all

why3_vc Mem_Num_Occ
proof (induct l)
  case (Cons y ys)
  from Num_Occ_NonNeg [of y ys]
  have "0 < 1 + num_occ y ys" by simp
  with Cons show ?case by simp
qed simp

why3_vc Append_Num_Occ
  by (induct l1) simp_all

why3_vc reverse_num_occ
  by (induct l) (simp_all add: Append_Num_Occ)

why3_end

section {* Permutation of lists *}

why3_open "list/Permut.xml"

why3_vc Permut_refl by (simp add: permut_def)

why3_vc Permut_sym using assms by (simp add: permut_def)

why3_vc Permut_trans using assms by (simp add: permut_def)

why3_vc Permut_cons using assms by (simp add: permut_def)

why3_vc Permut_swap by (simp add: permut_def)

why3_vc Permut_cons_append by (simp add: permut_def Append_Num_Occ)

why3_vc Permut_assoc by (simp add: permut_def)

why3_vc Permut_append using assms by (simp add: permut_def Append_Num_Occ)

why3_vc Permut_append_swap by (simp add: permut_def Append_Num_Occ)

why3_vc Permut_mem using assms by (simp add: permut_def Mem_Num_Occ)

why3_vc Permut_length
  using assms
proof (induct l1 arbitrary: l2)
  case Nil
  then show ?case
  proof (cases l2)
    case (Cons x xs)
    with Nil Num_Occ_NonNeg [of x xs]
    show ?thesis by (auto simp add: permut_def dest: spec [of _ x])
  qed simp
next
  case (Cons x xs)
  from `permut (x # xs) l2` have "x \<in> set l2"
    by (rule Permut_mem) simp
  then obtain ys zs where "l2 = ys @ x # zs"
    by (auto simp add: in_set_conv_decomp)
  with Cons have "permut (x # xs) (ys @ x # zs)" by simp
  moreover have "permut (ys @ x # zs) ((x # zs) @ ys)"
    by (rule Permut_append_swap)
  ultimately have "permut (x # xs) ((x # zs) @ ys)"
    by (rule Permut_trans)
  then have "permut xs (zs @ ys)" by (simp add: permut_def)
  then have "int (length xs) = int (length (zs @ ys))" by (rule Cons)
  with `l2 = ys @ x # zs` show ?case by simp
qed

why3_end

end


theory conditions_positive_infinitary
  imports conditions_positive "../boolean_algebra/boolean_algebra_infinitary"
begin

(**We define and interrelate infinitary variants for some previously introduced
 axiomatic conditions on operators.*)

(**Distribution over infinite joins (suprema) or infinite additivity (iADDI).*)
definition iADDI::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iADDI")
  where "iADDI \<phi>   \<equiv> \<forall>S. \<phi>(\<^bold>\<Or>S) \<approx> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>"
definition iADDI_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iADDI\<^sup>a")
  where "iADDI\<^sup>a \<phi> \<equiv> \<forall>S. \<phi>(\<^bold>\<Or>S) \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>"
definition iADDI_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iADDI\<^sup>b")
  where "iADDI\<^sup>b \<phi> \<equiv> \<forall>S. \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<phi>(\<^bold>\<Or>S)"
(**Distribution over infinite meets (infima) or infinite multiplicativity (iMULT).*)
definition iMULT::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iMULT")
  where "iMULT \<phi>   \<equiv> \<forall>S. \<phi>(\<^bold>\<And>S) \<approx> \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>"
definition iMULT_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iMULT\<^sup>a")
  where "iMULT\<^sup>a \<phi> \<equiv> \<forall>S. \<phi>(\<^bold>\<And>S) \<preceq> \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>"
definition iMULT_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("iMULT\<^sup>b")
  where "iMULT\<^sup>b \<phi> \<equiv> \<forall>S. \<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<phi>(\<^bold>\<And>S)"

declare iADDI_def[cond] iADDI_a_def[cond] iADDI_b_def[cond]
        iMULT_def[cond] iMULT_a_def[cond] iMULT_b_def[cond]

lemma iADDI_char: "iADDI \<phi> = (iADDI\<^sup>a \<phi> \<and> iADDI\<^sup>b \<phi>)" unfolding cond using setequ_char by blast
lemma iMULT_char: "iMULT \<phi> = (iMULT\<^sup>a \<phi> \<and> iMULT\<^sup>b \<phi>)" unfolding cond using setequ_char by blast

(**ADDI-b and iADDI-b are in fact equivalent.*)
lemma iADDIb_equ: "iADDI\<^sup>b \<phi> = ADDI\<^sup>b \<phi>" proof -
  have lr: "iADDI\<^sup>b \<phi> \<Longrightarrow> ADDI\<^sup>b \<phi>" proof - (*prove as a one-liner by instantiating iADDI_b_def with S=(\<lambda>Z. Z=A \<or> Z=B)*)
  assume iaddib: "iADDI\<^sup>b \<phi>"
  { fix A::"'a \<sigma>" and B::"'a \<sigma>" (* for some reason Isabelle doesn't like other letters as type variable. Why?*)
    let ?S="\<lambda>Z. Z=A \<or> Z=B"
    have "\<^bold>\<Or>?S = A \<^bold>\<or> B" unfolding supremum_def join_def by blast
    hence p1: "\<phi>(\<^bold>\<Or>?S) = \<phi>(A \<^bold>\<or> B)" by simp
    have "\<lbrakk>\<phi> ?S\<rbrakk> = (\<lambda>Z. Z=(\<phi> A) \<or> Z=(\<phi> B))" unfolding image_def by metis
    hence p2: "\<^bold>\<Or>\<lbrakk>\<phi> ?S\<rbrakk> = (\<phi> A) \<^bold>\<or> (\<phi> B)" unfolding supremum_def join_def by auto
    have " \<^bold>\<Or>\<lbrakk>\<phi> ?S\<rbrakk> \<preceq> \<phi>(\<^bold>\<Or>?S)" using iaddib iADDI_b_def by blast
    hence "(\<phi> A) \<^bold>\<or> (\<phi> B) \<preceq> \<phi>(A \<^bold>\<or> B)" using p1 p2 by simp
  } thus ?thesis by (simp add: ADDI_b_def) qed
  have rl: "ADDI\<^sup>b \<phi> \<Longrightarrow> iADDI\<^sup>b \<phi>" unfolding iADDI_b_def by (smt (verit) MONO_ADDIb MONO_def lub_def image_def sup_lub upper_bounds_def)
  from lr rl show ?thesis by auto
qed
(**MULT-a and iMULT-a are also equivalent.*)
lemma iMULTa_equ: "iMULT\<^sup>a \<phi> = MULT\<^sup>a \<phi>" proof -
  have lr: "iMULT\<^sup>a \<phi> \<Longrightarrow> MULT\<^sup>a \<phi>" proof - (*prove as a one-liner by instantiating iMULT_a_def with S=(\<lambda>Z. Z=A \<or> Z=B)*)
  assume imulta: "iMULT\<^sup>a \<phi>"
  { fix A::"'a \<sigma>" and B::"'a \<sigma>"
    let ?S="\<lambda>Z. Z=A \<or> Z=B"
    have "\<^bold>\<And>?S = A \<^bold>\<and> B" unfolding infimum_def meet_def by blast
    hence p1: "\<phi>(\<^bold>\<And>?S) = \<phi>(A \<^bold>\<and> B)" by simp
    have "\<lbrakk>\<phi> ?S\<rbrakk> = (\<lambda>Z. Z=(\<phi> A) \<or> Z=(\<phi> B))" unfolding image_def by metis
    hence p2: "\<^bold>\<And>\<lbrakk>\<phi> ?S\<rbrakk> = (\<phi> A) \<^bold>\<and> (\<phi> B)" unfolding infimum_def meet_def by auto
    have "\<phi>(\<^bold>\<And>?S) \<preceq> \<^bold>\<And>\<lbrakk>\<phi> ?S\<rbrakk>" using imulta iMULT_a_def by blast
    hence "\<phi>(A \<^bold>\<and> B) \<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)" using p1 p2 by simp
  } thus ?thesis by (simp add: MULT_a_def) qed
  have rl: "MULT\<^sup>a \<phi> \<Longrightarrow> iMULT\<^sup>a \<phi>" by (smt (verit) MONO_MULTa MONO_def glb_def iMULT_a_def inf_glb lower_bounds_def image_def)
  from lr rl show ?thesis by blast
qed

(**Thus we have that MONO, ADDI-b/iADDI-b and MULT-a/iMULT-a are all equivalent.*)
lemma MONO_iADDIb: "iADDI\<^sup>b \<phi> = MONO \<phi>" unfolding MONO_ADDIb iADDIb_equ by simp
lemma MONO_iMULTa: "iMULT\<^sup>a \<phi> = MONO \<phi>" unfolding MONO_MULTa iMULTa_equ by simp

(**Below we prove several duality relationships between iADDI(a/b) and iMULT(a/b).*)

(**Duality between iMULT-a and iADDI-b (an easy corollary from the previous equivalence).*)
lemma iMULTa_iADDIb_dual1: "iMULT\<^sup>a \<phi> = iADDI\<^sup>b \<phi>\<^sup>d" by (simp add: MULTa_ADDIb_dual1 iADDIb_equ iMULTa_equ)
lemma iMULTa_iADDIb_dual2: "iADDI\<^sup>b \<phi> = iMULT\<^sup>a \<phi>\<^sup>d" by (simp add: MULTa_ADDIb_dual2 iADDIb_equ iMULTa_equ)
(**Duality between iADDI-a and iMULT-b.*)
lemma iADDIa_iMULTb_dual1: "iADDI\<^sup>a \<phi> = iMULT\<^sup>b \<phi>\<^sup>d" by (smt (z3) BA_cmpl_equ BA_cp dualcompl_invol iADDI_a_def iDM_a iMULT_b_def im_prop1 op_dual_def setequ_ext)
lemma iADDIa_iMULTb_dual2: "iMULT\<^sup>b \<phi> = iADDI\<^sup>a \<phi>\<^sup>d" by (simp add: dual_invol iADDIa_iMULTb_dual1)
(**Duality between iADDI and iMULT.*)
lemma iADDI_iMULT_dual1: "iADDI \<phi> = iMULT \<phi>\<^sup>d" using iADDI_char iADDIa_iMULTb_dual1 iMULT_char iMULTa_iADDIb_dual2 by blast
lemma iADDI_iMULT_dual2: "iMULT \<phi> = iADDI \<phi>\<^sup>d" by (simp add: dual_invol iADDI_iMULT_dual1)

(**In fact, infinite additivity (multiplicativity) entails (dual) normality:*)
lemma iADDI_NORM: "iADDI \<phi> \<longrightarrow> NORM \<phi>" unfolding cond by (metis bottom_def image_def setequ_ext sup_empty)
lemma iMULT_DNRM: "iMULT \<phi> \<longrightarrow> DNRM \<phi>" by (simp add: NOR_dual2 iADDI_NORM iADDI_iMULT_dual2)

(**Suitable conditions on an operation can make the set of its fixed-points closed under infinite meets/joins.*)

lemma fp_sup_closed_cond1: "iADDI \<phi> \<longrightarrow> supremum_closed (fp \<phi>)" unfolding cond order supremum_closed_def fixpoints_def image_def by (smt (verit) supremum_def)
lemma fp_sup_closed_cond2: "iADDI\<^sup>a \<phi> \<and> EXPN \<phi> \<longrightarrow> supremum_closed (fp \<phi>)" unfolding cond by (smt (z3) fixpoints_def image_def setequ_char subset_def supremum_closed_def supremum_def)
lemma fp_sup_closed_cond3: "MONO \<phi> \<and> CNTR \<phi> \<longrightarrow> supremum_closed (fp \<phi>)" unfolding cond by (smt (verit, del_insts) fixpoints_def lub_def setequ_char setequ_ext subset_def sup_lub supremum_closed_def upper_bounds_def)

lemma fp_inf_closed_cond1: "iMULT \<phi> \<longrightarrow> infimum_closed (fp \<phi>)" by (metis fp_dual fp_sup_closed_cond1 iADDI_iMULT_dual2 inf_sup_closed_dc)
lemma fp_inf_closed_cond2: "iMULT\<^sup>b \<phi> \<and> CNTR \<phi> \<longrightarrow> infimum_closed (fp \<phi>)" by (metis EXPN_CNTR_dual2 fp_dual fp_sup_closed_cond2 iADDIa_iMULTb_dual2 inf_sup_closed_dc)
lemma fp_inf_closed_cond3: "MONO \<phi> \<and> EXPN \<phi> \<longrightarrow> infimum_closed (fp \<phi>)" by (metis EXPN_CNTR_dual1 MONO_dual fp_dual fp_sup_closed_cond3 inf_sup_closed_dc)

(**OTOH, the converse conjectures have (finite) countermodels. They need additional assumptions.*)
lemma "infimum_closed (fp \<phi>) \<longrightarrow> iMULT \<phi>" nitpick oops (*countermodel found: needs further assumptions*)
lemma "supremum_closed (fp \<phi>) \<longrightarrow> iADDI \<phi>" nitpick oops (*countermodel found: needs further assumptions*)
lemma fp_inf_closed_iMULT: "MONO \<phi> \<Longrightarrow> CNTR \<phi> \<Longrightarrow> IDEM\<^sup>b \<phi> \<Longrightarrow> infimum_closed (fp \<phi>) \<longrightarrow> iMULT \<phi>"
proof -
assume mono: "MONO \<phi>" and cntr: "CNTR \<phi>" and idem:"IDEM\<^sup>b \<phi>" {
  assume ic:"infimum_closed (fp \<phi>)" {
    fix S
    from ic have "\<forall>D. D \<preceq> (fp \<phi>) \<longrightarrow> (fp \<phi>)(\<^bold>\<And>D)" unfolding infimum_closed_def by simp
    hence "let D=\<lbrakk>\<phi> S\<rbrakk> in (\<forall>X. D X \<longrightarrow> (X \<approx> \<phi> X)) \<longrightarrow> \<^bold>\<And>D \<approx> \<phi> \<^bold>\<And>D" by (simp add: fixpoints_def setequ_ext subset_def)
    moreover from idem have "(\<forall>X. \<lbrakk>\<phi> S\<rbrakk> X \<longrightarrow> (X \<approx> \<phi> X))" by (metis (mono_tags, lifting) CNTR_def IDEM_b_def cntr image_def setequ_char)
    ultimately have aux: "\<^bold>\<And>(\<lbrakk>\<phi> S\<rbrakk>) \<approx> \<phi>(\<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>)" by meson
    from cntr have "\<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<^bold>\<And>S" by (smt (verit, best) CNTR_def image_def infimum_def subset_def)
    hence "\<phi>(\<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk>) \<preceq> \<phi>(\<^bold>\<And>S)" using mono by (simp add: MONO_def)
    from this aux have "\<^bold>\<And>\<lbrakk>\<phi> S\<rbrakk> \<preceq> \<phi>(\<^bold>\<And>S)" by (simp add: setequ_ext)
  } hence "infimum_closed (fp \<phi>) \<longrightarrow> iMULT \<phi>" by (simp add: MONO_iMULTa iMULT_b_def iMULT_char mono)
} thus ?thesis by simp
qed
lemma fp_sup_closed_iADDI: "MONO \<phi> \<Longrightarrow> EXPN \<phi> \<Longrightarrow> IDEM\<^sup>a \<phi> \<Longrightarrow> supremum_closed (fp \<phi>) \<longrightarrow> iADDI \<phi>" by (metis EXPN_CNTR_dual1 IDEM_dual2 MONO_dual dual_invol fp_inf_closed_iMULT fp_inf_sup_closed_dual iADDI_iMULT_dual1)
(*
proof -
assume mono: "MONO \<phi>" and expn: "EXPN \<phi>" and idem:"IDEM\<^sup>a \<phi>" {
  assume sc:"supremum_closed (fp \<phi>)" {
    fix S
    from sc have "\<forall>D. D \<preceq> (fp \<phi>) \<longrightarrow> (fp \<phi>)(\<^bold>\<Or>D)" unfolding supremum_closed_def by simp
    hence "let D=\<lbrakk>\<phi> S\<rbrakk> in (\<forall>X. D X \<longrightarrow> (X \<approx> \<phi> X)) \<longrightarrow> \<^bold>\<Or>D \<approx> \<phi> \<^bold>\<Or>D" by (simp add: fixpoints_def setequ_ext subset_def)
    moreover have "(\<forall>X. \<lbrakk>\<phi> S\<rbrakk> X \<longrightarrow> (X \<approx> \<phi> X))" by (metis (mono_tags, lifting) EXPN_def IDEM_a_def expn idem image_def setequ_char)
    ultimately have aux: "\<^bold>\<Or>(\<lbrakk>\<phi> S\<rbrakk>) \<approx> \<phi>(\<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>)" by meson
    have "\<^bold>\<Or>S \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>" by (metis EXPN_CNTR_dual1 EXPN_def IDEM_dual1 MONO_dual dual_invol expn fp_inf_closed_iMULT fp_inf_sup_closed_dual iADDI_def iADDI_iMULT_dual1 idem mono sc setequ_ext)
    hence "\<phi>(\<^bold>\<Or>S) \<preceq> \<phi>(\<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>)" using mono by (simp add: MONO_def)
    from this aux have "\<phi>(\<^bold>\<Or>S) \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> S\<rbrakk>" by (metis setequ_ext)
  } hence "supremum_closed (fp \<phi>) \<longrightarrow> iADDI \<phi>" by (simp add: MONO_ADDIb iADDI_a_def iADDI_char iADDIb_equ mono)
} thus ?thesis by simp
qed
*)

section \<open>Alexandrov topologies and (generalized) specialization preorders\<close>

(**A topology is called 'Alexandrov' (after the Russian mathematician Pavel Alexandrov) if the intersection
(resp. union) of any (finite or infinite) family of open (resp. closed) sets is open (resp. closed);
in algebraic terms, this means that the set of fixed points of the interior (closure) operation is closed
under infinite meets (joins). Another common algebraic formulation requires the closure (interior) operation
to satisfy the infinitary variants of additivity (multiplicativity), i.e. iADDI (iMULT) as introduced before.

In the literature, the well-known Kuratowski conditions for the closure (resp. interior) operation are assumed,
namely: ADDI, EXPN, NORM, IDEM (resp. MULT, CNTR, DNRM, IDEM). This makes both formulations equivalent.
However, this is not the case in general if those conditions become negotiable.*)

(**Alexandrov topologies have interesting properties relating them to the semantics of modal logic.
Assuming Kuratowski conditions, Alexandrov topological operations defined on subsets of S are in one-to-one
correspondence with preorders on S; in topological terms, Alexandrov topologies are uniquely determined by
their specialization preorders. Since we do not presuppose any Kuratowski conditions to begin with, the
preorders in question are in general not even transitive. Here we just call them 'reachability relations'.
We will still call (generalized) closure/interior-like operations as such (for lack of a better name).
We explore minimal conditions under which some relevant results for the semantics of modal logic obtain.*)

(**Closure/interior(-like) operators can be derived from an arbitrary relation (as in modal logic)*)
definition Cl_rel::"('w \<Rightarrow> 'w \<Rightarrow> bool) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("\<C>[_]")
  where "\<C>[R] \<equiv> \<lambda>A. \<lambda>w. \<exists>v. R w v \<and> A v"
definition Int_rel::"('w \<Rightarrow> 'w \<Rightarrow> bool) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("\<I>[_]")
  where "\<I>[R] \<equiv> \<lambda>A. \<lambda>w. \<forall>v. R w v \<longrightarrow> A v"

(**Duality between interior and closure follows directly:*)
lemma dual_CI: "\<C>[R] = \<I>[R]\<^sup>d" by (simp add: Cl_rel_def Int_rel_def compl_def op_dual_def setequ_char)

(**We explore minimal conditions of the reachability relation under which some operation's conditions obtain.*)
(**Define some relevant properties of relations: *)
abbreviation "serial R  \<equiv> \<forall>x. \<exists>y. R x y"
abbreviation "reflexive R  \<equiv> \<forall>x. R x x"
abbreviation "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
abbreviation "antisymmetric R  \<equiv> \<forall>x y. R x y \<and> R y x \<longrightarrow> x = y"
abbreviation "symmetric R  \<equiv> \<forall>x y. R x y \<longrightarrow> R y x"

lemma rC1: "iADDI \<C>[R]" unfolding iADDI_def Cl_rel_def image_def supremum_def using setequ_def by fastforce
lemma rC2: "reflexive R = EXPN \<C>[R]" by (metis (full_types) CNTR_def EXPN_CNTR_dual2 Int_rel_def dual_CI subset_def)
lemma rC3: "NORM \<C>[R]" by (simp add: iADDI_NORM rC1)
lemma rC4: "transitive R = IDEM\<^sup>a \<C>[R]" proof -
  have l2r: "transitive R \<longrightarrow> IDEM\<^sup>a \<C>[R]"  by (smt (verit, best) Cl_rel_def IDEM_a_def subset_def)
  have r2l: "IDEM\<^sup>a \<C>[R] \<longrightarrow> transitive R" unfolding Cl_rel_def IDEM_a_def subset_def using compl_def by force
  from l2r r2l show ?thesis by blast
qed

(**A reachability (specialization) relation (preorder) can be derived from a given operation (intended as a closure-like operation).*)
definition \<R>::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<Rightarrow> 'w \<Rightarrow> bool)" ("\<R>[_]")
  where "\<R>[\<phi>] \<equiv> \<lambda>w v. \<phi> (\<lambda>x. x = v) w"

(**Preorder properties of the reachability relation follow from the corresponding operation's conditions.*)
lemma rel_refl: "EXPN \<phi> \<longrightarrow> reflexive \<R>[\<phi>]" by (simp add: EXPN_def \<R>_def subset_def)
lemma rel_trans: "MONO \<phi> \<and> IDEM\<^sup>a \<phi> \<longrightarrow> transitive \<R>[\<phi>]" by (smt (verit, best) IDEM_a_def MONO_def \<R>_def subset_def)
lemma "IDEM\<^sup>a \<phi> \<longrightarrow> transitive \<R>[\<phi>]" nitpick oops (*counterexample*)

(*The converse directions do not hold*)
lemma "reflexive \<R>[\<phi>] \<longrightarrow> EXPN \<phi>" nitpick oops (*counterexample*)
lemma "transitive \<R>[\<phi>] \<longrightarrow> IDEM\<^sup>a \<phi>" nitpick oops (*counterexample*)
lemma "transitive \<R>[\<phi>] \<longrightarrow> MONO \<phi>" nitpick oops (*counterexample*)

(**However, we can obtain finite countermodels for antisymmetry and symmetry given all relevant conditions.
We will revisit this issue later and examine their relation with the topological separation axioms T0 and T1 resp.*)
lemma "iADDI \<phi> \<Longrightarrow> EXPN \<phi> \<Longrightarrow> IDEM\<^sup>a \<phi> \<Longrightarrow> antisymmetric \<R>[\<phi>]" nitpick oops (*counterexample*)
lemma "iADDI \<phi> \<Longrightarrow> EXPN \<phi> \<Longrightarrow> IDEM\<^sup>a \<phi> \<Longrightarrow> symmetric \<R>[\<phi>]" nitpick oops (*counterexample*)

(**As mentioned previously, Alexandrov closure (and by duality interior) operations correspond to
specialization orderings (reachability relations).
It is worth mentioning that in Alexandrov topologies every point has a minimal/smallest neighborhood,
namely the set of points related to it by the specialization preorder (reachability relation).
We examine below  minimal conditions under which these relations obtain.*)

lemma Cl_rel'_a:   "MONO \<phi> \<longrightarrow> (\<forall>A. \<C>[\<R>[\<phi>]] A \<preceq> \<phi> A)" unfolding Cl_rel_def MONO_def \<R>_def by (smt (verit, ccfv_SIG) subset_def)
lemma Cl_rel'_b: "iADDI\<^sup>a \<phi> \<longrightarrow> (\<forall>A. \<phi> A \<preceq> \<C>[\<R>[\<phi>]] A)" proof -
{ assume iaddia: "iADDI\<^sup>a \<phi>"
  { fix A::"'a \<sigma>"
    let ?S="\<lambda>B. \<exists>w. A w \<and> B=(\<lambda>u. u=w)"
    have "A \<approx> (\<^bold>\<Or>?S)" unfolding supremum_def setequ_def by auto
    hence "\<phi>(A) \<approx> \<phi>(\<^bold>\<Or>?S)" by (simp add: setequ_ext)
    moreover have "\<^bold>\<Or>\<lbrakk>\<phi> ?S\<rbrakk> \<approx> \<C>[\<R>[\<phi>]] A" by (smt (verit) Cl_rel_def \<R>_def image_def setequ_def supremum_def)
    moreover from iaddia have "\<phi>(\<^bold>\<Or>?S) \<preceq> \<^bold>\<Or>\<lbrakk>\<phi> ?S\<rbrakk>" unfolding iADDI_a_def by simp
    ultimately have "\<phi> A \<preceq> \<C>[\<R>[\<phi>]] A" by (simp add: setequ_ext)
} } thus ?thesis by simp
qed
lemma Cl_rel': "iADDI \<phi> \<longrightarrow> \<phi> \<cong> \<C>[\<R>[\<phi>]]" by (simp add: MONO_iADDIb iADDI_char setequ_char Cl_rel'_a Cl_rel'_b svfun_equ_def)
lemma Cl_rel: "iADDI \<phi> \<longleftrightarrow> \<phi> = \<C>[\<R>[\<phi>]]" using Cl_rel' by (metis rC1 svfun_equ_ext)

(**It is instructive to expand the definitions in the above result:*)
lemma "iADDI \<phi> \<longleftrightarrow> (\<forall>A. \<forall>w. (\<phi> A) w \<longleftrightarrow> (\<exists>v. A v \<and> \<phi> (\<lambda>x. x=v) w))" oops

(**Closure (interior) operations derived from relations are thus closed under infinite joins (meets).*)
lemma "supremum_closed (fp \<C>[R])" by (simp add: fp_sup_closed_cond1 rC1)
lemma "infimum_closed  (fp \<I>[R])" by (metis dual_CI fp_inf_closed_cond1 iADDI_iMULT_dual2 rC1)

(**We can now revisit the relationship between (anti)symmetry and the separation axioms T1 and T0.
The operator \<C> is intended as a closure operator (and its dual as interior)*)

(**T0: any two distinct points in the space can be separated by a closed (or open) set (i.e. containing one point and not the other).*)
abbreviation "T0 \<C> \<equiv> (\<forall>p q. p \<noteq> q \<longrightarrow> (\<exists>G. (fp \<C>) G \<and> \<not>(G p \<longleftrightarrow> G q)))"
(**T1: any two distinct points can be separated by (two not necessarily disjoint) closed (or open) sets.*)
abbreviation "T1 \<C> \<equiv> (\<forall>p q. p \<noteq> q \<longrightarrow> (\<exists>G H. (fp \<C>) G \<and> (fp \<C>) H \<and> G p \<and> \<not>G q \<and> H q \<and> \<not>H p))"

(**We can (sanity) check that T1 entails T0 but not viceversa.*)
lemma "T1 \<C> \<Longrightarrow> T0 \<C>" by meson
lemma "T0 \<C> \<Longrightarrow> T1 \<C>" nitpick oops (*counterexample*)

(**Under appropriate conditions, T0-separation corresponds to antisymmetry of the specialization relation (here an ordering).*)
lemma "T0 \<C> \<longleftrightarrow> antisymmetric \<R>[\<C>]" nitpick oops (*counterexample*)
lemma T0_antisymm_a: "MONO \<C> \<Longrightarrow> T0 \<C> \<longrightarrow> antisymmetric \<R>[\<C>]" by (smt (verit, best) Cl_rel'_a Cl_rel_def fixpoints_def setequ_ext subset_def)
lemma T0_antisymm_b: "EXPN \<C> \<Longrightarrow> IDEM\<^sup>a \<C> \<Longrightarrow> antisymmetric \<R>[\<C>] \<longrightarrow> T0 \<C>" by (metis EXPN_impl_IDEM_b IDEM_char IDEM_def \<R>_def fixpoints_def rel_refl)
lemma T0_antisymm: "MONO \<C> \<Longrightarrow> EXPN \<C> \<Longrightarrow> IDEM\<^sup>a \<C> \<Longrightarrow> T0 \<C> = antisymmetric \<R>[\<C>]" using T0_antisymm_a T0_antisymm_b by fastforce

(**Also, under the appropriate conditions, T1-separation corresponds to symmetry of the specialization relation.*)
lemma T1_symm_a: "MONO \<C> \<Longrightarrow> T1 \<C> \<longrightarrow> symmetric \<R>[\<C>]" by (metis (mono_tags, opaque_lifting) Cl_rel'_a Cl_rel_def fixpoints_def setequ_ext subset_def)
lemma T1_symm_b: "MONO \<C> \<Longrightarrow> EXPN \<C> \<Longrightarrow> T0 \<C> \<Longrightarrow> symmetric \<R>[\<C>] \<longrightarrow> T1 \<C>" by (smt (verit, ccfv_SIG) T0_antisymm_a \<R>_def fixpoints_def rel_refl setequ_def)
lemma T1_symm: "MONO \<C> \<Longrightarrow> EXPN \<C> \<Longrightarrow> T0 \<C> \<Longrightarrow> symmetric \<R>[\<C>] = T1 \<C>" using T1_symm_a T1_symm_b by (smt (verit, ccfv_threshold))

end


theory Transfer_Analysis
imports "HOL-Analysis.Analysis"
begin

text \<open>TODO: make this theory available much earlier! \<close>

context includes lifting_syntax begin
lemma Sigma_transfer[transfer_rule]:
  "(rel_set A ===> (A ===> rel_set B) ===> rel_set (rel_prod A B)) Sigma Sigma"
  unfolding Sigma_def
  by transfer_prover
end

subsection \<open>Parametricity rules for analysis constants\<close>

context includes lifting_syntax begin

lemma less_transfer[transfer_rule]:
  "(A ===> A ===> (=)) less less"
  if [transfer_rule]: "bi_unique A" "(A ===> A ===> (=)) less_eq less_eq"
  for A::"'c::order \<Rightarrow> 'd::order \<Rightarrow> bool"
  unfolding order.strict_iff_order[abs_def]
  by transfer_prover

lemma norm_transfer[transfer_rule]:
  "(A ===> (=)) norm norm"
  if [transfer_rule]: "(A ===> A ===> (=)) inner inner"
  unfolding norm_eq_sqrt_inner
  by transfer_prover

lemma dist_transfer[transfer_rule]:
  "(A ===> A ===> (=)) dist dist"
  if [transfer_rule]: "(A ===> (=)) norm norm" "(A ===> A ===> A) (-) (-)"
  unfolding dist_norm
  by transfer_prover

lemma open_transfer[transfer_rule]:
  "(rel_set A ===> (=)) open open"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(A ===> A ===> (=)) dist dist"
  unfolding open_dist
  by transfer_prover

lemma closed_transfer[transfer_rule]:
  "(rel_set A ===> (=)) closed closed"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
  unfolding closed_def
  by transfer_prover

lemma sgn_transfer[transfer_rule]:
  "(A ===> A) sgn sgn"
  if [transfer_rule]: "(A ===> (=)) norm norm" "((=) ===> A ===> A) scaleR scaleR"
  unfolding sgn_div_norm
  by transfer_prover

lemma uniformity_transfer[transfer_rule]:
  "(rel_filter (rel_prod A A)) uniformity uniformity"
  if [transfer_rule]: "bi_total A"  "bi_unique A" "(A ===> A ===> (=)) dist dist"
  unfolding uniformity_dist
  by transfer_prover

lemma lipschitz_on_transfer[transfer_rule]:
  "((=) ===> (rel_set A) ===> (A ===> B) ===> (=)) lipschitz_on lipschitz_on"
  if [transfer_rule]: "(B ===> B ===> (=)) dist dist" "(A ===> A ===> (=)) dist dist"
  unfolding lipschitz_on_def by transfer_prover

lemma cball_transfer[transfer_rule]:
  "(A ===> (=) ===> rel_set A) cball cball"
  if [transfer_rule]: "bi_total A" "(A ===> A ===> (=)) dist dist"
  unfolding cball_def by transfer_prover

lemma ball_transfer[transfer_rule]:
  "(A ===> (=) ===> rel_set A) ball ball"
  if [transfer_rule]: "bi_total A" "(A ===> A ===> (=)) dist dist"
  unfolding ball_def by transfer_prover

lemma local_lipschitz_transfer[transfer_rule]:
  "(rel_set A ===> rel_set B ===> (A ===> B ===> C) ===> (=)) local_lipschitz local_lipschitz"
  if [transfer_rule]: "bi_total A" "bi_unique A" "bi_total B" "bi_unique B"
    "(A ===> A ===> (=)) dist dist"
    "(B ===> B ===> (=)) dist dist"
    "(C ===> C ===> (=)) dist dist"
  unfolding local_lipschitz_def
  by transfer_prover

lemma filterlim_transfer[transfer_rule]:
  "((A ===> B) ===> rel_filter B ===> rel_filter A ===> (=)) filterlim filterlim"
  if [transfer_rule]: "bi_unique B"
  unfolding filterlim_iff
  by transfer_prover

lemma nhds_transfer[transfer_rule]:
  "(A ===> rel_filter A) nhds nhds"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
  unfolding nhds_def
  by transfer_prover

lemma at_within_transfer[transfer_rule]:
  "(A ===> rel_set A ===> rel_filter A) at_within at_within"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
  unfolding at_within_def
  by transfer_prover

lemma continuous_on_transfer[transfer_rule]:
  "(rel_set A ===> (A ===> B) ===> (=)) continuous_on continuous_on"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
    "bi_unique B" "bi_total B" "(rel_set B ===> (=)) open open"
  unfolding continuous_on_def
  by transfer_prover

lemma is_interval_transfer[transfer_rule]: "(rel_set A ===> (=)) is_interval is_interval"
  if [transfer_rule]: "bi_unique A" "bi_total A" "(A ===> A ===> (=)) inner inner" "(rel_set A) Basis Basis"
  unfolding is_interval_def
  by transfer_prover

lemma additive_transfer[transfer_rule]:
  "((B ===> A) ===> (=)) Modules.additive Modules.additive"
  if [transfer_rule]:
    "bi_unique A"
    "bi_total B"
    "(A ===> A ===> A) (+) (+)"
    "(B ===> B ===> B) (+) (+)"
  unfolding Modules.additive_def
  by transfer_prover

lemma linear_transfer[transfer_rule]: "((B ===> A) ===> (=)) linear linear"
  if [transfer_rule]:
    "bi_unique A"
    "bi_total B"
    "(A ===> A ===> A) (+) (+)"
    "((=) ===> A ===> A) (*\<^sub>R) (*\<^sub>R)"
    "(B ===> B ===> B) (+) (+)"
    "((=) ===> B ===> B) (*\<^sub>R) (*\<^sub>R)"
  unfolding linear_iff
  by transfer_prover

lemma bounded_linear_transfer[transfer_rule]: "((B ===> A) ===> (=)) bounded_linear bounded_linear"
  if [transfer_rule]:
    "bi_unique A"
    "bi_total B"
    "(A ===> A ===> A) (+) (+)"
    "((=) ===> A ===> A) (*\<^sub>R) (*\<^sub>R)"
    "(B ===> B ===> B) (+) (+)"
    "((=) ===> B ===> B) (*\<^sub>R) (*\<^sub>R)"
    "(A ===> (=)) norm norm"
    "(B ===> (=)) norm norm"
  unfolding bounded_linear_def bounded_linear_axioms_def
  by transfer_prover

lemma Pi_transfer[transfer_rule]: "(rel_set B ===> (B ===> rel_set A) ===> rel_set (B ===> A)) FuncSet.Pi FuncSet.Pi"
  if [transfer_rule]: "bi_unique A" "bi_total A" "bi_unique B" "bi_total B"
  unfolding FuncSet.Pi_def
  by transfer_prover

lift_definition rel_blinfun:: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow>
  ('a::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector) \<Rightarrow> ('b::real_normed_vector \<Rightarrow>\<^sub>L 'd::real_normed_vector) \<Rightarrow> bool" is rel_fun .

lemma bi_unique_rel_blinfun[transfer_rule]:
  "bi_total A \<Longrightarrow> bi_unique B \<Longrightarrow> bi_unique (rel_blinfun A B)"
  using bi_unique_fun[of A B]
  unfolding bi_unique_def
  by transfer auto

lemma bi_total_rel_blinfun[transfer_rule]:
  "bi_total (rel_blinfun A B)"
  if
    "bi_unique A" "bi_total B" (* really? *)
    "bi_unique B" "bi_total A"
    "(B ===> B ===> B) (+) (+)"
    "((=) ===> B ===> B) (*\<^sub>R) (*\<^sub>R)"
    "(A ===> A ===> A) (+) (+)"
    "((=) ===> A ===> A) (*\<^sub>R) (*\<^sub>R)"
    "(B ===> (=)) norm norm"
    "(A ===> (=)) norm norm"
  using bounded_linear_transfer[OF that(3-)]
  using bi_total_fun[OF that(1,2)]
  unfolding bi_total_def
  apply (transfer fixing: A B)
  apply auto
    subgoal for x
      apply (drule spec[where x=x])
      apply auto
      apply (drule rel_funD, assumption)
      apply fastforce
      done
    subgoal for x
      apply (drule spec[where x=x])
      apply auto
      apply (drule rel_funD, assumption)
      apply fastforce
      done
    done

lemma blinfun_apply_transfer[transfer_rule]:
  "(rel_blinfun A B ===> A ===> B) blinfun_apply blinfun_apply"
  by (auto simp: rel_blinfun_def)

lemma norm_blinfun_transfer[transfer_rule]: "(rel_blinfun A A ===> (=)) norm norm"
  if [transfer_rule]: "(A ===> (=)) norm norm" "(rel_set A) UNIV UNIV"
  unfolding norm_blinfun.rep_eq
  unfolding onorm_def
  by transfer_prover

lemma minus_blinfun_transfer[transfer_rule]:
  "(rel_blinfun A B ===> rel_blinfun A B ===> rel_blinfun A B) (-) (-)"
  if "(B ===> B ===> B) (-) (-)"
  using that
  apply (auto simp: rel_blinfun_def blinfun.bilinear_simps
      intro!: rel_funI dest: rel_funD)
  by (metis rel_funD)

lemma compose_blinfun_transfer[transfer_rule]:"(rel_blinfun A B ===> rel_blinfun C A ===> rel_blinfun C B) (o\<^sub>L) (o\<^sub>L)"
  apply (auto simp: rel_blinfun_def blinfun.bilinear_simps
      intro!: rel_funI dest: rel_funD)
  by (metis rel_funD)

end

end


theory Sieve_Primes
  imports
    "HOL-Computational_Algebra.Primes"
    "../Num_Class"
    "../HOLCF_Prelude"
(*FIXME: import order matters, if HOLCF_Prelude is not imported last,
constants like "filter" etc. refer to List.thy; I'm afraid however
that the current order only works by accident*)
begin

section \<open>The Sieve of Eratosthenes\<close>

declare [[coercion int]]
declare [[coercion_enabled]]

text \<open>
  This example proves that the well-known Haskell two-liner that lazily
  calculates the list of all primes does indeed do so. This proof is using
  coinduction.
\<close>

text \<open>
  We need to hide some constants again since we imported something from HOL
  not via @{theory "HOLCF-Prelude.HOLCF_Main"}.
\<close>

no_notation
  Rings.divide (infixl "div" 70) and
  Rings.modulo (infixl "mod" 70)

no_notation
  Set.member  ("(:)") and
  Set.member  ("(_/ : _)" [51, 51] 50)

text \<open>This is the implementation. We also need a modulus operator.\<close>
fixrec sieve :: "[Integer] \<rightarrow> [Integer]" where
  "sieve\<cdot>(p : xs) = p : (sieve\<cdot>(filter\<cdot>(\<Lambda> x. neg\<cdot>(eq\<cdot>(mod\<cdot>x\<cdot>p)\<cdot>0))\<cdot>xs))"

fixrec primes :: "[Integer]" where
  "primes = sieve\<cdot>[2..]"

text \<open>Simplification rules for modI:\<close>

definition MkI' :: "int \<Rightarrow> Integer" where
  "MkI' x = MkI\<cdot>x"

lemma MkI'_simps [simp]:
  shows "MkI' 0 = 0" and "MkI' 1 = 1" and "MkI' (numeral k) = numeral k"
  unfolding MkI'_def zero_Integer_def one_Integer_def numeral_Integer_eq
  by rule+

lemma modI_numeral_numeral [simp]:
  "mod\<cdot>(numeral i)\<cdot>(numeral j) = MkI' (Rings.modulo (numeral i) (numeral j))"
  unfolding numeral_Integer_eq mod_Integer_def MkI'_def by simp

text \<open>Some lemmas demonstrating evaluation of our list:\<close>

lemma "primes !! 0 = 2"
  unfolding primes.simps
  apply (simp only: enumFrom_intsFrom_conv)
  apply (subst intsFrom.simps)
  apply simp
  done

lemma "primes !! 1 = 3"
  unfolding primes.simps
  apply (simp only: enumFrom_intsFrom_conv)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply simp
  done

lemma "primes !! 2 = 5"
  unfolding primes.simps
  apply (simp only: enumFrom_intsFrom_conv)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply simp
  done

lemma "primes !! 3 = 7"
  unfolding primes.simps
  apply (simp only: enumFrom_intsFrom_conv)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply (subst intsFrom.simps)
  apply (simp del: filter_FF filter_TT)
  (* FIXME: remove these two from the default simpset *)
  done

text \<open>Auxiliary lemmas about prime numbers\<close>

lemma find_next_prime_nat:
  fixes n :: nat
  assumes "prime n"
  shows "\<exists> n'. n' > n \<and> prime n' \<and> (\<forall>k. n < k \<longrightarrow> k < n' \<longrightarrow> \<not> prime k)"
  using ex_least_nat_le[of "\<lambda> k . k > n \<and> prime k"]
  by (metis bigger_prime not_prime_0)

text \<open>Simplification for andalso:\<close>

lemma andAlso_Def[simp]: "((Def x) andalso (Def y)) = Def (x \<and> y)"
  by (metis Def_bool2 Def_bool4 andalso_thms(1) andalso_thms(2))

text \<open>This defines the bisimulation and proves it to be a list bisimulation.\<close>

definition prim_bisim:
  "prim_bisim x1 x2 = (\<exists> n . prime n  \<and>
    x1 = sieve\<cdot>(filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d. d > 1 \<longrightarrow> d < n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>n..]) \<and>
    x2 = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>n..])"

lemma prim_bisim_is_bisim: "list_bisim prim_bisim"
proof -
  {
    fix xs ys
    assume "prim_bisim xs ys"
    then obtain n :: nat where
      "prime n" and
      "n > 1" and
      "xs = sieve\<cdot>(filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>n..])" (is "_ = sieve\<cdot>?xs") and
      "ys = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>n..]"
      (* sledgehammer *)
    proof -
      assume a1: "\<And>n. \<lbrakk>prime n; 1 < n; xs = sieve\<cdot> (Data_List.filter\<cdot> (\<Lambda> (MkI\<cdot>i). Def (\<forall>d>1. d < int n \<longrightarrow> \<not> d dvd i))\<cdot> [MkI\<cdot>(int n)..]); ys = Data_List.filter\<cdot> (\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot> [MkI\<cdot>(int n)..]\<rbrakk> \<Longrightarrow> thesis"
      obtain ii  where
        f2: "\<forall>is isa. (\<not> prim_bisim is isa \<or> prime (ii is isa) \<and> is = sieve\<cdot> (Data_List.filter\<cdot> (\<Lambda> (MkI\<cdot>i). Def (\<forall>ia>1. ia < ii is isa \<longrightarrow> \<not> ia dvd i))\<cdot> [MkI\<cdot>(ii is isa)..]) \<and> isa = Data_List.filter\<cdot> (\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot> [MkI\<cdot>(ii is isa)..]) \<and> ((\<forall>i. \<not> prime i \<or> is \<noteq> sieve\<cdot> (Data_List.filter\<cdot> (\<Lambda> (MkI\<cdot>ia). Def (\<forall>ib>1. ib < i \<longrightarrow> \<not> ib dvd ia))\<cdot> [MkI\<cdot>i..]) \<or> isa \<noteq> Data_List.filter\<cdot> (\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot> [MkI\<cdot>i..]) \<or> prim_bisim is isa)"
        using prim_bisim by moura
      then have f3: "prime (ii xs ys)"
        using \<open>prim_bisim xs ys\<close> by blast
      then obtain nn :: "int \<Rightarrow> nat" where
        f4: "int (nn (ii xs ys)) = ii xs ys"
        by (metis (no_types) prime_gt_0_int zero_less_imp_eq_int)
      then have "prime (nn (ii xs ys))"
        using f3 by (metis (no_types) prime_nat_int_transfer)
      then show ?thesis
        using f4 f2 a1 \<open>prim_bisim xs ys\<close> prime_gt_1_nat by presburger
    qed

    obtain n' where "n' > n" and "prime n'" and not_prime: "\<forall>k. n < k \<longrightarrow> k < n' \<longrightarrow> \<not> prime k"
      using find_next_prime_nat[OF \<open>prime n\<close>] by auto

    {
      fix k :: int
      assume "n < k" and "k < n'"

      have  "k > 1" using \<open>n < k\<close> \<open>n > 1\<close> by auto
      then obtain k' :: nat where "k = int k'" by (cases k) auto
      then obtain p where "prime p" and "p dvd k"
        using \<open>k > 1\<close> \<open>k = int k'\<close>
        by (metis (full_types) less_numeral_extra(4) of_nat_1 of_nat_dvd_iff prime_factor_nat prime_nat_int_transfer)
      then have "p < n'" using \<open>k < n'\<close>  \<open>k > 1\<close>
        using zdvd_imp_le [of p k] by simp
      then have "p \<le> n" using \<open>prime p\<close> not_prime
        using not_le prime_gt_0_int zero_less_imp_eq_int
        by (metis of_nat_less_iff prime_nat_int_transfer)
      then have "\<exists>d::int>1. d \<le> n \<and> d dvd k" using \<open>p dvd k\<close> \<open>prime p\<close> of_nat_le_iff prime_gt_1_nat
          prime_gt_1_int by auto
    }
    then have between_have_divisors: "\<And>k::int. n < k \<Longrightarrow> k < n' \<Longrightarrow> \<exists>d::int>1. d \<le> n \<and> d dvd k".

    {
      fix i
      {
        assume small: "\<forall>d::int>1. d \<le> n \<longrightarrow> \<not> d dvd i"
        fix d
        assume "1 < d" and "d dvd i" and "d < n'"
        with small have "d > n" by auto

        obtain d'::int where "d' > 1" and "d' \<le> n" and "d' dvd d" using between_have_divisors[OF \<open>n < d\<close> \<open>d < n'\<close>] by auto
        with \<open>d dvd i\<close> small have False by (metis (full_types) dvd_trans)
      }
      then have "(\<forall>d::int. d > 1 \<longrightarrow> d \<le> n \<longrightarrow> \<not> (d dvd i)) = (\<forall>d::int. d > 1 \<longrightarrow> d < n' \<longrightarrow> \<not> (d dvd i))"
        using \<open>n' > n\<close> by auto
    }
    then have between_not_relvant:  "\<And> i. (\<forall>d::int. d > 1 \<longrightarrow> d \<le> n \<longrightarrow> \<not> (d dvd i)) = (\<forall>d::int. d > 1 \<longrightarrow> d < n' \<longrightarrow> \<not> (d dvd i))" .

    from \<open>prime n\<close>
    have "\<forall>d::int >1. d < n \<longrightarrow> \<not> d dvd n"
      unfolding prime_int_altdef using int_one_le_iff_zero_less le_less
      by (simp add: prime_int_not_dvd)
    then
    obtain xs' where "?xs = (MkI\<cdot>n) : xs'" and "xs' = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>(n+1)..]"
      by (subst (asm) intsFrom.simps[unfolded enumFrom_intsFrom_conv[symmetric]], simp add: one_Integer_def TT_def[symmetric] add.commute)

    {
      have "filter\<cdot>(\<Lambda> x. neg\<cdot>(eq\<cdot>(mod\<cdot>x\<cdot>(MkI\<cdot>n))\<cdot>0))\<cdot>(filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>(n+1)..])
            = filter\<cdot>(\<Lambda> (MkI\<cdot>x). Def (\<not> n dvd x))\<cdot>(filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>(n+1)..])"
        apply (rule filter_cong[rule_format])
        apply (rename_tac x, case_tac x)
         apply (simp)
        apply (auto simp add: zero_Integer_def)
         apply (rule FF_def)
        apply (simp add: TT_def)
        by (metis dvd_eq_mod_eq_0)
      also have "... = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<not> n dvd i) \<and> (\<forall>d::int. d > 1 \<longrightarrow> d < n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>(n+1)..]"
        by (auto intro!: filter_cong[rule_format])
      also have "... = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d \<le> n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>(n+1)..]"
        apply (rule filter_cong[rule_format])
        apply (rename_tac x, case_tac x)
        using \<open>n > 1\<close>
         apply auto
        done
      also have "... = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d \<le> n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>(int n+1)..]"
        by (metis (no_types, lifting) of_nat_1 of_nat_add)
      also have "... = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d \<le> n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>n'..]"
        apply (rule filter_fast_forward[of n n'])  using \<open>n' > n\<close>
         apply (auto simp add: between_have_divisors)
        done
      also have "... = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < n' \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>n'..]"
        by (auto intro: filter_cong[rule_format] simp add: between_not_relvant)
      also note calculation
    }
    note tmp = this

    {
      have "xs = sieve\<cdot>?xs" by fact
      also have "... = sieve\<cdot>((MkI\<cdot>n) : xs')" using \<open>?xs = _\<close> by simp
      also have "... = sieve\<cdot>((MkI\<cdot>n) : filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>(n+1)..])" using \<open>xs' = _\<close> by simp
      also have "... = (MkI\<cdot>n) : sieve\<cdot>(filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < n' \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>n'..])"  using tmp by simp
      also note calculation
    }
    moreover
    {
      have "ys = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>n..]" by fact
      also have "... = (MkI\<cdot>n) : filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>(int n+1)..]"
        using \<open>prime n\<close>
        by (subst intsFrom.simps[unfolded enumFrom_intsFrom_conv[symmetric]])(simp add: one_Integer_def TT_def[symmetric] add.commute)
      also have "... = (MkI\<cdot>n) : filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>n'..]"
        apply (subst filter_fast_forward[of n n']) using \<open>n' > n\<close> and not_prime
          apply auto
        apply (metis (full_types) \<open>\<And>k. \<lbrakk>int n < k; k < int n'\<rbrakk> \<Longrightarrow> \<exists>d>1. d \<le> int n \<and> d dvd k\<close> le_less not_le prime_gt_0_int prime_int_not_dvd zdvd_imp_le)
        done
      also note calculation
    }
    moreover
    note \<open>prime n'\<close>
    ultimately
    have "\<exists> p xs' ys'. xs = p : xs' \<and> ys = p : ys' \<and> prim_bisim xs' ys'" unfolding prim_bisim
      using prime_nat_int_transfer by blast
  }
  then show ?thesis unfolding list.bisim_def by metis
qed

text \<open>Now we apply coinduction:\<close>

lemma sieve_produces_primes:
  fixes n :: nat
  assumes "prime n"
  shows "sieve\<cdot>(filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < n \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>n..])
    = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>n..]"
  using assms
  apply -
  apply (rule list.coinduct[OF prim_bisim_is_bisim], auto simp add: prim_bisim)
  using prime_nat_int_transfer by blast

text \<open>And finally show the correctness of primes.\<close>

theorem primes:
  shows "primes = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>2..]"
proof -
  have "primes = sieve\<cdot>[2 ..]" by (rule primes.simps)
  also have "... = sieve\<cdot>(filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def ((\<forall>d::int. d > 1 \<longrightarrow> d < (int 2) \<longrightarrow> \<not> (d dvd i))))\<cdot>[MkI\<cdot>(int 2)..])"
    unfolding numeral_Integer_eq
    by (subst filter_TT, auto)
  also have "... = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>(int 2)..]"
    by (rule sieve_produces_primes[OF two_is_prime_nat])
  also have "... = filter\<cdot>(\<Lambda> (MkI\<cdot>i). Def (prime (nat \<bar>i\<bar>)))\<cdot>[MkI\<cdot>2..]"
    by simp
  finally show ?thesis .
qed

end


(*
  Title:    Social Decision Schemes.thy
  Author:   Manuel Eberl, TU München

  Definitions of Social Decision Schemes, their properties, and related concepts
*)

section \<open>Social Decision Schemes\<close>

theory Social_Decision_Schemes
imports
  Complex_Main
  "~~/src/HOL/Probability/Probability"
  Preference_Profiles
  Order_Predicates
  Missing_PMF
  Stochastic_Dominance
  SD_Efficiency
begin

subsection \<open>Basic Social Choice definitions\<close>

text \<open>
  An election consists of a finite set of agents and a finite non-empty
  set of alternatives.
\<close>
locale election =
  fixes agents :: "'agent set" and alts :: "'alt set"
  assumes finite_agents [simp, intro]: "finite agents"
  assumes finite_alts [simp, intro]: "finite alts"
  assumes nonempty_agents [simp]: "agents \<noteq> {}"
  assumes nonempty_alts [simp]: "alts \<noteq> {}"
begin

abbreviation "is_pref_profile \<equiv> pref_profile_wf agents alts"

lemma finite_total_preorder_on_iff' [simp]:
  "finite_total_preorder_on alts R \<longleftrightarrow> total_preorder_on alts R"
  by (simp add: finite_total_preorder_on_iff)

lemma pref_profile_wfI' [intro?]:
  "(\<And>i. i \<in> agents \<Longrightarrow> total_preorder_on alts (R i)) \<Longrightarrow>
   (\<And>i. i \<notin> agents \<Longrightarrow> R i = (\<lambda>_ _. False)) \<Longrightarrow> is_pref_profile R"
  by (simp add: pref_profile_wf_def)

lemma is_pref_profile_update [simp,intro]:
  assumes "is_pref_profile R" "total_preorder_on alts Ri'" "i \<in> agents"
  shows   "is_pref_profile (R(i := Ri'))"
  using assms by (auto intro!: pref_profile_wf.wf_update)

lemma election [simp,intro]: "election agents alts"
  by (rule election_axioms)

text \<open>
  The set of lotteries, i.e. the probability mass functions on the type @{typ "'alt"}
  whose support is a subset of the alternative set.
\<close>
abbreviation lotteries where
  "lotteries \<equiv> lotteries_on alts"

text \<open>
  The probability that a lottery returns an alternative that is in the given set
\<close>
abbreviation lottery_prob :: "'alt lottery \<Rightarrow> 'alt set \<Rightarrow> real" where
  "lottery_prob \<equiv> measure_pmf.prob"

lemma lottery_prob_alts_superset: "p \<in> lotteries \<Longrightarrow> alts \<subseteq> A \<Longrightarrow> lottery_prob p A = 1"
  by (metis UNIV_I antisym_conv emeasure_pmf ereal_eq_1(1) lotteries_on_def
            measure_pmf.emeasure_eq_measure measure_pmf.finite_measure_mono
            measure_pmf.prob_le_1 mem_Collect_eq sets_measure_pmf)

lemma lottery_prob_alts: "p \<in> lotteries \<Longrightarrow> lottery_prob p alts = 1"
  by (rule lottery_prob_alts_superset) simp_all

context
  fixes R assumes R: "total_preorder_on alts R"
begin

interpretation R: total_preorder_on alts R by fact

lemma Max_wrt_prefs_finite: "finite (Max_wrt R)"
  unfolding R.Max_wrt_preorder by simp

lemma Max_wrt_prefs_nonempty: "Max_wrt R \<noteq> {}"
  using R.Max_wrt_nonempty by simp

lemma maximal_imp_preferred:
  "x \<in> alts \<Longrightarrow> Max_wrt R \<subseteq> preferred_alts R x"
  using R.total
  by (auto simp: R.Max_wrt_total_preorder preferred_alts_def strongly_preferred_def)

end

end

text \<open>
  In the context of an election, a preference profile is a function that
  assigns to each agent her preference relation (which is a total preorder)
\<close>

subsection \<open>Social Decision Schemes\<close>

text \<open>
  In the context of an election, a Social Decision Scheme (SDS) is a function that
  maps preference profiles to lotteries on the alternatives.
\<close>
locale social_decision_scheme = election agents alts
  for agents :: "'agent set" and alts :: "'alt set" +
  fixes sds :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery"
  assumes sds_wf: "is_pref_profile R \<Longrightarrow> sds R \<in> lotteries"

subsection \<open>Anonymity\<close>

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

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   "sds (prefs_from_table xs) = sds (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   "sds R1 = sds R2" unfolding assms(1,3)
  by (rule anonymity_prefs_from_table) (simp_all add: assms)
end

end

subsection \<open>Neutrality\<close>

text \<open>
  An SDS 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_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes neutral: "\<sigma> permutes alts \<Longrightarrow> is_pref_profile R \<Longrightarrow>
                        sds (permute_profile \<sigma> R) = map_pmf \<sigma> (sds 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   "pmf (sds (permute_profile \<sigma> R)) (\<sigma> a) = pmf (sds R) a"
proof -
  from assms have A: "set_pmf (sds R) \<subseteq> alts" using sds_wf
    by (simp add: lotteries_on_def)
  from assms(1,2) have "pmf (sds (permute_profile \<sigma> R)) (\<sigma> a) = pmf (map_pmf \<sigma> (sds R)) (\<sigma> a)"
    by (subst neutral) simp_all
  also from assms have "\<dots> = pmf (sds R) a"
    by (intro pmf_map_inj') (simp_all add: permutes_inj)
  finally show ?thesis .
qed

end

locale an_sds =
  anonymous_sds agents alts sds + neutral_sds agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds
begin

lemma sds_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 (op ` \<sigma>)) (anonymous_profile R2)"
  shows   "sds R1 = map_pmf \<sigma> (sds 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 "sds (permute_profile \<sigma> R2 \<circ> \<pi>) = sds (permute_profile \<sigma> R2)"
    by (rule anonymous) fact+
  also have "\<dots> = map_pmf \<sigma> (sds R2)"
    by (rule neutral) fact+
  also have "permute_profile \<sigma> R2 \<circ> \<pi> = R1" by fact
  finally show ?thesis .
qed

lemma sds_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 (op ` \<sigma>)) (anonymous_profile R2)"
  shows   "pmf (sds R1) (\<sigma> x) = pmf (sds R2) x"
proof -
  have "sds R1 = map_pmf \<sigma> (sds R2)" by (intro sds_anonymous_neutral) fact+
  also have "pmf \<dots> (\<sigma> x) = pmf (sds R2) x" by (intro pmf_map_inj' permutes_inj[OF perm])
  finally show ?thesis .
qed

lemma sds_automorphism:
  assumes perm: "\<sigma> permutes alts" and wf: "is_pref_profile R"
  assumes eq: "image_mset (map (op ` \<sigma>)) (anonymous_profile R) = anonymous_profile R"
  shows   "map_pmf \<sigma> (sds R) = sds R"
  using sds_anonymous_neutral[OF perm wf wf eq [symmetric]] ..

end

subsection \<open>Ex-post efficiency\<close>

locale ex_post_efficient_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes ex_post_efficient:
    "is_pref_profile R \<Longrightarrow> set_pmf (sds R) \<inter> pareto_losers R = {}"
begin

lemma ex_post_efficient':
  assumes "is_pref_profile R" "y \<succ>[Pareto(R)] x"
  shows   "pmf (sds R) x = 0"
  using ex_post_efficient[of R] assms
  by (auto simp: set_pmf_eq pareto_losers_def)

lemma ex_post_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   "pmf (sds R) x = 0"
proof -
  from assms(1) interpret pref_profile_wf agents alts R .
  from assms(2-) show ?thesis
    by (intro ex_post_efficient'[OF assms(1), of _ y])
       (auto simp: Pareto_iff strongly_preferred_def)
qed

end

subsection \<open>SD efficiency\<close>

text \<open>
  An SDS is SD-efficient if it returns an SD-efficient lottery for every
  preference profile, i.e. if the SDS outputs a lottery, it is never the case
  that there is another lottery that is weakly preferred by all agents an
  strictly preferred by at least one agent.
\<close>
locale sd_efficient_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes SD_efficient: "is_pref_profile R \<Longrightarrow> SD_efficient R (sds R)"
begin

text \<open>
  An alternative formulation of SD-efficiency that is somewhat more convenient to use.
\<close>
lemma SD_efficient':
  assumes "is_pref_profile R" "q \<in> lotteries"
  assumes "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] sds R" "i \<in> agents" "q \<succ>[SD(R i)] sds R"
  shows   P
proof -
  interpret pref_profile_wf agents alts R by fact
  show ?thesis
    using SD_efficient[of R] sds_wf[OF assms(1)] assms unfolding SD_efficient_def' by blast
qed

text \<open>
  Any SD-efficient SDS is also ex-post efficient.
\<close>
sublocale ex_post_efficient_sds
proof unfold_locales
  fix R :: "('agent, 'alt) pref_profile" assume R_wf: "is_pref_profile R"
  interpret pref_profile_wf agents alts R by fact
  from R_wf show "set_pmf (sds R) \<inter> pareto_losers R = {}"
    by (intro SD_efficient_no_pareto_loser SD_efficient sds_wf)
qed

text \<open>
  The following rule can be used to derive facts from inefficient supports:
  If a set of alternatives is an inefficient support, at least one of the
  alternatives in it must receive probability 0.
\<close>
lemma SD_inefficient_support:
  assumes A: "A \<noteq> {}" "A \<subseteq> alts" and inefficient: "\<not>SD_efficient R (pmf_of_set A)"
  assumes wf: "is_pref_profile R"
  shows   "\<exists>x\<in>A. pmf (sds R) x = 0"
proof (rule ccontr)
  interpret pref_profile_wf agents alts R by fact
  assume "\<not>(\<exists>x\<in>A. pmf (sds R) x = 0)"
  with A have "set_pmf (pmf_of_set A) \<subseteq> set_pmf (sds R)"
     by (subst set_pmf_of_set) (auto simp: set_pmf_eq intro: finite_subset[OF _ finite_alts])
  from inefficient and this have "\<not>SD_efficient R (sds R)"
    by (rule SD_inefficient_support_subset) (simp add: wf sds_wf)
  moreover from SD_efficient wf have "SD_efficient R (sds R)" .
  ultimately show False by contradiction
qed

end

subsection \<open>Weak strategyproofness\<close>

context social_decision_scheme
begin

text \<open>
  The SDS is said to be manipulable for a particular preference profile,
  a particular agent, and a particular alternative preference ordering for that agent
  if the lottery obtained if the agent submits the alternative preferences strictly
  SD-dominates that obtained if the original preferences are submitted.
  (SD-dominated w.r.t. the original preferences)
\<close>
definition manipulable_profile
    :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt relation \<Rightarrow> bool" where
  "manipulable_profile R i Ri' \<longleftrightarrow> sds (R(i := Ri')) \<succ>[SD (R i)] sds R"

end

text \<open>
  An SDS is weakly strategyproof (or just strategyproof) if it is not manipulable
  for any combination of preference profiles, agents, and alternative preference relations.
\<close>
locale strategyproof_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes strategyproof:
    "is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> total_preorder_on alts Ri' \<Longrightarrow>
         \<not>manipulable_profile R i Ri'"

subsection \<open>Strong strategyproofness\<close>

context social_decision_scheme
begin

text \<open>
  The SDS is said to be strongly strategyproof for a particular preference profile,
  a particular agent, and a particular alternative preference ordering for that agent
  if the lottery obtained if the agent submits the alternative preferences is
  SD-dominated by the one obtained if the original preferences are submitted.
  (SD-dominated w.r.t. the original preferences)

  In other words: the SDS is strategyproof w.r.t the preference profile $R$ and
  the agent $i$ and the alternative preference relation $R_i'$ if the lottery for
  obtained for $R$ is at least as good for $i$ as the lottery obtained when $i$
  misrepresents her preferences as $R_i'$.
\<close>
definition strongly_strategyproof_profile
    :: "('agent, 'alt) pref_profile \<Rightarrow> 'agent \<Rightarrow> 'alt relation \<Rightarrow> bool" where
  "strongly_strategyproof_profile R i Ri' \<longleftrightarrow> sds R \<succeq>[SD (R i)] sds (R(i := Ri'))"

lemma strongly_strategyproof_profileI [intro]:
  assumes "is_pref_profile R" "total_preorder_on alts Ri'" "i \<in> agents"
  assumes "\<And>x. x \<in> alts \<Longrightarrow> lottery_prob (sds (R(i := Ri'))) (preferred_alts (R i) x)
                               \<le> lottery_prob (sds R) (preferred_alts (R i) x)"
  shows "strongly_strategyproof_profile R i Ri'"
proof -
  interpret pref_profile_wf agents alts R by fact
  show ?thesis
    unfolding strongly_strategyproof_profile_def
    by rule (auto intro!: sds_wf assms pref_profile_wf.wf_update)
qed

lemma strongly_strategyproof_imp_not_manipulable:
  assumes "strongly_strategyproof_profile R i Ri'"
  shows   "\<not>manipulable_profile R i Ri'"
  using assms unfolding strongly_strategyproof_profile_def manipulable_profile_def
  by (auto simp: strongly_preferred_def)

end

text \<open>
  An SDS is strongly strategyproof if it is strongly strategyproof for all combinations
  of preference profiles, agents, and alternative preference relations.
\<close>
locale strongly_strategyproof_sds = social_decision_scheme agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds +
  assumes strongly_strategyproof:
    "is_pref_profile R \<Longrightarrow> i \<in> agents \<Longrightarrow> total_preorder_on alts Ri' \<Longrightarrow>
         strongly_strategyproof_profile R i Ri'"
begin

text \<open>
  Any SDS that is strongly strategyproof is also weakly strategyproof.
\<close>
sublocale strategyproof_sds
  by unfold_locales
     (simp add: strongly_strategyproof_imp_not_manipulable strongly_strategyproof)

end

locale strategyproof_an_sds =
  strategyproof_sds agents alts sds + an_sds agents alts sds
  for agents :: "'agent set" and alts :: "'alt set" and sds

end