(*  Title:      HOL/Library/Sorting_Algorithms.thy
    Author:     Florian Haftmann, TU Muenchen
*)

theory Sorting_Algorithms
  imports Main Multiset Comparator
begin

section \<open>Stably sorted lists\<close>

abbreviation (input) stable_segment :: "'a comparator \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "stable_segment cmp x \<equiv> filter (\<lambda>y. compare cmp x y = Equiv)"

fun sorted :: "'a comparator \<Rightarrow> 'a list \<Rightarrow> bool"
  where sorted_Nil: "sorted cmp [] \<longleftrightarrow> True"
  | sorted_single: "sorted cmp [x] \<longleftrightarrow> True"
  | sorted_rec: "sorted cmp (y # x # xs) \<longleftrightarrow> compare cmp y x \<noteq> Greater \<and> sorted cmp (x # xs)"

lemma sorted_ConsI:
  "sorted cmp (x # xs)" if "sorted cmp xs"
    and "\<And>y ys. xs = y # ys \<Longrightarrow> compare cmp x y \<noteq> Greater"
  using that by (cases xs) simp_all

lemma sorted_Cons_imp_sorted:
  "sorted cmp xs" if "sorted cmp (x # xs)"
  using that by (cases xs) simp_all

lemma sorted_Cons_imp_not_less:
  "compare cmp y x \<noteq> Greater" if "sorted cmp (y # xs)"
    and "x \<in> set xs"
  using that by (induction xs arbitrary: y) (auto dest: compare.trans_not_greater)

lemma sorted_induct [consumes 1, case_names Nil Cons, induct pred: sorted]:
  "P xs" if "sorted cmp xs" and "P []"
    and *: "\<And>x xs. sorted cmp xs \<Longrightarrow> P xs
      \<Longrightarrow> (\<And>y. y \<in> set xs \<Longrightarrow> compare cmp x y \<noteq> Greater) \<Longrightarrow> P (x # xs)"
using \<open>sorted cmp xs\<close> proof (induction xs)
  case Nil
  show ?case
    by (rule \<open>P []\<close>)
next
  case (Cons x xs)
  from \<open>sorted cmp (x # xs)\<close> have "sorted cmp xs"
    by (cases xs) simp_all
  moreover have "P xs" using \<open>sorted cmp xs\<close>
    by (rule Cons.IH)
  moreover have "compare cmp x y \<noteq> Greater" if "y \<in> set xs" for y
  using that \<open>sorted cmp (x # xs)\<close> proof (induction xs)
    case Nil
    then show ?case
      by simp
  next
    case (Cons z zs)
    then show ?case
    proof (cases zs)
      case Nil
      with Cons.prems show ?thesis
        by simp
    next
      case (Cons w ws)
      with Cons.prems have "compare cmp z w \<noteq> Greater" "compare cmp x z \<noteq> Greater"
        by auto
      then have "compare cmp x w \<noteq> Greater"
        by (auto dest: compare.trans_not_greater)
      with Cons show ?thesis
        using Cons.prems Cons.IH by auto
    qed
  qed
  ultimately show ?case
    by (rule *)
qed

lemma sorted_induct_remove1 [consumes 1, case_names Nil minimum]:
  "P xs" if "sorted cmp xs" and "P []"
    and *: "\<And>x xs. sorted cmp xs \<Longrightarrow> P (remove1 x xs)
      \<Longrightarrow> x \<in> set xs \<Longrightarrow> hd (stable_segment cmp x xs) = x \<Longrightarrow> (\<And>y. y \<in> set xs \<Longrightarrow> compare cmp x y \<noteq> Greater)
    \<Longrightarrow> P xs"
using \<open>sorted cmp xs\<close> proof (induction xs)
  case Nil
  show ?case
    by (rule \<open>P []\<close>)
next
  case (Cons x xs)
  then have "sorted cmp (x # xs)"
    by (simp add: sorted_ConsI)
  moreover note Cons.IH
  moreover have "\<And>y. compare cmp x y = Greater \<Longrightarrow> y \<in> set xs \<Longrightarrow> False"
    using Cons.hyps by simp
  ultimately show ?case
    by (auto intro!: * [of "x # xs" x]) blast
qed

lemma sorted_remove1:
  "sorted cmp (remove1 x xs)" if "sorted cmp xs"
proof (cases "x \<in> set xs")
  case False
  with that show ?thesis
    by (simp add: remove1_idem)
next
  case True
  with that show ?thesis proof (induction xs)
    case Nil
    then show ?case
      by simp
  next
    case (Cons y ys)
    show ?case proof (cases "x = y")
      case True
      with Cons.hyps show ?thesis
        by simp
    next
      case False
      then have "sorted cmp (remove1 x ys)"
        using Cons.IH Cons.prems by auto
      then have "sorted cmp (y # remove1 x ys)"
      proof (rule sorted_ConsI)
        fix z zs
        assume "remove1 x ys = z # zs"
        with \<open>x \<noteq> y\<close> have "z \<in> set ys"
          using notin_set_remove1 [of z ys x] by auto
        then show "compare cmp y z \<noteq> Greater"
          by (rule Cons.hyps(2))
      qed
      with False show ?thesis
        by simp
    qed
  qed
qed

lemma sorted_stable_segment:
  "sorted cmp (stable_segment cmp x xs)"
proof (induction xs)
  case Nil
  show ?case
    by simp
next
  case (Cons y ys)
  then show ?case
    by (auto intro!: sorted_ConsI simp add: filter_eq_Cons_iff compare.sym)
      (auto dest: compare.trans_equiv simp add: compare.sym compare.greater_iff_sym_less)

qed

primrec insort :: "'a comparator \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "insort cmp y [] = [y]"
  | "insort cmp y (x # xs) = (if compare cmp y x \<noteq> Greater
       then y # x # xs
       else x # insort cmp y xs)"

lemma mset_insort [simp]:
  "mset (insort cmp x xs) = add_mset x (mset xs)"
  by (induction xs) simp_all

lemma length_insort [simp]:
  "length (insort cmp x xs) = Suc (length xs)"
  by (induction xs) simp_all

lemma sorted_insort:
  "sorted cmp (insort cmp x xs)" if "sorted cmp xs"
using that proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons y ys)
  then show ?case by (cases ys)
    (auto, simp_all add: compare.greater_iff_sym_less)
qed

lemma stable_insort_equiv:
  "stable_segment cmp y (insort cmp x xs) = x # stable_segment cmp y xs"
    if "compare cmp y x = Equiv"
proof (induction xs)
  case Nil
  from that show ?case
    by simp
next
  case (Cons z xs)
  moreover from that have "compare cmp y z = Equiv \<Longrightarrow> compare cmp z x = Equiv"
    by (auto intro: compare.trans_equiv simp add: compare.sym)
  ultimately show ?case
    using that by (auto simp add: compare.greater_iff_sym_less)
qed

lemma stable_insort_not_equiv:
  "stable_segment cmp y (insort cmp x xs) = stable_segment cmp y xs"
    if "compare cmp y x \<noteq> Equiv"
  using that by (induction xs) simp_all

lemma remove1_insort_same_eq [simp]:
  "remove1 x (insort cmp x xs) = xs"
  by (induction xs) simp_all

lemma insort_eq_ConsI:
  "insort cmp x xs = x # xs"
    if "sorted cmp xs" "\<And>y. y \<in> set xs \<Longrightarrow> compare cmp x y \<noteq> Greater"
  using that by (induction xs) (simp_all add: compare.greater_iff_sym_less)

lemma remove1_insort_not_same_eq [simp]:
  "remove1 y (insort cmp x xs) = insort cmp x (remove1 y xs)"
    if "sorted cmp xs" "x \<noteq> y"
using that proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons z zs)
  show ?case
  proof (cases "compare cmp x z = Greater")
    case True
    with Cons show ?thesis
      by simp
  next
    case False
    then have "compare cmp x y \<noteq> Greater" if "y \<in> set zs" for y
      using that Cons.hyps
      by (auto dest: compare.trans_not_greater)
    with Cons show ?thesis
      by (simp add: insort_eq_ConsI)
  qed
qed

lemma insort_remove1_same_eq:
  "insort cmp x (remove1 x xs) = xs"
    if "sorted cmp xs" and "x \<in> set xs" and "hd (stable_segment cmp x xs) = x"
using that proof (induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons y ys)
  then have "compare cmp x y \<noteq> Less"
    by (auto simp add: compare.greater_iff_sym_less)
  then consider "compare cmp x y = Greater" | "compare cmp x y = Equiv"
    by (cases "compare cmp x y") auto
  then show ?case proof cases
    case 1
    with Cons.prems Cons.IH show ?thesis
      by auto
  next
    case 2
    with Cons.prems have "x = y"
      by simp
    with Cons.hyps show ?thesis
      by (simp add: insort_eq_ConsI)
  qed
qed

lemma sorted_append_iff:
  "sorted cmp (xs @ ys) \<longleftrightarrow> sorted cmp xs \<and> sorted cmp ys
     \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. compare cmp x y \<noteq> Greater)" (is "?P \<longleftrightarrow> ?R \<and> ?S \<and> ?Q")
proof
  assume ?P
  have ?R
    using \<open>?P\<close> by (induction xs)
      (auto simp add: sorted_Cons_imp_not_less,
        auto simp add: sorted_Cons_imp_sorted intro: sorted_ConsI)
  moreover have ?S
    using \<open>?P\<close> by (induction xs) (auto dest: sorted_Cons_imp_sorted)
  moreover have ?Q
    using \<open>?P\<close> by (induction xs) (auto simp add: sorted_Cons_imp_not_less,
      simp add: sorted_Cons_imp_sorted)
  ultimately show "?R \<and> ?S \<and> ?Q"
    by simp
next
  assume "?R \<and> ?S \<and> ?Q"
  then have ?R ?S ?Q
    by simp_all
  then show ?P
    by (induction xs)
      (auto simp add: append_eq_Cons_conv intro!: sorted_ConsI)
qed

definition sort :: "'a comparator \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "sort cmp xs = foldr (insort cmp) xs []"

lemma sort_simps [simp]:
  "sort cmp [] = []"
  "sort cmp (x # xs) = insort cmp x (sort cmp xs)"
  by (simp_all add: sort_def)

lemma mset_sort [simp]:
  "mset (sort cmp xs) = mset xs"
  by (induction xs) simp_all

lemma length_sort [simp]:
  "length (sort cmp xs) = length xs"
  by (induction xs) simp_all

lemma sorted_sort [simp]:
  "sorted cmp (sort cmp xs)"
  by (induction xs) (simp_all add: sorted_insort)

lemma stable_sort:
  "stable_segment cmp x (sort cmp xs) = stable_segment cmp x xs"
  by (induction xs) (simp_all add: stable_insort_equiv stable_insort_not_equiv)

lemma sort_remove1_eq [simp]:
  "sort cmp (remove1 x xs) = remove1 x (sort cmp xs)"
  by (induction xs) simp_all

lemma set_insort [simp]:
  "set (insort cmp x xs) = insert x (set xs)"
  by (induction xs) auto

