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

  Locales for order relations modelled as predicates (as opposed to sets of pairs).
*)
section \<open>Order Relations as Binary Predicates\<close>

theory Order_Predicates
imports
  Main
  "HOL-Library.Disjoint_Sets"
  "HOL-Library.Permutations"
  "List-Index.List_Index"
begin

subsection \<open>Basic Operations on Relations\<close>

text \<open>The type of binary relations\<close>
type_synonym 'a relation = "'a \<Rightarrow> 'a \<Rightarrow> bool"

definition map_relation :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b relation \<Rightarrow> 'a relation" where
  "map_relation f R = (\<lambda>x y. R (f x) (f y))"

definition restrict_relation :: "'a set \<Rightarrow> 'a relation \<Rightarrow> 'a relation" where
  "restrict_relation A R = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> R x y)"

lemma restrict_relation_restrict_relation [simp]:
  "restrict_relation A (restrict_relation B R) = restrict_relation (A \<inter> B) R"
  by (intro ext) (auto simp add: restrict_relation_def)

lemma restrict_relation_empty [simp]: "restrict_relation {} R = (\<lambda>_ _. False)"
  by (simp add: restrict_relation_def)

lemma restrict_relation_UNIV [simp]: "restrict_relation UNIV R = R"
  by (simp add: restrict_relation_def)

subsection \<open>Preorders\<close>

text \<open>Preorders are reflexive and transitive binary relations.\<close>
locale preorder_on =
  fixes carrier :: "'a set"
  fixes le :: "'a relation"
  assumes not_outside: "le x y \<Longrightarrow> x \<in> carrier" "le x y \<Longrightarrow> y \<in> carrier"
  assumes refl: "x \<in> carrier \<Longrightarrow> le x x"
  assumes trans: "le x y \<Longrightarrow> le y z \<Longrightarrow> le x z"
begin

lemma carrier_eq: "carrier = {x. le x x}"
  using not_outside refl by auto

lemma preorder_on_map:
  "preorder_on (f -` carrier) (map_relation f le)"
  by unfold_locales (auto dest: not_outside simp: map_relation_def refl elim: trans)

lemma preorder_on_restrict:
  "preorder_on (carrier \<inter> A) (restrict_relation A le)"
  by unfold_locales (auto simp: restrict_relation_def refl intro: trans not_outside)

lemma preorder_on_restrict_subset:
  "A \<subseteq> carrier \<Longrightarrow> preorder_on A (restrict_relation A le)"
  using preorder_on_restrict[of A] by (simp add: Int_absorb1)

lemma restrict_relation_carrier [simp]:
  "restrict_relation carrier le = le"
  using not_outside by (intro ext) (auto simp add: restrict_relation_def)

end

subsection \<open>Total preorders\<close>

text \<open>Total preorders are preorders where any two elements are comparable.\<close>
locale total_preorder_on = preorder_on +
  assumes total: "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> le x y \<or> le y x"
begin

lemma total': "\<not>le x y \<Longrightarrow> x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> le y x"
  using total[of x y] by blast

lemma total_preorder_on_map:
  "total_preorder_on (f -` carrier) (map_relation f le)"
proof -
  interpret R': preorder_on "f -` carrier" "map_relation f le"
    using preorder_on_map[of f] .
  show ?thesis by unfold_locales (simp add: map_relation_def total)
qed

lemma total_preorder_on_restrict:
  "total_preorder_on (carrier \<inter> A) (restrict_relation A le)"
proof -
  interpret R': preorder_on "carrier \<inter> A" "restrict_relation A le"
    by (rule preorder_on_restrict)
  from total show ?thesis
    by unfold_locales (auto simp: restrict_relation_def)
qed

lemma total_preorder_on_restrict_subset:
  "A \<subseteq> carrier \<Longrightarrow> total_preorder_on A (restrict_relation A le)"
  using total_preorder_on_restrict[of A] by (simp add: Int_absorb1)

end

text \<open>Some fancy notation for order relations\<close>
abbreviation (input) weakly_preferred :: "'a \<Rightarrow> 'a relation \<Rightarrow> 'a \<Rightarrow> bool"
    ("_ \<preceq>[_] _" [51,10,51] 60) where
  "a \<preceq>[R] b \<equiv> R a b"

definition strongly_preferred ("_ \<prec>[_] _" [51,10,51] 60) where
  "a \<prec>[R] b \<equiv> (a \<preceq>[R] b) \<and> \<not>(b \<preceq>[R] a)"

definition indifferent ("_ \<sim>[_] _" [51,10,51] 60) where
  "a \<sim>[R] b \<equiv> (a \<preceq>[R] b) \<and> (b \<preceq>[R] a)"

abbreviation (input) weakly_not_preferred ("_ \<succeq>[_] _" [51,10,51] 60) where
  "a \<succeq>[R] b \<equiv> b \<preceq>[R] a"
  term "a \<succeq>[R] b \<longleftrightarrow> b \<preceq>[R] a"

abbreviation (input) strongly_not_preferred ("_ \<succ>[_] _" [51,10,51] 60) where
  "a \<succ>[R] b \<equiv> b \<prec>[R] a"

context preorder_on
begin

lemma strict_trans: "a \<prec>[le] b \<Longrightarrow> b \<prec>[le] c \<Longrightarrow> a \<prec>[le] c"
  unfolding strongly_preferred_def by (blast intro: trans)

lemma weak_strict_trans: "a \<preceq>[le] b \<Longrightarrow> b \<prec>[le] c \<Longrightarrow> a \<prec>[le] c"
  unfolding strongly_preferred_def by (blast intro: trans)

lemma strict_weak_trans: "a \<prec>[le] b \<Longrightarrow> b \<preceq>[le] c \<Longrightarrow> a \<prec>[le] c"
  unfolding strongly_preferred_def by (blast intro: trans)

end

lemma (in total_preorder_on) not_weakly_preferred_iff:
  "a \<in> carrier \<Longrightarrow> b \<in> carrier \<Longrightarrow> \<not>a \<preceq>[le] b \<longleftrightarrow> b \<prec>[le] a"
  using total[of a b] by (auto simp: strongly_preferred_def)

lemma (in total_preorder_on) not_strongly_preferred_iff:
  "a \<in> carrier \<Longrightarrow> b \<in> carrier \<Longrightarrow> \<not>a \<prec>[le] b \<longleftrightarrow> b \<preceq>[le] a"
  using total[of a b] by (auto simp: strongly_preferred_def)

subsection \<open>Orders\<close>

locale order_on = preorder_on +
  assumes antisymmetric: "le x y \<Longrightarrow> le y x \<Longrightarrow> x = y"

locale linorder_on = order_on carrier le + total_preorder_on carrier le for carrier le

subsection \<open>Maximal elements\<close>

text \<open>
  Maximal elements are elements in a preorder for which there exists no strictly greater element.
\<close>

definition Max_wrt_among :: "'a relation \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "Max_wrt_among R A = {x\<in>A. R x x \<and> (\<forall>y\<in>A. R x y \<longrightarrow> R y x)}"

lemma Max_wrt_among_cong:
  assumes "restrict_relation A R = restrict_relation A R'"
  shows   "Max_wrt_among R A = Max_wrt_among R' A"
proof -
  from assms have "R x y \<longleftrightarrow> R' x y" if "x \<in> A" "y \<in> A" for x y
    using that by (auto simp: restrict_relation_def fun_eq_iff)
  thus ?thesis unfolding Max_wrt_among_def by blast
qed

definition Max_wrt :: "'a relation \<Rightarrow> 'a set" where
  "Max_wrt R = Max_wrt_among R UNIV"

lemma Max_wrt_altdef: "Max_wrt R = {x. R x x \<and> (\<forall>y. R x y \<longrightarrow> R y x)}"
  unfolding Max_wrt_def Max_wrt_among_def by simp

context preorder_on
begin

lemma Max_wrt_among_preorder:
  "Max_wrt_among le A = {x\<in>carrier \<inter> A. \<forall>y\<in>carrier \<inter> A. le x y \<longrightarrow> le y x}"
  unfolding Max_wrt_among_def using not_outside refl by blast

lemma Max_wrt_preorder:
  "Max_wrt le = {x\<in>carrier. \<forall>y\<in>carrier. le x y \<longrightarrow> le y x}"
  unfolding Max_wrt_altdef using not_outside refl by blast

lemma Max_wrt_among_subset:
  "Max_wrt_among le A \<subseteq> carrier" "Max_wrt_among le A \<subseteq> A"
  unfolding Max_wrt_among_preorder by auto

lemma Max_wrt_subset:
  "Max_wrt le \<subseteq> carrier"
  unfolding Max_wrt_preorder by auto

lemma Max_wrt_among_nonempty:
  assumes "B \<inter> carrier \<noteq> {}" "finite (B \<inter> carrier)"
  shows   "Max_wrt_among le B \<noteq> {}"
proof -
  define A where "A = B \<inter> carrier"
  have "A \<subseteq> carrier" by (simp add: A_def)
  from assms(2,1)[folded A_def] this have "{x\<in>A. (\<forall>y\<in>A. le x y \<longrightarrow> le y x)} \<noteq> {}"
  proof (induction A rule: finite_ne_induct)
    case (singleton x)
    thus ?case by (auto simp: refl)
  next
    case (insert x A)
    then obtain y where y: "y \<in> A" "\<And>z. z \<in> A \<Longrightarrow> le y z \<Longrightarrow> le z y" by blast
    thus ?case using insert.prems
      by (cases "le y x") (blast intro: trans)+
  qed
  thus ?thesis by (simp add: A_def Max_wrt_among_preorder Int_commute)
qed

lemma Max_wrt_nonempty:
  "carrier \<noteq> {} \<Longrightarrow> finite carrier \<Longrightarrow> Max_wrt le \<noteq> {}"
  using Max_wrt_among_nonempty[of UNIV] by (simp add: Max_wrt_def)

lemma Max_wrt_among_map_relation_vimage:
  "f -` Max_wrt_among le A \<subseteq> Max_wrt_among (map_relation f le) (f -` A)"
  by (auto simp: Max_wrt_among_def map_relation_def)

lemma image_subset_vimage_the_inv_into:
  assumes "inj_on f A" "B \<subseteq> A"
  shows   "f ` B \<subseteq> the_inv_into A f -` B"
  using assms by (auto simp: the_inv_into_f_f)