lemma set_sort [simp]:
  "set (sort cmp xs) = set xs"
  by (induction xs) auto

lemma sort_eqI:
  "sort cmp ys = xs"
    if permutation: "mset ys = mset xs"
    and sorted: "sorted cmp xs"
    and stable: "\<And>y. y \<in> set ys \<Longrightarrow>
      stable_segment cmp y ys = stable_segment cmp y xs"
proof -
  have stable': "stable_segment cmp y ys =
    stable_segment cmp y xs" for y
  proof (cases "\<exists>x\<in>set ys. compare cmp y x = Equiv")
    case True
    then obtain z where "z \<in> set ys" and "compare cmp y z = Equiv"
      by auto
    then have "compare cmp y x = Equiv \<longleftrightarrow> compare cmp z x = Equiv" for x
      by (meson compare.sym compare.trans_equiv)
    moreover have "stable_segment cmp z ys =
      stable_segment cmp z xs"
      using \<open>z \<in> set ys\<close> by (rule stable)
    ultimately show ?thesis
      by simp
  next
    case False
    moreover from permutation have "set ys = set xs"
      by (rule mset_eq_setD)
    ultimately show ?thesis
      by simp
  qed
  show ?thesis
  using sorted permutation stable' proof (induction xs arbitrary: ys rule: sorted_induct_remove1)
    case Nil
    then show ?case
      by simp
  next
    case (minimum x xs)
    from \<open>mset ys = mset xs\<close> have ys: "set ys = set xs"
      by (rule mset_eq_setD)
    then have "compare cmp x y \<noteq> Greater" if "y \<in> set ys" for y
      using that minimum.hyps by simp
    from minimum.prems have stable: "stable_segment cmp x ys = stable_segment cmp x xs"
      by simp
    have "sort cmp (remove1 x ys) = remove1 x xs"
      by (rule minimum.IH) (simp_all add: minimum.prems filter_remove1)
    then have "remove1 x (sort cmp ys) = remove1 x xs"
      by simp
    then have "insort cmp x (remove1 x (sort cmp ys)) =
      insort cmp x (remove1 x xs)"
      by simp
    also from minimum.hyps ys stable have "insort cmp x (remove1 x (sort cmp ys)) = sort cmp ys"
      by (simp add: stable_sort insort_remove1_same_eq)
    also from minimum.hyps have "insort cmp x (remove1 x xs) = xs"
      by (simp add: insort_remove1_same_eq)
    finally show ?case .
  qed
qed

lemma filter_insort:
  "filter P (insort cmp x xs) = insort cmp x (filter P xs)"
    if "sorted cmp xs" and "P x"
  using that by (induction xs)
    (auto simp add: compare.trans_not_greater insort_eq_ConsI)

lemma filter_insort_triv:
  "filter P (insort cmp x xs) = filter P xs"
    if "\<not> P x"
  using that by (induction xs) simp_all

lemma filter_sort:
  "filter P (sort cmp xs) = sort cmp (filter P xs)"
  by (induction xs) (auto simp add: filter_insort filter_insort_triv)

section \<open>Alternative sorting algorithms\<close>

subsection \<open>Quicksort\<close>

definition quicksort :: "'a comparator \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where quicksort_is_sort [simp]: "quicksort = sort"

lemma sort_by_quicksort:
  "sort = quicksort"
  by simp

lemma sort_by_quicksort_rec:
  "sort cmp xs = sort cmp [x\<leftarrow>xs. compare cmp x (xs ! (length xs div 2)) = Less]
    @ stable_segment cmp (xs ! (length xs div 2)) xs
    @ sort cmp [x\<leftarrow>xs. compare cmp x (xs ! (length xs div 2)) = Greater]" (is "_ = ?rhs")
proof (rule sort_eqI)
  show "mset xs = mset ?rhs"
    by (rule multiset_eqI) (auto simp add: compare.sym intro: comp.exhaust)
next
  show "sorted cmp ?rhs"
    by (auto simp add: sorted_append_iff sorted_stable_segment compare.equiv_subst_right dest: compare.trans_greater)
next
  let ?pivot = "xs ! (length xs div 2)"
  fix l
  have "compare cmp x ?pivot = comp \<and> compare cmp l x = Equiv
    \<longleftrightarrow> compare cmp l ?pivot = comp \<and> compare cmp l x = Equiv" for x comp
  proof -
    have "compare cmp x ?pivot = comp \<longleftrightarrow> compare cmp l ?pivot = comp"
      if "compare cmp l x = Equiv"
      using that by (simp add: compare.equiv_subst_left compare.sym)
    then show ?thesis by blast
  qed
  then show "stable_segment cmp l xs = stable_segment cmp l ?rhs"
    by (simp add: stable_sort compare.sym [of _ ?pivot])
      (cases "compare cmp l ?pivot", simp_all)
qed

context
begin

qualified definition partition :: "'a comparator \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list \<times> 'a list"
  where "partition cmp pivot xs =
    ([x \<leftarrow> xs. compare cmp x pivot = Less], stable_segment cmp pivot xs, [x \<leftarrow> xs. compare cmp x pivot = Greater])"

qualified lemma partition_code [code]:
  "partition cmp pivot [] = ([], [], [])"
  "partition cmp pivot (x # xs) =
    (let (lts, eqs, gts) = partition cmp pivot xs
     in case compare cmp x pivot of
       Less \<Rightarrow> (x # lts, eqs, gts)
     | Equiv \<Rightarrow> (lts, x # eqs, gts)
     | Greater \<Rightarrow> (lts, eqs, x # gts))"
  using comp.exhaust by (auto simp add: partition_def Let_def compare.sym [of _ pivot])

lemma quicksort_code [code]:
  "quicksort cmp xs =
    (case xs of
      [] \<Rightarrow> []
    | [x] \<Rightarrow> xs
    | [x, y] \<Rightarrow> (if compare cmp x y \<noteq> Greater then xs else [y, x])
    | _ \<Rightarrow>
        let (lts, eqs, gts) = partition cmp (xs ! (length xs div 2)) xs
        in quicksort cmp lts @ eqs @ quicksort cmp gts)"
proof (cases "length xs \<ge> 3")
  case False
  then have "length xs \<in> {0, 1, 2}"
    by (auto simp add: not_le le_less less_antisym)
  then consider "xs = []" | x where "xs = [x]" | x y where "xs = [x, y]"
    by (auto simp add: length_Suc_conv numeral_2_eq_2)
  then show ?thesis
    by cases simp_all
next
  case True
  then obtain x y z zs where "xs = x # y # z # zs"
    by (metis le_0_eq length_0_conv length_Cons list.exhaust not_less_eq_eq numeral_3_eq_3)
  moreover have "quicksort cmp xs =
    (let (lts, eqs, gts) = partition cmp (xs ! (length xs div 2)) xs
    in quicksort cmp lts @ eqs @ quicksort cmp gts)"
    using sort_by_quicksort_rec [of cmp xs] by (simp add: partition_def)
  ultimately show ?thesis
    by simp
qed

end

subsection \<open>Mergesort\<close>

definition mergesort :: "'a comparator \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where mergesort_is_sort [simp]: "mergesort = sort"

lemma sort_by_mergesort:
  "sort = mergesort"
  by simp

context
  fixes cmp :: "'a comparator"
begin

qualified function merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where "merge [] ys = ys"
  | "merge xs [] = xs"
  | "merge (x # xs) (y # ys) = (if compare cmp x y = Greater
      then y # merge (x # xs) ys else x # merge xs (y # ys))"
  by pat_completeness auto

qualified termination by lexicographic_order

lemma mset_merge:
  "mset (merge xs ys) = mset xs + mset ys"
  by (induction xs ys rule: merge.induct) simp_all

lemma merge_eq_Cons_imp:
  "xs \<noteq> [] \<and> z = hd xs \<or> ys \<noteq> [] \<and> z = hd ys"
    if "merge xs ys = z # zs"
  using that by (induction xs ys rule: merge.induct) (auto split: if_splits)

lemma filter_merge:
  "filter P (merge xs ys) = merge (filter P xs) (filter P ys)"
    if "sorted cmp xs" and "sorted cmp ys"
using that proof (induction xs ys rule: merge.induct)
  case (1 ys)
  then show ?case
    by simp
next
  case (2 xs)
  then show ?case
    by simp
next
  case (3 x xs y ys)
  show ?case
  proof (cases "compare cmp x y = Greater")
    case True
    with 3 have hyp: "filter P (merge (x # xs) ys) =
      merge (filter P (x # xs)) (filter P ys)"
      by (simp add: sorted_Cons_imp_sorted)
    show ?thesis
    proof (cases "\<not> P x \<and> P y")
      case False
      with \<open>compare cmp x y = Greater\<close> show ?thesis
        by (auto simp add: hyp)
    next
      case True
      from \<open>compare cmp x y = Greater\<close> "3.prems"
      have *: "compare cmp z y = Greater" if "z \<in> set (filter P xs)" for z
        using that by (auto dest: compare.trans_not_greater sorted_Cons_imp_not_less)
      from \<open>compare cmp x y = Greater\<close> show ?thesis
        by (cases "filter P xs") (simp_all add: hyp *)
    qed
  next
    case False
    with 3 have hyp: "filter P (merge xs (y # ys)) =
      merge (filter P xs) (filter P (y # ys))"
      by (simp add: sorted_Cons_imp_sorted)
    show ?thesis
    proof (cases "P x \<and> \<not> P y")
      case False
      with \<open>compare cmp x y \<noteq> Greater\<close> show ?thesis
        by (auto simp add: hyp)
    next
      case True
      from \<open>compare cmp x y \<noteq> Greater\<close> "3.prems"
      have *: "compare cmp x z \<noteq> Greater" if "z \<in> set (filter P ys)" for z
        using that by (auto dest: compare.trans_not_greater sorted_Cons_imp_not_less)
      from \<open>compare cmp x y \<noteq> Greater\<close> show ?thesis
        by (cases "filter P ys") (simp_all add: hyp *)
    qed
  qed
qed

lemma sorted_merge:
  "sorted cmp (merge xs ys)" if "sorted cmp xs" and "sorted cmp ys"
using that proof (induction xs ys rule: merge.induct)
  case (1 ys)
  then show ?case
    by simp
next
  case (2 xs)
  then show ?case
    by simp
next
  case (3 x xs y ys)
  show ?case
  proof (cases "compare cmp x y = Greater")
    case True
    with 3 have "sorted cmp (merge (x # xs) ys)"
      by (simp add: sorted_Cons_imp_sorted)
    then have "sorted cmp (y # merge (x # xs) ys)"
    proof (rule sorted_ConsI)
      fix z zs
      assume "merge (x # xs) ys = z # zs"
      with 3(4) True show "compare cmp y z \<noteq> Greater"
        by (clarsimp simp add: sorted_Cons_imp_sorted dest!: merge_eq_Cons_imp)
          (auto simp add: compare.asym_greater sorted_Cons_imp_not_less)
    qed
    with True show ?thesis
      by simp
  next
    case False
    with 3 have "sorted cmp (merge xs (y # ys))"
      by (simp add: sorted_Cons_imp_sorted)
    then have "sorted cmp (x # merge xs (y # ys))"
    proof (rule sorted_ConsI)
      fix z zs
      assume "merge xs (y # ys) = z # zs"
      with 3(3) False show "compare cmp x z \<noteq> Greater"
        by (clarsimp simp add: sorted_Cons_imp_sorted dest!: merge_eq_Cons_imp)
          (auto simp add: compare.asym_greater sorted_Cons_imp_not_less)
    qed
    with False show ?thesis
      by simp
  qed
qed

lemma merge_eq_appendI:
  "merge xs ys = xs @ ys"
    if "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set ys \<Longrightarrow> compare cmp x y \<noteq> Greater"
  using that by (induction xs ys rule: merge.induct) simp_all

lemma merge_stable_segments:
  "merge (stable_segment cmp l xs) (stable_segment cmp l ys) =
     stable_segment cmp l xs @ stable_segment cmp l ys"
  by (rule merge_eq_appendI) (auto dest: compare.trans_equiv_greater)

lemma sort_by_mergesort_rec:
  "sort cmp xs =
    merge (sort cmp (take (length xs div 2) xs))
      (sort cmp (drop (length xs div 2) xs))" (is "_ = ?rhs")
proof (rule sort_eqI)
  have "mset (take (length xs div 2) xs) + mset (drop (length xs div 2) xs) =
    mset (take (length xs div 2) xs @ drop (length xs div 2) xs)"
    by (simp only: mset_append)
  then show "mset xs = mset ?rhs"
    by (simp add: mset_merge)
next
  show "sorted cmp ?rhs"
    by (simp add: sorted_merge)
next
  fix l
  have "stable_segment cmp l (take (length xs div 2) xs) @ stable_segment cmp l (drop (length xs div 2) xs)
    = stable_segment cmp l xs"
    by (simp only: filter_append [symmetric] append_take_drop_id)
  have "merge (stable_segment cmp l (take (length xs div 2) xs))
    (stable_segment cmp l (drop (length xs div 2) xs)) =
    stable_segment cmp l (take (length xs div 2) xs) @ stable_segment cmp l (drop (length xs div 2) xs)"
    by (rule merge_eq_appendI) (auto simp add: compare.trans_equiv_greater)
  also have "\<dots> = stable_segment cmp l xs"
    by (simp only: filter_append [symmetric] append_take_drop_id)
  finally show "stable_segment cmp l xs = stable_segment cmp l ?rhs"
    by (simp add: stable_sort filter_merge)
qed

lemma mergesort_code [code]:
  "mergesort cmp xs =
    (case xs of
      [] \<Rightarrow> []
    | [x] \<Rightarrow> xs
    | [x, y] \<Rightarrow> (if compare cmp x y \<noteq> Greater then xs else [y, x])
    | _ \<Rightarrow>
        let
          half = length xs div 2;
          ys = take half xs;
          zs = drop half xs
        in merge (mergesort cmp ys) (mergesort cmp zs))"
proof (cases "length xs \<ge> 3")
  case False
  then have "length xs \<in> {0, 1, 2}"
    by (auto simp add: not_le le_less less_antisym)
  then consider "xs = []" | x where "xs = [x]" | x y where "xs = [x, y]"
    by (auto simp add: length_Suc_conv numeral_2_eq_2)
  then show ?thesis
    by cases simp_all
next
  case True
  then obtain x y z zs where "xs = x # y # z # zs"
    by (metis le_0_eq length_0_conv length_Cons list.exhaust not_less_eq_eq numeral_3_eq_3)
  moreover have "mergesort cmp xs =
    (let
       half = length xs div 2;
       ys = take half xs;
       zs = drop half xs
     in merge (mergesort cmp ys) (mergesort cmp zs))"
    using sort_by_mergesort_rec [of xs] by (simp add: Let_def)
  ultimately show ?thesis
    by simp
qed

end

end


(*  Title:       Affine systems of ODEs
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Affine systems of ODEs \<close>

text \<open>Affine systems of ordinary differential equations (ODEs) are those whose vector
fields are linear operators. Broadly speaking, if there are functions $A$ and $B$ such that the
system of ODEs $X'\, t = f\, (X\, t)$ turns into $X'\, t = (A\, t)\cdot (X\, t)+(B\, t)$, then it
is affine. The end goal of this section is to prove that every affine system of ODEs has a unique
solution, and to obtain a characterization of said solution. \<close>

theory MTX_Flows
  imports SQ_MTX "Hybrid_Systems_VCs.HS_ODEs"

begin

subsection \<open> Existence and uniqueness for affine systems \<close>

definition matrix_continuous_on :: "real set \<Rightarrow> (real \<Rightarrow> ('a::real_normed_algebra_1)^'n^'m) \<Rightarrow> bool"
  where "matrix_continuous_on T A = (\<forall>t \<in> T. \<forall>\<epsilon> > 0. \<exists> \<delta> > 0. \<forall>\<tau>\<in>T. \<bar>\<tau> - t\<bar> < \<delta> \<longrightarrow> \<parallel>A \<tau> - A t\<parallel>\<^sub>o\<^sub>p \<le> \<epsilon>)"

lemma continuous_on_matrix_vector_multl:
  assumes "matrix_continuous_on T A"
  shows "continuous_on T (\<lambda>t. A t *v s)"
proof(rule continuous_onI, simp add: dist_norm)
  fix e t::real assume "0 < e" and "t \<in> T"
  let ?\<epsilon> = "e/(\<parallel>(if s = 0 then 1 else s)\<parallel>)"
  have "?\<epsilon> > 0"
    using \<open>0 < e\<close> by simp
  then obtain \<delta> where dHyp: "\<delta> > 0 \<and> (\<forall>\<tau>\<in>T. \<bar>\<tau> - t\<bar> < \<delta> \<longrightarrow> \<parallel>A \<tau> - A t\<parallel>\<^sub>o\<^sub>p \<le> ?\<epsilon>)"
    using assms \<open>t \<in> T\<close> unfolding dist_norm matrix_continuous_on_def by fastforce
  {fix \<tau> assume "\<tau> \<in> T" and "\<bar>\<tau> - t\<bar> < \<delta>"
    have obs: "?\<epsilon> * (\<parallel>s\<parallel>) = (if s = 0 then 0 else e)"
      by auto
    have "\<parallel>A \<tau> *v s - A t *v s\<parallel> = \<parallel>(A \<tau> - A t) *v s\<parallel>"
      by (simp add: matrix_vector_mult_diff_rdistrib)
    also have "... \<le> (\<parallel>A \<tau> - A t\<parallel>\<^sub>o\<^sub>p) * (\<parallel>s\<parallel>)"
      using norm_matrix_le_mult_op_norm by blast
    also have "... \<le> ?\<epsilon> * (\<parallel>s\<parallel>)"
      using dHyp \<open>\<tau> \<in> T\<close> \<open>\<bar>\<tau> - t\<bar> < \<delta>\<close> mult_right_mono norm_ge_zero by blast
    finally have "\<parallel>A \<tau> *v s - A t *v s\<parallel> \<le> e"
      by (subst (asm) obs) (metis (mono_tags, hide_lams) \<open>0 < e\<close> less_eq_real_def order_trans)}
  thus "\<exists>d>0. \<forall>\<tau>\<in>T. \<bar>\<tau> - t\<bar> < d \<longrightarrow> \<parallel>A \<tau> *v s - A t *v s\<parallel> \<le> e"
    using dHyp by blast
qed

lemma lipschitz_cond_affine:
  fixes A :: "real \<Rightarrow> 'a::real_normed_algebra_1^'n^'m" and T::"real set"
  defines "L \<equiv> Sup {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> T}"
  assumes "t \<in> T" and "bdd_above {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> T}"
  shows "\<parallel>A t *v x - A t *v y\<parallel> \<le> L * (\<parallel>x - y\<parallel>)"
proof-
  have obs: "\<parallel>A t\<parallel>\<^sub>o\<^sub>p \<le> Sup {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> T}"
    apply(rule cSup_upper)
    using continuous_on_subset assms by (auto simp: dist_norm)
  have "\<parallel>A t *v x - A t *v y\<parallel> = \<parallel>A t *v (x - y)\<parallel>"
    by (simp add: matrix_vector_mult_diff_distrib)
  also have "... \<le> (\<parallel>A t\<parallel>\<^sub>o\<^sub>p) * (\<parallel>x - y\<parallel>)"
    using norm_matrix_le_mult_op_norm by blast
  also have "... \<le> Sup {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> T} * (\<parallel>x - y\<parallel>)"
    using obs mult_right_mono norm_ge_zero by blast
  finally show "\<parallel>A t *v x - A t *v y\<parallel> \<le> L * (\<parallel>x - y\<parallel>)"
    unfolding assms .
qed

lemma local_lipschitz_affine:
  fixes A :: "real \<Rightarrow> 'a::real_normed_algebra_1^'n^'m"
  assumes "open T" and "open S"
    and Ahyp: "\<And>\<tau> \<epsilon>. \<epsilon> > 0 \<Longrightarrow> \<tau> \<in> T \<Longrightarrow> cball \<tau> \<epsilon> \<subseteq> T \<Longrightarrow> bdd_above {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. t \<in> cball \<tau> \<epsilon>}"
  shows "local_lipschitz T S (\<lambda>t s. A t *v s + B t)"
proof(unfold local_lipschitz_def lipschitz_on_def, clarsimp)
  fix s t assume "s \<in> S" and "t \<in> T"
  then obtain e1 e2 where "cball t e1 \<subseteq> T" and "cball s e2 \<subseteq> S" and "min e1 e2 > 0"
    using open_cballE[OF _ \<open>open T\<close>] open_cballE[OF _ \<open>open S\<close>] by force
  hence obs: "cball t (min e1 e2) \<subseteq> T"
    by auto
  let ?L = "Sup {\<parallel>A \<tau>\<parallel>\<^sub>o\<^sub>p |\<tau>. \<tau> \<in> cball t (min e1 e2)}"
  have "\<parallel>A t\<parallel>\<^sub>o\<^sub>p \<in> {\<parallel>A \<tau>\<parallel>\<^sub>o\<^sub>p |\<tau>. \<tau> \<in> cball t (min e1 e2)}"
    using \<open>min e1 e2 > 0\<close> by auto
  moreover have bdd: "bdd_above {\<parallel>A \<tau>\<parallel>\<^sub>o\<^sub>p |\<tau>. \<tau> \<in> cball t (min e1 e2)}"
    by (rule Ahyp, simp only: \<open>min e1 e2 > 0\<close>, simp_all add: \<open>t \<in> T\<close> obs)
  moreover have "Sup {\<parallel>A \<tau>\<parallel>\<^sub>o\<^sub>p |\<tau>. \<tau> \<in> cball t (min e1 e2)} \<ge> 0"
    apply(rule order.trans[OF op_norm_ge_0[of "A t"]])
    by (rule cSup_upper[OF calculation])
  moreover have "\<forall>x\<in>cball s (min e1 e2) \<inter> S. \<forall>y\<in>cball s (min e1 e2) \<inter> S.
    \<forall>\<tau>\<in>cball t (min e1 e2) \<inter> T. dist (A \<tau> *v x) (A \<tau> *v y) \<le> ?L * dist x y"
    apply(clarify, simp only: dist_norm, rule lipschitz_cond_affine)
    using \<open>min e1 e2 > 0\<close> bdd by auto
  ultimately show "\<exists>e>0. \<exists>L. \<forall>t\<in>cball t e \<inter> T. 0 \<le> L \<and>
    (\<forall>x\<in>cball s e \<inter> S. \<forall>y\<in>cball s e \<inter> S. dist (A t *v x) (A t *v y) \<le> L * dist x y)"
    using \<open>min e1 e2 > 0\<close> by blast
qed

lemma picard_lindeloef_affine:
  fixes A :: "real \<Rightarrow> 'a::{banach,real_normed_algebra_1,heine_borel}^'n^'n"
  assumes Ahyp: "matrix_continuous_on T A"
      and "\<And>\<tau> \<epsilon>. \<tau> \<in> T \<Longrightarrow> \<epsilon> > 0 \<Longrightarrow> bdd_above {\<parallel>A t\<parallel>\<^sub>o\<^sub>p |t. dist \<tau> t \<le> \<epsilon>}"
      and Bhyp: "continuous_on T B" and "open S"
      and "t\<^sub>0 \<in> T" and Thyp: "open T" "is_interval T"
    shows "picard_lindeloef (\<lambda> t s. A t *v s + B t) T S t\<^sub>0"
  apply (unfold_locales, simp_all add: assms, clarsimp)
   apply (rule continuous_on_add[OF continuous_on_matrix_vector_multl[OF Ahyp] Bhyp])
  by (rule local_lipschitz_affine) (simp_all add: assms)

lemma picard_lindeloef_autonomous_affine:
  fixes A :: "'a::{banach,real_normed_field,heine_borel}^'n^'n"
  shows "picard_lindeloef (\<lambda> t s. A *v s + B) UNIV UNIV t\<^sub>0"
  using picard_lindeloef_affine[of _ "\<lambda>t. A" "\<lambda>t. B"]
  unfolding matrix_continuous_on_def by (simp only: diff_self op_norm0, auto)

lemma picard_lindeloef_autonomous_linear:
  fixes A :: "'a::{banach,real_normed_field,heine_borel}^'n^'n"
  shows "picard_lindeloef (\<lambda> t. (*v) A) UNIV UNIV t\<^sub>0"
  using picard_lindeloef_autonomous_affine[of A 0] by force

lemmas unique_sol_autonomous_affine = picard_lindeloef.unique_solution[OF
    picard_lindeloef_autonomous_affine _ _ funcset_UNIV UNIV_I _ _ funcset_UNIV UNIV_I]

lemmas unique_sol_autonomous_linear = picard_lindeloef.unique_solution[OF
    picard_lindeloef_autonomous_linear _ _ funcset_UNIV UNIV_I _ _ funcset_UNIV UNIV_I]

subsection \<open> Flow for affine systems \<close>

subsubsection \<open> Derivative rules for square matrices \<close>

lemma has_derivative_exp_scaleRl[derivative_intros]:
  fixes f::"real \<Rightarrow> real" (* by Fabian Immler and Johannes Hölzl *)
  assumes "D f \<mapsto> f' at t within T"
  shows "D (\<lambda>t. exp (f t *\<^sub>R A)) \<mapsto> (\<lambda>h. f' h *\<^sub>R (exp (f t *\<^sub>R A) * A)) at t within T"
proof -
  have "bounded_linear f'"
    using assms by auto
  then obtain m where obs: "f' = (\<lambda>h. h * m)"
    using real_bounded_linear by blast
  thus ?thesis
    using vector_diff_chain_within[OF _ exp_scaleR_has_vector_derivative_right]
      assms obs by (auto simp: has_vector_derivative_def comp_def)
qed

lemma has_vderiv_on_exp_scaleRl:
  assumes "D f = f' on T"
  shows "D (\<lambda>x. exp (f x *\<^sub>R A)) = (\<lambda>x. f' x *\<^sub>R exp (f x *\<^sub>R A) * A) on T"
  using assms unfolding has_vderiv_on_def has_vector_derivative_def apply clarsimp
  by (rule has_derivative_exp_scaleRl, auto simp: fun_eq_iff)

lemma vderiv_on_exp_scaleRlI[poly_derivatives]:
  assumes "D f = f' on T" and "g' = (\<lambda>x. f' x *\<^sub>R exp (f x *\<^sub>R A) * A)"
  shows "D (\<lambda>x. exp (f x *\<^sub>R A)) = g' on T"
  using has_vderiv_on_exp_scaleRl assms by simp

lemma has_derivative_mtx_ith[derivative_intros]:
  fixes t::real and T :: "real set"
  defines "t\<^sub>0 \<equiv> netlimit (at t within T)"
  assumes "D A \<mapsto> (\<lambda>h. h *\<^sub>R A' t) at t within T"
  shows "D (\<lambda>t. A t $$ i) \<mapsto> (\<lambda>h. h *\<^sub>R A' t $$ i) at t within T"
  using assms unfolding has_derivative_def apply safe
   apply(force simp: bounded_linear_def bounded_linear_axioms_def)
  apply(rule_tac F="\<lambda>\<tau>. (A \<tau> - A t\<^sub>0 - (\<tau> - t\<^sub>0) *\<^sub>R A' t) /\<^sub>R (\<parallel>\<tau> - t\<^sub>0\<parallel>)" in tendsto_zero_norm_bound)
  by (clarsimp, rule mult_left_mono, metis (no_types, lifting) norm_column_le_norm
      sq_mtx_minus_ith sq_mtx_scaleR_ith) simp_all

lemmas has_derivative_mtx_vec_mult[derivative_intros] =
  bounded_bilinear.FDERIV[OF bounded_bilinear_sq_mtx_vec_mult]

lemma vderiv_mtx_vec_mult_intro[poly_derivatives]:
  assumes "D u = u' on T" and "D A = A' on T"
      and "g = (\<lambda>t. A t *\<^sub>V u' t + A' t *\<^sub>V u t )"
    shows "D (\<lambda>t. A t *\<^sub>V u t) = g on T"
  using assms unfolding has_vderiv_on_def has_vector_derivative_def apply clarsimp
  apply(erule_tac x=x in ballE, simp_all)+
  apply(rule derivative_eq_intros(142))
  by (auto simp: fun_eq_iff mtx_vec_scaleR_commute pth_6 scaleR_mtx_vec_assoc)

lemmas has_vderiv_on_ivl_integral = ivl_integral_has_vderiv_on[OF vderiv_on_continuous_on]

declare has_vderiv_on_ivl_integral [poly_derivatives]

lemma has_derivative_mtx_vec_multl[derivative_intros]:
  assumes "\<And> i j. D (\<lambda>t. (A t) $$ i $ j) \<mapsto> (\<lambda>\<tau>. \<tau> *\<^sub>R (A' t) $$ i $ j) (at t within T)"
  shows "D (\<lambda>t. A t *\<^sub>V x) \<mapsto> (\<lambda>\<tau>. \<tau> *\<^sub>R (A' t) *\<^sub>V x) at t within T"
  unfolding sq_mtx_vec_mult_sum_cols
  apply(rule_tac f'1="\<lambda>i \<tau>. \<tau> *\<^sub>R  (x $ i *\<^sub>R \<c>\<o>\<l> i (A' t))" in derivative_eq_intros(10))
   apply(simp_all add: scaleR_right.sum)
  apply(rule_tac g'1="\<lambda>\<tau>. \<tau> *\<^sub>R \<c>\<o>\<l> i (A' t)" in derivative_eq_intros(4), simp_all add: mult.commute)
  using assms unfolding sq_mtx_col_def column_def apply(transfer, simp)
  apply(rule has_derivative_vec_lambda)
  by (simp add: scaleR_vec_def)

lemma continuous_on_mtx_vec_multr: "continuous_on S ((*\<^sub>V) A)"
  by transfer (simp add: matrix_vector_mult_linear_continuous_on)

\<comment> \<open>Automatically generated derivative rules from this subsubsection \<close>

thm derivative_eq_intros(140,141,142,143)

subsubsection \<open> Existence and uniqueness with square matrices \<close>

text \<open>Finally, we can use the @{term exp} operation to characterize the general solutions for affine
systems of ODEs. We show that they satisfy the @{term "local_flow"} locale.\<close>

lemma continuous_on_sq_mtx_vec_multl:
  fixes A :: "real \<Rightarrow> ('n::finite) sq_mtx"
  assumes "continuous_on T A"
  shows "continuous_on T (\<lambda>t. A t *\<^sub>V s)"
proof-
  have "matrix_continuous_on T (\<lambda>t. to_vec (A t))"
    using assms by (force simp: continuous_on_iff dist_norm norm_sq_mtx_def matrix_continuous_on_def)
  hence "continuous_on T (\<lambda>t. to_vec (A t) *v s)"
    by (rule continuous_on_matrix_vector_multl)
  thus ?thesis
    by transfer
qed

lemmas continuous_on_affine = continuous_on_add[OF continuous_on_sq_mtx_vec_multl]

lemma local_lipschitz_sq_mtx_affine:
  fixes A :: "real \<Rightarrow> ('n::finite) sq_mtx"
  assumes "continuous_on T A" "open T" "open S"
  shows "local_lipschitz T S (\<lambda>t s. A t *\<^sub>V s + B t)"
proof-
  have obs: "\<And>\<tau> \<epsilon>. 0 < \<epsilon> \<Longrightarrow>  \<tau> \<in> T \<Longrightarrow> cball \<tau> \<epsilon> \<subseteq> T \<Longrightarrow> bdd_above {\<parallel>A t\<parallel> |t. t \<in> cball \<tau> \<epsilon>}"
    by (rule bdd_above_norm_cont_comp, rule continuous_on_subset[OF assms(1)], simp_all)
  hence "\<And>\<tau> \<epsilon>. 0 < \<epsilon> \<Longrightarrow> \<tau> \<in> T \<Longrightarrow> cball \<tau> \<epsilon> \<subseteq> T \<Longrightarrow> bdd_above {\<parallel>to_vec (A t)\<parallel>\<^sub>o\<^sub>p |t. t \<in> cball \<tau> \<epsilon>}"
    by (simp add: norm_sq_mtx_def)
  hence "local_lipschitz T S (\<lambda>t s. to_vec (A t) *v s + B t)"
    using local_lipschitz_affine[OF assms(2,3), of "\<lambda>t. to_vec (A t)"] by force
  thus ?thesis
    by transfer
qed

lemmas sq_mtx_unique_sol_autonomous_affine = picard_lindeloef.unique_solution[OF
    picard_lindeloef_sq_mtx_affine[OF
      continuous_on_const
      continuous_on_const
      UNIV_I is_interval_univ
      open_UNIV open_UNIV]
    _ _ funcset_UNIV UNIV_I _ _ funcset_UNIV UNIV_I]

lemma has_vderiv_on_sq_mtx_linear:
  "D (\<lambda>t. exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V s) = (\<lambda>t. A *\<^sub>V (exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V s)) on {t\<^sub>0--t}"
  by (rule poly_derivatives)+ (auto simp: exp_times_scaleR_commute sq_mtx_times_vec_assoc)

lemma has_vderiv_on_sq_mtx_affine:
  fixes t\<^sub>0::real and A :: "('a::finite) sq_mtx"
  defines "lSol c t \<equiv> exp ((c * (t - t\<^sub>0)) *\<^sub>R A)"
  shows "D (\<lambda>t. lSol 1 t *\<^sub>V s + lSol 1 t *\<^sub>V (\<integral>\<^sub>t\<^sub>0\<^sup>t (lSol (-1) \<tau> *\<^sub>V B) \<partial>\<tau>)) =
  (\<lambda>t. A *\<^sub>V (lSol 1 t *\<^sub>V s + lSol 1 t *\<^sub>V (\<integral>\<^sub>t\<^sub>0\<^sup>t (lSol (-1) \<tau> *\<^sub>V B) \<partial>\<tau>)) + B) on {t\<^sub>0--t}"
  unfolding assms apply(simp only: mult.left_neutral mult_minus1)
  apply(rule poly_derivatives, (force)?, (force)?, (force)?, (force)?)+
  by (simp add: mtx_vec_mult_add_rdistl sq_mtx_times_vec_assoc[symmetric]
      exp_minus_inverse exp_times_scaleR_commute mult_exp_exp  scale_left_distrib[symmetric])

lemma autonomous_linear_sol_is_exp:
  assumes "D X = (\<lambda>t. A *\<^sub>V X t) on {t\<^sub>0--t}" and "X t\<^sub>0 = s"
  shows "X t = exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V s"
  apply(rule sq_mtx_unique_sol_autonomous_affine[of X A 0, OF _ \<open>X t\<^sub>0 = s\<close>])
  using assms has_vderiv_on_sq_mtx_linear by force+

lemma autonomous_affine_sol_is_exp_plus_int:
  assumes "D X = (\<lambda>t. A *\<^sub>V X t + B) on {t\<^sub>0--t}" and "X t\<^sub>0 = s"
  shows "X t = exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V s + exp ((t - t\<^sub>0) *\<^sub>R A) *\<^sub>V (\<integral>\<^sub>t\<^sub>0\<^sup>t(exp (- (\<tau> - t\<^sub>0) *\<^sub>R A) *\<^sub>V B)\<partial>\<tau>)"
  apply(rule sq_mtx_unique_sol_autonomous_affine[OF assms])
  using has_vderiv_on_sq_mtx_affine by force+

lemma local_flow_sq_mtx_linear: "local_flow ((*\<^sub>V) A) UNIV UNIV (\<lambda>t s. exp (t *\<^sub>R A) *\<^sub>V s)"
  unfolding local_flow_def local_flow_axioms_def apply safe
  using picard_lindeloef_sq_mtx_affine[of _ "\<lambda>t. A" "\<lambda>t. 0"] apply force
  using has_vderiv_on_sq_mtx_linear[of 0] by auto

lemma local_flow_sq_mtx_affine: "local_flow (\<lambda>s. A *\<^sub>V s + B) UNIV UNIV
  (\<lambda>t s. exp (t *\<^sub>R A) *\<^sub>V s + exp (t *\<^sub>R A) *\<^sub>V (\<integral>\<^sub>0\<^sup>t(exp (- \<tau> *\<^sub>R A) *\<^sub>V B)\<partial>\<tau>))"
  unfolding local_flow_def local_flow_axioms_def apply safe
  using picard_lindeloef_sq_mtx_affine[of _ "\<lambda>t. A" "\<lambda>t. B"] apply force
  using has_vderiv_on_sq_mtx_affine[of 0 A] by auto

end


(*
   File:     Shift_Operator.thy
   Author:   Manuel Eberl, TU München
*)
section \<open>The shift operator on an infinite product measure\<close>
theory Shift_Operator
  imports Ergodicity ME_Library_Complement
begin

text \<open>
  Let \<open>P\<close> be an an infinite product of i.i.d. instances of the distribution \<open>M\<close>.
  Then the shift operator is the map
  \[T(x_0, x_1, x_2, \ldots) = T(x_1, x_2, \ldots)\ .\]
  In this section, we define this operator and show that it is ergodic using Kolmogorov's
  0--1 law.
\<close>

locale shift_operator_ergodic = prob_space +
  fixes T :: "(nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)" and P :: "(nat \<Rightarrow> 'a) measure"
  defines "T \<equiv> (\<lambda>f. f \<circ> Suc)"
  defines "P \<equiv> PiM (UNIV :: nat set) (\<lambda>_. M)"
begin

sublocale P: product_prob_space "\<lambda>_. M" UNIV
  by unfold_locales

sublocale P: prob_space P
  by (simp add: prob_space_PiM prob_space_axioms P_def)

lemma measurable_T [measurable]: "T \<in> P \<rightarrow>\<^sub>M P"
  unfolding P_def T_def o_def
  by (rule measurable_abs_UNIV[OF measurable_compose[OF measurable_component_singleton]]) auto

text \<open>
  The \<open>n\<close>-th tail algebra $\mathcal{T}_n$ is, in some sense, the algebra in which we forget all
  information about all $x_i$ with \<open>i < n\<close>. We simply change the product algebra of \<open>P\<close> by replacing
  the algebra for each \<open>i < n\<close> with the trivial algebra that contains only the empty set and the
  entire space.
\<close>
definition tail_algebra :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) measure"
  where "tail_algebra n = PiM UNIV (\<lambda>i. if i < n then trivial_measure (space M) else M)"

lemma tail_algebra_0 [simp]: "tail_algebra 0 = P"
  by (simp add: tail_algebra_def P_def)

lemma space_tail_algebra [simp]: "space (tail_algebra n) = PiE UNIV (\<lambda>_. space M)"
  by (simp add: tail_algebra_def space_PiM PiE_def Pi_def)

lemma measurable_P_component [measurable]: "P.random_variable M (\<lambda>f. f i)"
  unfolding P_def by measurable

lemma P_component [simp]: "distr P M (\<lambda>f. f i) = M"
  unfolding P_def by (subst P.PiM_component) auto

lemma indep_vars: "P.indep_vars (\<lambda>_. M) (\<lambda>i f. f i) UNIV"
  by (subst P.indep_vars_iff_distr_eq_PiM)
     (simp_all add: restrict_def distr_id2 P.PiM_component P_def)

text \<open>
  The shift operator takes us from $\mathcal{T}_n$ to $\mathcal{T}_{n+1}$ (it forgets the
  information about one more variable):
\<close>
lemma measurable_T_tail: "T \<in> tail_algebra (Suc n) \<rightarrow>\<^sub>M tail_algebra n"
  unfolding T_def tail_algebra_def o_def
  by (rule measurable_abs_UNIV[OF measurable_compose[OF measurable_component_singleton]]) simp_all

lemma measurable_funpow_T: "T ^^ n \<in> tail_algebra (m + n) \<rightarrow>\<^sub>M tail_algebra m"
proof (induction n)
  case (Suc n)
  have "(T ^^ n) \<circ> T \<in> tail_algebra (m + Suc n) \<rightarrow>\<^sub>M tail_algebra m"
    by (rule measurable_comp[OF _ Suc]) (simp_all add: measurable_T_tail)
  thus ?case by (simp add: o_def funpow_swap1)
qed auto

lemma measurable_funpow_T': "T ^^ n \<in> tail_algebra n \<rightarrow>\<^sub>M P"
  using measurable_funpow_T[of n 0] by simp

text \<open>
  The shift operator is clearly measure-preserving:
\<close>
lemma measure_preserving: "T \<in> measure_preserving P P"
proof
  fix A :: "(nat \<Rightarrow> 'a) set" assume "A \<in> P.events"
  hence "emeasure P (T -` A \<inter> space P) = emeasure (distr P P T) A"
    by (subst emeasure_distr) simp_all
  also have "distr P P T = P" unfolding P_def T_def o_def
    using distr_PiM_reindex[of UNIV "\<lambda>_. M" Suc UNIV] by (simp add: prob_space_axioms restrict_def)
  finally show "emeasure P (T -` A \<inter> space P) = emeasure P A" .
qed auto

sublocale fmpt P T
  by unfold_locales
     (use measure_preserving in \<open>blast intro: measure_preserving_is_quasi_measure_preserving\<close>)+

lemma indep_sets_vimage_algebra:
  "P.indep_sets (\<lambda>i. sets (vimage_algebra (space P) (\<lambda>f. f i) M)) UNIV"
  using indep_vars unfolding P.indep_vars_def sets_vimage_algebra by blast

text \<open>
  We can now show that the tail algebra $\mathcal{T}_n$ is a subalgebra of the algebra generated by the
  algebras induced by all the variables \<open>x\<^sub>i\<close> with \<open>i \<ge> n\<close>:
\<close>
lemma tail_algebra_subset:
  "sets (tail_algebra n) \<subseteq>
     sigma_sets (space P) (\<Union>i\<in>{n..}. sets (vimage_algebra (space P) (\<lambda>f. f i) M))"
proof -
  have "sets (tail_algebra n) = sigma_sets (space P)
           (prod_algebra UNIV (\<lambda>i. if i < n then trivial_measure (space M) else M))"
    by (simp add: tail_algebra_def sets_PiM PiE_def Pi_def P_def space_PiM)

  also have "\<dots> \<subseteq> sigma_sets (space P) (\<Union>i\<in>{n..}. sets (vimage_algebra (space P) (\<lambda>f. f i) M))"
  proof (intro sigma_sets_mono subsetI)
    fix C assume "C \<in> prod_algebra UNIV (\<lambda>i. if i < n then trivial_measure (space M) else M)"
    then obtain C'
      where C': "C = Pi\<^sub>E UNIV C'"
                "C' \<in> (\<Pi> i\<in>UNIV. sets (if i < n then trivial_measure (space M) else M))"
      by (elim prod_algebraE_all)
    have C'_1: "C' i \<in> {{}, space M}" if "i < n" for i
      using C'(2) that by (auto simp: Pi_def sets_trivial_measure split: if_splits)
    have C'_2: "C' i \<in> sets M" if "i \<ge> n" for i
    proof -
      from that have "\<not>(i < n)"
        by auto
      with C'(2) show ?thesis
        by (force simp: Pi_def sets_trivial_measure split: if_splits)
    qed
    have "C' i \<in> events" for i
      using C'_1[of i] C'_2[of i] by (cases "i \<ge> n") auto
    hence "C \<in> sets P"
      unfolding P_def C'(1) by (intro sets_PiM_I_countable) auto
    hence "C \<subseteq> space P"
      using sets.sets_into_space by blast

    show "C \<in> sigma_sets (space P) (\<Union>i\<in>{n..}. sets (vimage_algebra (space P) (\<lambda>f. f i) M))"
    proof (cases "C = {}")
      case False
      have "C = (\<Inter>i\<in>{n..}. (\<lambda>f. f i) -` C' i) \<inter> space P"
      proof (intro equalityI subsetI, goal_cases)
        case (1 f)
        hence "f \<in> space P"
          using 1 \<open>C \<subseteq> space P\<close> by blast
        thus ?case
          using C' 1 by (auto simp: Pi_def sets_trivial_measure split: if_splits)
      next
        case (2 f)
        hence f: "f i \<in> C' i" if "i \<ge> n" for i
          using that by auto
        have "f i \<in> C' i" for i
        proof (cases "i \<ge> n")
          case True
          thus ?thesis using C'_2[of i] f[of i] by auto
        next
          case False
          thus ?thesis using C'_1[of i] C'(1) \<open>C \<noteq> {}\<close> 2
            by (auto simp: P_def space_PiM)
        qed
        thus "f \<in> C"
          using C' by auto
      qed

      also have "(\<Inter>i\<in>{n..}. (\<lambda>f. f i) -` C' i) \<inter> space P =
                 (\<Inter>i\<in>{n..}. (\<lambda>f. f i) -` C' i \<inter> space P)"
        by blast

      also have "\<dots> \<in> sigma_sets (space P) (\<Union>i\<in>{n..}. sets (vimage_algebra (space P) (\<lambda>f. f i) M))"
        (is "_ \<in> ?rhs")
      proof (intro sigma_sets_INTER, goal_cases)
        fix i show "(\<lambda>f. f i) -` C' i \<inter> space P \<in> ?rhs"
        proof (cases "i \<ge> n")
          case False
          hence "C' i = {} \<or> C' i = space M"
            using C'_1[of i] by auto
          thus ?thesis
          proof
            assume [simp]: "C' i = space M"
            have "space P \<subseteq> (\<lambda>f. f i) -` C' i"
              by (auto simp: P_def space_PiM)
            hence "(\<lambda>f. f i) -` C' i \<inter> space P = space P"
              by blast
            thus ?thesis using sigma_sets_top
              by metis
          qed (auto intro: sigma_sets.Empty)
        next
          case i: True
          have "(\<lambda>f. f i) -` C' i \<inter> space P \<in> sets (vimage_algebra (space P) (\<lambda>f. f i) M)"
            using C'_2[OF i] by (blast intro: in_vimage_algebra)
          thus ?thesis using i by blast
        qed
      next
        have "C \<subseteq> space P" if "C \<in> sets (vimage_algebra (space P) (\<lambda>f. f i) M)" for i C
          using sets.sets_into_space[OF that] by simp
        thus "(\<Union>i\<in>{n..}. sets (vimage_algebra (space P) (\<lambda>f. f i) M)) \<subseteq> Pow (space P)"
          by auto
      qed auto

      finally show ?thesis .
    qed (auto simp: sigma_sets.Empty)
  qed

  finally show ?thesis .
qed

text \<open>
  It now follows that the \<open>T\<close>-invariant events are a subset of the tail algebra induced
  by the variables:
\<close>
lemma Invariants_subset_tail_algebra:
  "sets Invariants \<subseteq> P.tail_events (\<lambda>i. sets (vimage_algebra (space P) (\<lambda>f. f i) M))"
proof
  fix A assume A: "A \<in> sets Invariants"
  have A': "A \<in> P.events"
    using A unfolding Invariants_sets by simp_all
  show "A \<in> P.tail_events (\<lambda>i. sets (vimage_algebra (space P) (\<lambda>f. f i) M))"
        unfolding P.tail_events_def
  proof safe
    fix n :: nat
    have "vimage_restr T A = A"
      using A by (simp add: Invariants_vrestr)
    hence "A = vimage_restr (T ^^ n) A"
      using A' by (induction n) (simp_all add: vrestr_comp)
    also have "vimage_restr (T ^^ n) A = (T ^^ n) -` (A \<inter> space P) \<inter> space P"
      unfolding vimage_restr_def ..
    also have "A \<inter> space P = A"
      using A' by simp
    also have "space P = space (tail_algebra n)"
      by (simp add: P_def space_PiM)
    also have "(T ^^ n) -` A \<inter> space (tail_algebra n) \<in> sets (tail_algebra n)"
      by (rule measurable_sets[OF measurable_funpow_T' A'])
    also have "sets (tail_algebra n) \<subseteq>
               sigma_sets (space P) (\<Union>i\<in>{n..}. sets (vimage_algebra (space P) (\<lambda>f. f i) M))"
      by (rule tail_algebra_subset)
    finally show "A \<in> sigma_sets (space P)
                        (\<Union>i\<in>{n..}. sets (vimage_algebra (space P) (\<lambda>f. f i) M))" .
  qed
qed

text \<open>
  A simple invocation of Kolmogorov's 0--1 law now proves that \<open>T\<close> is indeed ergodic:
\<close>
sublocale ergodic_fmpt P T
proof
  fix A assume A: "A \<in> sets Invariants"
  have A': "A \<in> P.events"
    using A unfolding Invariants_sets by simp_all
  have "sigma_algebra (space P) (sets (vimage_algebra (space P) (\<lambda>f. f i) M))" for i
    by (metis sets.sigma_algebra_axioms space_vimage_algebra)
  hence "P.prob A = 0 \<or> P.prob A = 1"
    using indep_sets_vimage_algebra
    by (rule P.kolmogorov_0_1_law) (use A Invariants_subset_tail_algebra in blast)
  thus "A \<in> null_sets P \<or> space P - A \<in> null_sets P"
    by (rule disj_forward) (use A'(1) P.prob_compl[of A] in \<open>auto simp: P.emeasure_eq_measure\<close>)
qed

end

end


theory morten_pre_star imports morten_saturation morten_pds (* "~~/src/HOL/Hoare/HeapSyntax" *)
begin

(* Here we define the saturation rule for pre* (pre_star), and try to prove the correctness of the saturation procedure. *)

(* This is the saturation rule defined on page 32 in http://www.lsv.fr/Publis/PAPERS/PDF/schwoon-phd02.pdf *)
definition pre_star_step :: "transition set \<Rightarrow> transition \<Rightarrow> bool" where
  "pre_star_step rel \<equiv> \<lambda>(p,\<gamma>,q). (\<exists>p' w. (p,\<gamma>) \<hookrightarrow> (p',w) \<and> (p', op_labels w, q) \<in> (transition_star rel))"

(* Use this rule in the saturation procedure. *)
definition pre_star_rel where
  "pre_star_rel = saturate pre_star_step"

(* This is what we want to prove: *)
theorem "language (pre_star_rel rel) = pre_star (language rel)"
  oops

lemma pre_star_step_mono[simp]: "mono pre_star_step"
  using transition_star_mono unfolding mono_def pre_star_step_def
  by clarsimp (meson subsetD)

lemma rule_pre_star_saturation:
  "(p,\<gamma>) \<hookrightarrow> (p',w) \<Longrightarrow> (p', op_labels w, q) \<in> (transition_star rel)
   \<Longrightarrow> (p, \<gamma>, q) \<in> start_from init (saturate_step pre_star_step) rel"
  unfolding saturate_step_def start_from_def pre_star_step_def
  by auto

lemma rule_pre_star_rel: "(p,\<gamma>) \<hookrightarrow> (p',w) \<Longrightarrow> (p', op_labels w, q) \<in> (transition_star (pre_star_rel rel))
       \<Longrightarrow> (p, \<gamma>, q) \<in> pre_star_rel rel"
  unfolding pre_star_rel_def saturate_def
  using saturate_mono pre_star_step_mono lfp_fixpoint rule_pre_star_saturation
  by blast

(* This is Lemma 3.1 from page 33 in http://www.lsv.fr/Publis/PAPERS/PDF/schwoon-phd02.pdf *)
(* I managed to prove this one. *)
lemma lemma_3_1:
  assumes "(p',w) \<Rightarrow>\<^sup>* (p,v)"
      and "(p,v) \<in> language rel"
    shows "accepts (pre_star_rel rel) (p',w)"
  using assms unfolding step_starp_def
proof (induct rule: converse_rtranclp_induct)
  case base
  then show ?case
    using accepts_mono saturate_subseteq
    unfolding mono_def pre_star_rel_def language_def
    by auto
next
  case (step y z)
  then show ?case
    unfolding step_relp_def step_def
    using accepts_unfoldn rule_pre_star_rel accepts_cons
    apply clarsimp
    subgoal for p w
      by (induct w; clarsimp) blast
    done
qed

(* Lemma 3.2 on page 34 turned out to be harder to prove.
   Here goes several failed attempts... *)

lemma lemma_3_2_base:
  "(p, w, q) \<in> transition_star rel \<Longrightarrow> \<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel"
  unfolding step_starp_def
  by auto
lemma lemma_3_2_step:
  "\<lbrakk>(p, w, q) \<in> transition_star (start_from rel_0 (saturate_step f) rel)\<rbrakk>
        \<Longrightarrow> \<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel_0"
  unfolding step_starp_def (*saturate_step_def start_from_def*)
  apply -
  oops

lemma "rel \<subseteq> pre_star_rel rel"
  unfolding pre_star_rel_def saturate_def
  apply clarsimp
  apply (induct rule: lfp_ordinal_induct, fact saturate_mono[OF pre_star_step_mono])
  using start_from_subseteq
   apply fast
  apply clarsimp
  nitpick
  oops

lemma pre_star_rel_mono: "t \<in> transition_star rel \<Longrightarrow> t \<in> transition_star (pre_star_rel rel)"
  using transition_star_mono start_from_lfp_subseteq
  unfolding pre_star_rel_def saturate_def
  by (metis in_mono mono_def)

lemma pre_star_rel_induct: "\<lbrakk>P rel_0; \<And>rel. P rel \<Longrightarrow> P (f rel)\<rbrakk> \<Longrightarrow> P (lfp f)"
  apply -
  quickcheck
  oops

lemma "\<lbrakk>(p, w, q) \<in> transition_star (pre_star_saturation rel_0 rel_i);
        (p, w, q) \<notin> transition_star rel_i\<rbrakk>
         \<Longrightarrow> \<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel_0"

  oops

lemma lemma_3_2:
  assumes "(p, w, q) \<in> transition_star (pre_star_rel rel)"
  shows   "\<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel" (* \<and> (q \<in> P_states \<longrightarrow> w' = []) *)
  using assms unfolding pre_star_rel_def saturate_def
proof (induct rule: lfp_ordinal_induct)
  case mono
  then show ?case using saturate_mono by force
next
  case (step S)
  then show ?case by (simp add: lemma_3_2_step)
next
  case (union M)
  then show ?case using assms
    apply (rule_tac ?x="p" in exI)
    apply (rule_tac ?x="w" in exI)
    unfolding step_starp_def
    apply clarsimp
    apply (frule pre_star_rel_mono)
    sorry
qed
thm lfp_ordinal_induct[OF saturate_mono[OF pre_star_sat_step_mono]]
thm lfp_induct_set
lemma lemma_3_2':
  assumes "(p, w, q) \<in> transition_star (pre_star_rel rel)"
  shows   "\<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel"
  using assms unfolding pre_star_rel_def saturate_def
  apply (induct rule: lfp_ordinal_induct[OF saturate_mono[OF pre_star_sat_step_mono]])
  apply auto
  apply (simp add: lemma_3_2_step)
  using pre_star_rel_mono
  unfolding pre_star_rel_def
  apply clarsimp
  apply (rule_tac ?x="p" in exI)
  apply (rule_tac ?x="w" in exI)
  unfolding step_starp_def
  apply clarsimp
  oops

lemma lemma_3_2_converse:
  assumes "\<And>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<Longrightarrow> (p', w', q) \<notin> transition_star rel"
  shows   "(p, w, q) \<notin> transition_star (pre_star_rel rel)"
  using assms unfolding pre_star_rel_def saturate_def
  apply (induct rule: lfp_ordinal_induct[OF saturate_mono[OF pre_star_step_mono]])
   apply clarsimp
  unfolding start_from_def saturate_step_def
   apply safe
   apply simp_all
   defer
  subgoal for M
    apply (cases "rel \<in> M")
    apply auto
   apply (insert lemma_3_2_base)
    oops

lemma lemma_3_2'':
  assumes "(p, w, q) \<in> transition_star (pre_star_rel rel)"
  shows   "\<exists>p' w'. (p, w) \<Rightarrow>\<^sup>* (p', w') \<and> (p', w', q) \<in> transition_star rel"
  using assms unfolding pre_star_rel_def
  thm saturate_converse_induct saturate_converse_induct[OF pre_star_sat_step_mono]
  apply (induct rule: saturate_converse_induct[OF pre_star_sat_step_mono transition_star_mono], assumption)
  using lemma_3_2_base
   apply simp
  apply clarsimp
  apply (simp add: lemma_3_2_step)
  using pre_star_rel_mono
  unfolding pre_star_rel_def
  apply clarsimp
  apply (rule_tac ?x="p" in exI)
  apply (rule_tac ?x="w" in exI)
  unfolding step_starp_def
  apply clarsimp
  oops

(* This proof works, if lemma_3_2_converse can be proven. *)
theorem "language (pre_star_rel rel) = pre_star (language rel)"
  using lemma_3_1 lemma_3_2_converse
  unfolding language_def pre_star_def accepts_def
  by blast

lemma mono_temp[mono]: "mono (\<lambda>p x. (\<exists>t. x = t \<and> t \<in> \<rightarrow>) \<or> (\<exists>t. x = t \<and> pre_star_sat_step {x. p x} t))"
  using pre_star_sat_step_mono
  unfolding mono_def
  by clarsimp (metis Collect_mono_iff rev_predicate1D)

(*
(* inductive and inductive_set cannot prove monocity even though the proof is right above here  *)
inductive rel_pre_starp :: "transition \<Rightarrow> bool" where
  rel_pre_starp_refl[iff]: "t \<in> rel \<Longrightarrow> rel_pre_starp t"
| rel_pre_starp_step: "pre_star_sat {t'. rel_pre_starp t'} t \<Longrightarrow> rel_pre_starp t"

*)
lemma fake_mono: "X \<subseteq> Y \<Longrightarrow> pre_star_sat_step X t \<longrightarrow> pre_star_sat_step Y t"
  oops
(* If you 'sorry' this lemma, then the inductive set below works... *)

(* I first tried to define the saturation procedure as an inductive set like this.
   But it is not happy about it. *)
inductive_set rel_pre_star :: "transition set \<Rightarrow> transition set" for rel where
  rel_pre_star_refl[iff]: "t \<in> rel \<Longrightarrow> t \<in> (rel_pre_star rel)"
| rel_pre_star_step: "pre_star_sat_step (rel_pre_star rel) t \<Longrightarrow> t \<in> (rel_pre_star rel)"
monos fake_mono

(* Here I tried something similar with the general saturation procedure. *)
lemma f_mono: "A \<subseteq> B \<Longrightarrow> Collect (f A) \<subseteq> Collect (f B)"
  oops

inductive_set saturate :: "('a set \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set"
  for f :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" and S :: "'a set" where
  "t \<in> S \<Longrightarrow> t \<in> saturate f S" |
  "mono f \<Longrightarrow> f (saturate f S) t \<Longrightarrow> t \<in> saturate f S"
monos f_mono
print_theorems

end


header {* Definition of Lambda terms and convertibility *}

theory LambdaTerms imports "../../Nominal2" begin

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam x::"name" l::"lam"  binds x in l ("Lam [_]. _" [100, 100] 100)

notation
  App (infixl "\<cdot>" 98) and
  Lam ("\<integral> _. _" [97, 97] 99)

nominal_function
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_ [_ ::= _]" [90, 90, 90] 90)
where
  "(Var x)[y ::= s] = (if x = y then s else (Var x))"
| "(t1 \<cdot> t2)[y ::= s] = (t1[y ::= s]) \<cdot> (t2[y ::= s])"
| "atom x \<sharp> (y, s) \<Longrightarrow> (\<integral>x. t)[y ::= s] = \<integral>x.(t[y ::= s])"
proof auto
  fix a b :: lam and aa :: name and P
  assume "\<And>x y s. a = Var x \<and> aa = y \<and> b = s \<Longrightarrow> P"
    "\<And>t1 t2 y s. a = t1 \<cdot> t2 \<and> aa = y \<and> b = s \<Longrightarrow> P"
    "\<And>x y s t. \<lbrakk>atom x \<sharp> (y, s); a = \<integral> x. t \<and> aa = y \<and> b = s\<rbrakk> \<Longrightarrow> P"
  then show "P"
    by (rule_tac y="a" and c="(aa, b)" in lam.strong_exhaust)
       (blast, blast, simp add: fresh_star_def)
next
  fix x :: name and t and xa :: name and ya sa ta
  assume *: "eqvt_at subst_sumC (t, ya, sa)"
    "atom x \<sharp> (ya, sa)" "atom xa \<sharp> (ya, sa)"
    "[[atom x]]lst. t = [[atom xa]]lst. ta"
  then show "[[atom x]]lst. subst_sumC (t, ya, sa) = [[atom xa]]lst. subst_sumC (ta, ya, sa)"
    apply -
    apply (erule Abs_lst1_fcb)
    apply(simp (no_asm) add: Abs_fresh_iff)
    apply(drule_tac a="atom xa" in fresh_eqvt_at)
    apply(simp add: finite_supp)
    apply(simp_all add: fresh_Pair_elim Abs_fresh_iff Abs1_eq_iff)
    apply(subgoal_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> ya = ya")
    apply(subgoal_tac "(atom x \<rightleftharpoons> atom xa) \<bullet> sa = sa")
    apply(simp add: atom_eqvt eqvt_at_def)
    apply(rule perm_supp_eq, simp add: supp_swap fresh_star_def fresh_Pair)+
    done
next
  show "eqvt subst_graph" unfolding eqvt_def subst_graph_def
    by (rule, perm_simp, rule)
qed

nominal_termination (eqvt) by lexicographic_order

lemma forget[simp]:
  shows "atom x \<sharp> t \<Longrightarrow> t[x ::= s] = t"
  by (nominal_induct t avoiding: x s rule: lam.strong_induct)
     (auto simp add: lam.fresh fresh_at_base)

lemma forget_closed[simp]: "supp t = {} \<Longrightarrow> t[x ::= s] = t"
  by (simp add: fresh_def)

lemma subst_id[simp]: "M [x ::= Var x] = M"
  by (rule_tac lam="M" and c="x" in lam.strong_induct)
     (simp_all add: fresh_star_def lam.fresh fresh_Pair)

inductive
  beta :: "lam \<Rightarrow> lam \<Rightarrow> bool" (infix "\<approx>" 80)
where
  bI: "(\<integral>x. M) \<cdot> N \<approx> M[x ::= N]"
| b1: "M \<approx> M"
| b2: "M \<approx> N \<Longrightarrow> N \<approx> M"
| b3: "M \<approx> N \<Longrightarrow> N \<approx> L \<Longrightarrow> M \<approx> L"
| b4: "M \<approx> N \<Longrightarrow> Z \<cdot> M \<approx> Z \<cdot> N"
| b5: "M \<approx> N \<Longrightarrow> M \<cdot> Z \<approx> N \<cdot> Z"
| b6: "M \<approx> N \<Longrightarrow> \<integral>x. M \<approx> \<integral>x. N"

lemmas [trans] = b3
equivariance beta

end


(*  File:       Preference_Relation.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

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

section \<open>Preference Relation\<close>

theory Preference_Relation
  imports Main
begin

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

subsection \<open>Definition\<close>

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

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

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

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

subsection \<open>Ranking\<close>

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

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

subsection \<open>Limited Preference\<close>

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

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

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

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

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

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

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

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

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

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

lemma limit_presv_antisym:
  assumes
    antisymmetric: "antisym r" and
    subset: "A \<subseteq> S"
  shows "antisym (limit A r)"
  using antisym_def antisymmetric
  by auto

lemma limit_presv_trans:
  assumes
    transitive: "trans r" and
    subset:     "A \<subseteq> S"
  shows "trans (limit A r)"
  unfolding trans_def
proof (simp, safe)
  fix
    x :: "'a" and
    y :: "'a" and
    z :: "'a"
  assume
    asm1: "(x, y) \<in> r" and
    asm2: "x \<in> A" and
    asm3: "y \<in> A" and
    asm4: "(y, z) \<in> r" and
    asm5: "z \<in> A"
  show  "(x, z) \<in> r"
    using asm1 asm4 transE transitive
    by metis
qed

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

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

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

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

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

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

subsection \<open>Auxiliary Lemmata\<close>

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

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

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

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

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

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

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

lemma above_one:
  assumes
    "linear_order_on A r" and
    "finite A \<and> A \<noteq> {}"
  shows "\<exists>a\<in>A. above r a = {a} \<and> (\<forall>x\<in>A. above r x = {x} \<longrightarrow> x = a)"
proof -
  obtain n::nat where n: "n+1 = card A"
    using Suc_eq_plus1 antisym_conv2 assms(2) card_eq_0_iff
          gr0_implies_Suc le0
    by metis
  have
    "(linear_order_on A r \<and> finite A \<and> A \<noteq> {} \<and> n+1 = card A)
          \<longrightarrow> (\<exists>a. a\<in>A \<and> above r a = {a})"
  proof (induction n arbitrary: A r)
    case 0
    show ?case
    proof
      assume asm: "linear_order_on A r \<and> finite A \<and> A \<noteq> {} \<and> 0+1 = card A"
      then obtain a where "{a} = A"
        using card_1_singletonE add.left_neutral
        by metis
      hence "a \<in> A \<and> above r a = {a}"
        using above_def asm connex_imp_refl above_refl
              lin_ord_imp_connex refl_on_domain
        by fastforce
      thus "\<exists>a. a\<in>A \<and> above r a = {a}"
        by auto
    qed
  next
    case (Suc n)
    show ?case
    proof
      assume asm:
        "linear_order_on A r \<and> finite A \<and> A \<noteq> {} \<and> Suc n+1 = card A"
      then obtain B where B: "card B = n+1 \<and> B \<subseteq> A"
        using Suc_inject add_Suc card.insert_remove finite.cases
              insert_Diff_single subset_insertI
        by (metis (mono_tags, lifting))
      then obtain a where a: "{a} = A - B"
        using Suc_eq_plus1 add_diff_cancel_left' asm card_1_singletonE
              card_Diff_subset finite_subset
        by metis
      have "\<exists>b\<in>B. above (limit B r) b = {b}"
        using B One_nat_def Suc.IH add_diff_cancel_left' asm
              card_eq_0_iff diff_le_self finite_subset leD lessI
              limit_presv_lin_ord
        by metis
      then obtain b where b: "above (limit B r) b = {b}"
        by blast
      hence b1: "{a. (b, a) \<in> limit B r} = {b}"
        using above_def
        by metis
      hence b2: "b \<preceq>\<^sub>r b"
        using CollectD limit_presv_prefs2 singletonI
        by (metis (lifting))
      show "\<exists>a. a \<in> A \<and> above r a = {a}"
      proof cases
        assume
          asm1: "a \<preceq>\<^sub>r b"
        have f1:
          "\<forall>A r a aa.
            \<not> refl_on A r \<or> (a::'a, aa) \<notin> r \<or> a \<in> A \<and> aa \<in> A"
          using refl_on_domain
          by metis
        have f2:
          "\<forall>A r. \<not> connex (A::'a set) r \<or> refl_on A r"
          using connex_imp_refl
          by metis
        have f3:
          "\<forall>A r. \<not> linear_order_on (A::'a set) r \<or> connex A r"
          by (simp add: lin_ord_imp_connex)
        hence "refl_on A r"
          using f2 asm
          by metis
        hence "a \<in> A \<and> b \<in> A"
          using f1 asm1
          by simp
        hence f4:
          "\<forall>a. a \<notin> A \<or> b = a \<or> (b, a) \<in> r \<or> (a, b) \<in> r"
          using asm order_on_defs(3) total_on_def
          by metis
        have f5:
          "(b, b) \<in> limit B r"
          using above_def b mem_Collect_eq singletonI
          by metis
        have f6:
          "\<forall>a A Aa. (a::'a) \<notin> A - Aa \<or> a \<in> A \<and> a \<notin> Aa"
          by simp
        have ff1:
          "{a. (b, a) \<in> limit B r} = {b}"
          using above_def b
          by (metis (no_types))
        have ff2:
          "(b, b) \<in> {(aa, a). (aa, a) \<in> r \<and> aa \<in> B \<and> a \<in> B}"
          using f5
          by simp
        moreover have b_wins_B:
          "\<forall>x \<in> B. b \<in> above r x"
          using B above_def f4 ff1 ff2 CollectI
                Product_Type.Collect_case_prodD
          by fastforce
        moreover have "b \<in> above r a"
          using asm1 pref_imp_in_above
          by metis
        ultimately have b_wins:
          "\<forall>x \<in> A. b \<in> above r x"
          using Diff_iff a empty_iff insert_iff
          by (metis (no_types))
        hence "\<forall>x \<in> A. x \<in> above r b \<longrightarrow> x = b"
          using CollectD above_def antisym_def asm lin_imp_antisym
          by metis
        hence "\<forall>x \<in> A. x \<in> above r b \<longleftrightarrow> x = b"
          using b_wins
          by blast
        moreover have above_b_in_A: "above r b \<subseteq> A"
          using above_def asm connex_imp_refl lin_ord_imp_connex
                mem_Collect_eq refl_on_domain subsetI
          by metis
        ultimately have "above r b = {b}"
          using above_def b
          by fastforce
        thus ?thesis
          using above_b_in_A
          by blast
      next
        assume "\<not>a \<preceq>\<^sub>r b"
        hence b_smaller_a: "b \<preceq>\<^sub>r a"
          using B DiffE a asm b limit_to_limits connex_def
                limited_dest singletonI subset_iff
                lin_ord_imp_connex pref_imp_in_above
          by metis
        hence b_smaller_a_0: "(b, a) \<in> r"
          by simp
        have g1:
          "\<forall>A r Aa.
            \<not> linear_order_on (A::'a set) r \<or>
              \<not> Aa \<subseteq> A \<or>
              linear_order_on Aa (limit Aa r)"
          using limit_presv_lin_ord
          by metis
        have
          "{a. (b, a) \<in> limit B r} = {b}"
          using above_def b
          by metis
        hence g2: "b \<in> B"
          by auto
        have g3:
          "partial_order_on B (limit B r) \<and> total_on B (limit B r)"
          using g1 B asm order_on_defs(3)
          by metis
        have
          "\<forall>A r.
            total_on A r = (\<forall>a. (a::'a) \<notin> A \<or>
              (\<forall>aa. (aa \<notin> A \<or> a = aa) \<or> (a, aa) \<in> r \<or> (aa, a) \<in> r))"
          using total_on_def
          by metis
        hence
          "\<forall>a. a \<notin> B \<or>
            (\<forall>aa. aa \<notin> B \<or> a = aa \<or>
                (a, aa) \<in> limit B r \<or> (aa, a) \<in> limit B r)"
          using g3
          by simp
        hence "\<forall>x \<in> B. b \<in> above r x"
          using limit_presv_prefs2 pref_imp_in_above singletonD mem_Collect_eq
                asm b b1 b2 B g2
          by (metis (lifting))
        hence
          "\<forall>x \<in> B. x \<preceq>\<^sub>r b"
          by (simp add: above_def)
        hence b_wins2:
          "\<forall>x \<in> B. (x, b) \<in> r"
          by simp
        have "trans r"
          using asm lin_imp_trans
          by metis
        hence "\<forall>x \<in> B. (x, a) \<in> r"
          using transE b_smaller_a_0 b_wins2
          by metis
        hence "\<forall>x \<in> B. x \<preceq>\<^sub>r a"
          by simp
        hence nothing_above_a: "\<forall>x \<in> A. x \<preceq>\<^sub>r a"
          using a asm lin_ord_imp_connex above_connex Diff_iff
                empty_iff insert_iff pref_imp_in_above
          by metis
        have "\<forall>x \<in> A. x \<in> above r a \<longleftrightarrow> x = a"
          using antisym_def asm lin_imp_antisym
                nothing_above_a pref_imp_in_above
                CollectD above_def
          by metis
        moreover have above_a_in_A: "above r a \<subseteq> A"
          using above_def asm connex_imp_refl lin_ord_imp_connex
                mem_Collect_eq refl_on_domain
          by fastforce
        ultimately have "above r a = {a}"
          using above_def a
          by auto
        thus ?thesis
          using above_a_in_A
          by blast
      qed
    qed
  qed
  hence "\<exists>a. a\<in>A \<and> above r a = {a}"
    using assms n
    by blast
  thus ?thesis
    using assms connex_def lin_ord_imp_connex
          pref_imp_in_above singletonD
    by metis
qed

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

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

subsection \<open>Lifting Property\<close>

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

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

lemma trivial_equiv_rel:
  assumes order: "linear_order_on A p"
  shows "\<forall>a \<in> A. equiv_rel_except_a A p p a"
  by (simp add: equiv_rel_except_a_def order)

lemma lifted_imp_equiv_rel_except_a:
  assumes lifted: "lifted A r s a"
  shows "equiv_rel_except_a A r s a"
proof -
  from lifted have
    "linear_order_on A r \<and> linear_order_on A s \<and> a \<in> A \<and>
      (\<forall>x \<in> A - {a}. \<forall>y \<in> A - {a}. x \<preceq>\<^sub>r y \<longleftrightarrow> x \<preceq>\<^sub>s y)"
    by (simp add: lifted_def equiv_rel_except_a_def)
  thus ?thesis
    by (simp add: equiv_rel_except_a_def)
qed

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

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

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

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

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

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

theorem lifted_above_winner:
  assumes
    lifted_a: "lifted A r s a" and
    above_x: "above r x = {x}" and
    fin_A: "finite A"
  shows "above s x = {x} \<or> above s a = {a}"
proof cases
  assume "x = a"
  thus ?thesis
    using above_subset_geq_one lifted_a above_x
          lifted_above lifted_def equiv_rel_except_a_def
    by metis
next
  assume asm1: "x \<noteq> a"
  thus ?thesis
  proof cases
    assume "above s x = {x}"
    thus ?thesis
      by simp
  next
    assume asm2: "above s x \<noteq> {x}" (* \<and> asm1: x \<noteq> a *)
    have "\<forall>y \<in> A. y \<preceq>\<^sub>r x"
    proof -
      fix aa :: 'a
      have imp_a: "x \<preceq>\<^sub>r aa \<longrightarrow> aa \<notin> A \<or> aa \<preceq>\<^sub>r x"
        using singletonD pref_imp_in_above above_x
        by metis
      also have f1:
        "\<forall>A r.
          (connex A r \<or>
            (\<exists>a. (\<exists>aa. \<not> (aa::'a) \<preceq>\<^sub>r a \<and> \<not> a \<preceq>\<^sub>r aa \<and> aa \<in> A) \<and> a \<in> A) \<or>
              \<not> limited A r) \<and>
            ((\<forall>a. (\<forall>aa. aa \<preceq>\<^sub>r a \<or> a \<preceq>\<^sub>r aa \<or> aa \<notin> A) \<or> a \<notin> A) \<and> limited A r \<or>
              \<not> connex A r)"
        using connex_def
        by metis
      moreover have eq_exc_a:
        "equiv_rel_except_a A r s a"
        using lifted_def lifted_a
        by metis
      ultimately have "aa \<notin> A \<or> aa \<preceq>\<^sub>r x"
        using pref_imp_in_above above_x equiv_rel_except_a_def
              lin_ord_imp_connex limited_dest insertCI
        by metis
      thus ?thesis
        using f1 eq_exc_a above_one above_one2 above_x fin_A
              equiv_rel_except_a_def insert_not_empty pref_imp_in_above
              lin_ord_imp_connex mk_disjoint_insert insertE
        by metis
    qed
    moreover have "equiv_rel_except_a A r s a"
      using lifted_a lifted_def
      by metis
    moreover have "x \<in> A-{a}"
      using above_one above_one2 asm1 assms calculation
            equiv_rel_except_a_def insert_not_empty
            member_remove remove_def insert_absorb
      by metis
    ultimately have "\<forall>y \<in> A-{a}. y \<preceq>\<^sub>s x"
      using DiffD1 lifted_a equiv_rel_except_a_def
      by metis
    hence not_others: "\<forall>y \<in> A-{a}. above s y \<noteq> {y}"
      using asm2 empty_iff insert_iff pref_imp_in_above
      by metis
    hence "above s a = {a}"
      using Diff_iff all_not_in_conv lifted_a fin_A lifted_def
            equiv_rel_except_a_def above_one singleton_iff
      by metis
    thus ?thesis
      by simp
  qed
qed

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

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

end