lemma Max_wrt_among_map_relation_bij_subset:
  assumes "bij (f :: 'a \<Rightarrow> 'b)"
  shows   "f ` Max_wrt_among le A \<subseteq>
             Max_wrt_among (map_relation (inv f) le) (f ` A)"
  using assms Max_wrt_among_map_relation_vimage[of "inv f" A]
  by (simp add: bij_imp_bij_inv inv_inv_eq bij_vimage_eq_inv_image)

lemma Max_wrt_among_map_relation_bij:
  assumes "bij f"
  shows   "f ` Max_wrt_among le A = Max_wrt_among (map_relation (inv f) le) (f ` A)"
proof (intro equalityI Max_wrt_among_map_relation_bij_subset assms)
  interpret R: preorder_on "f ` carrier" "map_relation (inv f) le"
    using preorder_on_map[of "inv f"] assms
      by (simp add: bij_imp_bij_inv bij_vimage_eq_inv_image inv_inv_eq)
  show "Max_wrt_among (map_relation (inv f) le) (f ` A) \<subseteq> f ` Max_wrt_among le A"
    unfolding Max_wrt_among_preorder R.Max_wrt_among_preorder
    using assms bij_is_inj[OF assms]
    by (auto simp: map_relation_def inv_f_f image_Int [symmetric])
qed

lemma Max_wrt_map_relation_bij:
  "bij f \<Longrightarrow> f ` Max_wrt le = Max_wrt (map_relation (inv f) le)"
proof -
  assume bij: "bij f"
  interpret R: preorder_on "f ` carrier" "map_relation (inv f) le"
    using preorder_on_map[of "inv f"] bij
      by (simp add: bij_imp_bij_inv bij_vimage_eq_inv_image inv_inv_eq)
  from bij show ?thesis
    unfolding R.Max_wrt_preorder Max_wrt_preorder
    by (auto simp: map_relation_def inv_f_f bij_is_inj)
qed

lemma Max_wrt_among_mono:
  "le x y \<Longrightarrow> x \<in> Max_wrt_among le A \<Longrightarrow> y \<in> A \<Longrightarrow> y \<in> Max_wrt_among le A"
  using not_outside by (auto simp: Max_wrt_among_preorder intro: trans)

lemma Max_wrt_mono:
  "le x y \<Longrightarrow> x \<in> Max_wrt le \<Longrightarrow> y \<in> Max_wrt le"
  unfolding Max_wrt_def using Max_wrt_among_mono[of x y UNIV] by blast

end

context total_preorder_on
begin

lemma Max_wrt_among_total_preorder:
  "Max_wrt_among le A = {x\<in>carrier \<inter> A. \<forall>y\<in>carrier \<inter> A. le y x}"
  unfolding Max_wrt_among_preorder using total by blast

lemma Max_wrt_total_preorder:
  "Max_wrt le = {x\<in>carrier. \<forall>y\<in>carrier. le y x}"
  unfolding Max_wrt_preorder using total by blast

lemma decompose_Max:
  assumes A: "A \<subseteq> carrier"
  defines "M \<equiv> Max_wrt_among le A"
  shows   "restrict_relation A le = (\<lambda>x y. x \<in> A \<and> y \<in> M \<or> (y \<notin> M \<and> restrict_relation (A - M) le x y))"
  using A by (intro ext) (auto simp: M_def Max_wrt_among_total_preorder
                            restrict_relation_def Int_absorb1 intro: trans)

end

subsection \<open>Weak rankings\<close>

inductive of_weak_ranking :: "'alt set list \<Rightarrow> 'alt relation" where
  "i \<le> j \<Longrightarrow> i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> x \<in> xs ! i \<Longrightarrow> y \<in> xs ! j \<Longrightarrow>
     x \<succeq>[of_weak_ranking xs] y"

lemma of_weak_ranking_Nil [simp]: "of_weak_ranking [] = (\<lambda>_ _. False)"
  by (intro ext) (simp add: of_weak_ranking.simps)

lemma of_weak_ranking_Nil' [code]: "of_weak_ranking [] x y = False"
  by simp

lemma of_weak_ranking_Cons [code]:
  "x \<succeq>[of_weak_ranking (z#zs)] y \<longleftrightarrow> x \<in> z \<and> y \<in> \<Union>(set (z#zs)) \<or> x \<succeq>[of_weak_ranking zs] y"
      (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain i j
    where ij: "i < length (z#zs)" "j < length (z#zs)" "i \<le> j" "x \<in> (z#zs) ! i" "y \<in> (z#zs) ! j"
    by (blast elim: of_weak_ranking.cases)
  thus ?rhs by (cases i; cases j) (force intro: of_weak_ranking.intros)+
next
  assume ?rhs
  thus ?lhs
  proof (elim disjE conjE)
    assume "x \<in> z" "y \<in> \<Union>(set (z # zs))"
    then obtain j where "j < length (z # zs)" "y \<in> (z # zs) ! j"
      by (subst (asm) set_conv_nth) auto
    with \<open>x \<in> z\<close> show "of_weak_ranking (z # zs) y x"
      by (intro of_weak_ranking.intros[of 0 j]) auto
  next
    assume "of_weak_ranking zs y x"
    then obtain i j where "i < length zs" "j < length zs" "i \<le> j" "x \<in> zs ! i" "y \<in> zs ! j"
      by (blast elim: of_weak_ranking.cases)
    thus "of_weak_ranking (z # zs) y x"
      by (intro of_weak_ranking.intros[of "Suc i" "Suc j"]) auto
  qed
qed

lemma of_weak_ranking_indifference:
  assumes "A \<in> set xs" "x \<in> A" "y \<in> A"
  shows   "x \<preceq>[of_weak_ranking xs] y"
  using assms by (induction xs) (auto simp: of_weak_ranking_Cons)

lemma of_weak_ranking_map:
  "map_relation f (of_weak_ranking xs) = of_weak_ranking (map ((-`) f) xs)"
  by (intro ext, induction xs)
     (simp_all add: map_relation_def of_weak_ranking_Cons)

lemma of_weak_ranking_permute':
  assumes "f permutes (\<Union>(set xs))"
  shows   "map_relation f (of_weak_ranking xs) = of_weak_ranking (map ((`) (inv f)) xs)"
proof -
  have "map_relation f (of_weak_ranking xs) = of_weak_ranking (map ((-`) f) xs)"
    by (rule of_weak_ranking_map)
  also from assms have "map ((-`) f) xs = map ((`) (inv f)) xs"
    by (intro map_cong refl) (simp_all add: bij_vimage_eq_inv_image permutes_bij)
  finally show ?thesis .
qed

lemma of_weak_ranking_permute:
  assumes "f permutes (\<Union>(set xs))"
  shows   "of_weak_ranking (map ((`) f) xs) = map_relation (inv f) (of_weak_ranking xs)"
  using of_weak_ranking_permute'[OF permutes_inv[OF assms]] assms
  by (simp add: inv_inv_eq permutes_bij)

definition is_weak_ranking where
  "is_weak_ranking xs \<longleftrightarrow> ({} \<notin> set xs) \<and>
     (\<forall>i j. i < length xs \<and> j < length xs \<and> i \<noteq> j \<longrightarrow> xs ! i \<inter> xs ! j = {})"

definition is_finite_weak_ranking where
  "is_finite_weak_ranking xs \<longleftrightarrow> is_weak_ranking xs \<and> (\<forall>x\<in>set xs. finite x)"

definition weak_ranking :: "'alt relation \<Rightarrow> 'alt set list" where
  "weak_ranking R = (SOME xs. is_weak_ranking xs \<and> R = of_weak_ranking xs)"

lemma is_weak_ranking_nonempty: "is_weak_ranking xs \<Longrightarrow> {} \<notin> set xs"
  by (simp add: is_weak_ranking_def)

lemma is_weak_ranking_rev [simp]: "is_weak_ranking (rev xs) \<longleftrightarrow> is_weak_ranking xs"
  by (simp add: is_weak_ranking_iff)

lemma is_weak_ranking_map_inj:
  assumes "is_weak_ranking xs" "inj_on f (\<Union>(set xs))"
  shows   "is_weak_ranking (map ((`) f) xs)"
  using assms by (auto simp: is_weak_ranking_iff distinct_map inj_on_image disjoint_image)

lemma of_weak_ranking_rev [simp]:
  "of_weak_ranking (rev xs) (x::'a) y \<longleftrightarrow> of_weak_ranking xs y x"
proof -
  have "of_weak_ranking (rev xs) y x" if "of_weak_ranking xs x y" for xs and x y :: 'a
  proof -
    from that obtain i j where "i < length xs" "j < length xs" "x \<in> xs ! i" "y \<in> xs ! j" "i \<ge> j"
      by (elim of_weak_ranking.cases) simp_all
    thus ?thesis
      by (intro of_weak_ranking.intros[of "length xs - i - 1" "length xs - j - 1"] diff_le_mono2)
         (auto simp: diff_le_mono2 rev_nth)
  qed
  from this[of xs y x] this[of "rev xs" x y] show ?thesis by (intro iffI) simp_all
qed

lemma is_weak_ranking_Nil [simp, code]: "is_weak_ranking []"
  by (auto simp: is_weak_ranking_def)

lemma is_finite_weak_ranking_Nil [simp, code]: "is_finite_weak_ranking []"
  by (auto simp: is_finite_weak_ranking_def)

lemma is_weak_ranking_Cons_empty [simp]:
  "\<not>is_weak_ranking ({} # xs)" by (simp add: is_weak_ranking_def)

lemma is_finite_weak_ranking_Cons_empty [simp]:
  "\<not>is_finite_weak_ranking ({} # xs)" by (simp add: is_finite_weak_ranking_def)

lemma is_weak_ranking_singleton [simp]:
  "is_weak_ranking [x] \<longleftrightarrow> x \<noteq> {}"
  by (auto simp add: is_weak_ranking_def)

lemma is_finite_weak_ranking_singleton [simp]:
  "is_finite_weak_ranking [x] \<longleftrightarrow> x \<noteq> {} \<and> finite x"
  by (auto simp add: is_finite_weak_ranking_def)

lemma is_weak_ranking_append:
  "is_weak_ranking (xs @ ys) \<longleftrightarrow>
      is_weak_ranking xs \<and> is_weak_ranking ys \<and>
      (set xs \<inter> set ys = {} \<and> \<Union>(set xs) \<inter> \<Union>(set ys) = {})"
  by (simp only: is_weak_ranking_iff)
     (auto dest: disjointD disjoint_unionD1 disjoint_unionD2 intro: disjoint_union)

lemma is_weak_ranking_Cons [code]:
  "is_weak_ranking (x # xs) \<longleftrightarrow>
      x \<noteq> {} \<and> is_weak_ranking xs \<and> x \<inter> \<Union>(set xs) = {}"
  using is_weak_ranking_append[of "[x]" xs] by auto

lemma is_finite_weak_ranking_Cons [code]:
  "is_finite_weak_ranking (x # xs) \<longleftrightarrow>
      x \<noteq> {} \<and> finite x \<and> is_finite_weak_ranking xs \<and> x \<inter> \<Union>(set xs) = {}"
  by (auto simp add: is_finite_weak_ranking_def is_weak_ranking_Cons)

primrec is_weak_ranking_aux where
  "is_weak_ranking_aux A [] \<longleftrightarrow> True"
| "is_weak_ranking_aux A (x#xs) \<longleftrightarrow> x \<noteq> {} \<and>
       A \<inter> x = {} \<and> is_weak_ranking_aux (A \<union> x) xs"

lemma is_weak_ranking_aux:
  "is_weak_ranking_aux A xs \<longleftrightarrow> A \<inter> \<Union>(set xs) = {} \<and> is_weak_ranking xs"
  by (induction xs arbitrary: A) (auto simp: is_weak_ranking_Cons)

lemma is_weak_ranking_code [code]:
  "is_weak_ranking xs \<longleftrightarrow> is_weak_ranking_aux {} xs"
  by (subst is_weak_ranking_aux) auto

lemma of_weak_ranking_altdef:
  assumes "is_weak_ranking xs" "x \<in> \<Union>(set xs)" "y \<in> \<Union>(set xs)"
  shows   "of_weak_ranking xs x y \<longleftrightarrow>
             find_index ((\<in>) x) xs \<ge> find_index ((\<in>) y) xs"
proof -
 from assms
    have A: "find_index ((\<in>) x) xs < length xs" "find_index ((\<in>) y) xs < length xs"
    by (simp_all add: find_index_less_size_conv)
 from this[THEN nth_find_index]
    have B: "x \<in> xs ! find_index ((\<in>) x) xs" "y \<in> xs ! find_index ((\<in>) y) xs" .
  show ?thesis
  proof
    assume "of_weak_ranking xs x y"
    then obtain i j where ij: "j \<le> i" "i < length xs" "j < length xs" "x \<in> xs ! i" "y \<in> xs !j"
      by (cases rule: of_weak_ranking.cases) simp_all
    with A B have "i = find_index ((\<in>) x) xs" "j = find_index ((\<in>) y) xs"
      using assms(1) unfolding is_weak_ranking_def by blast+
    with ij show "find_index ((\<in>) x) xs \<ge> find_index ((\<in>) y) xs" by simp
  next
    assume "find_index ((\<in>) x) xs \<ge> find_index ((\<in>) y) xs"
    from this A(2,1) B(2,1) show "of_weak_ranking xs x y"
      by (rule of_weak_ranking.intros)
  qed
qed

lemma restrict_relation_of_weak_ranking_Cons:
  assumes "is_weak_ranking (A # As)"
  shows   "restrict_relation (\<Union>(set As)) (of_weak_ranking (A # As)) = of_weak_ranking As"
proof -
  from assms interpret R: total_preorder_on "\<Union>(set As)" "of_weak_ranking As"
    by (intro total_preorder_of_weak_ranking)
       (simp_all add: is_weak_ranking_Cons)
  from assms show ?thesis using R.not_outside
    by (intro ext) (auto simp: restrict_relation_def of_weak_ranking_Cons
                     is_weak_ranking_Cons)
qed

lemmas of_weak_ranking_wf =
  total_preorder_of_weak_ranking is_weak_ranking_code insert_commute

(* Test *)
lemma "total_preorder_on {1,2,3,4::nat} (of_weak_ranking [{1,3},{2},{4}])"
  by (simp add: of_weak_ranking_wf)

context
  fixes x :: "'alt set" and xs :: "'alt set list"
  assumes wf: "is_weak_ranking (x#xs)"
begin

interpretation R: total_preorder_on "\<Union>(set (x#xs))" "of_weak_ranking (x#xs)"
  by (intro total_preorder_of_weak_ranking) (simp_all add: wf)

lemma of_weak_ranking_imp_in_set:
  assumes "of_weak_ranking xs a b"
  shows   "a \<in> \<Union>(set xs)" "b \<in> \<Union>(set xs)"
  using assms by (fastforce elim!: of_weak_ranking.cases)+

lemma of_weak_ranking_Cons':
  assumes "a \<in> \<Union>(set (x#xs))" "b \<in> \<Union>(set (x#xs))"
  shows   "of_weak_ranking (x#xs) a b \<longleftrightarrow> b \<in> x \<or> (a \<notin> x \<and> of_weak_ranking xs a b)"
proof
  assume "of_weak_ranking (x # xs) a b"
  with wf of_weak_ranking_imp_in_set[of a b]
    show "(b \<in> x \<or>  a \<notin> x \<and> of_weak_ranking xs a b)"
    by (auto simp: is_weak_ranking_Cons of_weak_ranking_Cons)
next
  assume "b \<in> x \<or> a \<notin> x \<and> of_weak_ranking xs a b"
  with assms show "of_weak_ranking (x#xs) a b"
    by (fastforce simp: of_weak_ranking_Cons)
qed

lemma Max_wrt_among_of_weak_ranking_Cons1:
  assumes "x \<inter> A = {}"
  shows   "Max_wrt_among (of_weak_ranking (x#xs)) A = Max_wrt_among (of_weak_ranking xs) A"
proof -
  from wf interpret R': total_preorder_on "\<Union>(set xs)" "of_weak_ranking xs"
    by (intro total_preorder_of_weak_ranking) (simp_all add: is_weak_ranking_Cons)
  from assms show ?thesis
    by (auto simp: R.Max_wrt_among_total_preorder
          R'.Max_wrt_among_total_preorder of_weak_ranking_Cons)
qed

lemma Max_wrt_among_of_weak_ranking_Cons2:
  assumes "x \<inter> A \<noteq> {}"
  shows   "Max_wrt_among (of_weak_ranking (x#xs)) A = x \<inter> A"
proof -
  from wf interpret R': total_preorder_on "\<Union>(set xs)" "of_weak_ranking xs"
    by (intro total_preorder_of_weak_ranking) (simp_all add: is_weak_ranking_Cons)
  from assms obtain a where "a \<in> x \<inter> A" by blast
  with wf R'.not_outside(1)[of a] show ?thesis
    by (auto simp: R.Max_wrt_among_total_preorder is_weak_ranking_Cons
          R'.Max_wrt_among_total_preorder of_weak_ranking_Cons)
qed

lemma Max_wrt_among_of_weak_ranking_Cons:
  "Max_wrt_among (of_weak_ranking (x#xs)) A =
     (if x \<inter> A = {} then Max_wrt_among (of_weak_ranking xs) A else x \<inter> A)"
  using Max_wrt_among_of_weak_ranking_Cons1 Max_wrt_among_of_weak_ranking_Cons2 by simp

lemma Max_wrt_of_weak_ranking_Cons:
  "Max_wrt (of_weak_ranking (x#xs)) = x"
  using wf by (simp add: is_weak_ranking_Cons Max_wrt_def Max_wrt_among_of_weak_ranking_Cons)

end

lemma Max_wrt_of_weak_ranking:
  assumes "is_weak_ranking xs"
  shows   "Max_wrt (of_weak_ranking xs) = (if xs = [] then {} else hd xs)"
proof (cases xs)
  case Nil
  hence "of_weak_ranking xs = (\<lambda>_ _. False)" by (intro ext) simp_all
  with Nil show ?thesis by (simp add: Max_wrt_def Max_wrt_among_def)
next
  case (Cons x xs')
  with assms show ?thesis by (simp add: Max_wrt_of_weak_ranking_Cons)
qed

locale finite_total_preorder_on = total_preorder_on +
  assumes finite_carrier [intro]: "finite carrier"
begin

lemma finite_total_preorder_on_map:
  assumes "finite (f -` carrier)"
  shows   "finite_total_preorder_on (f -` carrier) (map_relation f le)"
proof -
  interpret R': total_preorder_on "f -` carrier" "map_relation f le"
    using total_preorder_on_map[of f] .
  from assms show ?thesis by unfold_locales simp
qed

function weak_ranking_aux :: "'a set \<Rightarrow> 'a set list" where
  "weak_ranking_aux {} = []"
| "A \<noteq> {} \<Longrightarrow> A \<subseteq> carrier \<Longrightarrow> weak_ranking_aux A =
     Max_wrt_among le A # weak_ranking_aux (A - Max_wrt_among le A)"
| "\<not>(A \<subseteq> carrier) \<Longrightarrow> weak_ranking_aux A = undefined"
by blast simp_all
termination proof (relation "Wellfounded.measure card")
  fix A
  let ?B = "Max_wrt_among le A"
  assume A: "A \<noteq> {}" "A \<subseteq> carrier"
  moreover from A(2) have "finite A" by (rule finite_subset) blast
  moreover from A have "?B \<noteq> {}" "?B \<subseteq> A"
    by (intro Max_wrt_among_nonempty Max_wrt_among_subset; force)+
  ultimately have "card (A - ?B) < card A"
    by (intro psubset_card_mono) auto
  thus "(A - ?B, A) \<in> measure card" by simp
qed simp_all

lemma weak_ranking_aux_Union:
  "A \<subseteq> carrier \<Longrightarrow> \<Union>(set (weak_ranking_aux A)) = A"
proof (induction A rule: weak_ranking_aux.induct [case_names empty nonempty])
  case (nonempty A)
  with Max_wrt_among_subset[of A] show ?case by auto
qed simp_all

lemma weak_ranking_aux_wf:
  "A \<subseteq> carrier \<Longrightarrow> is_weak_ranking (weak_ranking_aux A)"
proof (induction A rule: weak_ranking_aux.induct [case_names empty nonempty])
  case (nonempty A)
  have "is_weak_ranking (Max_wrt_among le A # weak_ranking_aux (A - Max_wrt_among le A))"
    unfolding is_weak_ranking_Cons
  proof (intro conjI)
    from nonempty.prems nonempty.hyps show "Max_wrt_among le A \<noteq> {}"
      by (intro Max_wrt_among_nonempty) auto
  next
    from nonempty.prems show "is_weak_ranking (weak_ranking_aux (A - Max_wrt_among le A))"
      by (intro nonempty.IH) blast
  next
    from nonempty.prems nonempty.hyps have "Max_wrt_among le A \<noteq> {}"
      by (intro Max_wrt_among_nonempty) auto
    moreover from nonempty.prems
      have "\<Union>(set (weak_ranking_aux (A - Max_wrt_among le A))) = A - Max_wrt_among le A"
      by (intro weak_ranking_aux_Union) auto
    ultimately show "Max_wrt_among le A \<inter> \<Union>(set (weak_ranking_aux (A - Max_wrt_among le A))) = {}"
      by blast+
  qed
  with nonempty.prems nonempty.hyps show ?case by simp
qed simp_all

lemma of_weak_ranking_weak_ranking_aux':
  assumes "A \<subseteq> carrier" "x \<in> A" "y \<in> A"
  shows   "of_weak_ranking (weak_ranking_aux A) x y \<longleftrightarrow> restrict_relation A le x y"
using assms
proof (induction A rule: weak_ranking_aux.induct [case_names empty nonempty])
  case (nonempty A)
  define M where "M = Max_wrt_among le A"
  from nonempty.prems nonempty.hyps have M: "M \<subseteq> A" unfolding M_def
    by (intro Max_wrt_among_subset)
  from nonempty.prems have in_MD: "le x y" if "x \<in> A" "y \<in> M" for x y
    using that unfolding M_def Max_wrt_among_total_preorder
    by (auto simp: Int_absorb1)
  from nonempty.prems have in_MI: "x \<in> M" if "y \<in> M" "x \<in> A"  "le y x" for x y
    using that unfolding M_def Max_wrt_among_total_preorder
    by (auto simp: Int_absorb1 intro: trans)

  from nonempty.prems nonempty.hyps
    have IH: "of_weak_ranking (weak_ranking_aux (A - M)) x y =
                restrict_relation (A - M) le x y" if "x \<notin> M" "y \<notin> M"
       using that unfolding M_def by (intro nonempty.IH) auto
  from nonempty.prems
    interpret R': total_preorder_on "A - M" "of_weak_ranking (weak_ranking_aux (A - M))"
    by (intro total_preorder_of_weak_ranking weak_ranking_aux_wf weak_ranking_aux_Union) auto

  from nonempty.prems nonempty.hyps M weak_ranking_aux_Union[of A] R'.not_outside[of x y]
    show ?case
    by (cases "x \<in> M"; cases "y \<in> M")
       (auto simp: restrict_relation_def of_weak_ranking_Cons IH M_def [symmetric]
             intro: in_MD dest: in_MI)
qed simp_all

lemma of_weak_ranking_weak_ranking_aux:
  "of_weak_ranking (weak_ranking_aux carrier) = le"
proof (intro ext)
  fix x y
  have "is_weak_ranking (weak_ranking_aux carrier)" by (rule weak_ranking_aux_wf) simp
  then interpret R: total_preorder_on carrier "of_weak_ranking (weak_ranking_aux carrier)"
    by (intro total_preorder_of_weak_ranking weak_ranking_aux_wf weak_ranking_aux_Union)
       (simp_all add: weak_ranking_aux_Union)

  show "of_weak_ranking (weak_ranking_aux carrier) x y = le x y"
  proof (cases "x \<in> carrier \<and> y \<in> carrier")
    case True
    thus ?thesis
      using of_weak_ranking_weak_ranking_aux'[of carrier x y]  by simp
  next
    case False
    with R.not_outside have "of_weak_ranking (weak_ranking_aux carrier) x y = False"
      by auto
    also from not_outside False have "\<dots> = le x y" by auto
    finally show ?thesis .
  qed
qed

lemma weak_ranking_aux_unique':
  assumes "\<Union>(set As) \<subseteq> carrier" "is_weak_ranking As"
          "of_weak_ranking As = restrict_relation (\<Union>(set As)) le"
  shows   "As = weak_ranking_aux (\<Union>(set As))"
using assms
proof (induction As)
  case (Cons A As)
  have "restrict_relation (\<Union>(set As)) (of_weak_ranking (A # As)) = of_weak_ranking As"
    by (intro restrict_relation_of_weak_ranking_Cons Cons.prems)
  also have eq1: "of_weak_ranking (A # As) = restrict_relation (\<Union>(set (A # As))) le" by fact
  finally have eq: "of_weak_ranking As = restrict_relation (\<Union>(set As)) le"
    by (simp add: Int_absorb2)
  with Cons.prems have eq2: "weak_ranking_aux (\<Union>(set As)) = As"
    by (intro sym [OF Cons.IH]) (auto simp: is_weak_ranking_Cons)

  from eq1 have
    "Max_wrt_among le (\<Union>(set (A # As))) =
       Max_wrt_among (of_weak_ranking (A#As)) (\<Union>(set (A#As)))"
    by (intro Max_wrt_among_cong) simp_all
  also from Cons.prems have "\<dots> = A"
    by (subst Max_wrt_among_of_weak_ranking_Cons2)
       (simp_all add: is_weak_ranking_Cons)
  finally have Max: "Max_wrt_among le (\<Union>(set (A # As))) = A" .

  moreover from Cons.prems have "A \<noteq> {}" by (simp add: is_weak_ranking_Cons)
  ultimately have "weak_ranking_aux (\<Union>(set (A # As))) = A # weak_ranking_aux (A \<union> \<Union>(set As) - A)"
    using Cons.prems by simp
  also from Cons.prems have "A \<union> \<Union>(set As) - A = \<Union>(set As)"
    by (auto simp: is_weak_ranking_Cons)
  also from eq2 have "weak_ranking_aux \<dots> = As" .
  finally show ?case ..
qed simp_all

lemma weak_ranking_aux_unique:
  assumes "is_weak_ranking As" "of_weak_ranking As = le"
  shows   "As = weak_ranking_aux carrier"
proof -
  interpret R: total_preorder_on "\<Union>(set As)" "of_weak_ranking As"
    by (intro total_preorder_of_weak_ranking assms) simp_all
  from assms have "x \<in> \<Union>(set As) \<longleftrightarrow> x \<in> carrier" for x
    using R.not_outside not_outside R.refl[of x] refl[of x]
    by blast
  hence eq: "\<Union>(set As) = carrier" by blast
  from assms eq have "As = weak_ranking_aux (\<Union>(set As))"
    by (intro weak_ranking_aux_unique') simp_all
  with eq show ?thesis by simp
qed

lemma weak_ranking_total_preorder:
  "is_weak_ranking (weak_ranking le)" "of_weak_ranking (weak_ranking le) = le"
proof -
  from weak_ranking_aux_wf[of carrier] of_weak_ranking_weak_ranking_aux
    have "\<exists>x. is_weak_ranking x \<and> le = of_weak_ranking x" by auto
  hence "is_weak_ranking (weak_ranking le) \<and> le = of_weak_ranking (weak_ranking le)"
    unfolding weak_ranking_def by (rule someI_ex)
  thus "is_weak_ranking (weak_ranking le)" "of_weak_ranking (weak_ranking le) = le"
    by simp_all
qed

lemma weak_ranking_altdef:
  "weak_ranking le = weak_ranking_aux carrier"
  by (intro weak_ranking_aux_unique weak_ranking_total_preorder)

lemma weak_ranking_Union: "\<Union>(set (weak_ranking le)) = carrier"
  by (simp add: weak_ranking_altdef weak_ranking_aux_Union)

lemma weak_ranking_unique:
  assumes "is_weak_ranking As" "of_weak_ranking As = le"
  shows   "As = weak_ranking le"
  using assms unfolding weak_ranking_altdef by (rule weak_ranking_aux_unique)

lemma weak_ranking_permute:
  assumes "f permutes carrier"
  shows   "weak_ranking (map_relation (inv f) le) = map ((`) f) (weak_ranking le)"
proof -
  from assms have "inv f -` carrier = carrier"
    by (simp add: permutes_vimage permutes_inv)
  then interpret R: finite_total_preorder_on "inv f -` carrier" "map_relation (inv f) le"
    by (intro finite_total_preorder_on_map) (simp_all add: finite_carrier)
  from assms have "is_weak_ranking (map ((`) f) (weak_ranking le))"
    by (intro is_weak_ranking_map_inj)
       (simp_all add: weak_ranking_total_preorder permutes_inj_on)
  with assms show ?thesis
    by (intro sym[OF R.weak_ranking_unique])
       (simp_all add: of_weak_ranking_permute weak_ranking_Union weak_ranking_total_preorder)
qed

lemma weak_ranking_index_unique:
  assumes "is_weak_ranking xs" "i < length xs" "j < length xs" "x \<in> xs ! i" "x \<in> xs ! j"
  shows   "i = j"
  using assms unfolding is_weak_ranking_def by auto

lemma weak_ranking_index_unique':
  assumes "is_weak_ranking xs" "i < length xs" "x \<in> xs ! i"
  shows   "i = find_index ((\<in>) x) xs"
  using assms find_index_less_size_conv nth_mem
  by (intro weak_ranking_index_unique[OF assms(1,2) _ assms(3)]
        nth_find_index[of "(\<in>) x"]) blast+

lemma weak_ranking_eqclass1:
  assumes "A \<in> set (weak_ranking le)" "x \<in> A" "y \<in> A"
  shows   "le x y"
proof -
  from assms obtain i where "weak_ranking le ! i = A" "i < length (weak_ranking le)"
    by (auto simp: set_conv_nth)
  with assms have "of_weak_ranking (weak_ranking le) x y"
    by (intro of_weak_ranking.intros[of i i]) auto
  thus ?thesis by (simp add: weak_ranking_total_preorder)
qed

lemma weak_ranking_eqclass2:
  assumes A: "A \<in> set (weak_ranking le)" "x \<in> A" and le: "le x y" "le y x"
  shows   "y \<in> A"
proof -
  define xs where "xs = weak_ranking le"
  have wf: "is_weak_ranking xs" by (simp add: xs_def weak_ranking_total_preorder)
  let ?le' = "of_weak_ranking xs"
  from le have le': "?le' x y" "?le' y x" by (simp_all add: weak_ranking_total_preorder xs_def)
  from le'(1) obtain i j
    where ij: "j \<le> i" "i < length xs" "j < length xs" "x \<in> xs ! i" "y \<in> xs ! j"
    by (cases rule: of_weak_ranking.cases)
  from le'(2) obtain i' j'
    where i'j': "j' \<le> i'" "i' < length xs" "j' < length xs" "x \<in> xs ! j'" "y \<in> xs ! i'"
    by (cases rule: of_weak_ranking.cases)
  from ij i'j' have eq: "i = j'" "j = i'"
    by (intro weak_ranking_index_unique[OF wf]; simp)+
  moreover from A obtain k where k: "k < length xs" "A = xs ! k"
    by (auto simp: xs_def set_conv_nth)
  ultimately have "k = i" using ij i'j' A
    by (intro weak_ranking_index_unique[OF wf, of _ _ x]) auto
  with ij i'j' k eq show ?thesis by (auto simp: xs_def)
qed

lemma hd_weak_ranking:
  assumes "x \<in> hd (weak_ranking le)" "y \<in> carrier"
  shows   "le y x"
proof -
  from weak_ranking_Union assms obtain i
    where "i < length (weak_ranking le)" "y \<in> weak_ranking le ! i"
    by (auto simp: set_conv_nth)
  moreover from assms(2) weak_ranking_Union have "weak_ranking le \<noteq> []" by auto
  ultimately have "of_weak_ranking (weak_ranking le) y x" using assms(1)
    by (intro of_weak_ranking.intros[of 0 i]) (auto simp: hd_conv_nth)
  thus ?thesis by (simp add: weak_ranking_total_preorder)
qed

lemma last_weak_ranking:
  assumes "x \<in> last (weak_ranking le)" "y \<in> carrier"
  shows   "le x y"
proof -
  from weak_ranking_Union assms obtain i
    where "i < length (weak_ranking le)" "y \<in> weak_ranking le ! i"
    by (auto simp: set_conv_nth)
  moreover from assms(2) weak_ranking_Union have "weak_ranking le \<noteq> []" by auto
  ultimately have "of_weak_ranking (weak_ranking le) x y" using assms(1)
    by (intro of_weak_ranking.intros[of i "length (weak_ranking le) - 1"])
       (auto simp: last_conv_nth)
  thus ?thesis by (simp add: weak_ranking_total_preorder)
qed

text \<open>
  The index in weak ranking of a given alternative. An element with index 0 is
  first-ranked; larger indices correspond to less-preferred alternatives.
\<close>
definition weak_ranking_index :: "'a \<Rightarrow> nat" where
  "weak_ranking_index x = find_index (\<lambda>A. x \<in> A) (weak_ranking le)"

lemma nth_weak_ranking_index:
  assumes "x \<in> carrier"
  shows   "weak_ranking_index x < length (weak_ranking le)"
          "x \<in> weak_ranking le ! weak_ranking_index x"
proof -
  from assms weak_ranking_Union show "weak_ranking_index x < length (weak_ranking le)"
     unfolding weak_ranking_index_def by (auto simp add: find_index_less_size_conv)
  thus "x \<in> weak_ranking le ! weak_ranking_index x" unfolding weak_ranking_index_def
    by (rule nth_find_index)
qed

lemma ranking_index_eqI:
  "i < length (weak_ranking le) \<Longrightarrow> x \<in> weak_ranking le ! i \<Longrightarrow> weak_ranking_index x = i"
  using weak_ranking_index_unique'[of "weak_ranking le" i x]
  by (simp add: weak_ranking_index_def weak_ranking_total_preorder)

lemma ranking_index_le_iff [simp]:
  assumes "x \<in> carrier" "y \<in> carrier"
  shows   "weak_ranking_index x \<ge> weak_ranking_index y \<longleftrightarrow> le x y"
proof -
  have "le x y \<longleftrightarrow> of_weak_ranking (weak_ranking le) x y"
    by (simp add: weak_ranking_total_preorder)
  also have "\<dots> \<longleftrightarrow> weak_ranking_index x \<ge> weak_ranking_index y"
  proof
    assume "weak_ranking_index x \<ge> weak_ranking_index y"
    thus "of_weak_ranking (weak_ranking le) x y"
      by (rule of_weak_ranking.intros) (simp_all add: nth_weak_ranking_index assms)
  next
    assume "of_weak_ranking (weak_ranking le) x y"
    then obtain i j where
      "i \<le> j" "i < length (weak_ranking le)" "j < length (weak_ranking le)"
      "x \<in> weak_ranking le ! j" "y \<in> weak_ranking le ! i"
      by (elim of_weak_ranking.cases) blast
    with ranking_index_eqI[of i] ranking_index_eqI[of j]
      show "weak_ranking_index x \<ge> weak_ranking_index y" by simp
  qed
  finally show ?thesis ..
qed

end

lemma weak_ranking_False [simp]: "weak_ranking (\<lambda>_ _. False) = []"
proof -
  interpret finite_total_preorder_on "{}" "\<lambda>_ _. False"
    by unfold_locales simp_all
  have "[] = weak_ranking (\<lambda>_ _. False)" by (rule weak_ranking_unique) simp_all
  thus ?thesis ..
qed

lemmas of_weak_ranking_weak_ranking =
  finite_total_preorder_on.weak_ranking_total_preorder(2)

lemma finite_total_preorder_on_iff:
  "finite_total_preorder_on A R \<longleftrightarrow> total_preorder_on A R \<and> finite A"
  by (simp add: finite_total_preorder_on_def finite_total_preorder_on_axioms_def)

lemma finite_total_preorder_of_weak_ranking:
  assumes "\<Union>(set xs) = A" "is_finite_weak_ranking xs"
  shows   "finite_total_preorder_on A (of_weak_ranking xs)"
proof -
  from assms(2) have "is_weak_ranking xs" by (simp add: is_finite_weak_ranking_def)
  from assms(1) and this interpret total_preorder_on A "of_weak_ranking xs"
    by (rule total_preorder_of_weak_ranking)
  from assms(2) show ?thesis
    by unfold_locales (simp add: assms(1)[symmetric] is_finite_weak_ranking_def)
qed

lemma weak_ranking_of_weak_ranking:
  assumes "is_finite_weak_ranking xs"
  shows   "weak_ranking (of_weak_ranking xs) = xs"
proof -
  from assms interpret finite_total_preorder_on "\<Union>(set xs)" "of_weak_ranking xs"
    by (intro finite_total_preorder_of_weak_ranking) simp_all
  from assms show ?thesis
    by (intro sym[OF weak_ranking_unique]) (simp_all add: is_finite_weak_ranking_def)
qed

lemma weak_ranking_eqD:
  assumes "finite_total_preorder_on alts R1"
  assumes "finite_total_preorder_on alts R2"
  assumes "weak_ranking R1 = weak_ranking R2"
  shows   "R1 = R2"
proof -
  from assms have "of_weak_ranking (weak_ranking R1) = of_weak_ranking (weak_ranking R2)" by simp
  with assms(1,2) show ?thesis by (simp add: of_weak_ranking_weak_ranking)
qed

lemma weak_ranking_eq_iff:
  assumes "finite_total_preorder_on alts R1"
  assumes "finite_total_preorder_on alts R2"
  shows   "weak_ranking R1 = weak_ranking R2 \<longleftrightarrow> R1 = R2"
  using assms weak_ranking_eqD by auto

definition preferred_alts :: "'alt relation \<Rightarrow> 'alt \<Rightarrow> 'alt set" where
  "preferred_alts R x = {y. y \<succeq>[R] x}"

lemma (in preorder_on) preferred_alts_refl [simp]: "x \<in> carrier \<Longrightarrow> x \<in> preferred_alts le x"
  by (simp add: preferred_alts_def refl)

lemma (in preorder_on) preferred_alts_altdef:
  "preferred_alts le x = {y\<in>carrier. y \<succeq>[le] x}"
  by (auto simp: preferred_alts_def intro: not_outside)

lemma (in preorder_on) preferred_alts_subset: "preferred_alts le x \<subseteq> carrier"
  unfolding preferred_alts_def using not_outside by blast

subsection \<open>Rankings\<close>

(* TODO: Extend theory on rankings. Can probably mostly be based on
   existing theory on weak rankings. *)

definition ranking :: "'a relation \<Rightarrow> 'a list" where
  "ranking R = map the_elem (weak_ranking R)"

locale finite_linorder_on = linorder_on +
  assumes finite_carrier [intro]: "finite carrier"
begin

sublocale finite_total_preorder_on carrier le
  by unfold_locales (fact finite_carrier)

lemma singleton_weak_ranking:
  assumes "A \<in> set (weak_ranking le)"
  shows   "is_singleton A"
proof (rule is_singletonI')
  from assms show "A \<noteq> {}"
    using weak_ranking_total_preorder(1) is_weak_ranking_iff by auto
next
  fix x y assume "x \<in> A" "y \<in> A"
  with assms
    have "x \<preceq>[of_weak_ranking (weak_ranking le)] y" "y \<preceq>[of_weak_ranking (weak_ranking le)] x"
    by (auto intro!: of_weak_ranking_indifference)
  with weak_ranking_total_preorder(2)
    show "x = y" by (intro antisymmetric) simp_all
qed

lemma weak_ranking_ranking: "weak_ranking le = map (\<lambda>x. {x}) (ranking le)"
  unfolding ranking_def map_map o_def
proof (rule sym, rule map_idI)
  fix A assume "A \<in> set (weak_ranking le)"
  hence "is_singleton A" by (rule singleton_weak_ranking)
  thus "{the_elem A} = A" by (auto elim: is_singletonE)
qed

end

end


(*  Title:    HOL/Library/Periodic_Fun.thy
    Author:   Manuel Eberl, TU München
*)

section \<open>Periodic Functions\<close>

theory Periodic_Fun
imports Complex_Main
begin

text \<open>
  A locale for periodic functions. The idea is that one proves $f(x + p) = f(x)$
  for some period $p$ and gets derived results like $f(x - p) = f(x)$ and $f(x + 2p) = f(x)$
  for free.

  @{term g} and @{term gm} are ``plus/minus k periods'' functions.
  @{term g1} and @{term gn1} are ``plus/minus one period'' functions.
  This is useful e.g. if the period is one; the lemmas one gets are then
  @{term "f (x + 1) = f x"} instead of @{term "f (x + 1 * 1) = f x"} etc.
\<close>
locale periodic_fun =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b" and g gm :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" and g1 gn1 :: "'a \<Rightarrow> 'a"
  assumes plus_1: "f (g1 x) = f x"
  assumes periodic_arg_plus_0: "g x 0 = x"
  assumes periodic_arg_plus_distrib: "g x (of_int (m + n)) = g (g x (of_int n)) (of_int m)"
  assumes plus_1_eq: "g x 1 = g1 x" and minus_1_eq: "g x (-1) = gn1 x"
          and minus_eq: "g x (-y) = gm x y"
begin

lemma plus_of_nat: "f (g x (of_nat n)) = f x"
  by (induction n) (insert periodic_arg_plus_distrib[of _ 1 "int n" for n],
                    simp_all add: plus_1 periodic_arg_plus_0 plus_1_eq)

lemma minus_of_nat: "f (gm x (of_nat n)) = f x"
proof -
  have "f (g x (- of_nat n)) = f (g (g x (- of_nat n)) (of_nat n))"
    by (rule plus_of_nat[symmetric])
  also have "\<dots> = f (g (g x (of_int (- of_nat n))) (of_int (of_nat n)))" by simp
  also have "\<dots> = f x"
    by (subst periodic_arg_plus_distrib [symmetric]) (simp add: periodic_arg_plus_0)
  finally show ?thesis by (simp add: minus_eq)
qed

lemma plus_of_int: "f (g x (of_int n)) = f x"
  by (induction n) (simp_all add: plus_of_nat minus_of_nat minus_eq del: of_nat_Suc)

lemma minus_of_int: "f (gm x (of_int n)) = f x"
  using plus_of_int[of x "of_int (-n)"] by (simp add: minus_eq)

lemma plus_numeral: "f (g x (numeral n)) = f x"
  by (subst of_nat_numeral[symmetric], subst plus_of_nat) (rule refl)

lemma minus_numeral: "f (gm x (numeral n)) = f x"
  by (subst of_nat_numeral[symmetric], subst minus_of_nat) (rule refl)

lemma minus_1: "f (gn1 x) = f x"
  using minus_of_nat[of x 1] by (simp add: minus_1_eq minus_eq[symmetric])

lemmas periodic_simps = plus_of_nat minus_of_nat plus_of_int minus_of_int
                        plus_numeral minus_numeral plus_1 minus_1

end

text \<open>
  Specialised case of the @{term periodic_fun} locale for periods that are not 1.
  Gives lemmas @{term "f (x - period) = f x"} etc.
\<close>
locale periodic_fun_simple =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b" and period :: 'a
  assumes plus_period: "f (x + period) = f x"
begin
sublocale periodic_fun f "\<lambda>z x. z + x * period" "\<lambda>z x. z - x * period"
  "\<lambda>z. z + period" "\<lambda>z. z - period"
  by standard (simp_all add: ring_distribs plus_period)
end

text \<open>
  Specialised case of the @{term periodic_fun} locale for period 1.
  Gives lemmas @{term "f (x - 1) = f x"} etc.
\<close>
locale periodic_fun_simple' =
  fixes f :: "('a :: {ring_1}) \<Rightarrow> 'b"
  assumes plus_period: "f (x + 1) = f x"
begin
sublocale periodic_fun f "\<lambda>z x. z + x" "\<lambda>z x. z - x" "\<lambda>z. z + 1" "\<lambda>z. z - 1"
  by standard (simp_all add: ring_distribs plus_period)

lemma of_nat: "f (of_nat n) = f 0" using plus_of_nat[of 0 n] by simp
lemma uminus_of_nat: "f (-of_nat n) = f 0" using minus_of_nat[of 0 n] by simp
lemma of_int: "f (of_int n) = f 0" using plus_of_int[of 0 n] by simp
lemma uminus_of_int: "f (-of_int n) = f 0" using minus_of_int[of 0 n] by simp
lemma of_numeral: "f (numeral n) = f 0" using plus_numeral[of 0 n] by simp
lemma of_neg_numeral: "f (-numeral n) = f 0" using minus_numeral[of 0 n] by simp
lemma of_1: "f 1 = f 0" using plus_of_nat[of 0 1] by simp
lemma of_neg_1: "f (-1) = f 0" using minus_of_nat[of 0 1] by simp

lemmas periodic_simps' =
  of_nat uminus_of_nat of_int uminus_of_int of_numeral of_neg_numeral of_1 of_neg_1

end

lemma sin_plus_pi: "sin ((z :: 'a :: {real_normed_field,banach}) + of_real pi) = - sin z"
  by (simp add: sin_add)

lemma cos_plus_pi: "cos ((z :: 'a :: {real_normed_field,banach}) + of_real pi) = - cos z"
  by (simp add: cos_add)

interpretation sin: periodic_fun_simple sin "2 * of_real pi :: 'a :: {real_normed_field,banach}"
proof
  fix z :: 'a
  have "sin (z + 2 * of_real pi) = sin (z + of_real pi + of_real pi)" by (simp add: ac_simps)
  also have "\<dots> = sin z" by (simp only: sin_plus_pi) simp
  finally show "sin (z + 2 * of_real pi) = sin z" .
qed

interpretation cos: periodic_fun_simple cos "2 * of_real pi :: 'a :: {real_normed_field,banach}"
proof
  fix z :: 'a
  have "cos (z + 2 * of_real pi) = cos (z + of_real pi + of_real pi)" by (simp add: ac_simps)
  also have "\<dots> = cos z" by (simp only: cos_plus_pi) simp
  finally show "cos (z + 2 * of_real pi) = cos z" .
qed

interpretation tan: periodic_fun_simple tan "2 * of_real pi :: 'a :: {real_normed_field,banach}"
  by standard (simp only: tan_def [abs_def] sin.plus_1 cos.plus_1)

interpretation cot: periodic_fun_simple cot "2 * of_real pi :: 'a :: {real_normed_field,banach}"
  by standard (simp only: cot_def [abs_def] sin.plus_1 cos.plus_1)

end


header{*An Application: Finite Automata*}

theory Finite_Automata imports Ordinal
begin

text {*The point of this example is that the HF sets are closed under disjoint sums and Cartesian products,
 allowing the theory of finite state machines to be developed without issues of polymorphism
 or any tricky encodings of states.*}

record 'a fsm = states :: hf
                init :: hf
                final :: hf
                nxt :: "hf \<Rightarrow> 'a \<Rightarrow> hf \<Rightarrow> bool"

inductive reaches :: "['a fsm, hf, 'a list, hf] \<Rightarrow> bool"
where
    Nil:  "st <: states fsm \<Longrightarrow> reaches fsm st [] st"
  | Cons: "\<lbrakk>nxt fsm st x st''; reaches fsm st'' xs st'; st <: states fsm\<rbrakk> \<Longrightarrow> reaches fsm st (x#xs) st'"

declare reaches.intros [intro]
inductive_simps reaches_Nil [simp]:  "reaches fsm st [] st'"
inductive_simps reaches_Cons [simp]: "reaches fsm st (x#xs) st'"

lemma reaches_imp_states: "reaches fsm st xs st' \<Longrightarrow> st <: states fsm \<and> st' <: states fsm"
  by (induct xs arbitrary: st st', auto)

lemma reaches_append_iff:
     "reaches fsm st (xs@ys) st' \<longleftrightarrow> (\<exists>st''. reaches fsm st xs st'' \<and> reaches fsm st'' ys st')"
  by (induct xs arbitrary: ys st st') (auto simp: reaches_imp_states)

definition accepts :: "'a fsm \<Rightarrow> 'a list \<Rightarrow> bool"  where
  "accepts fsm xs \<equiv> \<exists>st st'. reaches fsm st xs st' \<and> st <: init fsm \<and> st' <: final fsm"

definition regular :: "'a list set \<Rightarrow> bool" where
  "regular S \<equiv> \<exists>fsm. S = {xs. accepts fsm xs}"

definition Null where
  "Null = \<lparr>states = 0, init = 0, final = 0, nxt = \<lambda>st x st'. False\<rparr>"

theorem regular_empty:  "regular {}"
  by (auto simp: regular_def accepts_def) (metis hempty_iff simps(2))

abbreviation NullStr where
  "NullStr \<equiv> \<lparr>states = 1, init = 1, final = 1, nxt = \<lambda>st x st'. False\<rparr>"

theorem regular_emptystr:  "regular {[]}"
  apply (auto simp: regular_def accepts_def)
  apply (rule exI [where x = NullStr], auto)
  apply (case_tac x, auto)
  done

abbreviation SingStr where
  "SingStr a \<equiv> \<lparr>states = {|0, 1|}, init = {|0|}, final = {|1|}, nxt = \<lambda>st x st'. st=0 \<and> x=a \<and> st'=1\<rparr>"

theorem regular_singstr: "regular {[a]}"
  apply (auto simp: regular_def accepts_def)
  apply (rule exI [where x = "SingStr a"], auto)
  apply (case_tac x, auto)
  apply (case_tac list, auto)
  done

definition Reverse where
  "Reverse fsm = \<lparr>states = states fsm, init = final fsm, final = init fsm,
                  nxt = \<lambda>st x st'. nxt fsm st' x st\<rparr>"

lemma Reverse_Reverse_ident [simp]: "Reverse (Reverse fsm) = fsm"
  by (simp add: Reverse_def)

lemma reaches_Reverse_iff [simp]:
     "reaches (Reverse fsm) st (rev xs) st' \<longleftrightarrow> reaches fsm st' xs st"
  by (induct xs arbitrary: st st') (auto simp add: Reverse_def reaches_append_iff reaches_imp_states)

lemma reaches_Reverse_iff2 [simp]:
     "reaches (Reverse fsm) st' xs st \<longleftrightarrow> reaches fsm st (rev xs) st'"
  by (metis reaches_Reverse_iff rev_rev_ident)

lemma [simp]: "final (Reverse fsm) = init fsm"
  by (simp add: Reverse_def)

theorem regular_rev: "regular S \<Longrightarrow> regular (rev ` S)"
  apply (auto simp: regular_def accepts_def)
  apply (rule_tac x="Reverse fsm" in exI, force+)
  done

definition Times where
  "Times fsm1 fsm2 = \<lparr>states = states fsm1 * states fsm2,
                      init = init fsm1 * init fsm2,
                      final = final fsm1 * final fsm2,
                      nxt = \<lambda>st x st'. (\<exists>st1 st2 st1' st2'. st = \<langle>st1,st2\<rangle> \<and> st' = \<langle>st1',st2'\<rangle> \<and>
                                      nxt fsm1 st1 x st1' \<and> nxt fsm2 st2 x st2')\<rparr>"

lemma states_Times [simp]: "states (Times fsm1 fsm2) = states fsm1 * states fsm2"
  by (simp add: Times_def)

lemma init_Times [simp]: "init (Times fsm1 fsm2) = init fsm1 * init fsm2"
  by (simp add: Times_def)

lemma final_Times [simp]: "final (Times fsm1 fsm2) = final fsm1 * final fsm2"
  by (simp add: Times_def)

lemma nxt_Times: "nxt (Times fsm1 fsm2) \<langle>st1,st2\<rangle> x st' \<longleftrightarrow>
    (\<exists>st1' st2'. st' = \<langle>st1',st2'\<rangle> \<and> nxt fsm1 st1 x st1' \<and> nxt fsm2 st2 x st2')"
  by (simp add: Times_def)

lemma reaches_Times_iff [simp]:
     "reaches (Times fsm1 fsm2) \<langle>st1,st2\<rangle> xs \<langle>st1',st2'\<rangle> \<longleftrightarrow>
      reaches fsm1 st1 xs st1' \<and> reaches fsm2 st2 xs st2'"
apply (induct xs arbitrary: st1 st2 st1' st2', force)
apply (force simp add: nxt_Times Times_def reaches.Cons)
done

lemma accepts_Times_iff [simp]:
     "accepts (Times fsm1 fsm2) xs \<longleftrightarrow>
      accepts fsm1 xs \<and> accepts fsm2 xs"
  by (force simp add: accepts_def)

theorem regular_Int:
  assumes S: "regular S" and T: "regular T" shows "regular (S \<inter> T)"
proof -
  obtain fsmS fsmT where "S = {xs. accepts fsmS xs}" "T = {xs. accepts fsmT xs}" using S T
    by (auto simp: regular_def)
  hence "S \<inter> T = {xs. accepts (Times fsmS fsmT) xs}"
    by (auto simp: accepts_Times_iff [of fsmS fsmT])
  thus ?thesis
    by (metis regular_def)
qed

definition Plus where
  "Plus fsm1 fsm2 = \<lparr>states = states fsm1 + states fsm2,
                      init = init fsm1 + init fsm2,
                      final = final fsm1 + final fsm2,
                      nxt = \<lambda>st x st'. (\<exists>st1 st1'. st = Inl st1 \<and> st' = Inl st1' \<and> nxt fsm1 st1 x st1') \<or>
                                       (\<exists>st2 st2'. st = Inr st2 \<and> st' = Inr st2' \<and> nxt fsm2 st2 x st2')\<rparr>"

lemma states_Plus [simp]: "states (Plus fsm1 fsm2) = states fsm1 + states fsm2"
  by (simp add: Plus_def)

lemma init_Plus [simp]: "init (Plus fsm1 fsm2) = init fsm1 + init fsm2"
  by (simp add: Plus_def)

lemma final_Plus [simp]: "final (Plus fsm1 fsm2) = final fsm1 + final fsm2"
  by (simp add: Plus_def)

lemma nxt_Plus1: "nxt (Plus fsm1 fsm2) (Inl st1) x st' \<longleftrightarrow> (\<exists>st1'. st' = Inl st1' \<and> nxt fsm1 st1 x st1')"
  by (simp add: Plus_def)

lemma nxt_Plus2: "nxt (Plus fsm1 fsm2) (Inr st2) x st' \<longleftrightarrow> (\<exists>st2'. st' = Inr st2' \<and> nxt fsm2 st2 x st2')"
  by (simp add: Plus_def)

lemma reaches_Plus_iff1 [simp]:
     "reaches (Plus fsm1 fsm2) (Inl st1) xs st' \<longleftrightarrow>
      (\<exists>st1'. st' = Inl st1' \<and> reaches fsm1 st1 xs st1')"
apply (induct xs arbitrary: st1, force)
apply (force simp add: nxt_Plus1 reaches.Cons)
done

lemma reaches_Plus_iff2 [simp]:
     "reaches (Plus fsm1 fsm2) (Inr st2) xs st' \<longleftrightarrow>
      (\<exists>st2'. st' = Inr st2' \<and> reaches fsm2 st2 xs st2')"
apply (induct xs arbitrary: st2, force)
apply (force simp add: nxt_Plus2 reaches.Cons)
done

lemma reaches_Plus_iff [simp]:
     "reaches (Plus fsm1 fsm2) st xs st' \<longleftrightarrow>
      (\<exists>st1 st1'. st = Inl st1 \<and> st' = Inl st1' \<and> reaches fsm1 st1 xs st1') \<or>
      (\<exists>st2 st2'. st = Inr st2 \<and> st' = Inr st2' \<and> reaches fsm2 st2 xs st2')"
apply (induct xs arbitrary: st st', auto)
apply (force simp add: nxt_Plus1 nxt_Plus2 Plus_def reaches.Cons)
apply (auto simp: Plus_def)
done

lemma accepts_Plus_iff [simp]:
     "accepts (Plus fsm1 fsm2) xs \<longleftrightarrow> accepts fsm1 xs \<or> accepts fsm2 xs"
  by (auto simp: accepts_def) (metis sum_iff)

lemma regular_Un:
  assumes S: "regular S" and T: "regular T" shows "regular (S \<union> T)"
proof -
  obtain fsmS fsmT where "S = {xs. accepts fsmS xs}" "T = {xs. accepts fsmT xs}" using S T
    by (auto simp: regular_def)
  hence "S \<union> T = {xs. accepts (Plus fsmS fsmT) xs}"
    by (auto simp: accepts_Plus_iff [of fsmS fsmT])
  thus ?thesis
    by (metis regular_def)
qed

end


theory Submission
  imports Defs
begin

lemma set_of_altdef_aux: "fold (\<union>) (map set_of_i xs) A  = \<Union> (set_of_i ` set xs) \<union> A"
  unfolding set_of_def
  by (induction xs arbitrary: A) auto

lemma set_of_altdef: "set_of xs = (\<Union>ivl\<in>set xs. set_of_i ivl)"
  unfolding set_of_def by (simp add: set_of_altdef_aux)

lemma set_of_Nil [simp]: "set_of [] = {}"
  by (simp add: set_of_altdef)

lemma set_of_append [simp]: "set_of (xs @ ys) = set_of xs \<union> set_of ys"
  by (simp add: set_of_altdef)

lemma set_of_Cons [simp]: "set_of (x # xs) = set_of_i x \<union> set_of xs"
  by (simp add: set_of_altdef)

fun compl_aux :: "nat \<Rightarrow> intervals \<Rightarrow> intervals" where
  "compl_aux a [] = [[a, \<infinity>)]"
| "compl_aux a ([l, enat u) # ivls) = (if a = l then [] else [[a, enat l)]) @ compl_aux u ivls"
| "compl_aux a [[l, \<infinity>)] = (if a = l then [] else [[a, enat l)])"

lemma inv'_mono:
  assumes "inv' a ivls" "b \<le> a"
  shows   "inv' b ivls"
  using assms
  by (induction a ivls rule: inv'.induct) auto

lemma inv'_subset:
  assumes "inv' u ivls"
  shows   "set_of ivls \<subseteq> {u..}"
  using assms by (induction u ivls rule: inv'.induct) auto

lemma inv'_compl_aux:
  fixes ivls :: intervals
  assumes "inv' a ivls" "\<forall>x\<in>set_of ivls. x \<ge> a"
  shows   "inv' a (compl_aux a ivls)"
  using assms
proof (induction a ivls rule: compl_aux.induct)
  case (2 a l u ivls)
  have IH: "inv' u (compl_aux u ivls)"
    using 2 inv'_mono[of "Suc u" ivls u] inv'_subset
    by (intro "2.IH") auto
  show ?case
    using IH "2.prems" by (auto intro: inv'_mono)
qed (auto simp: atLeast_def)

lemma set_of_compl_aux:
  fixes ivls :: intervals
  assumes "inv' a ivls"
  shows   "set_of (compl_aux a ivls) = {a..} - set_of ivls"
  using assms
proof (induction a ivls rule: compl_aux.induct)
  case (2 a l u ivls)
  have "set_of (compl_aux u ivls) = {u..} - set_of ivls"
    using "2.prems" inv'_mono by (intro "2.IH") force+
  thus ?case using "2.prems"  inv'_subset[of "Suc u" ivls] by force
qed auto

definition compl :: "intervals \<Rightarrow> intervals" where
  "compl x = compl_aux 0 x"

theorem compl_inv:
  assumes "inv ins"
  shows "inv (compl ins)"
  unfolding compl_def inv_def
  using assms by (intro inv'_compl_aux) (auto simp: inv_def)

theorem compl_set_of:
  assumes "inv ins"
  shows "set_of (compl ins) = -set_of ins"
  using assms unfolding compl_def by (subst set_of_compl_aux) (auto simp: inv_def)

text \<open>
  And for good measure: Intersection of interval lists.
\<close>
fun inter :: "intervals \<Rightarrow> intervals \<Rightarrow> intervals" where
  "inter [] ivls2 = []"
| "inter ivls1 [] = []"
| "inter [[l1, \<infinity>)] [[l2, \<infinity>)] = [[max l1 l2, \<infinity>)]"
| "inter ([l1, enat u1) # ivls1) [[l2, \<infinity>)] =
     (if u1 > l2 then [[max l1 l2, u1)] else []) @ inter ivls1 [[l2, \<infinity>)]"
| "inter [[l1, \<infinity>)] ([l2, enat u2) # ivls2) =
     (if u2 > l1 then [[max l1 l2, u2)] else []) @ inter [[l1, \<infinity>)] ivls2"
| "inter ([l1, enat u1) # ivls1) ([l2, enat u2) # ivls2) =
     (if u1 \<le> l2 then inter ivls1 ([l2, u2) # ivls2)
      else if u2 \<le> l1 then inter ([l1, u1) # ivls1) ivls2
      else [max l1 l2, min u1 u2) #
             (if u1 \<le> u2 then inter ivls1 ([l2, u2) # ivls2)
              else inter ([l1, u1) # ivls1) ivls2))"

lemma inv'_inter:
  assumes "inv' a ivls1" "inv' b ivls2" "max a b \<ge> c"
  shows   "inv' c (inter ivls1 ivls2)"
  using assms by (induction ivls1 ivls2 arbitrary: a b c rule: inter.induct) auto

lemma inv_inter:
  assumes "inv ivls1" "inv ivls2"
  shows   "inv (inter ivls1 ivls2)"
  using assms unfolding inv_def by (intro inv'_inter[where a = 0 and b = 0]) auto

lemma set_of_inter_aux:
  assumes "inv' a ivls1" "inv' b ivls2"
  shows   "set_of (inter ivls1 ivls2) = set_of ivls1 \<inter> set_of ivls2"
  using assms
proof (induction ivls1 ivls2 arbitrary: a b rule: inter.induct)
  case (6 l1 u1 ivls1 l2 u2 ivls2 a b)
  show ?case
  proof (cases "u1 \<le> l2")
    case True
    thus ?thesis using "6.prems" inv'_subset
      apply simp
      apply (subst "6.IH"(1)[where a = "Suc u1" and b = b])
         apply force+
      done
  next
    case not_le: False
    show ?thesis
    proof (cases "u2 \<le> l1")
      case True
      thus ?thesis using not_le inv'_subset "6.prems"
        apply simp
        apply (subst "6.IH"(2)[where a = "a" and b = "Suc u2"])
            apply force+
        done
    next
      case not_le': False
      show ?thesis
      proof (cases "u1 \<le> u2")
        case True
        thus ?thesis using not_le not_le' "6.prems" inv'_subset
          apply (simp)
          apply (subst "6.IH"(3)[where a = "Suc u1" and b = b])
               apply force+
          done
      next
        case False
        thus ?thesis using not_le not_le' "6.prems" inv'_subset
          apply (simp)
          apply (subst "6.IH"(4)[where a = a and b = "Suc u2"])
               apply force+
          done
      qed
    qed
  qed
qed auto

lemma set_of_inter:
  assumes "inv ivls1" "inv ivls2"
  shows   "set_of (inter ivls1 ivls2) = set_of ivls1 \<inter> set_of ivls2"
  using assms unfolding inv_def by (intro set_of_inter_aux[where a = 0 and b = 0]) auto

end


theory Demo3 imports Main begin

section {* Example 1 *}

locale semi =
  fixes prod :: "['a, 'a] => 'a" (infixl "\<cdot>" 70)
  assumes assoc: "(x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"

locale group = semi +
  fixes one and inv
  assumes l_one: "one \<cdot> x = x"
    and r_one: "x \<cdot> one = x"
    and l_inv: "inv x \<cdot> x = one"
    and r_inv: "x \<cdot> inv x = one"

lemma (in group) l_cancel: "(x \<cdot> y = x \<cdot> z) = (y = z)"
proof
  assume "x \<cdot> y = x \<cdot> z"
  then have "(inv x \<cdot> x) \<cdot> y = (inv x \<cdot> x) \<cdot> z" by (simp add: assoc)
  then show "y = z" by (simp add: l_one l_inv)
next
  assume "y = z"
  then show "x \<cdot> y = x \<cdot> z" by simp
qed

subsection {* Export *}

thm semi.assoc group.l_cancel

subsection {* Definitions *}

locale semi2 = semi +
  fixes rprod (infixl "\<odot>" 70)
  defines rprod_def: "rprod x y \<equiv> y \<cdot> x "

lemma (in semi2) r_assoc:
  "(x \<odot> y) \<odot> z = x \<odot> (y \<odot> z)"
  by (simp only: rprod_def assoc)

thm semi2.r_assoc

section {* Example 2 *}

locale group_hom = group sum zero minus + group +
  fixes hom
  assumes hom_mult: "hom (sum x y) = hom x \<cdot> hom y"

lemma (in group_hom) hom_one: "hom zero = one"
proof -
  have "hom zero \<cdot> one = hom zero \<cdot> hom zero"
    by (simp add: hom_mult [symmetric]
      sum_zero_minus.l_one prod_one_inv.r_one)
    -- {* Or add @{text l_one} to simpset right away. *}
  then show ?thesis by (simp add: l_cancel)
qed

section {* Example 3 *}

lemma int_semi:
  "semi (op +::[int, int]=>int)"
  by (auto intro!: semi.intro)

lemma int_group:
  "group (op +) (0::int) uminus"
  by (auto intro!: group.intro semi.intro group_axioms.intro)

text {* Manual interpretation possible with the OF attribute. *}

thm semi.assoc [OF int_semi]
thm group.l_cancel [OF int_group]

text {* Automatic interpretation *}

lemma bla: True
proof -
  from int_group interpret my: group ["op +" "0::int" "uminus"]
    by (auto intro: group.axioms)
  thm my.assoc my.l_cancel
oops

end


(*
Title: Uniqueness of the representation of a prime as a sum of two squares
Author: Jose Manuel Rodriguez Caballero

Roelof Oosterhuis [SumSquares-AFP] mechanized the so-called Fermat's Christmas Theorem:
any prime number having the form p = 4k+1 can be represented as a sum of two squares of natural
numbers. In the present development, we contribute to the subject of representation of integers
as a sum of two squares by means of the following uniqueness result: the representation of
a prime p = 4k+1 as a sum of two squares of natural numbers is unique up a to permutation of the
squares.

Our approach will be like in the proof of Theorem 13.4 in [nathanson2008elementary]. The original
proof involves subtractions, but we attained the same goal using additions and cancellations.

References.

@book{nathanson2008elementary,
  title={Elementary methods in number theory},
  author={Nathanson, Melvyn B},
  volume={195},
  year={2008},
  publisher={Springer Science & Business Media}
}

@article{SumSquares-AFP,
  author  = {Roelof Oosterhuis},
  title   = {Sums of Two and Four Squares},
  journal = {Archive of Formal Proofs},
  month   = aug,
  year    = 2007,
  note    = {\url{http://isa-afp.org/entries/SumSquares.html},
            Formal proof development},
  ISSN    = {2150-914x},
}

(This code was verified in Isabelle2018)

*)

theory SumOfSquaresUniqueness

imports Complex_Main "HOL-Number_Theory.Number_Theory"

begin

lemma DiophantusIdentityNat :
  fixes a b c d :: nat
  assumes kdef: "k + b*d = a*c"
  shows "(a^2 + b^2)*(c^2 + d^2) = k^2 + (a*d + b*c)^2"
proof -
  from kdef have "a^2*c^2 = k^2 + 2*k*b*d + b^2*d^2" by (metis (mono_tags, lifting) power2_sum semiring_normalization_rules(18) semiring_normalization_rules(23) semiring_normalization_rules(30))
  hence "a^2*(c^2 + d^2) = k^2 + 2*k*b*d + b^2*d^2 + a^2*d^2" by (simp add: distrib_left)
  hence "a^2*(c^2 + d^2)+b^2*(c^2 + d^2) = k^2 + 2*k*b*d + b^2*d^2 + a^2*d^2 + b^2*c^2 + b^2*d^2" by (simp add: distrib_left)
  hence "(a^2 + b^2)*(c^2 + d^2) = k^2 + 2*k*b*d + a^2*d^2 + b^2*c^2 + 2* b^2*d^2" by (simp add: semiring_normalization_rules(1))
  hence  "(a^2 + b^2)*(c^2 + d^2) = k^2 + 2*b*d* (k + b*d) + a^2*d^2 + b^2*c^2" by (smt add_mult_distrib2 mult.commute power2_eq_square semiring_normalization_rules(16) semiring_normalization_rules(23) semiring_normalization_rules(25))
  hence  "(a^2 + b^2)*(c^2 + d^2) = k^2 + 2*b*d*a*c + a^2*d^2 + b^2*c^2" using kdef by simp
  thus ?thesis by (simp add: power2_sum power_mult_distrib)
qed

lemma  FermatChristmasUniquenessLem :
  fixes p a\<^sub>1 b\<^sub>1 a\<^sub>2 b\<^sub>2 :: nat
  assumes a1la2: "a\<^sub>1 < a\<^sub>2"
    and podd: "odd p"
    and sumofsq1: "p = a\<^sub>1^2 + b\<^sub>1^2"
    and a1odd: "odd a\<^sub>1"
    and sumofsq2: "p = a\<^sub>2^2 + b\<^sub>2^2"
    and a2odd: "odd a\<^sub>2"
  shows "\<not>  prime p"
proof -
  have  b1lb2: "b\<^sub>1 > b\<^sub>2"
  proof-
    from a1la2 have a1la2sq: "a\<^sub>1^2 < a\<^sub>2^2" by (simp add: power_strict_mono)
    from sumofsq1 sumofsq2 have "a\<^sub>1^2 + b\<^sub>1^2 =a\<^sub>2^2 + b\<^sub>2^2" by simp
    then   have "b\<^sub>1^2 > b\<^sub>2^2" using  a1la2sq by linarith
    thus ?thesis using power_less_imp_less_base by blast
  qed

  from podd sumofsq1 a1odd have b1eveb: "even b\<^sub>1" by simp
  from podd sumofsq2 a1odd have b2eveb: "even b\<^sub>2" by (simp add: a2odd )

  have "\<exists> x::nat. a\<^sub>2 = a\<^sub>1 + 2*x"
  proof -
    from a1la2 obtain U::nat where a2eqa1plusU: "a\<^sub>2 = a\<^sub>1 + U" using less_imp_add_positive by blast
    from a2eqa1plusU a1odd a2odd have "even U" using even_add by blast
    then obtain u::nat where Ux: "U = 2*u" using evenE by blast
    from Ux a2eqa1plusU show ?thesis  by blast
  qed
  then obtain x :: nat where xdef: "a\<^sub>2 = a\<^sub>1 + 2*x"  by blast
  have "\<exists> y::nat. b\<^sub>1 = b\<^sub>2 + 2*y"
  proof -
    from b1lb2 obtain V::nat where b1eqb2plusV: "b\<^sub>1 = b\<^sub>2 + V" using less_imp_add_positive by blast
    from b1eqb2plusV have "even V" using even_add  using b1eveb b2eveb by blast
    then obtain v::nat where Vy: "V = 2*v" using evenE by blast
    from Vy b1eqb2plusV show ?thesis  by blast
  qed
  then obtain y::nat where ydef: "b\<^sub>1 = b\<^sub>2 + 2*y" by blast
  obtain d::nat where ddef: "d = gcd x y" by simp
  from a1la2 xdef have x0: "x \<noteq> 0"  by simp
  from b1lb2 ydef have y0: "y \<noteq> 0"  by simp
  from ddef have d0: "d \<noteq> 0"  using x0  by auto
  from ddef obtain X::nat where Xdef: "x = d*X" using dvdE by blast
  from ddef obtain Y::nat where Ydef: "y = d*Y" using dvdE by blast
  from x0 Xdef d0 have X0: "X \<noteq> 0" by simp
  from y0 Ydef d0 have Y0: "Y \<noteq> 0" by simp
  from ddef d0 Xdef Ydef have gcdXY: "gcd X Y = 1" by (metis gcd_mult_distrib_nat mult_eq_self_implies_10)
  have b1y: "b\<^sub>1*Y = (a\<^sub>1 + x)*X + y*Y"
  proof -
    from xdef have xsq: "a\<^sub>2^2 = a\<^sub>1^2 + 4*x*a\<^sub>1 + 4*x^2"
    proof -
      show ?thesis
        by (simp add: power2_sum xdef)
    qed
    from ydef have ysq: "b\<^sub>2^2 + 4*y*b\<^sub>2 + 4*y^2 = b\<^sub>1^2"
    proof -
      show ?thesis
        by (simp add: power2_sum ydef)
    qed
    from xsq ysq  have  "(a\<^sub>2^2 + b\<^sub>2^2) + 4*y*b\<^sub>2 + 4*y^2 = (a\<^sub>1^2 + b\<^sub>1^2) + 4*x*a\<^sub>1 + 4*x^2"  by (simp add: semiring_normalization_rules(21))
    hence "p + 4*y*b\<^sub>2 + 4*y^2 = p + 4*x*a\<^sub>1 + 4*x^2" using sumofsq1 sumofsq2 by simp
    hence "y*b\<^sub>2 + y^2 = x*a\<^sub>1 + x^2" by simp
    hence "y*(b\<^sub>2 + 2*y) = x*a\<^sub>1 + x^2 + y^2"  by (smt add.commute add_mult_distrib2 left_add_mult_distrib mult_2 power2_eq_square semiring_normalization_rules(1))
    hence "b\<^sub>1*y = a\<^sub>1*x + x^2 + y^2" using ydef by (simp add: semiring_normalization_rules(7))
    hence "d*b\<^sub>1*Y = d*a\<^sub>1*X + d*x*X + d*y*Y" using Xdef Ydef by (metis mult.left_commute power2_eq_square semiring_normalization_rules(18))
    hence "d*b\<^sub>1*Y = d*(a\<^sub>1*X + x*X + y*Y)" by (simp add: distrib_left)
    hence "b\<^sub>1*Y = a\<^sub>1*X + x*X + y*Y" using d0 by simp
    thus ?thesis by (simp add: add_mult_distrib)
  qed
  have  rdef: "\<exists> r::nat. r*Y = a\<^sub>1 + d*X"
  proof -
    from b1y have "Y dvd (a\<^sub>1 + x)*X"  by (metis dvd_add_times_triv_right_iff dvd_triv_right)
    hence "Y dvd (a\<^sub>1 + x)" using gcdXY
      by (metis (no_types, lifting) division_decomp dvd_triv_right  gcd_greatest_iff mult.right_neutral mult_dvd_mono)
    thus ?thesis by (metis Xdef dvdE semiring_normalization_rules(7))
  qed

  from rdef obtain r::nat where rdef: "r*Y = a\<^sub>1 + d*X" by auto
  from  rdef b1y Xdef Ydef Y0  have  randb1: "b\<^sub>1 = r*X + d*Y"  by (metis add_mult_distrib mult_cancel_right semiring_normalization_rules(16))
  have rd2: "r^2 + d^2 \<ge> 2" by (smt One_nat_def Suc_1 Suc_leI Y0 Ydef add_cancel_left_left add_gr_0 d0 le_add1 le_add2 le_add_same_cancel1 le_antisym le_less mult.commute mult_2_right mult_eq_0_iff power_eq_0_iff randb1 ydef)
  have XY2: "X^2 + Y^2 \<ge> 2" by (metis One_nat_def Suc_leI X0 Y0 add_mono neq0_conv numeral_Bit0 numeral_code(1) power_not_zero)
  from rdef randb1  have "(r^2 + d^2)*(X^2 + Y^2) = a\<^sub>1^2 + b\<^sub>1^2"  by (metis DiophantusIdentityNat add.commute)
  hence prod2sq: "(r^2 + d^2)*(X^2 + Y^2) = p" using sumofsq1 by blast
  from prod2sq rd2 XY2 show ?thesis by (metis add_diff_cancel_left' diff_is_0_eq' dvd_triv_left mult.right_neutral mult_eq_0_iff nat_mult_eq_cancel_disj numeral_Bit0 numeral_One prime_nat_iff prime_prime_factor_sqrt)
qed

lemma  FermatChristmasUniquenessUpPermOneIsOdd :
  fixes p a\<^sub>1 b\<^sub>1 :: nat
  assumes
    sumofsq1: "p = a\<^sub>1^2 + b\<^sub>1^2"
    and podd: "odd p"
  shows \<open>odd a\<^sub>1 \<or> odd b\<^sub>1\<close>
  using podd sumofsq1 by auto

theorem  FermatChristmasUniqueness:
  fixes p a\<^sub>1 b\<^sub>1 a\<^sub>2 b\<^sub>2 :: nat
  assumes pprime: "prime p"
    and podd: "odd p"
    and sumofsq1: "p = a\<^sub>1^2 + b\<^sub>1^2"
    and a1odd: "odd a\<^sub>1"
    and sumofsq2: "p = a\<^sub>2^2 + b\<^sub>2^2"
    and a2odd: "odd a\<^sub>2"
  shows "a\<^sub>1 = a\<^sub>2 \<and> b\<^sub>1 = b\<^sub>2"
proof-
  from pprime podd sumofsq1 a1odd sumofsq2 a2odd  have a12: "a\<^sub>1 \<ge> a\<^sub>2"
    using FermatChristmasUniquenessLem leI by blast
  from pprime podd sumofsq1 a1odd sumofsq2 a2odd  have a21: "a\<^sub>2 \<ge> a\<^sub>1"
    using FermatChristmasUniquenessLem leI by blast
  from a12 a21 have a1eqa2: "a\<^sub>1 = a\<^sub>2" using le_antisym by blast
  from sumofsq1 sumofsq2 a1eqa2 have b1eqb2: "b\<^sub>1 = b\<^sub>2" by auto
  from a1eqa2 b1eqb2 show ?thesis by simp
qed

corollary  FermatChristmasUniquenessUpPermPOdd :
  fixes p a\<^sub>1 b\<^sub>1 a\<^sub>2 b\<^sub>2 :: nat
  assumes pprime: "prime p"
    and podd: "odd p"
    and sumofsq1: "p = a\<^sub>1^2 + b\<^sub>1^2"
    and sumofsq2: "p = a\<^sub>2^2 + b\<^sub>2^2"
  shows "(a\<^sub>1 = a\<^sub>2 \<and> b\<^sub>1 = b\<^sub>2) \<or> (a\<^sub>1 = b\<^sub>2 \<and> b\<^sub>1 = a\<^sub>2)"
  by (metis FermatChristmasUniqueness FermatChristmasUniquenessUpPermOneIsOdd add.commute podd pprime sumofsq1 sumofsq2)

end


theory Abs_Qr

imports Mod_Plus_Minus
        Kyber_spec

begin
text \<open>Auxiliary lemmas\<close>

lemma finite_range_plus:
  assumes "finite (range f)"
          "finite (range g)"
  shows "finite (range (\<lambda>x. f x + g x))"
proof -
  have subs: "range (\<lambda>x. (f x, g x)) \<subseteq> range f \<times> range g" by auto
  have cart: "finite (range f \<times> range g)" using assms by auto
  have finite: "finite (range (\<lambda>x. (f x, g x)))"
    using rev_finite_subset[OF cart subs] .
  have "range (\<lambda>x. f x + g x) = (\<lambda>(a,b). a+b) ` range (\<lambda>x. (f x, g x))"
    using range_composition[of "(\<lambda>(a,b). a+b)" "(\<lambda>x. (f x, g x))"]
    by auto
  then show ?thesis
    using finite finite_image_set[where f = "(\<lambda>(a,b). a+b)"]
    by auto
qed

lemma all_impl_Max:
  assumes "\<forall>x. f x \<ge> (a::int)"
          "finite (range f)"
  shows "(MAX x. f x) \<ge> a"
by (simp add: Max_ge_iff assms(1) assms(2))

lemma Max_mono':
  assumes "\<forall>x. f x \<le> g x"
          "finite (range f)"
          "finite (range g)"
  shows "(MAX x. f x) \<le> (MAX x. g x)"
using assms
by (metis (no_types, lifting) Max_ge_iff Max_in UNIV_not_empty
  image_is_empty rangeE rangeI)

lemma Max_mono_plus:
  assumes "finite (range (f::_\<Rightarrow>_::ordered_ab_semigroup_add))"
          "finite (range g)"
  shows "(MAX x. f x + g x) \<le> (MAX x. f x) + (MAX x. g x)"
proof -
  obtain xmax where xmax_def: "f xmax + g xmax = (MAX x. f x + g x)"
    using finite_range_plus[OF assms] Max_in by fastforce
  have "(MAX x. f x + g x) = f xmax + g xmax" using xmax_def by auto
  also have "\<dots> \<le> (MAX x. f x) + g xmax"
    using Max_ge[OF assms(1), of "f xmax"]
    by (auto simp add: add_right_mono[of "f xmax"])
  also have "\<dots> \<le> (MAX x. f x) + (MAX x. g x)"
    using Max_ge[OF assms(2), of "g xmax"]
    by (auto simp add: add_left_mono[of "g xmax"])
  finally show ?thesis by auto
qed

text \<open>Lemmas for porting to \<open>qr\<close>.\<close>

lemma of_qr_mult:
  "of_qr (a * b) = of_qr a * of_qr b mod qr_poly"
by (metis of_qr_to_qr to_qr_mult to_qr_of_qr)

lemma of_qr_scale:
  "of_qr (to_module s * b) =
  Polynomial.smult (of_int_mod_ring s) (of_qr b)"
unfolding to_module_def
  by (auto simp add: of_qr_mult[of "to_qr [:of_int_mod_ring s:]" "b"]
  of_qr_to_qr) (simp add: mod_mult_left_eq mod_smult_left of_qr.rep_eq)

lemma to_module_mult:
  "poly.coeff (of_qr (to_module s * a)) x1 =
   of_int_mod_ring (s) * poly.coeff (of_qr a) x1"
using of_qr_scale[of s a] by simp

text \<open>Lemmas on \<open>round\<close> and \<open>floor\<close>.\<close>
lemma odd_round_up:
assumes "odd x"
shows "round (real_of_int x / 2) = (x+1) div 2"
proof -
  have "round (real_of_int x / 2) = round (real_of_int (x+1) /2)"
    using assms unfolding round_def
    by (metis (no_types, opaque_lifting) add.commute
      add_divide_distrib even_add even_succ_div_2
      floor_divide_of_int_eq odd_one of_int_add
      of_int_hom.hom_one of_int_numeral)
  also have "\<dots> = (x+1) div 2"
    by (metis add_divide_distrib calculation
    floor_divide_of_int_eq of_int_add of_int_hom.hom_one
    of_int_numeral round_def)
  finally show ?thesis by blast
qed

lemma floor_unique:
assumes "real_of_int a \<le> x" "x < a+1"
shows "floor x = a"
  using assms(1) assms(2) by linarith

lemma same_floor:
assumes "real_of_int a \<le> x" "real_of_int a \<le> y"
  "x < a+1" "y < a+1"
shows "floor x = floor y"
using assms floor_unique  by presburger

lemma one_mod_four_round:
assumes "x mod 4 = 1"
shows "round (real_of_int x / 4) = (x-1) div 4"
proof -
  have leq: "(x-1) div 4 \<le> real_of_int x / 4  + 1 / 2"
    using assms by linarith
  have gr: "real_of_int x / 4  + 1 / 2 < (x-1) div 4 + 1"
  proof -
    have "x+2 < 4 * ((x-1) div 4 + 1)"
    proof -
      have *:  "(x-1) div 4 + 1 = (x+3) div 4" by auto
      have "4 dvd x + 3" using assms by presburger
      then have "4 * ((x+3) div 4) = x+3"
        by (subst dvd_imp_mult_div_cancel_left, auto)
      then show ?thesis unfolding * by auto
    qed
    then show ?thesis by auto
  qed
  show "round (real_of_int x / 4) = (x-1) div 4"
    using floor_unique[OF leq gr] unfolding round_def by auto
qed

lemma odd_half_floor:
assumes "odd x"
shows "\<lfloor>real_of_int x / 2\<rfloor> = (x-1) div 2"
using assms by (metis add.commute diff_add_cancel even_add
 even_succ_div_2 floor_divide_of_int_eq odd_one of_int_numeral)

section \<open>Re-centered "Norm" Function\<close>

context module_spec
begin
text \<open>We want to show that \<open>abs_infty_q\<close> is a function induced by the
  Euclidean norm on the \<open>mod_ring\<close> using a re-centered representative via \<open>mod+-\<close>.

  \<open>abs_infty_poly\<close> is the induced norm by \<open>abs_infty_q\<close> on polynomials over the polynomial
  ring over the \<open>mod_ring\<close>.

  Unfortunately this is not a norm per se, as the homogeneity only holds in
  inequality, not equality. Still, it fulfils its purpose, since we only
  need the triangular inequality.\<close>

definition abs_infty_q :: "('a mod_ring) \<Rightarrow> int" where
  "abs_infty_q p = abs ((to_int_mod_ring p) mod+- q)"

definition abs_infty_poly :: "'a qr \<Rightarrow> int" where
  "abs_infty_poly p = Max (range (abs_infty_q \<circ> poly.coeff (of_qr p)))"

text \<open>Helping lemmas and properties of \<open>Max\<close>, \<open>range\<close> and \<open>finite\<close>.\<close>

lemma to_int_mod_ring_range:
  "range (to_int_mod_ring :: 'a mod_ring \<Rightarrow> int) = {0 ..< q}"
using CARD_a by (simp add: range_to_int_mod_ring)

lemma finite_Max:
  "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))"
proof -
  have finite_range: "finite (range (\<lambda>xa. (poly.coeff (of_qr x) xa)))"
  using MOST_coeff_eq_0[of "of_qr x"] by auto
  have "range (\<lambda>xa. \<bar>to_int_mod_ring (poly.coeff (of_qr x) xa) mod+- q\<bar>)
    = (\<lambda>z. \<bar>to_int_mod_ring z mod+- q\<bar>) ` range (poly.coeff (of_qr x))"
  using range_composition[of "(\<lambda>z. abs (to_int_mod_ring z mod+- q))"
    "poly.coeff (of_qr x)"] by auto
  then show ?thesis
    using finite_range finite_image_set[where
      f = "(\<lambda>z. abs (to_int_mod_ring z) mod+- q)"]
    by (auto simp add: abs_infty_q_def)
qed

lemma finite_Max_scale:
  "finite (range (\<lambda>xa. abs_infty_q (of_int_mod_ring s *
    poly.coeff (of_qr x) xa)))"
proof -
  have "of_int_mod_ring s * poly.coeff (of_qr x) xa =
    poly.coeff (of_qr (to_module s * x)) xa" for xa
  by (metis coeff_smult of_qr_to_qr_smult to_qr_of_qr
    to_qr_smult_to_module to_module_def)
  then show ?thesis
  using finite_Max by presburger
qed

lemma finite_Max_sum:
  "finite (range (\<lambda>xa. abs_infty_q
    (poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)))"
proof -
  have finite_range: "finite (range (\<lambda>xa. (poly.coeff (of_qr x) xa +
    poly.coeff (of_qr y) xa)))"
  using MOST_coeff_eq_0[of "of_qr x"] by auto
  have "range (\<lambda>xa. \<bar>to_int_mod_ring (poly.coeff (of_qr x) xa +
    poly.coeff (of_qr y) xa) mod+- q\<bar>) =
    (\<lambda>z. \<bar>to_int_mod_ring z mod+- q\<bar>) `
    range (\<lambda>xa. poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)"
  using range_composition[of "(\<lambda>z. abs (to_int_mod_ring z mod+- q))"
    "(\<lambda>xa. poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)"]
  by auto
  then show ?thesis
    using finite_range finite_image_set[where
      f = "(\<lambda>z. abs (to_int_mod_ring z) mod+- q)" ]
    by (auto simp add: abs_infty_q_def)
qed

lemma finite_Max_sum':
  "finite (range
     (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa) +
      abs_infty_q (poly.coeff (of_qr y) xa)))"
proof -
  have finite_range_x:
    "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))"
    using finite_Max[of x] by auto
  have finite_range_y:
    "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr y) xa)))"
    using finite_Max[of y] by auto
  show ?thesis
    using finite_range_plus[OF finite_range_x finite_range_y] by auto
qed

lemma Max_scale:
"(MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa)) =
    \<bar>s\<bar> * (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
proof -
  have "(MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa)) =
    (Max (range (\<lambda>xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa))))"
    by auto
  moreover have "\<dots> = (Max ((\<lambda>a. \<bar>s\<bar> * a) `
    (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))))"
    by (metis range_composition)
  moreover have "\<dots> = \<bar>s\<bar> * (Max (range
    (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa))))"
    by (subst mono_Max_commute[symmetric])
       (auto simp add: finite_Max Rings.mono_mult)
  moreover have "\<dots> =  \<bar>s\<bar> *
    (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
    by auto
  ultimately show ?thesis by auto
qed

text \<open>Show that \<open>abs_infty_q\<close> is definite, positive and fulfils the triangle inequality.\<close>

lemma abs_infty_q_definite:
  "abs_infty_q x = 0 \<longleftrightarrow> x = 0"
proof (auto simp add: abs_infty_q_def
  mod_plus_minus_zero'[OF q_gt_zero q_odd])
  assume "to_int_mod_ring x mod+- q = 0"
  then have "to_int_mod_ring x mod q = 0"
    using mod_plus_minus_zero[of "to_int_mod_ring x" q]
    by auto
  then have "to_int_mod_ring x = 0"
    using to_int_mod_ring_range CARD_a
    by (metis mod_rangeE range_eqI)
  then show "x = 0" by force
qed

lemma abs_infty_q_pos:
  "abs_infty_q x \<ge> 0"
by (auto simp add: abs_infty_q_def)

lemma abs_infty_q_minus:
  "abs_infty_q (- x) = abs_infty_q x"
proof (cases "x=0")
case True
  then show ?thesis by auto
next
case False
  have minus_x: "to_int_mod_ring (-x) = q - to_int_mod_ring x"
  proof -
    have "to_int_mod_ring (-x) = to_int_mod_ring (-x) mod q"
      by (metis CARD_a Rep_mod_ring_mod to_int_mod_ring.rep_eq)
    also have "\<dots> = (- to_int_mod_ring x) mod q"
      by (metis (no_types, opaque_lifting) CARD_a diff_eq_eq
        mod_add_right_eq plus_mod_ring.rep_eq to_int_mod_ring.rep_eq
        uminus_add_conv_diff)
    also have "\<dots> = q - to_int_mod_ring x"
    proof -
      have "- to_int_mod_ring x \<in> {-q<..<0}"
      using CARD_a range_to_int_mod_ring False
        by (smt (verit, best) Rep_mod_ring_mod greaterThanLessThan_iff
          q_gt_zero to_int_mod_ring.rep_eq to_int_mod_ring_hom.eq_iff
          to_int_mod_ring_hom.hom_zero zmod_trivial_iff)
      then have "q-to_int_mod_ring x\<in>{0<..<q}" by auto
      then show ?thesis
        using minus_mod_self1 mod_rangeE
        by (simp add: to_int_mod_ring.rep_eq zmod_zminus1_eq_if)
    qed
    finally show ?thesis by auto
  qed
  then have "\<bar>to_int_mod_ring (- x) mod+- q\<bar> =
    \<bar>(q - (to_int_mod_ring x)) mod+- q\<bar>"
    by auto
  also have "\<dots> = \<bar> (- to_int_mod_ring x) mod+- q\<bar>"
    unfolding mod_plus_minus_def by (smt (z3) mod_add_self2)
  also have "\<dots> = \<bar> - (to_int_mod_ring x mod+- q)\<bar>"
    using neg_mod_plus_minus[OF q_odd q_gt_zero,
      of "to_int_mod_ring x"] by simp
  also have "\<dots> = \<bar>to_int_mod_ring x mod+- q\<bar>" by auto
  finally show ?thesis unfolding abs_infty_q_def by auto
qed

lemma to_int_mod_ring_mult:
  "to_int_mod_ring (a*b) =  to_int_mod_ring (a::'a mod_ring) *
    to_int_mod_ring (b::'a mod_ring) mod q"
by (metis (no_types, lifting) CARD_a of_int_hom.hom_mult
  of_int_mod_ring.rep_eq of_int_mod_ring_to_int_mod_ring
  of_int_of_int_mod_ring to_int_mod_ring.rep_eq)

text \<open>Scaling only with inequality not equality! This causes a problem in proof of the
  Kyber scheme. Needed to add $q\equiv 1 \mod 4$ to change proof.\<close>
lemma mod_plus_minus_leq_mod:
  "\<bar>x mod+- q\<bar> \<le> \<bar>x\<bar>"
by (smt (verit, best) atLeastAtMost_iff mod_plus_minus_range_odd
  mod_plus_minus_rangeE q_gt_zero q_odd)

lemma abs_infty_q_scale_pos:
  assumes "s\<ge>0"
  shows "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le>
    \<bar>s\<bar> * (abs_infty_q x)"
proof -
  have "\<bar>to_int_mod_ring (of_int_mod_ring s * x) mod+- q\<bar> =
        \<bar>(to_int_mod_ring (of_int_mod_ring s ::'a mod_ring) *
          to_int_mod_ring x mod q) mod+- q\<bar>"
    using to_int_mod_ring_mult[of "of_int_mod_ring s" x] by simp
  also have "\<dots> = \<bar>(s mod q * to_int_mod_ring x) mod+- q\<bar>"
  by (simp add: CARD_a mod_plus_minus_def of_int_mod_ring.rep_eq to_int_mod_ring.rep_eq)
  also have "\<dots> \<le> \<bar>s mod q\<bar> * \<bar>to_int_mod_ring x mod+- q\<bar>"
  proof -
    have "\<bar>s mod q * to_int_mod_ring x mod+- q\<bar> =
          \<bar>(s mod q mod+- q) * (to_int_mod_ring x mod+- q) mod+- q\<bar>"
      using mod_plus_minus_mult by auto
    also have "\<dots> \<le> \<bar>(s mod q mod+- q) * (to_int_mod_ring x mod+- q)\<bar>"
      using mod_plus_minus_leq_mod by blast
    also have "\<dots> \<le> \<bar>s mod q mod+- q\<bar> * \<bar>(to_int_mod_ring x mod+- q)\<bar>"
      by (simp add: abs_mult)
    also have "\<dots> \<le> \<bar>s mod q\<bar> * \<bar>(to_int_mod_ring x mod+- q)\<bar>"
      using mod_plus_minus_leq_mod[of "s mod q"]
      by (simp add: mult_right_mono)
    finally show ?thesis by auto
  qed
  also have "\<dots> \<le> \<bar>s\<bar> * \<bar>to_int_mod_ring x mod+- q\<bar>" using assms
    by (simp add: mult_mono' q_gt_zero zmod_le_nonneg_dividend)
  finally show ?thesis unfolding abs_infty_q_def by auto
qed

lemma abs_infty_q_scale_neg:
  assumes "s<0"
  shows "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le>
    \<bar>s\<bar> * (abs_infty_q x)"
using abs_infty_q_minus abs_infty_q_scale_pos
by (smt (verit, best) mult_minus_left of_int_minus of_int_of_int_mod_ring)

lemma abs_infty_q_scale:
  "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le>
    \<bar>s\<bar> * (abs_infty_q x)"
apply (cases "s\<ge>0")
using abs_infty_q_scale_pos apply presburger
using abs_infty_q_scale_neg by force

text \<open>Triangle inequality for \<open>abs_infty_q\<close>.\<close>

lemma abs_infty_q_triangle_ineq:
  "abs_infty_q (x+y) \<le> abs_infty_q x + abs_infty_q y"
proof -
  have "to_int_mod_ring (x + y) mod+- q =
        (to_int_mod_ring x + to_int_mod_ring y) mod q mod+-q"
    by (simp add: to_int_mod_ring_def CARD_a plus_mod_ring.rep_eq)
  also have "\<dots> = (to_int_mod_ring x + to_int_mod_ring y) mod+-q"
    unfolding mod_plus_minus_def by auto
  also have "\<dots> = (to_int_mod_ring x mod+- q +
    to_int_mod_ring y mod+- q) mod+- q"
    unfolding mod_plus_minus_def
    by (smt (verit, ccfv_threshold) minus_mod_self2 mod_add_eq)
  finally have rewrite:"to_int_mod_ring (x + y) mod+- q =
    (to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q) mod+- q" .
  then have "\<bar>to_int_mod_ring (x + y) mod+- q\<bar>
    \<le> \<bar>to_int_mod_ring x mod+- q\<bar> + \<bar>to_int_mod_ring y mod+- q\<bar>"
    proof (cases
    "(to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q) \<in>
       {-\<lfloor>real_of_int q/2\<rfloor>..<\<lfloor>real_of_int q/2\<rfloor>}")
    case True
      then have True': "to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q
        \<in> {- \<lfloor>real_of_int q / 2\<rfloor>..\<lfloor>real_of_int q / 2\<rfloor>}" by auto
      then have "(to_int_mod_ring x mod+- q +
        to_int_mod_ring y mod+- q) mod+- q
       = to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q"
        using mod_plus_minus_rangeE[OF True' q_odd q_gt_zero] by auto
      then show ?thesis by (simp add: rewrite)
    next
    case False
      then have "\<bar>(to_int_mod_ring x mod+- q +
        to_int_mod_ring y mod+- q)\<bar> \<ge> \<lfloor>real_of_int q /2\<rfloor>"
        by auto
      then have "\<bar>(to_int_mod_ring x mod+- q +
        to_int_mod_ring y mod+- q)\<bar> \<ge> \<bar>(to_int_mod_ring x mod+- q +
        to_int_mod_ring y mod+- q) mod+- q\<bar>"
      using mod_plus_minus_range_odd[OF q_gt_zero q_odd,
        of "(to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q)"]
      by auto
      then show ?thesis by (simp add: rewrite)
    qed
  then show ?thesis
    by (auto simp add: abs_infty_q_def mod_plus_minus_def)
qed

text \<open>Show that \<open>abs_infty_poly\<close> is definite, positive and fulfils the triangle inequality.\<close>

lemma abs_infty_poly_definite:
  "abs_infty_poly x = 0 \<longleftrightarrow> x = 0"
proof (auto simp add: abs_infty_poly_def abs_infty_q_definite)
  assume "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) = 0"
  then have abs_le_zero: "abs_infty_q (poly.coeff (of_qr x) xa) \<le> 0"
    for xa
    using Max_ge[OF finite_Max[of x],
      of "abs_infty_q (poly.coeff (of_qr x) xa)"]
    by (auto simp add: Max_ge[OF finite_Max])
  have "abs_infty_q (poly.coeff (of_qr x) xa) = 0" for xa
    using abs_infty_q_pos[of "poly.coeff (of_qr x) xa"]
    abs_le_zero[of xa] by auto
  then have "poly.coeff (of_qr x) xa = 0" for xa
    by (auto simp add: abs_infty_q_definite)
  then show "x = 0"
    using leading_coeff_0_iff of_qr_eq_0_iff by blast
qed

lemma abs_infty_poly_pos:
  "abs_infty_poly x \<ge> 0"
proof (auto simp add: abs_infty_poly_def)
  have f_ge_zero: "\<forall>xa. abs_infty_q (poly.coeff (of_qr x) xa) \<ge> 0"
    by (auto simp add: abs_infty_q_pos)
  then show " 0 \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
    using all_impl_Max[OF f_ge_zero finite_Max] by auto
qed

text \<open>Again, homogeneity is only true for inequality not necessarily equality!
  Need to add $q\equiv 1\mod 4$ such that proof of crypto scheme works out.\<close>
lemma abs_infty_poly_scale:
  "abs_infty_poly ((to_module s) * x) \<le> (abs s) * (abs_infty_poly x)"
proof -
  have fin1: "finite (range (\<lambda>xa. abs_infty_q (of_int_mod_ring s *
    poly.coeff (of_qr x) xa)))"
    using finite_Max_scale by auto
  have fin2: "finite (range (\<lambda>xa. \<bar>s\<bar> *
     abs_infty_q (poly.coeff (of_qr x) xa)))"
    by (metis finite_Max finite_imageI range_composition)
  have "abs_infty_poly (to_module s * x) =
        (MAX xa. abs_infty_q
         ((of_int_mod_ring s) * poly.coeff (of_qr x) xa))"
  using abs_infty_poly_def to_module_mult
    by (metis (mono_tags, lifting) comp_apply image_cong)
  also have "\<dots> \<le> (MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa))"
    using abs_infty_q_scale fin1 fin2 by (subst Max_mono', auto)
  also have "\<dots> = \<bar>s\<bar> * abs_infty_poly x"
    unfolding abs_infty_poly_def comp_def using Max_scale by auto
  finally show ?thesis by blast
qed

text \<open>Triangle inequality for \<open>abs_infty_poly\<close>.\<close>
lemma abs_infty_poly_triangle_ineq:
  "abs_infty_poly (x+y) \<le> abs_infty_poly x + abs_infty_poly y"
proof -
  have "abs_infty_q (poly.coeff (of_qr x) xa +
    poly.coeff (of_qr y) xa) \<le>
    abs_infty_q (poly.coeff (of_qr x) xa) +
    abs_infty_q (poly.coeff (of_qr y) xa)"
    for xa
    using abs_infty_q_triangle_ineq[of
      "poly.coeff (of_qr x) xa" "poly.coeff (of_qr y) xa"]
    by auto
  then have abs_q_triang: "\<forall>xa.
    abs_infty_q (poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa) \<le>
    abs_infty_q (poly.coeff (of_qr x) xa) +
    abs_infty_q (poly.coeff (of_qr y) xa)"
    by auto
  have "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa +
      poly.coeff (of_qr y) xa))
    \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa) +
      abs_infty_q (poly.coeff (of_qr y) xa))"
    using Max_mono'[OF abs_q_triang finite_Max_sum finite_Max_sum']
    by auto
  also have "\<dots> \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) +
       (MAX xb. abs_infty_q (poly.coeff (of_qr y) xb))"
    using Max_mono_plus[OF finite_Max[of x] finite_Max[of y]]
    by auto
  finally have "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa +
      poly.coeff (of_qr y) xa))
    \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) +
       (MAX xb. abs_infty_q (poly.coeff (of_qr y) xb))"
    by auto
  then show ?thesis
    by (auto simp add: abs_infty_poly_def)
qed

end

text \<open>Estimation inequality using message bit.\<close>

lemma(in kyber_spec) abs_infty_poly_ineq_pm_1:
assumes "\<exists>x. poly.coeff (of_qr a) x \<in> {of_int_mod_ring (-1),1}"
shows "abs_infty_poly (to_module (round((real_of_int q)/2)) * a) \<ge>
              2 * round (real_of_int q / 4)"
proof -
  let ?x = "to_module (round((real_of_int q)/2)) * a"
  obtain x1 where x1_def:
    "poly.coeff (of_qr a) x1 \<in> {of_int_mod_ring(-1),1}"
    using assms by auto
  have "abs_infty_poly (to_module (round((real_of_int q)/2)) * a)
    \<ge> abs_infty_q (poly.coeff (of_qr (to_module
      (round (real_of_int q / 2)) * a)) x1)"
    unfolding abs_infty_poly_def using x1_def
    by (simp add: finite_Max)
  also have "abs_infty_q (poly.coeff (of_qr (to_module
    (round (real_of_int q / 2)) * a)) x1)
  = abs_infty_q (of_int_mod_ring (round (real_of_int q / 2))
    * (poly.coeff (of_qr a) x1))"
    using to_module_mult[of "round (real_of_int q / 2)" a]
    by simp
  also have "\<dots> = abs_infty_q (of_int_mod_ring
    (round (real_of_int q / 2)))"
  proof -
    consider "poly.coeff (of_qr a) x1=1" |
      "poly.coeff (of_qr a) x1 = of_int_mod_ring (-1)"
      using x1_def by auto
    then show ?thesis
    proof (cases)
      case 2
      then show ?thesis
      by (metis abs_infty_q_minus mult.right_neutral mult_minus_right
          of_int_hom.hom_one of_int_minus of_int_of_int_mod_ring)
    qed (auto)
  qed
  also have "\<dots> = \<bar>round (real_of_int q / 2) mod+- q\<bar>"
    unfolding abs_infty_q_def
    using to_int_mod_ring_of_int_mod_ring
    by (simp add: CARD_a mod_add_left_eq mod_plus_minus_def
      of_int_mod_ring.rep_eq to_int_mod_ring.rep_eq)
  also have "\<dots> = \<bar>((q + 1) div 2) mod+- q\<bar>"
    using odd_round_up[OF q_odd] by auto
  also have "\<dots> = \<bar>((2 * q) div 2) mod q - (q - 1) div 2\<bar>"
  proof -
    have "(q + 1) div 2 mod q = (q + 1) div 2" using q_gt_two by auto
    moreover have "(q + 1) div 2 - q = - ((q - 1) div 2)" by (simp add: q_odd)
    ultimately show ?thesis
    unfolding mod_plus_minus_def odd_half_floor[OF q_odd]
    by (split if_splits) simp
  qed
  also have "\<dots> = \<bar>(q-1) div 2\<bar>" using q_odd
    by (subst nonzero_mult_div_cancel_left[of 2 q], simp)
       (simp add: abs_div abs_minus_commute)
  also have "\<dots> = 2 * ((q-1) div 4)"
  proof -
    from q_gt_two have "(q-1) div 2 > 0" by simp
    then have "\<bar>(q-1) div 2\<bar> = (q-1) div 2" by auto
    also have "\<dots> = 2 * ((q-1) div 4)"
      by (subst div_mult_swap) (use q_mod_4 in
      \<open>metis dvd_minus_mod\<close>, force)
    finally show ?thesis by blast
  qed
  also have "\<dots> = 2 * round (real_of_int q / 4)"
    unfolding odd_round_up[OF q_odd] one_mod_four_round[OF q_mod_4]
    by (simp add: round_def)
  finally show ?thesis unfolding abs_infty_poly_def by simp
qed

end