theory Natlog2
imports Complex_Main
begin

definition "natlog2 n = (if n = 0 then 0 else nat \<lfloor>log 2 (real_of_nat n)\<rfloor>)"

lemma natlog2_0: "natlog2 0 = 0" by (simp add: natlog2_def)

lemma natlog2_power_of_two [simp]: "natlog2 (2 ^ n) = n"
  by (simp add: natlog2_def log_nat_power)

lemma powr_real_of_int:
  "x > 0 \<Longrightarrow> x powr real_of_int n = (if n \<ge> 0 then x ^ nat n else inverse (x ^ nat (-n)))"
  using powr_realpow[of x "nat n"] powr_realpow[of x "nat (-n)"]
  by (auto simp: field_simps powr_minus)

lemma natlog2_mono: "m \<le> n \<Longrightarrow> natlog2 m \<le> natlog2 n"
  unfolding natlog2_def by (simp_all add: nat_mono floor_mono)

lemma pow_natlog2_le: "n > 0 \<Longrightarrow> 2 ^ natlog2 n \<le> n"
proof -
  assume n: "n > 0"
  from n have "of_nat (2 ^ natlog2 n) = 2 powr real_of_nat (nat \<lfloor>log 2 (real_of_nat n)\<rfloor>)"
    by (subst powr_realpow) (simp_all add: natlog2_def)
  also have "\<dots> = 2 powr of_int \<lfloor>log 2 (real_of_nat n)\<rfloor>" using n by simp
  also have "\<dots> \<le> 2 powr log 2 (real_of_nat n)" by (intro powr_mono) (linarith, simp_all)
  also have "\<dots> = of_nat n" using n by simp
  finally show ?thesis by simp
qed

lemma pow_natlog2_gt: "n > 0 \<Longrightarrow> 2 * 2 ^ natlog2 n > n"
  and pow_natlog2_ge: "n > 0 \<Longrightarrow> 2 * 2 ^ natlog2 n \<ge> n"
proof -
  assume n: "n > 0"
  from n have "of_nat n = 2 powr log 2 (real_of_nat n)" by simp
  also have "\<dots> < 2 powr (1 + of_int \<lfloor>log 2 (real_of_nat n)\<rfloor>)"
    by (intro powr_less_mono) (linarith, simp_all)
  also from n have "\<dots> = 2 powr (1 + real_of_nat (nat \<lfloor>log 2 (real_of_nat n)\<rfloor>))" by simp
  also from n have "\<dots> = of_nat (2 * 2 ^ natlog2 n)"
    by (simp_all add: natlog2_def powr_real_of_int powr_add)
  finally show "2 * 2 ^ natlog2 n > n" by (rule of_nat_less_imp_less)
  thus "2 * 2 ^ natlog2 n \<ge> n" by simp
qed

lemma natlog2_eqI:
  assumes "n > 0" "2^k \<le> n" "n < 2 * 2^k"
  shows   "natlog2 n = k"
proof -
  from assms have "of_nat (2 ^ k) \<le> real_of_nat n"  by (subst of_nat_le_iff) simp_all
  hence "real_of_int (int k) \<le> log (of_nat 2) (real_of_nat n)"
    by (subst le_log_iff) (simp_all add: powr_realpow assms del: of_nat_le_iff)
  moreover from assms have "real_of_nat n < of_nat (2 ^ Suc k)" by (subst of_nat_less_iff) simp_all
  hence "log 2 (real_of_nat n) < of_nat k + 1"
    by (subst log_less_iff) (simp_all add: assms powr_realpow powr_add)
  ultimately have "\<lfloor>log 2 (real_of_nat n)\<rfloor> = of_nat k" by (intro floor_unique) simp_all
  with assms show ?thesis by (simp add: natlog2_def)
qed

end


section\<open>Merge Sort\<close>

theory MergeSort
imports "HOL-Library.Multiset"
begin

context linorder
begin

fun merge :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "merge (x#xs) (y#ys) =
      (if x \<le> y then
        x # merge xs (y#ys)
      else y # merge (x#xs) ys)"
| "merge xs [] = xs"
| "merge [] ys = ys"

fun msort :: "'a list \<Rightarrow> 'a list"
where
  "msort [] = []"
| "msort [x] = [x]"
| "msort xs = merge (msort (take (size xs div 2) xs))
                    (msort (drop (size xs div 2) xs))"

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

lemma set_merge:
  "set (merge xs ys) = set xs \<union> set ys"
  by (induct xs ys rule: merge.induct) auto

lemma mset_msort:
  "mset (msort xs) = mset xs"
apply(induct xs rule: msort.induct)
  apply simp apply simp
  apply(simp add:mset_merge,
        metis append_take_drop_id mset.simps(2) mset_append)
done
(*  by (induct xs rule: msort.induct)
    (simp_all, metis append_take_drop_id mset.simps(2) mset_append)*)

lemma sorted_merge:
  "sorted (merge xs ys) \<longleftrightarrow> sorted xs \<and> sorted ys"
  by (induct xs ys rule: merge.induct)
      (auto simp add: set_merge ball_Un not_le less_le)

lemma sorted_msort:
  "sorted (msort xs)"
  apply (induct xs rule: msort.induct)
  apply simp apply simp apply(simp add:sorted_merge)
done

theorem msort_sort:
  "sort = msort"
  by (rule ext, rule properties_for_sort) (fact mset_msort sorted_msort)+

end

end


(*
  File:    IMO2019_Q5.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Q5\<close>
theory IMO2019_Q5
  imports Complex_Main
begin

text \<open>
  Given a sequence $(c_1,\ldots, c_n)$ of coins, each of which can be heads (\<open>H\<close>) or tails (\<open>T\<close>),
  Harry performs the following process: Let \<open>k\<close> be the number of coins that show \<open>H\<close>. If \<open>k > 0\<close>,
  flip the \<open>k\<close>-th coin and repeat the process. Otherwise, stop.

  What is the average number of steps that this process takes, averaged over all $2^n$
  coin sequences of length \<open>n\<close>?
\<close>

subsection \<open>Definition\<close>

text \<open>
  We represent coins as Booleans, where @{term True} indicates \<open>H\<close> and @{term False} indicates \<open>T\<close>.
  Coin sequences are then simply lists of Booleans.

  The following function flips the \<open>i\<close>-th coin in the sequence (in Isabelle, the convention is that
  the first list element is indexed with 0).
\<close>
definition flip :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
  "flip xs i = xs[i := \<not>xs ! i]"

lemma flip_Cons_pos [simp]: "n > 0 \<Longrightarrow> flip (x # xs) n = x # flip xs (n - 1)"
  by (cases n) (auto simp: flip_def)

lemma flip_Cons_0 [simp]: "flip (x # xs) 0 = (\<not>x) # xs"
  by (simp add: flip_def)

lemma flip_append1 [simp]: "n < length xs \<Longrightarrow> flip (xs @ ys) n = flip xs n @ ys"
  and flip_append2 [simp]: "n \<ge> length xs \<Longrightarrow> n < length xs + length ys \<Longrightarrow>
                               flip (xs @ ys) n = xs @ flip ys (n - length xs)"
  by (auto simp: flip_def list_update_append nth_append)

lemma length_flip [simp]: "length (flip xs i) = length xs"
  by (simp add: flip_def)

text \<open>
  The following function computes the number of \<open>H\<close> in a coin sequence.
\<close>
definition heads :: "bool list \<Rightarrow> nat" where "heads xs = length (filter id xs)"

lemma heads_True [simp]: "heads (True # xs) = 1 + heads xs"
  and heads_False [simp]: "heads (False # xs) = heads xs"
  and heads_append [simp]: "heads (xs @ ys) = heads xs + heads ys"
  and heads_Nil [simp]: "heads [] = 0"
  by (auto simp: heads_def)

lemma heads_Cons: "heads (x # xs) = (if x then heads xs + 1 else heads xs)"
  by (auto simp: heads_def)

lemma heads_pos: "True \<in> set xs \<Longrightarrow> heads xs > 0"
  by (induction xs) (auto simp: heads_Cons)

lemma heads_eq_0 [simp]: "True \<notin> set xs \<Longrightarrow> heads xs = 0"
  by (induction xs) (auto simp: heads_Cons)

lemma heads_eq_0_iff [simp]: "heads xs = 0 \<longleftrightarrow> True \<notin> set xs"
  by (induction xs) (auto simp: heads_Cons)

lemma heads_pos_iff [simp]: "heads xs > 0 \<longleftrightarrow> True \<in> set xs"
  by (induction xs) (auto simp: heads_Cons)

lemma heads_le_length: "heads xs \<le> length xs"
  by (auto simp: heads_def)

text \<open>
  The following function performs a single step of Harry's process.
\<close>
definition harry_step :: "bool list \<Rightarrow> bool list" where
  "harry_step xs = flip xs (heads xs - 1)"

lemma length_harry_step [simp]: "length (harry_step xs) = length xs"
  by (simp add: harry_step_def)

text \<open>
  The following is the measure function for Harry's process, i.e. how many steps the process takes
  to terminate starting from the given sequence. We define it like this now and prove the
  correctness later.
\<close>
function harry_meas where
  "harry_meas xs =
     (if xs = [] then 0
      else if hd xs then 1 + harry_meas (tl xs)
      else if \<not>last xs then harry_meas (butlast xs)
      else let n = length xs in harry_meas (take (n - 2) (tl xs)) + 2 * n - 1)"
  by auto
termination by (relation "Wellfounded.measure length") (auto simp: min_def)

lemmas [simp del] = harry_meas.simps

text \<open>
  We now prove some simple properties of @{const harry_meas} and @{const harry_step}.
\<close>

text \<open>
  We prove a more convenient case distinction rule for lists that allows us to
  distinguish between lists starting with @{term True}, ending with @{term False}, and
  starting with @{term False} and ending with @{term True}.
\<close>
lemma head_last_cases [case_names Nil True False False_True]:
  assumes "xs = [] \<Longrightarrow> P"
  assumes "\<And>ys. xs = True # ys \<Longrightarrow> P" "\<And>ys. xs = ys @ [False] \<Longrightarrow> P"
          "\<And>ys. xs = False # ys @ [True] \<Longrightarrow> P"
  shows   "P"
proof -
  consider "length xs = 0" | "length xs = 1" | "length xs \<ge> 2" by linarith
  thus ?thesis
  proof cases
    assume "length xs = 1"
    hence "xs = [hd xs]" by (cases xs) auto
    thus P using assms(2)[of "[]"] assms(3)[of "[]"] by (cases "hd xs") auto
  next
    assume len: "length xs \<ge> 2"
    from len obtain x xs' where *: "xs = x # xs'"
      by (cases xs) auto
    have **: "xs' = butlast xs' @ [last xs']"
      using len by (subst append_butlast_last_id) (auto simp: *)
    have [simp]: "xs = x # butlast xs' @ [last xs']"
      by (subst *, subst **) auto
    show P
      using assms(2)[of xs'] assms(3)[of "x # butlast xs'"] assms(4)[of "butlast xs'"] **
      by (cases x; cases "last xs'") auto
  qed (use assms in auto)
qed

lemma harry_meas_Nil [simp]: "harry_meas [] = 0"
  by (simp add: harry_meas.simps)

lemma harry_meas_True_start [simp]: "harry_meas (True # xs) = 1 + harry_meas xs"
  by (subst harry_meas.simps) auto

lemma harry_meas_False_end [simp]: "harry_meas (xs @ [False]) = harry_meas xs"
proof (induction xs)
  case (Cons x xs)
  thus ?case by (cases x) (auto simp: harry_meas.simps)
qed (auto simp: harry_meas.simps)

lemma harry_meas_False_True: "harry_meas (False # xs @ [True]) = harry_meas xs + 2 * length xs + 3"
  by (subst harry_meas.simps) auto

lemma harry_meas_eq_0 [simp]:
  assumes "True \<notin> set xs"
  shows   "harry_meas xs = 0"
  using assms by (induction xs rule: rev_induct) auto

text \<open>
  If the sequence starts with \<open>H\<close>, the process runs on the remaining sequence until it
  terminates and then flips this \<open>H\<close> in another single step.
\<close>
lemma harry_step_True_start [simp]:
  "harry_step (True # xs) = (if True \<in> set xs then True # harry_step xs else False # xs)"
  by (auto simp: harry_step_def)

text \<open>
  If the sequence ends in \<open>T\<close>, the process simply runs on the remaining sequence as if it
  were not present.
\<close>
lemma harry_step_False_end [simp]:
  assumes "True \<in> set xs"
  shows   "harry_step (xs @ [False]) = harry_step xs @ [False]"
proof -
  have "harry_step (xs @ [False]) = flip (xs @ [False]) (heads xs - 1)"
    using heads_le_length[of xs] by (auto simp: harry_step_def)
  also have "\<dots> = harry_step xs @ [False]"
    using Suc_less_eq assms heads_le_length[of xs]
    by (subst flip_append1; fastforce simp: harry_step_def)
  finally show ?thesis .
qed

text \<open>
  If the sequence starts with \<open>T\<close> and ends with \<open>H\<close>, the process runs on the remaining
  sequence inbetween as if these two were not present, eventually leaving a sequence that
  consists entirely if \<open>T\<close> except for a single final \<open>H\<close>.
\<close>
lemma harry_step_False_True:
  assumes "True \<in> set xs"
  shows "harry_step (False # xs @ [True]) = False # harry_step xs @ [True]"
proof -
  have "harry_step (False # xs @ [True]) = False # flip (xs @ [True]) (heads xs - 1)"
    using assms heads_le_length[of xs] by (auto simp: harry_step_def heads_le_length)
  also have "\<dots> = False # harry_step xs @ [True]"
    using assms by (subst flip_append1)
                   (auto simp: harry_step_def Suc_less_SucD heads_le_length less_Suc_eq_le)
  finally show ?thesis .
qed

text \<open>
  That sequence consisting only of \<open>T\<close> except for a single final \<open>H\<close> is then turned into
  an all-\<open>T\<close> sequence in \<open>2n+1\<close> steps.
\<close>
lemma harry_meas_Falses_True [simp]: "harry_meas (replicate n False @ [True]) = 2 * n + 1"
proof (cases "n = 0")
  case False
  hence "replicate n False @ [True] = False # replicate (n - 1) False @ [True]"
    by (cases n) auto
  also have "harry_meas \<dots> = 2 * n + 1"
    using False by (simp add: harry_meas_False_True algebra_simps)
  finally show ?thesis .
qed auto

lemma harry_step_Falses_True [simp]:
  "n > 0 \<Longrightarrow> harry_step (replicate n False @ [True]) = True # replicate (n - 1) False @ [True]"
  by (cases n) (simp_all add: harry_step_def)

subsection \<open>Correctness of the measure\<close>

text \<open>
  We will now show that @{const harry_meas} indeed counts the length of the process.
  As a first step, we will show that if there is a \<open>H\<close> in a sequence, applying a single step
  decreases the measure by one.
\<close>
lemma harry_meas_step_aux:
  assumes "True \<in> set xs"
  shows   "harry_meas xs = Suc (harry_meas (harry_step xs))"
  using assms
proof (induction xs rule: length_induct)
  case (1 xs)
  hence IH: "harry_meas ys = Suc (harry_meas (harry_step ys))"
    if "length ys < length xs" "True \<in> set ys" for ys
    using that by blast

  show ?case
  proof (cases xs rule: head_last_cases)
    case (True ys)
    thus ?thesis by (auto simp: IH)
  next
    case (False ys)
    thus ?thesis using "1.prems" by (auto simp: IH)
  next
    case (False_True ys)
    thus ?thesis
    proof (cases "True \<in> set ys")
      case False
      define n where "n = length ys + 1"
      have "n > 0" by (simp add: n_def)
      from False have "ys = replicate (n - 1) False"
        unfolding n_def by (induction ys) auto
      with False_True \<open>n > 0\<close> have [simp]: "xs = replicate n False @ [True]"
        by (cases n) auto
      show ?thesis using \<open>n > 0\<close> by auto
    qed (auto simp: IH False_True harry_step_False_True harry_meas_False_True)
  qed (use 1 in auto)
qed

lemma harry_meas_step: "True \<in> set xs \<Longrightarrow> harry_meas (harry_step xs) = harry_meas xs - 1"
  using harry_meas_step_aux[of xs] by simp

text \<open>
  Next, we show that the measure is zero if and only if there is no \<open>H\<close> left in the sequence.
\<close>
lemma harry_meas_eq_0_iff [simp]: "harry_meas xs = 0 \<longleftrightarrow> True \<notin> set xs"
proof (induction xs rule: length_induct)
  case (1 xs)
  show ?case
    by (cases xs rule: head_last_cases) (auto simp: 1 harry_meas_False_True 1)
qed

text \<open>
  It follows by induction that if the measure of a sequence is \<open>n\<close>, then iterating the step
  less than \<open>n\<close> times yields a sequence with at least one \<open>H\<close> in it, but iterating it exactly
  \<open>n\<close> times yields a sequence that contains no more \<open>H\<close>.
\<close>
lemma True_in_funpow_harry_step:
  assumes "n < harry_meas xs"
  shows   "True \<in> set ((harry_step ^^ n) xs)"
  using assms
proof (induction n arbitrary: xs)
  case 0
  show ?case by (rule ccontr) (use 0 in auto)
next
  case (Suc n)
  have "True \<in> set xs" by (rule ccontr) (use Suc in auto)
  have "(harry_step ^^ Suc n) xs = (harry_step ^^ n) (harry_step xs)"
    by (simp only: funpow_Suc_right o_def)
  also have "True \<in> set \<dots>"
    using Suc \<open>True \<in> set xs\<close> by (intro Suc) (auto simp: harry_meas_step)
  finally show ?case .
qed

lemma True_notin_funpow_harry_step: "True \<notin> set ((harry_step ^^ harry_meas xs) xs)"
proof (induction "harry_meas xs" arbitrary: xs)
  case (Suc n)
  have "True \<in> set xs" by (rule ccontr) (use Suc in auto)
  have "(harry_step ^^ harry_meas xs) xs = (harry_step ^^ Suc n) xs"
    by (simp only: Suc)
  also have "\<dots> = (harry_step ^^ n) (harry_step xs)"
    by (simp only: funpow_Suc_right o_def)
  also have "\<dots> = (harry_step ^^ (harry_meas xs - 1)) (harry_step xs)"
    by (simp flip: Suc(2))
  also have "harry_meas xs - 1 = harry_meas (harry_step xs)"
     using \<open>True \<in> set xs\<close> by (subst harry_meas_step) auto
  also have "True \<notin> set ((harry_step ^^ \<dots>) (harry_step xs))"
    using Suc \<open>True \<in> set xs\<close> by (intro Suc) (auto simp: harry_meas_step)
  finally show ?case .
qed auto

text \<open>
  This shows that the measure is indeed the correct one: It is the smallest number such that
  iterating Harry's step that often yields a sequence with no heads in it.
\<close>
theorem "harry_meas xs = (LEAST n. True \<notin> set ((harry_step ^^ n) xs))"
proof (rule sym, rule Least_equality, goal_cases)
  show "True \<notin> set ((harry_step ^^ harry_meas xs) xs)"
    by (rule True_notin_funpow_harry_step)
next
  case (2 y)
  show ?case
    by (rule ccontr) (use 2 True_in_funpow_harry_step[of y] in auto)
qed

subsection \<open>Average-case analysis\<close>

text \<open>
  The set of all coin sequences of a given length.
\<close>
definition seqs where "seqs n = {xs :: bool list . length xs = n}"

lemma length_seqs [dest]: "xs \<in> seqs n \<Longrightarrow> length xs = n"
  by (simp add: seqs_def)

lemma seqs_0 [simp]: "seqs 0 = {[]}"
  by (auto simp: seqs_def)

text \<open>
  The coin sequences of length \<open>n + 1\<close> are simply what is obtained by appending either \<open>H\<close>
  or \<open>T\<close> to each coin sequence of length \<open>n\<close>.
\<close>
lemma seqs_Suc: "seqs (Suc n) = (\<lambda>xs. True # xs) ` seqs n \<union> (\<lambda>xs. False # xs) ` seqs n"
  by (auto simp: seqs_def length_Suc_conv)

text \<open>
  The set of coin sequences of length \<open>n\<close> is invariant under reversal.
\<close>
lemma seqs_rev [simp]: "rev ` seqs n = seqs n"
proof
  show "rev ` seqs n \<subseteq> seqs n"
    by (auto simp: seqs_def)
  hence "rev ` rev ` seqs n \<subseteq> rev ` seqs n"
    by blast
  thus "seqs n \<subseteq> rev ` seqs n" by (simp add: image_image)
qed

text \<open>
  Hence we get a similar decomposition theorem that appends at the end.
\<close>
lemma seqs_Suc': "seqs (Suc n) = (\<lambda>xs. xs @ [True]) ` seqs n \<union> (\<lambda>xs. xs @ [False]) ` seqs n"
proof -
  have "rev ` rev ` ((\<lambda>xs. xs @ [True]) ` seqs n \<union> (\<lambda>xs. xs @ [False]) ` seqs n) =
          rev ` ((\<lambda>xs. True # xs) ` rev ` seqs n \<union> (\<lambda>xs. False # xs) ` rev ` seqs n)"
    unfolding image_Un image_image by simp
  also have "(\<lambda>xs. True # xs) ` rev ` seqs n \<union> (\<lambda>xs. False # xs) ` rev ` seqs n = seqs (Suc n)"
    by (simp add: seqs_Suc)
  finally show ?thesis by (simp add: image_image)
qed

lemma finite_seqs [intro]: "finite (seqs n)"
  by (induction n) (auto simp: seqs_Suc)

lemma card_seqs [simp]: "card (seqs n) = 2 ^ n"
proof (induction n)
  case (Suc n)
  have "card (seqs (Suc n)) = card ((#) True ` seqs n \<union> (#) False ` seqs n)"
    by (auto simp: seqs_Suc)
  also from Suc.IH have "\<dots> = 2 ^ Suc n"
    by (subst card_Un_disjoint) (auto simp: card_image)
  finally show ?case .
qed auto

lemmas seqs_code [code] = seqs_0 seqs_Suc

text \<open>
  The sum of the measures over all possible coin sequences of a given length (defined
  as a recurrence relation; correctness proven later).
\<close>
fun harry_sum :: "nat \<Rightarrow> nat" where
  "harry_sum 0 = 0"
| "harry_sum (Suc 0) = 1"
| "harry_sum (Suc (Suc n)) = 2 * harry_sum (Suc n) + (2 * n + 4) * 2 ^ n"

lemma Suc_Suc_induct: "P 0 \<Longrightarrow> P (Suc 0) \<Longrightarrow> (\<And>n. P n \<Longrightarrow> P (Suc n) \<Longrightarrow> P (Suc (Suc n))) \<Longrightarrow> P n"
  by induction_schema (pat_completeness, rule wf_measure[of id], auto)

text \<open>
  The recurrence relation really does describe the sum over all measures:
\<close>
lemma harry_sum_correct: "harry_sum n = sum harry_meas (seqs n)"
proof (induction n rule: Suc_Suc_induct)
  case (3 n)
  have "seqs (Suc (Suc n)) =
          (\<lambda>xs. xs @ [False]) ` seqs (Suc n) \<union>
          (\<lambda>xs. True # xs @ [True]) ` seqs n \<union>
          (\<lambda>xs. False # xs @ [True]) ` seqs n"
    by (subst (1) seqs_Suc, subst (1 2) seqs_Suc') (simp add: image_Un image_image Un_ac seqs_Suc)
  also have "int (sum harry_meas \<dots>) =
               int (harry_sum (Suc n)) +
               int (\<Sum>xs\<in>seqs n. 1 + harry_meas (xs @ [True])) +
               int (\<Sum>xs\<in>seqs n. harry_meas (False # xs @ [True]))"
    by (subst sum.union_disjoint sum.reindex, auto simp: inj_on_def 3)+
  also have "int (\<Sum>xs\<in>seqs n. 1 + harry_meas (xs @ [True])) =
                2 ^ n + int (\<Sum>xs\<in>seqs n. harry_meas (xs @ [True]))"
    by (subst sum.distrib) auto
  also have "(\<Sum>xs\<in>seqs n. harry_meas (False # xs @ [True])) = harry_sum n + (2 * n + 3) * 2 ^ n"
    by (auto simp: 3 harry_meas_False_True sum.distrib algebra_simps length_seqs)
  also have "harry_sum (Suc n) = (\<Sum>xs\<in>seqs n. harry_meas (xs @ [True])) + harry_sum n"
    unfolding seqs_Suc' 3 by (subst sum.union_disjoint sum.reindex, auto simp: inj_on_def)+
  hence "int (\<Sum>xs\<in>seqs n. harry_meas (xs @ [True])) = int (harry_sum (Suc n)) - int (harry_sum n)"
    by simp
  finally have "int (\<Sum>x\<in>seqs (Suc (Suc n)). harry_meas x) =
                  int (2 * harry_sum (Suc n) + (2 * n + 4) * 2 ^ n)"
    unfolding of_nat_add by (simp add: algebra_simps)
  hence "(\<Sum>x\<in>seqs (Suc (Suc n)). (harry_meas x)) =
            (2 * harry_sum (Suc n) + (2 * n + 4) * 2 ^ n)" by linarith
  thus ?case by simp
qed (auto simp: seqs_Suc)

lemma harry_sum_closed_form_aux: "4 * harry_sum n = n * (n + 1) * 2 ^ n"
  by (induction n rule: harry_sum.induct) (auto simp: algebra_simps)

text \<open>
  Solving the recurrence gives us the following solution:
\<close>
theorem harry_sum_closed_form: "harry_sum n = n * (n + 1) * 2 ^ n div 4"
  using harry_sum_closed_form_aux[of n] by simp

text \<open>
  The average is now a simple consequence:
\<close>
definition harry_avg where "harry_avg n = harry_sum n / card (seqs n)"

corollary "harry_avg n = n * (n + 1) / 4"
proof -
  have "real (4 * harry_sum n) = n * (n + 1) * 2 ^ n"
    by (subst harry_sum_closed_form_aux) auto
  hence "real (harry_sum n) = n * (n + 1) * 2 ^ n / 4"
    by (simp add: field_simps)
  thus ?thesis
    by (simp add: harry_avg_def field_simps)
qed

end


(*
    $Id: sol.thy,v 1.4 2010/11/29 07:13:36 kleing Exp $
    Author: Martin Strecker
*)

header {* The Euclidean Algorithm -- Inductively *}

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

subsection {* Rules without base case *}

text {* Show that the following *}

inductive_set evenempty :: "nat set" where
Add2Ie: "n \<in> evenempty \<Longrightarrow> Suc(Suc n) \<in> evenempty"

text {* defines the empty set: *}

lemma evenempty_empty: "evenempty = {}"
by (auto elim: evenempty.induct)

subsection {* The Euclidean algorithm *}

text {* Define inductively the set @{text gcd}:
@{text "(a,b,g) \<in> gcd"} means that @{text g} is the greatest common divisor
of @{text a} und @{text b}. The definition should closely follow the
Euclidean algorithm.

Reminder: The Euclidean algorithm repeatedly subtracts the smaller
from the larger number, until one of the numbers is 0. Then, the other
number is the gcd. *}

inductive_set  gcd :: "(nat \<times> nat \<times> nat) set" where
gcdZero: "(u, 0, u) \<in> gcd" |
gcdStep: "\<lbrakk> (u - v, v, g) \<in> gcd; 0 < v; v \<le> u \<rbrakk> \<Longrightarrow> (u, v, g) \<in> gcd" |
gcdSwap: "\<lbrakk> (v, u, g) \<in> gcd; u < v \<rbrakk> \<Longrightarrow> (u, v, g) \<in> gcd"

text {* Now, compute the gcd of 15 and 10: *}

schematic_lemma "(15, 10, ?g)  \<in> gcd"
  apply (rule gcdStep) apply simp
  apply (rule gcdSwap)
  apply (rule gcdStep) apply simp
  apply (rule gcdStep) apply simp
  apply (rule gcdSwap)
  apply (rule gcdZero)
  apply simp+
done

text {* How does your algorithm behave on special cases as the following? *}

schematic_lemma "(0, 0, ?g)  \<in> gcd"
by (rule gcdZero)

text {* Show that the gcd is really a divisor (for the proof, you need an
appropriate lemma): *}

lemma gcd_divides: "(a,b,g) \<in> gcd \<Longrightarrow> g dvd a \<and> g dvd b"
(*<*) oops (*>*)

lemma dvd_minus: "\<lbrakk> v \<le> u;  (g::nat) dvd u - v; g dvd v\<rbrakk> \<Longrightarrow> g dvd u"
  apply (clarsimp simp add: dvd_def)
  apply (rule_tac x="k + ka" in exI)
  apply (simp add: add_mult_distrib2)
done

lemma gcd_divides: "(a,b,g) \<in> gcd \<Longrightarrow> g dvd a \<and> g dvd b"
  apply (induct rule: gcd.induct)
  apply simp
  apply (simp add: dvd_minus)
  apply simp
done

text {* Show that the gcd is the greatest common divisor: *}

lemma gcd_greatest [rule_format]: "(a,b,g) \<in> gcd \<Longrightarrow>
  0 < a \<or> 0 < b \<longrightarrow> (\<forall> d. d dvd a \<longrightarrow> d dvd b \<longrightarrow> d \<le> g)"
(*<*) oops (*>*)

lemma dvd_leq: "\<lbrakk> 0 < v; (d\<Colon>nat) dvd v \<rbrakk> \<Longrightarrow> d \<le> v"
  by (clarsimp simp add: dvd_def)

lemma dvd_minus2: "\<lbrakk> (d::nat) dvd u; d dvd v \<rbrakk> \<Longrightarrow> d dvd u - v"
  apply (clarsimp simp add: dvd_def)
  apply (rule_tac x="k-ka" in exI)
  apply (simp add: diff_mult_distrib2)
done

lemma gcd_greatest [rule_format]: "(a,b,g) \<in> gcd \<Longrightarrow>
  0 < a \<or> 0 < b \<longrightarrow> (\<forall> d. d dvd a \<longrightarrow> d dvd b \<longrightarrow> d \<le> g)"
  apply (induct rule: gcd.induct)
  apply (clarsimp simp add: dvd_leq)

  apply clarsimp
  apply (case_tac "v = u")
  apply simp
  apply (blast dest: dvd_minus2)+
done

text {* Here as well, you will have to prove a suitable lemma. What is the
precondition @{text "0 < a \<or> 0 < b"} good for?

So far, we have only shown that @{text gcd} is correct, but your algorithm
might not compute a result for all values @{text "a,b"}.  Thus, show
completeness of the algorithm: *}

lemma gcd_defined: "\<forall> a b. \<exists> g. (a, b, g) \<in> gcd"
(*<*) oops (*>*)

text {* The following lemma, proved by course-of-value recursion over @{text
n}, may be useful.  Why does standard induction over natural numbers not work
here? *}

lemma gcd_defined_aux [rule_format]:
  "\<forall> a b. (a + b) \<le> n \<longrightarrow> (\<exists> g. (a, b, g) \<in> gcd)"
  apply (induct rule: nat_less_induct)
  apply clarify
(*<*) oops (*>*)

text {* The idea is to show that @{text gcd} yields a result for all @{text "a,
b"} whenever it is known that @{text gcd} yields a result for all @{text "a',
b'"} whose sum is smaller than @{text "a + b"}.

In order to prove this lemma, make case distinctions corresponding to the
different clauses of the algorithm, and show how to reduce computation of
@{text gcd} for @{text "a, b"} to computation of @{text gcd} for suitable
smaller @{text "a', b'"}. *}

lemma gcd_defined_aux [rule_format]:
  "\<forall> a b. (a + b) \<le> n \<longrightarrow> (\<exists> g. (a, b, g) \<in> gcd)"
apply (induct rule: nat_less_induct)
apply clarify

apply (case_tac b)

-- "Application of gcdZero"
apply simp
apply (rule exI)
apply (rule gcdZero)

apply (rename_tac n a b b')
apply simp

apply (case_tac "b \<le> a")

-- "Application of gcdStep"
apply simp
apply (drule_tac x=a in spec, drule mp)
apply arith
apply (elim allE impE)
prefer 2
apply (elim exE)
apply (rule exI)
apply (rule gcdStep, assumption)
apply simp+

apply (case_tac a)
apply simp

-- "Application of gcdSwap, followed by gcdZero"
apply (drule_tac x=0 in spec, drule mp) apply arith
apply (drule_tac x=0 in spec, drule_tac x=0 in spec, drule mp)
apply simp
apply (elim exE)
apply (rule exI)
apply (rule gcdSwap) apply (rule gcdZero)
apply simp

-- "Application of gcdSwap, followed by gcdStep"
apply (drule_tac x=b in spec, drule mp) apply arith
apply (elim allE impE)
prefer 2
apply (elim exE)
apply (rule exI)
apply (rule gcdSwap)
apply (rule gcdStep) apply assumption
apply arith+
done

lemma gcd_defined: "\<forall> a b. \<exists> g. (a, b, g) \<in> gcd"
  apply clarify
  apply (rule_tac n="a + b" in gcd_defined_aux)
  apply simp
done

(*<*) end (*>*)


theory Recursion
  imports HOL.Fun Main
begin

subsection \<open>primitive recursive functions\<close>

primrec add :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "add x 0 = x" |
        "add x (Suc y) = Suc (add x y)"

value "add 5 6"

primrec prede :: "nat \<Rightarrow> nat"
  where "prede 0 = 0" |
        "prede (Suc x) = x"

primrec sub :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "sub x 0 = x" |
        "sub x (Suc y) = prede (sub x y)"

value "sub 8 2"
value "sub 2 5"

primrec time :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "time x 0 = 0" |
        "time x (Suc y) = add (time x y) x"

value "time 5 6"

primrec fact :: "nat \<Rightarrow> nat"
  where "fact 0 = 1" |
        "fact (Suc n) = time (fact n) (add n 1)"

value "fact 5"

primrec exp :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "exp x 0 = 1" |
        "exp x (Suc y) = time (exp x y) x"

value "exp 2 5"

subsection \<open>total recursive functions\<close>

fun A :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "A 0 n = n + 1" |
        "A (Suc m) 0 = A m 1" |
        "A (Suc m) (Suc n) = A m (A (Suc m) n)"

value "A 3 3"

(*
primrec fib2 :: "nat \<Rightarrow> nat"
  where "fib2 0 = 1" |
        "fib2 (Suc n) = (case n of 0 \<Rightarrow> 1 |
                                  Suc m \<Rightarrow> fib2 m + fib2 n)"
*)

fun fib :: "nat \<Rightarrow> nat"
  where "fib 0 = 1" |
        "fib (Suc 0) = 1" |
        "fib (Suc (Suc n)) = fib n + fib (Suc n)"

value "fib 9"

primrec sep0 :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "sep0 [] a = []" |
        "sep0 (x # xs) a =
            (case xs of [] \<Rightarrow> [x] |
                        _ \<Rightarrow> x#a#(sep0 xs a))"

value "sep0 [a,b,c,d,e,f] x"

fun sep :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "sep [] a = []" |
        "sep [x] a = [x]" |
        "sep (x#y#zs) a = x # a # sep (y#zs) a"

value "sep [a,b,c,d,e,f] x"

subsection \<open>fun vs. function\<close>

function f1 :: "nat \<Rightarrow> nat"
  where "f1 0 = f1 1" |
        "f1 n = f1 (Suc n)"
  by auto
termination sorry (* this function is not terminated *)

fun fib2 :: "nat \<Rightarrow> nat"
  where "fib2 0 = 1" |
        "fib2 (Suc 0) = 1" |
        "fib2 (Suc (Suc 0)) = 2" |
        "fib2 (Suc (Suc n)) = fib2 n + fib2 (Suc n)"

value "fib2 0"
value "fib2 2"
value "fib2 9"

function fib3 :: "nat \<Rightarrow> nat"
where  "fib3 0 = 1" |
       "fib3 1 = 1" |
(*     "fib3 2 = 2" | *)
      "fib3 (n + 2) = fib3 n + fib3 (n + 1)"
apply atomize_elim
apply arith
  by auto
termination by lexicographic_order

lemma "fib3 0 = 1"
  by simp

lemma "fib3 2 = 2"
  using fib3.simps(1) fib3.simps(2) fib3.simps(3)[of 0]
    by (metis add.left_neutral one_add_one)

function ev :: "nat \<Rightarrow> bool"
  where "ev (2 * n) = True" |
        "ev (2 * n + 1) = False"
apply atomize_elim
  by arith+
termination by (relation "{}") simp

(*
function ev_case :: "nat \<Rightarrow> bool"
  where "ev_case n = (case n of (2 * m) \<Rightarrow> True |
                                (2 * m + 1) => False)"
*)

lemma "ev 4 = True"
  using ev.simps(1)[of 2] by simp

lemma "ev 102 = True"
  using ev.simps(1)[of 51] by simp

lemma "ev 101 = False"
  using ev.simps(2)[of 50] by simp

subsection \<open>pattern match\<close>

definition first :: "('a \<times> 'b) \<Rightarrow> 'a"
  where "first p \<equiv> case p of (a,_) \<Rightarrow> a"

definition second :: "('a \<times> 'b) \<Rightarrow> 'b"
  where "second p \<equiv> case p of (_,b) \<Rightarrow> b"

primrec gt0 :: "nat \<Rightarrow> bool"
  where "gt0 0 = False" |
        "gt0 (Suc _) = True"

fun addcase :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "addcase x y =
          (case y of 0 \<Rightarrow> x |
               (Suc z) \<Rightarrow> Suc (add x z))"

value "addcase 5 6"

fun sep0case :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "sep0case xs a =
    (case xs of [] \<Rightarrow> [] |
                (x # xs) \<Rightarrow> (case xs of [] \<Rightarrow> [x] |
                                        _ \<Rightarrow> x#a#(sep0 xs a)))"

value "sep0case [a,b,c,d,e,f] x"

fun sep2 :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "sep2 (x#y#zs) a = x # a # sep2 (y#zs) a" |
        "sep2 xs a = xs"

thm sep2.simps

fun fib1_case :: "nat \<Rightarrow> nat"
  where "fib1_case n =
            (case n of 0 \<Rightarrow> 1 |
                      (Suc 0) \<Rightarrow> 1 |
                      (Suc (Suc n)) \<Rightarrow> fib1_case n + fib1_case (n + 1))"

value "fib1_case 6"

fun len2 :: "'a list \<Rightarrow> bool"
  where "len2 [] = False" |
        "len2 [_] = False" |
        "len2 (_#_#_) = True"

value "len2 [x]"
value "len2 [x,y]"

function gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "gcd x 0 = x" |
        "gcd 0 y = y" |
        "x < y \<Longrightarrow> gcd (Suc x) (Suc y) = gcd (Suc x) (y - x)" |
        "x \<ge> y \<Longrightarrow> gcd (Suc x) (Suc y) = gcd (x - y) (Suc y)"
by (atomize_elim, auto, arith)
termination by lexicographic_order

lemma "gcd 8 24 = 8"
  using gcd.simps(3)[of 7 23] gcd.simps(3)[of 7 15]
        gcd.simps(4)[of 7 7] gcd.simps(2)[of "Suc 7"]
  by force

(*
function check :: "string \<Rightarrow> bool"
  where "check (''good'') = True" |
        "check s = False"
     apply auto[1] apply simp
     *)

function check :: "string \<Rightarrow> bool"
  where "check ''good'' = True" |
        "s \<noteq> ''good'' \<Longrightarrow> check s = False"
  by auto
termination by (relation "{}") simp

value "check ''good''"
lemma "check ''aaaa'' = False"
  using check.simps(2) by simp

definition check3 :: "string \<Rightarrow> bool"
  where "check3 s \<equiv> (s = ''good'')"

value "check3 ''good''"

subsection \<open>mutual, nested, high-order recursion\<close>

function even :: "nat \<Rightarrow> bool"
     and odd :: "nat \<Rightarrow> bool"
where "even 0 = True" |
      "odd 0 = False" |
      "even (Suc n) = odd n" |
      "odd (Suc n) = even n"
  by pat_completeness auto
termination by lexicographic_order

value "even 4"

function nest :: "nat \<Rightarrow> nat"
  where "nest 0 = 0" |
        "nest (Suc n) = nest ((nest n))"
  by pat_completeness auto

lemma nest_is_zero: "nest_dom n \<Longrightarrow> nest n = 0"
  by (induct rule:nest.pinduct) (auto simp: nest.psimps)

termination
  by (relation "measure (\<lambda>n. n)") (auto simp: nest_is_zero)

lemma "nest n = 0"
  apply(induct n)
  using nest.simps by simp+

subsection \<open>tail recursion\<close>

fun fact_help :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "fact_help i a =
    (if i = 0 then a
      else fact_help (i - 1) (i * a))"

definition fact2 :: "nat \<Rightarrow> nat"
  where "fact2 m \<equiv> fact_help m 1"

end


(*  Author: Tobias Nipkow, 2007 *)

section \<open>Lists as vectors\<close>

theory ListVector
imports MainRLT
begin

text\<open>\noindent
A vector-space like structure of lists and arithmetic operations on them.
Is only a vector space if restricted to lists of the same length.\<close>

text\<open>Multiplication with a scalar:\<close>

abbreviation scale :: "('a::times) \<Rightarrow> 'a list \<Rightarrow> 'a list" (infix "*\<^sub>s" 70)
where "x *\<^sub>s xs \<equiv> map ((*) x) xs"

lemma scale1[simp]: "(1::'a::monoid_mult) *\<^sub>s xs = xs"
by (induct xs) simp_all

subsection \<open>\<open>+\<close> and \<open>-\<close>\<close>

fun zipwith0 :: "('a::zero \<Rightarrow> 'b::zero \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list"
where
"zipwith0 f [] [] = []" |
"zipwith0 f (x#xs) (y#ys) = f x y # zipwith0 f xs ys" |
"zipwith0 f (x#xs) [] = f x 0 # zipwith0 f xs []" |
"zipwith0 f [] (y#ys) = f 0 y # zipwith0 f [] ys"

instantiation list :: ("{zero, plus}") plus
begin

definition
  list_add_def: "(+) = zipwith0 (+)"

instance ..

end

instantiation list :: ("{zero, uminus}") uminus
begin

definition
  list_uminus_def: "uminus = map uminus"

instance ..

end

instantiation list :: ("{zero,minus}") minus
begin

definition
  list_diff_def: "(-) = zipwith0 (-)"

instance ..

end

lemma zipwith0_Nil[simp]: "zipwith0 f [] ys = map (f 0) ys"
by(induct ys) simp_all

lemma list_add_Nil[simp]: "[] + xs = (xs::'a::monoid_add list)"
by (induct xs) (auto simp:list_add_def)

lemma list_add_Nil2[simp]: "xs + [] = (xs::'a::monoid_add list)"
by (induct xs) (auto simp:list_add_def)

lemma list_add_Cons[simp]: "(x#xs) + (y#ys) = (x+y)#(xs+ys)"
by(auto simp:list_add_def)

lemma list_diff_Nil[simp]: "[] - xs = -(xs::'a::group_add list)"
by (induct xs) (auto simp:list_diff_def list_uminus_def)

lemma list_diff_Nil2[simp]: "xs - [] = (xs::'a::group_add list)"
by (induct xs) (auto simp:list_diff_def)

lemma list_diff_Cons_Cons[simp]: "(x#xs) - (y#ys) = (x-y)#(xs-ys)"
by (induct xs) (auto simp:list_diff_def)

lemma list_uminus_Cons[simp]: "-(x#xs) = (-x)#(-xs)"
by (induct xs) (auto simp:list_uminus_def)

lemma self_list_diff:
  "xs - xs = replicate (length(xs::'a::group_add list)) 0"
by(induct xs) simp_all

lemma list_add_assoc: fixes xs :: "'a::monoid_add list"
shows "(xs+ys)+zs = xs+(ys+zs)"
apply(induct xs arbitrary: ys zs)
 apply simp
apply(case_tac ys)
 apply(simp)
apply(simp)
apply(case_tac zs)
 apply(simp)
apply(simp add: add.assoc)
done

subsection "Inner product"

definition iprod :: "'a::ring list \<Rightarrow> 'a list \<Rightarrow> 'a" ("\<langle>_,_\<rangle>") where
"\<langle>xs,ys\<rangle> = (\<Sum>(x,y) \<leftarrow> zip xs ys. x*y)"

lemma iprod_Nil[simp]: "\<langle>[],ys\<rangle> = 0"
by(simp add: iprod_def)

lemma iprod_Nil2[simp]: "\<langle>xs,[]\<rangle> = 0"
by(simp add: iprod_def)

lemma iprod_Cons[simp]: "\<langle>x#xs,y#ys\<rangle> = x*y + \<langle>xs,ys\<rangle>"
by(simp add: iprod_def)

lemma iprod0_if_coeffs0: "\<forall>c\<in>set cs. c = 0 \<Longrightarrow> \<langle>cs,xs\<rangle> = 0"
apply(induct cs arbitrary:xs)
 apply simp
apply(case_tac xs) apply simp
apply auto
done

lemma iprod_uminus[simp]: "\<langle>-xs,ys\<rangle> = -\<langle>xs,ys\<rangle>"
by(simp add: iprod_def uminus_sum_list_map o_def split_def map_zip_map list_uminus_def)

lemma iprod_left_add_distrib: "\<langle>xs + ys,zs\<rangle> = \<langle>xs,zs\<rangle> + \<langle>ys,zs\<rangle>"
apply(induct xs arbitrary: ys zs)
apply (simp add: o_def split_def)
apply(case_tac ys)
apply simp
apply(case_tac zs)
apply (simp)
apply(simp add: distrib_right)
done

lemma iprod_left_diff_distrib: "\<langle>xs - ys, zs\<rangle> = \<langle>xs,zs\<rangle> - \<langle>ys,zs\<rangle>"
apply(induct xs arbitrary: ys zs)
apply (simp add: o_def split_def)
apply(case_tac ys)
apply simp
apply(case_tac zs)
apply (simp)
apply(simp add: left_diff_distrib)
done

lemma iprod_assoc: "\<langle>x *\<^sub>s xs, ys\<rangle> = x * \<langle>xs,ys\<rangle>"
apply(induct xs arbitrary: ys)
apply simp
apply(case_tac ys)
apply (simp)
apply (simp add: distrib_left mult.assoc)
done

end


(*  Title:      HOL/Orderings.thy
    Author:     Tobias Nipkow, Markus Wenzel, and Larry Paulson
*)

section \<open>Abstract orderings\<close>

theory Orderings
imports HOL
keywords "print_orders" :: diag
begin

subsection \<open>Abstract ordering\<close>

locale partial_preordering =
  fixes less_eq :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> (infix \<open>\<^bold>\<le>\<close> 50)
  assumes refl: \<open>a \<^bold>\<le> a\<close> \<comment> \<open>not \<open>iff\<close>: makes problems due to multiple (dual) interpretations\<close>
    and trans: \<open>a \<^bold>\<le> b \<Longrightarrow> b \<^bold>\<le> c \<Longrightarrow> a \<^bold>\<le> c\<close>

locale preordering = partial_preordering +
  fixes less :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> (infix \<open>\<^bold><\<close> 50)
  assumes strict_iff_not: \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> \<not> b \<^bold>\<le> a\<close>
begin

lemma strict_implies_order:
  \<open>a \<^bold>< b \<Longrightarrow> a \<^bold>\<le> b\<close>
  by (simp add: strict_iff_not)

lemma irrefl: \<comment> \<open>not \<open>iff\<close>: makes problems due to multiple (dual) interpretations\<close>
  \<open>\<not> a \<^bold>< a\<close>
  by (simp add: strict_iff_not)

lemma asym:
  \<open>a \<^bold>< b \<Longrightarrow> b \<^bold>< a \<Longrightarrow> False\<close>
  by (auto simp add: strict_iff_not)

lemma strict_trans1:
  \<open>a \<^bold>\<le> b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c\<close>
  by (auto simp add: strict_iff_not intro: trans)

lemma strict_trans2:
  \<open>a \<^bold>< b \<Longrightarrow> b \<^bold>\<le> c \<Longrightarrow> a \<^bold>< c\<close>
  by (auto simp add: strict_iff_not intro: trans)

lemma strict_trans:
  \<open>a \<^bold>< b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c\<close>
  by (auto intro: strict_trans1 strict_implies_order)

end

lemma preordering_strictI: \<comment> \<open>Alternative introduction rule with bias towards strict order\<close>
  fixes less_eq (infix \<open>\<^bold>\<le>\<close> 50)
    and less (infix \<open>\<^bold><\<close> 50)
  assumes less_eq_less: \<open>\<And>a b. a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>< b \<or> a = b\<close>
    assumes asym: \<open>\<And>a b. a \<^bold>< b \<Longrightarrow> \<not> b \<^bold>< a\<close>
  assumes irrefl: \<open>\<And>a. \<not> a \<^bold>< a\<close>
  assumes trans: \<open>\<And>a b c. a \<^bold>< b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c\<close>
  shows \<open>preordering (\<^bold>\<le>) (\<^bold><)\<close>
proof
  fix a b
  show \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> \<not> b \<^bold>\<le> a\<close>
    by (auto simp add: less_eq_less asym irrefl)
next
  fix a
  show \<open>a \<^bold>\<le> a\<close>
    by (auto simp add: less_eq_less)
next
  fix a b c
  assume \<open>a \<^bold>\<le> b\<close> and \<open>b \<^bold>\<le> c\<close> then show \<open>a \<^bold>\<le> c\<close>
    by (auto simp add: less_eq_less intro: trans)
qed

lemma preordering_dualI:
  fixes less_eq (infix \<open>\<^bold>\<le>\<close> 50)
    and less (infix \<open>\<^bold><\<close> 50)
  assumes \<open>preordering (\<lambda>a b. b \<^bold>\<le> a) (\<lambda>a b. b \<^bold>< a)\<close>
  shows \<open>preordering (\<^bold>\<le>) (\<^bold><)\<close>
proof -
  from assms interpret preordering \<open>\<lambda>a b. b \<^bold>\<le> a\<close> \<open>\<lambda>a b. b \<^bold>< a\<close> .
  show ?thesis
    by standard (auto simp: strict_iff_not refl intro: trans)
qed

locale ordering = partial_preordering +
  fixes less :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> (infix \<open>\<^bold><\<close> 50)
  assumes strict_iff_order: \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> a \<noteq> b\<close>
  assumes antisym: \<open>a \<^bold>\<le> b \<Longrightarrow> b \<^bold>\<le> a \<Longrightarrow> a = b\<close>
begin

sublocale preordering \<open>(\<^bold>\<le>)\<close> \<open>(\<^bold><)\<close>
proof
  show \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> \<not> b \<^bold>\<le> a\<close> for a b
    by (auto simp add: strict_iff_order intro: antisym)
qed

lemma strict_implies_not_eq:
  \<open>a \<^bold>< b \<Longrightarrow> a \<noteq> b\<close>
  by (simp add: strict_iff_order)

lemma not_eq_order_implies_strict:
  \<open>a \<noteq> b \<Longrightarrow> a \<^bold>\<le> b \<Longrightarrow> a \<^bold>< b\<close>
  by (simp add: strict_iff_order)

lemma order_iff_strict:
  \<open>a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>< b \<or> a = b\<close>
  by (auto simp add: strict_iff_order refl)

lemma eq_iff: \<open>a = b \<longleftrightarrow> a \<^bold>\<le> b \<and> b \<^bold>\<le> a\<close>
  by (auto simp add: refl intro: antisym)

end

lemma ordering_strictI: \<comment> \<open>Alternative introduction rule with bias towards strict order\<close>
  fixes less_eq (infix \<open>\<^bold>\<le>\<close> 50)
    and less (infix \<open>\<^bold><\<close> 50)
  assumes less_eq_less: \<open>\<And>a b. a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>< b \<or> a = b\<close>
    assumes asym: \<open>\<And>a b. a \<^bold>< b \<Longrightarrow> \<not> b \<^bold>< a\<close>
  assumes irrefl: \<open>\<And>a. \<not> a \<^bold>< a\<close>
  assumes trans: \<open>\<And>a b c. a \<^bold>< b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c\<close>
  shows \<open>ordering (\<^bold>\<le>) (\<^bold><)\<close>
proof
  fix a b
  show \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> a \<noteq> b\<close>
    by (auto simp add: less_eq_less asym irrefl)
next
  fix a
  show \<open>a \<^bold>\<le> a\<close>
    by (auto simp add: less_eq_less)
next
  fix a b c
  assume \<open>a \<^bold>\<le> b\<close> and \<open>b \<^bold>\<le> c\<close> then show \<open>a \<^bold>\<le> c\<close>
    by (auto simp add: less_eq_less intro: trans)
next
  fix a b
  assume \<open>a \<^bold>\<le> b\<close> and \<open>b \<^bold>\<le> a\<close> then show \<open>a = b\<close>
    by (auto simp add: less_eq_less asym)
qed

lemma ordering_dualI:
  fixes less_eq (infix \<open>\<^bold>\<le>\<close> 50)
    and less (infix \<open>\<^bold><\<close> 50)
  assumes \<open>ordering (\<lambda>a b. b \<^bold>\<le> a) (\<lambda>a b. b \<^bold>< a)\<close>
  shows \<open>ordering (\<^bold>\<le>) (\<^bold><)\<close>
proof -
  from assms interpret ordering \<open>\<lambda>a b. b \<^bold>\<le> a\<close> \<open>\<lambda>a b. b \<^bold>< a\<close> .
  show ?thesis
    by standard (auto simp: strict_iff_order refl intro: antisym trans)
qed

locale ordering_top = ordering +
  fixes top :: \<open>'a\<close>  (\<open>\<^bold>\<top>\<close>)
  assumes extremum [simp]: \<open>a \<^bold>\<le> \<^bold>\<top>\<close>
begin

lemma extremum_uniqueI:
  \<open>\<^bold>\<top> \<^bold>\<le> a \<Longrightarrow> a = \<^bold>\<top>\<close>
  by (rule antisym) auto

lemma extremum_unique:
  \<open>\<^bold>\<top> \<^bold>\<le> a \<longleftrightarrow> a = \<^bold>\<top>\<close>
  by (auto intro: antisym)

lemma extremum_strict [simp]:
  \<open>\<not> (\<^bold>\<top> \<^bold>< a)\<close>
  using extremum [of a] by (auto simp add: order_iff_strict intro: asym irrefl)

lemma not_eq_extremum:
  \<open>a \<noteq> \<^bold>\<top> \<longleftrightarrow> a \<^bold>< \<^bold>\<top>\<close>
  by (auto simp add: order_iff_strict intro: not_eq_order_implies_strict extremum)

end

subsection \<open>Syntactic orders\<close>

class ord =
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

notation
  less_eq  ("'(\<le>')") and
  less_eq  ("(_/ \<le> _)"  [51, 51] 50) and
  less  ("'(<')") and
  less  ("(_/ < _)"  [51, 51] 50)

abbreviation (input)
  greater_eq  (infix "\<ge>" 50)
  where "x \<ge> y \<equiv> y \<le> x"

abbreviation (input)
  greater  (infix ">" 50)
  where "x > y \<equiv> y < x"

notation (ASCII)
  less_eq  ("'(<=')") and
  less_eq  ("(_/ <= _)" [51, 51] 50)

notation (input)
  greater_eq  (infix ">=" 50)

end

subsection \<open>Quasi orders\<close>

class preorder = ord +
  assumes less_le_not_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> (y \<le> x)"
  and order_refl [iff]: "x \<le> x"
  and order_trans: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
begin

sublocale order: preordering less_eq less + dual_order: preordering greater_eq greater
proof -
  interpret preordering less_eq less
    by standard (auto intro: order_trans simp add: less_le_not_le)
  show \<open>preordering less_eq less\<close>
    by (fact preordering_axioms)
  then show \<open>preordering greater_eq greater\<close>
    by (rule preordering_dualI)
qed

text \<open>Reflexivity.\<close>

lemma eq_refl: "x = y \<Longrightarrow> x \<le> y"
    \<comment> \<open>This form is useful with the classical reasoner.\<close>
by (erule ssubst) (rule order_refl)

lemma less_irrefl [iff]: "\<not> x < x"
by (simp add: less_le_not_le)

lemma less_imp_le: "x < y \<Longrightarrow> x \<le> y"
by (simp add: less_le_not_le)

text \<open>Asymmetry.\<close>

lemma less_not_sym: "x < y \<Longrightarrow> \<not> (y < x)"
by (simp add: less_le_not_le)

lemma less_asym: "x < y \<Longrightarrow> (\<not> P \<Longrightarrow> y < x) \<Longrightarrow> P"
by (drule less_not_sym, erule contrapos_np) simp

text \<open>Transitivity.\<close>

lemma less_trans: "x < y \<Longrightarrow> y < z \<Longrightarrow> x < z"
by (auto simp add: less_le_not_le intro: order_trans)

lemma le_less_trans: "x \<le> y \<Longrightarrow> y < z \<Longrightarrow> x < z"
by (auto simp add: less_le_not_le intro: order_trans)

lemma less_le_trans: "x < y \<Longrightarrow> y \<le> z \<Longrightarrow> x < z"
by (auto simp add: less_le_not_le intro: order_trans)

text \<open>Useful for simplification, but too risky to include by default.\<close>

lemma less_imp_not_less: "x < y \<Longrightarrow> (\<not> y < x) \<longleftrightarrow> True"
by (blast elim: less_asym)

lemma less_imp_triv: "x < y \<Longrightarrow> (y < x \<longrightarrow> P) \<longleftrightarrow> True"
by (blast elim: less_asym)

text \<open>Transitivity rules for calculational reasoning\<close>

lemma less_asym': "a < b \<Longrightarrow> b < a \<Longrightarrow> P"
by (rule less_asym)

text \<open>Dual order\<close>

lemma dual_preorder:
  \<open>class.preorder (\<ge>) (>)\<close>
  by standard (auto simp add: less_le_not_le intro: order_trans)

end

lemma preordering_preorderI:
  \<open>class.preorder (\<^bold>\<le>) (\<^bold><)\<close> if \<open>preordering (\<^bold>\<le>) (\<^bold><)\<close>
    for less_eq (infix \<open>\<^bold>\<le>\<close> 50) and less (infix \<open>\<^bold><\<close> 50)
proof -
  from that interpret preordering \<open>(\<^bold>\<le>)\<close> \<open>(\<^bold><)\<close> .
  show ?thesis
    by standard (auto simp add: strict_iff_not refl intro: trans)
qed

subsection \<open>Partial orders\<close>

class order = preorder +
  assumes order_antisym: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
begin

lemma less_le: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
  by (auto simp add: less_le_not_le intro: order_antisym)

sublocale order: ordering less_eq less + dual_order: ordering greater_eq greater
proof -
  interpret ordering less_eq less
    by standard (auto intro: order_antisym order_trans simp add: less_le)
  show "ordering less_eq less"
    by (fact ordering_axioms)
  then show "ordering greater_eq greater"
    by (rule ordering_dualI)
qed

text \<open>Reflexivity.\<close>

lemma le_less: "x \<le> y \<longleftrightarrow> x < y \<or> x = y"
    \<comment> \<open>NOT suitable for iff, since it can cause PROOF FAILED.\<close>
by (fact order.order_iff_strict)

lemma le_imp_less_or_eq: "x \<le> y \<Longrightarrow> x < y \<or> x = y"
by (simp add: less_le)

text \<open>Useful for simplification, but too risky to include by default.\<close>

lemma less_imp_not_eq: "x < y \<Longrightarrow> (x = y) \<longleftrightarrow> False"
by auto

lemma less_imp_not_eq2: "x < y \<Longrightarrow> (y = x) \<longleftrightarrow> False"
by auto

text \<open>Transitivity rules for calculational reasoning\<close>

lemma neq_le_trans: "a \<noteq> b \<Longrightarrow> a \<le> b \<Longrightarrow> a < b"
by (fact order.not_eq_order_implies_strict)

lemma le_neq_trans: "a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> a < b"
by (rule order.not_eq_order_implies_strict)

text \<open>Asymmetry.\<close>

lemma order_eq_iff: "x = y \<longleftrightarrow> x \<le> y \<and> y \<le> x"
  by (fact order.eq_iff)

lemma antisym_conv: "y \<le> x \<Longrightarrow> x \<le> y \<longleftrightarrow> x = y"
  by (simp add: order.eq_iff)

lemma less_imp_neq: "x < y \<Longrightarrow> x \<noteq> y"
  by (fact order.strict_implies_not_eq)

lemma antisym_conv1: "\<not> x < y \<Longrightarrow> x \<le> y \<longleftrightarrow> x = y"
  by (simp add: local.le_less)

lemma antisym_conv2: "x \<le> y \<Longrightarrow> \<not> x < y \<longleftrightarrow> x = y"
  by (simp add: local.less_le)

lemma leD: "y \<le> x \<Longrightarrow> \<not> x < y"
  by (auto simp: less_le order.antisym)

text \<open>Least value operator\<close>

definition (in ord)
  Least :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" (binder "LEAST " 10) where
  "Least P = (THE x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<le> y))"

lemma Least_equality:
  assumes "P x"
    and "\<And>y. P y \<Longrightarrow> x \<le> y"
  shows "Least P = x"
unfolding Least_def by (rule the_equality)
  (blast intro: assms order.antisym)+

lemma LeastI2_order:
  assumes "P x"
    and "\<And>y. P y \<Longrightarrow> x \<le> y"
    and "\<And>x. P x \<Longrightarrow> \<forall>y. P y \<longrightarrow> x \<le> y \<Longrightarrow> Q x"
  shows "Q (Least P)"
unfolding Least_def by (rule theI2)
  (blast intro: assms order.antisym)+

lemma Least_ex1:
  assumes   "\<exists>!x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<le> y)"
  shows     Least1I: "P (Least P)" and Least1_le: "P z \<Longrightarrow> Least P \<le> z"
  using     theI'[OF assms]
  unfolding Least_def
  by        auto

text \<open>Greatest value operator\<close>

definition Greatest :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" (binder "GREATEST " 10) where
"Greatest P = (THE x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<ge> y))"

lemma GreatestI2_order:
  "\<lbrakk> P x;
    \<And>y. P y \<Longrightarrow> x \<ge> y;
    \<And>x. \<lbrakk> P x; \<forall>y. P y \<longrightarrow> x \<ge> y \<rbrakk> \<Longrightarrow> Q x \<rbrakk>
  \<Longrightarrow> Q (Greatest P)"
unfolding Greatest_def
by (rule theI2) (blast intro: order.antisym)+

lemma Greatest_equality:
  "\<lbrakk> P x;  \<And>y. P y \<Longrightarrow> x \<ge> y \<rbrakk> \<Longrightarrow> Greatest P = x"
unfolding Greatest_def
by (rule the_equality) (blast intro: order.antisym)+

end

lemma ordering_orderI:
  fixes less_eq (infix "\<^bold>\<le>" 50)
    and less (infix "\<^bold><" 50)
  assumes "ordering less_eq less"
  shows "class.order less_eq less"
proof -
  from assms interpret ordering less_eq less .
  show ?thesis
    by standard (auto intro: antisym trans simp add: refl strict_iff_order)
qed

lemma order_strictI:
  fixes less (infix "\<^bold><" 50)
    and less_eq (infix "\<^bold>\<le>" 50)
  assumes "\<And>a b. a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>< b \<or> a = b"
    assumes "\<And>a b. a \<^bold>< b \<Longrightarrow> \<not> b \<^bold>< a"
  assumes "\<And>a. \<not> a \<^bold>< a"
  assumes "\<And>a b c. a \<^bold>< b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c"
  shows "class.order less_eq less"
  by (rule ordering_orderI) (rule ordering_strictI, (fact assms)+)

context order
begin

text \<open>Dual order\<close>

lemma dual_order:
  "class.order (\<ge>) (>)"
  using dual_order.ordering_axioms by (rule ordering_orderI)

end

subsection \<open>Linear (total) orders\<close>

class linorder = order +
  assumes linear: "x \<le> y \<or> y \<le> x"
begin

lemma less_linear: "x < y \<or> x = y \<or> y < x"
unfolding less_le using less_le linear by blast

lemma le_less_linear: "x \<le> y \<or> y < x"
by (simp add: le_less less_linear)

lemma le_cases [case_names le ge]:
  "(x \<le> y \<Longrightarrow> P) \<Longrightarrow> (y \<le> x \<Longrightarrow> P) \<Longrightarrow> P"
using linear by blast

lemma (in linorder) le_cases3:
  "\<lbrakk>\<lbrakk>x \<le> y; y \<le> z\<rbrakk> \<Longrightarrow> P; \<lbrakk>y \<le> x; x \<le> z\<rbrakk> \<Longrightarrow> P; \<lbrakk>x \<le> z; z \<le> y\<rbrakk> \<Longrightarrow> P;
    \<lbrakk>z \<le> y; y \<le> x\<rbrakk> \<Longrightarrow> P; \<lbrakk>y \<le> z; z \<le> x\<rbrakk> \<Longrightarrow> P; \<lbrakk>z \<le> x; x \<le> y\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (blast intro: le_cases)

lemma linorder_cases [case_names less equal greater]:
  "(x < y \<Longrightarrow> P) \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> (y < x \<Longrightarrow> P) \<Longrightarrow> P"
using less_linear by blast

lemma linorder_wlog[case_names le sym]:
  "(\<And>a b. a \<le> b \<Longrightarrow> P a b) \<Longrightarrow> (\<And>a b. P b a \<Longrightarrow> P a b) \<Longrightarrow> P a b"
  by (cases rule: le_cases[of a b]) blast+

lemma not_less: "\<not> x < y \<longleftrightarrow> y \<le> x"
  unfolding less_le
  using linear by (blast intro: order.antisym)

lemma not_less_iff_gr_or_eq: "\<not>(x < y) \<longleftrightarrow> (x > y \<or> x = y)"
  by (auto simp add:not_less le_less)

lemma not_le: "\<not> x \<le> y \<longleftrightarrow> y < x"
  unfolding less_le
  using linear by (blast intro: order.antisym)

lemma neq_iff: "x \<noteq> y \<longleftrightarrow> x < y \<or> y < x"
by (cut_tac x = x and y = y in less_linear, auto)

lemma neqE: "x \<noteq> y \<Longrightarrow> (x < y \<Longrightarrow> R) \<Longrightarrow> (y < x \<Longrightarrow> R) \<Longrightarrow> R"
by (simp add: neq_iff) blast

lemma antisym_conv3: "\<not> y < x \<Longrightarrow> \<not> x < y \<longleftrightarrow> x = y"
by (blast intro: order.antisym dest: not_less [THEN iffD1])

lemma leI: "\<not> x < y \<Longrightarrow> y \<le> x"
unfolding not_less .

lemma not_le_imp_less: "\<not> y \<le> x \<Longrightarrow> x < y"
unfolding not_le .

lemma linorder_less_wlog[case_names less refl sym]:
     "\<lbrakk>\<And>a b. a < b \<Longrightarrow> P a b;  \<And>a. P a a;  \<And>a b. P b a \<Longrightarrow> P a b\<rbrakk> \<Longrightarrow> P a b"
  using antisym_conv3 by blast

text \<open>Dual order\<close>

lemma dual_linorder:
  "class.linorder (\<ge>) (>)"
by (rule class.linorder.intro, rule dual_order) (unfold_locales, rule linear)

end

text \<open>Alternative introduction rule with bias towards strict order\<close>

lemma linorder_strictI:
  fixes less_eq (infix "\<^bold>\<le>" 50)
    and less (infix "\<^bold><" 50)
  assumes "class.order less_eq less"
  assumes trichotomy: "\<And>a b. a \<^bold>< b \<or> a = b \<or> b \<^bold>< a"
  shows "class.linorder less_eq less"
proof -
  interpret order less_eq less
    by (fact \<open>class.order less_eq less\<close>)
  show ?thesis
  proof
    fix a b
    show "a \<^bold>\<le> b \<or> b \<^bold>\<le> a"
      using trichotomy by (auto simp add: le_less)
  qed
qed

subsection \<open>Reasoning tools setup\<close>

ML_file \<open>~~/src/Provers/order_procedure.ML\<close>
ML_file \<open>~~/src/Provers/order_tac.ML\<close>

ML \<open>
structure Logic_Signature : LOGIC_SIGNATURE = struct
  val mk_Trueprop = HOLogic.mk_Trueprop
  val dest_Trueprop = HOLogic.dest_Trueprop
  val Trueprop_conv = HOLogic.Trueprop_conv
  val Not = HOLogic.Not
  val conj = HOLogic.conj
  val disj = HOLogic.disj

  val notI = @{thm notI}
  val ccontr = @{thm ccontr}
  val conjI = @{thm conjI}
  val conjE = @{thm conjE}
  val disjE = @{thm disjE}

  val not_not_conv = Conv.rewr_conv @{thm eq_reflection[OF not_not]}
  val de_Morgan_conj_conv = Conv.rewr_conv @{thm eq_reflection[OF de_Morgan_conj]}
  val de_Morgan_disj_conv = Conv.rewr_conv @{thm eq_reflection[OF de_Morgan_disj]}
  val conj_disj_distribL_conv = Conv.rewr_conv @{thm eq_reflection[OF conj_disj_distribL]}
  val conj_disj_distribR_conv = Conv.rewr_conv @{thm eq_reflection[OF conj_disj_distribR]}
end

structure HOL_Base_Order_Tac = Base_Order_Tac(
  structure Logic_Sig = Logic_Signature;
  (* Exclude types with specialised solvers. *)
  val excluded_types = [HOLogic.natT, HOLogic.intT, HOLogic.realT]
)

structure HOL_Order_Tac = Order_Tac(structure Base_Tac = HOL_Base_Order_Tac)

fun print_orders ctxt0 =
  let
    val ctxt = Config.put show_sorts true ctxt0
    val orders = HOL_Order_Tac.Data.get (Context.Proof ctxt)
    fun pretty_term t = Pretty.block
      [Pretty.quote (Syntax.pretty_term ctxt t), Pretty.brk 1,
        Pretty.str "::", Pretty.brk 1,
        Pretty.quote (Syntax.pretty_typ ctxt (type_of t)), Pretty.brk 1]
    fun pretty_order ({kind = kind, ops = ops, ...}, _) =
      Pretty.block ([Pretty.str (@{make_string} kind), Pretty.str ":", Pretty.brk 1]
                    @ map pretty_term ops)
  in
    Pretty.writeln (Pretty.big_list "order structures:" (map pretty_order orders))
  end

val _ =
  Outer_Syntax.command \<^command_keyword>\<open>print_orders\<close>
    "print order structures available to order reasoner"
    (Scan.succeed (Toplevel.keep (print_orders o Toplevel.context_of)))

\<close>

method_setup order = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (HOL_Order_Tac.tac [] ctxt))
\<close> "partial and linear order reasoner"

text \<open>Declarations to set up transitivity reasoner of partial and linear orders.\<close>

context order
begin

lemma nless_le: "(\<not> a < b) \<longleftrightarrow> (\<not> a \<le> b) \<or> a = b"
  using local.dual_order.order_iff_strict by blast

local_setup \<open>
  HOL_Order_Tac.declare_order {
    ops = {eq = @{term \<open>(=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>}, le = @{term \<open>(\<le>)\<close>}, lt = @{term \<open>(<)\<close>}},
    thms = {trans = @{thm order_trans}, refl = @{thm order_refl}, eqD1 = @{thm eq_refl},
            eqD2 = @{thm eq_refl[OF sym]}, antisym = @{thm order_antisym}, contr = @{thm notE}},
    conv_thms = {less_le = @{thm eq_reflection[OF less_le]},
                 nless_le = @{thm eq_reflection[OF nless_le]}}
  }
\<close>

end

context linorder
begin

lemma nle_le: "(\<not> a \<le> b) \<longleftrightarrow> b \<le> a \<and> b \<noteq> a"
  using not_le less_le by simp

local_setup \<open>
  HOL_Order_Tac.declare_linorder {
    ops = {eq = @{term \<open>(=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>}, le = @{term \<open>(\<le>)\<close>}, lt = @{term \<open>(<)\<close>}},
    thms = {trans = @{thm order_trans}, refl = @{thm order_refl}, eqD1 = @{thm eq_refl},
            eqD2 = @{thm eq_refl[OF sym]}, antisym = @{thm order_antisym}, contr = @{thm notE}},
    conv_thms = {less_le = @{thm eq_reflection[OF less_le]},
                 nless_le = @{thm eq_reflection[OF not_less]},
                 nle_le = @{thm eq_reflection[OF nle_le]}}
  }
\<close>

end

setup \<open>
  map_theory_simpset (fn ctxt0 => ctxt0 addSolver
    mk_solver "partial and linear orders" (fn ctxt => HOL_Order_Tac.tac (Simplifier.prems_of ctxt) ctxt))
\<close>

ML \<open>
local
  fun prp t thm = Thm.prop_of thm = t;  (* FIXME proper aconv!? *)
in

fun antisym_le_simproc ctxt ct =
  (case Thm.term_of ct of
    (le as Const (_, T)) $ r $ s =>
     (let
        val prems = Simplifier.prems_of ctxt;
        val less = Const (\<^const_name>\<open>less\<close>, T);
        val t = HOLogic.mk_Trueprop(le $ s $ r);
      in
        (case find_first (prp t) prems of
          NONE =>
            let val t = HOLogic.mk_Trueprop(HOLogic.Not $ (less $ r $ s)) in
              (case find_first (prp t) prems of
                NONE => NONE
              | SOME thm => SOME(mk_meta_eq(thm RS @{thm antisym_conv1})))
             end
         | SOME thm => SOME (mk_meta_eq (thm RS @{thm order_class.antisym_conv})))
      end handle THM _ => NONE)
  | _ => NONE);

fun antisym_less_simproc ctxt ct =
  (case Thm.term_of ct of
    NotC $ ((less as Const(_,T)) $ r $ s) =>
     (let
       val prems = Simplifier.prems_of ctxt;
       val le = Const (\<^const_name>\<open>less_eq\<close>, T);
       val t = HOLogic.mk_Trueprop(le $ r $ s);
      in
        (case find_first (prp t) prems of
          NONE =>
            let val t = HOLogic.mk_Trueprop (NotC $ (less $ s $ r)) in
              (case find_first (prp t) prems of
                NONE => NONE
              | SOME thm => SOME (mk_meta_eq(thm RS @{thm linorder_class.antisym_conv3})))
            end
        | SOME thm => SOME (mk_meta_eq (thm RS @{thm antisym_conv2})))
      end handle THM _ => NONE)
  | _ => NONE);

end;
\<close>

simproc_setup antisym_le ("(x::'a::order) \<le> y") = "K antisym_le_simproc"
simproc_setup antisym_less ("\<not> (x::'a::linorder) < y") = "K antisym_less_simproc"

subsection \<open>Bounded quantifiers\<close>

syntax (ASCII)
  "_All_less" :: "[idt, 'a, bool] => bool"    ("(3ALL _<_./ _)"  [0, 0, 10] 10)
  "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3EX _<_./ _)"  [0, 0, 10] 10)
  "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3ALL _<=_./ _)" [0, 0, 10] 10)
  "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3EX _<=_./ _)" [0, 0, 10] 10)

  "_All_greater" :: "[idt, 'a, bool] => bool"    ("(3ALL _>_./ _)"  [0, 0, 10] 10)
  "_Ex_greater" :: "[idt, 'a, bool] => bool"    ("(3EX _>_./ _)"  [0, 0, 10] 10)
  "_All_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3ALL _>=_./ _)" [0, 0, 10] 10)
  "_Ex_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3EX _>=_./ _)" [0, 0, 10] 10)

  "_All_neq" :: "[idt, 'a, bool] => bool"    ("(3ALL _~=_./ _)"  [0, 0, 10] 10)
  "_Ex_neq" :: "[idt, 'a, bool] => bool"    ("(3EX _~=_./ _)"  [0, 0, 10] 10)

syntax
  "_All_less" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_<_./ _)"  [0, 0, 10] 10)
  "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_<_./ _)"  [0, 0, 10] 10)
  "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<le>_./ _)" [0, 0, 10] 10)
  "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<le>_./ _)" [0, 0, 10] 10)

  "_All_greater" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_>_./ _)"  [0, 0, 10] 10)
  "_Ex_greater" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_>_./ _)"  [0, 0, 10] 10)
  "_All_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<ge>_./ _)" [0, 0, 10] 10)
  "_Ex_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<ge>_./ _)" [0, 0, 10] 10)

  "_All_neq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<noteq>_./ _)"  [0, 0, 10] 10)
  "_Ex_neq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<noteq>_./ _)"  [0, 0, 10] 10)

syntax (input)
  "_All_less" :: "[idt, 'a, bool] => bool"    ("(3! _<_./ _)"  [0, 0, 10] 10)
  "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3? _<_./ _)"  [0, 0, 10] 10)
  "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3! _<=_./ _)" [0, 0, 10] 10)
  "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3? _<=_./ _)" [0, 0, 10] 10)
  "_All_neq" :: "[idt, 'a, bool] => bool"    ("(3! _~=_./ _)"  [0, 0, 10] 10)
  "_Ex_neq" :: "[idt, 'a, bool] => bool"    ("(3? _~=_./ _)"  [0, 0, 10] 10)

translations
  "\<forall>x<y. P" \<rightharpoonup> "\<forall>x. x < y \<longrightarrow> P"
  "\<exists>x<y. P" \<rightharpoonup> "\<exists>x. x < y \<and> P"
  "\<forall>x\<le>y. P" \<rightharpoonup> "\<forall>x. x \<le> y \<longrightarrow> P"
  "\<exists>x\<le>y. P" \<rightharpoonup> "\<exists>x. x \<le> y \<and> P"
  "\<forall>x>y. P" \<rightharpoonup> "\<forall>x. x > y \<longrightarrow> P"
  "\<exists>x>y. P" \<rightharpoonup> "\<exists>x. x > y \<and> P"
  "\<forall>x\<ge>y. P" \<rightharpoonup> "\<forall>x. x \<ge> y \<longrightarrow> P"
  "\<exists>x\<ge>y. P" \<rightharpoonup> "\<exists>x. x \<ge> y \<and> P"
  "\<forall>x\<noteq>y. P" \<rightharpoonup> "\<forall>x. x \<noteq> y \<longrightarrow> P"
  "\<exists>x\<noteq>y. P" \<rightharpoonup> "\<exists>x. x \<noteq> y \<and> P"

print_translation \<open>
let
  val All_binder = Mixfix.binder_name \<^const_syntax>\<open>All\<close>;
  val Ex_binder = Mixfix.binder_name \<^const_syntax>\<open>Ex\<close>;
  val impl = \<^const_syntax>\<open>HOL.implies\<close>;
  val conj = \<^const_syntax>\<open>HOL.conj\<close>;
  val less = \<^const_syntax>\<open>less\<close>;
  val less_eq = \<^const_syntax>\<open>less_eq\<close>;

  val trans =
   [((All_binder, impl, less),
    (\<^syntax_const>\<open>_All_less\<close>, \<^syntax_const>\<open>_All_greater\<close>)),
    ((All_binder, impl, less_eq),
    (\<^syntax_const>\<open>_All_less_eq\<close>, \<^syntax_const>\<open>_All_greater_eq\<close>)),
    ((Ex_binder, conj, less),
    (\<^syntax_const>\<open>_Ex_less\<close>, \<^syntax_const>\<open>_Ex_greater\<close>)),
    ((Ex_binder, conj, less_eq),
    (\<^syntax_const>\<open>_Ex_less_eq\<close>, \<^syntax_const>\<open>_Ex_greater_eq\<close>))];

  fun matches_bound v t =
    (case t of
      Const (\<^syntax_const>\<open>_bound\<close>, _) $ Free (v', _) => v = v'
    | _ => false);
  fun contains_var v = Term.exists_subterm (fn Free (x, _) => x = v | _ => false);
  fun mk x c n P = Syntax.const c $ Syntax_Trans.mark_bound_body x $ n $ P;

  fun tr' q = (q, fn _ =>
    (fn [Const (\<^syntax_const>\<open>_bound\<close>, _) $ Free (v, T),
        Const (c, _) $ (Const (d, _) $ t $ u) $ P] =>
        (case AList.lookup (=) trans (q, c, d) of
          NONE => raise Match
        | SOME (l, g) =>
            if matches_bound v t andalso not (contains_var v u) then mk (v, T) l u P
            else if matches_bound v u andalso not (contains_var v t) then mk (v, T) g t P
            else raise Match)
      | _ => raise Match));
in [tr' All_binder, tr' Ex_binder] end
\<close>

subsection \<open>Transitivity reasoning\<close>

context ord
begin

lemma ord_le_eq_trans: "a \<le> b \<Longrightarrow> b = c \<Longrightarrow> a \<le> c"
  by (rule subst)

lemma ord_eq_le_trans: "a = b \<Longrightarrow> b \<le> c \<Longrightarrow> a \<le> c"
  by (rule ssubst)

lemma ord_less_eq_trans: "a < b \<Longrightarrow> b = c \<Longrightarrow> a < c"
  by (rule subst)

lemma ord_eq_less_trans: "a = b \<Longrightarrow> b < c \<Longrightarrow> a < c"
  by (rule ssubst)

end

lemma order_less_subst2: "(a::'a::order) < b \<Longrightarrow> f b < (c::'c::order) \<Longrightarrow>
  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> f a < c"
proof -
  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
  assume "a < b" hence "f a < f b" by (rule r)
  also assume "f b < c"
  finally (less_trans) show ?thesis .
qed

lemma order_less_subst1: "(a::'a::order) < f b \<Longrightarrow> (b::'b::order) < c \<Longrightarrow>
  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> a < f c"
proof -
  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
  assume "a < f b"
  also assume "b < c" hence "f b < f c" by (rule r)
  finally (less_trans) show ?thesis .
qed

lemma order_le_less_subst2: "(a::'a::order) <= b \<Longrightarrow> f b < (c::'c::order) \<Longrightarrow>
  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> f a < c"
proof -
  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
  assume "a <= b" hence "f a <= f b" by (rule r)
  also assume "f b < c"
  finally (le_less_trans) show ?thesis .
qed

lemma order_le_less_subst1: "(a::'a::order) <= f b \<Longrightarrow> (b::'b::order) < c \<Longrightarrow>
  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> a < f c"
proof -
  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
  assume "a <= f b"
  also assume "b < c" hence "f b < f c" by (rule r)
  finally (le_less_trans) show ?thesis .
qed

lemma order_less_le_subst2: "(a::'a::order) < b \<Longrightarrow> f b <= (c::'c::order) \<Longrightarrow>
  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> f a < c"
proof -
  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
  assume "a < b" hence "f a < f b" by (rule r)
  also assume "f b <= c"
  finally (less_le_trans) show ?thesis .
qed

lemma order_less_le_subst1: "(a::'a::order) < f b \<Longrightarrow> (b::'b::order) <= c \<Longrightarrow>
  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> a < f c"
proof -
  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
  assume "a < f b"
  also assume "b <= c" hence "f b <= f c" by (rule r)
  finally (less_le_trans) show ?thesis .
qed

lemma order_subst1: "(a::'a::order) <= f b \<Longrightarrow> (b::'b::order) <= c \<Longrightarrow>
  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> a <= f c"
proof -
  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
  assume "a <= f b"
  also assume "b <= c" hence "f b <= f c" by (rule r)
  finally (order_trans) show ?thesis .
qed

lemma order_subst2: "(a::'a::order) <= b \<Longrightarrow> f b <= (c::'c::order) \<Longrightarrow>
  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> f a <= c"
proof -
  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
  assume "a <= b" hence "f a <= f b" by (rule r)
  also assume "f b <= c"
  finally (order_trans) show ?thesis .
qed

lemma ord_le_eq_subst: "a <= b \<Longrightarrow> f b = c \<Longrightarrow>
  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> f a <= c"
proof -
  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
  assume "a <= b" hence "f a <= f b" by (rule r)
  also assume "f b = c"
  finally (ord_le_eq_trans) show ?thesis .
qed

lemma ord_eq_le_subst: "a = f b \<Longrightarrow> b <= c \<Longrightarrow>
  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> a <= f c"
proof -
  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
  assume "a = f b"
  also assume "b <= c" hence "f b <= f c" by (rule r)
  finally (ord_eq_le_trans) show ?thesis .
qed

lemma ord_less_eq_subst: "a < b \<Longrightarrow> f b = c \<Longrightarrow>
  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> f a < c"
proof -
  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
  assume "a < b" hence "f a < f b" by (rule r)
  also assume "f b = c"
  finally (ord_less_eq_trans) show ?thesis .
qed

lemma ord_eq_less_subst: "a = f b \<Longrightarrow> b < c \<Longrightarrow>
  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> a < f c"
proof -
  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
  assume "a = f b"
  also assume "b < c" hence "f b < f c" by (rule r)
  finally (ord_eq_less_trans) show ?thesis .
qed

text \<open>
  Note that this list of rules is in reverse order of priorities.
\<close>

lemmas [trans] =
  order_less_subst2
  order_less_subst1
  order_le_less_subst2
  order_le_less_subst1
  order_less_le_subst2
  order_less_le_subst1
  order_subst2
  order_subst1
  ord_le_eq_subst
  ord_eq_le_subst
  ord_less_eq_subst
  ord_eq_less_subst
  forw_subst
  back_subst
  rev_mp
  mp

lemmas (in order) [trans] =
  neq_le_trans
  le_neq_trans

lemmas (in preorder) [trans] =
  less_trans
  less_asym'
  le_less_trans
  less_le_trans
  order_trans

lemmas (in order) [trans] =
  order.antisym

lemmas (in ord) [trans] =
  ord_le_eq_trans
  ord_eq_le_trans
  ord_less_eq_trans
  ord_eq_less_trans

lemmas [trans] =
  trans

lemmas order_trans_rules =
  order_less_subst2
  order_less_subst1
  order_le_less_subst2
  order_le_less_subst1
  order_less_le_subst2
  order_less_le_subst1
  order_subst2
  order_subst1
  ord_le_eq_subst
  ord_eq_le_subst
  ord_less_eq_subst
  ord_eq_less_subst
  forw_subst
  back_subst
  rev_mp
  mp
  neq_le_trans
  le_neq_trans
  less_trans
  less_asym'
  le_less_trans
  less_le_trans
  order_trans
  order.antisym
  ord_le_eq_trans
  ord_eq_le_trans
  ord_less_eq_trans
  ord_eq_less_trans
  trans

text \<open>These support proving chains of decreasing inequalities
    a \<open>\<ge>\<close> b \<open>\<ge>\<close> c ... in Isar proofs.\<close>

lemma xt1 [no_atp]:
  "a = b \<Longrightarrow> b > c \<Longrightarrow> a > c"
  "a > b \<Longrightarrow> b = c \<Longrightarrow> a > c"
  "a = b \<Longrightarrow> b \<ge> c \<Longrightarrow> a \<ge> c"
  "a \<ge> b \<Longrightarrow> b = c \<Longrightarrow> a \<ge> c"
  "(x::'a::order) \<ge> y \<Longrightarrow> y \<ge> x \<Longrightarrow> x = y"
  "(x::'a::order) \<ge> y \<Longrightarrow> y \<ge> z \<Longrightarrow> x \<ge> z"
  "(x::'a::order) > y \<Longrightarrow> y \<ge> z \<Longrightarrow> x > z"
  "(x::'a::order) \<ge> y \<Longrightarrow> y > z \<Longrightarrow> x > z"
  "(a::'a::order) > b \<Longrightarrow> b > a \<Longrightarrow> P"
  "(x::'a::order) > y \<Longrightarrow> y > z \<Longrightarrow> x > z"
  "(a::'a::order) \<ge> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> a > b"
  "(a::'a::order) \<noteq> b \<Longrightarrow> a \<ge> b \<Longrightarrow> a > b"
  "a = f b \<Longrightarrow> b > c \<Longrightarrow> (\<And>x y. x > y \<Longrightarrow> f x > f y) \<Longrightarrow> a > f c"
  "a > b \<Longrightarrow> f b = c \<Longrightarrow> (\<And>x y. x > y \<Longrightarrow> f x > f y) \<Longrightarrow> f a > c"
  "a = f b \<Longrightarrow> b \<ge> c \<Longrightarrow> (\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y) \<Longrightarrow> a \<ge> f c"
  "a \<ge> b \<Longrightarrow> f b = c \<Longrightarrow> (\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y) \<Longrightarrow> f a \<ge> c"
  by auto

lemma xt2 [no_atp]:
  assumes "(a::'a::order) \<ge> f b"
    and "b \<ge> c"
    and "\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y"
  shows  "a \<ge> f c"
  using assms by force

lemma xt3 [no_atp]:
 assumes "(a::'a::order) \<ge> b"
    and "(f b::'b::order) \<ge> c"
    and "\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y"
  shows  "f a \<ge> c"
  using assms by force

lemma xt4 [no_atp]:
 assumes "(a::'a::order) > f b"
    and "(b::'b::order) \<ge> c"
    and "\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y"
  shows  "a > f c"
  using assms by force

lemma xt5 [no_atp]:
 assumes "(a::'a::order) > b"
    and "(f b::'b::order) \<ge> c"
    and "\<And>x y. x > y \<Longrightarrow> f x > f y"
  shows  "f a > c"
  using assms by force

lemma xt6 [no_atp]:
 assumes "(a::'a::order) \<ge> f b"
    and "b > c"
    and "\<And>x y. x > y \<Longrightarrow> f x > f y"
  shows  "a > f c"
  using assms by force

lemma xt7 [no_atp]:
 assumes "(a::'a::order) \<ge> b"
    and "(f b::'b::order) > c"
    and "\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y"
  shows  "f a > c"
  using assms by force

lemma xt8 [no_atp]:
 assumes "(a::'a::order) > f b"
    and "(b::'b::order) > c"
    and "\<And>x y. x > y \<Longrightarrow> f x > f y"
  shows  "a > f c"
  using assms by force

lemma xt9 [no_atp]:
 assumes "(a::'a::order) > b"
    and "(f b::'b::order) > c"
    and "\<And>x y. x > y \<Longrightarrow> f x > f y"
  shows  "f a > c"
  using assms by force

lemmas xtrans = xt1 xt2 xt3 xt4 xt5 xt6 xt7 xt8 xt9

(*
  Since "a \<ge> b" abbreviates "b \<le> a", the abbreviation "..." stands
  for the wrong thing in an Isar proof.

  The extra transitivity rules can be used as follows:

lemma "(a::'a::order) > z"
proof -
  have "a \<ge> b" (is "_ \<ge> ?rhs")
    sorry
  also have "?rhs \<ge> c" (is "_ \<ge> ?rhs")
    sorry
  also (xtrans) have "?rhs = d" (is "_ = ?rhs")
    sorry
  also (xtrans) have "?rhs \<ge> e" (is "_ \<ge> ?rhs")
    sorry
  also (xtrans) have "?rhs > f" (is "_ > ?rhs")
    sorry
  also (xtrans) have "?rhs > z"
    sorry
  finally (xtrans) show ?thesis .
qed

  Alternatively, one can use "declare xtrans [trans]" and then
  leave out the "(xtrans)" above.
*)

subsection \<open>min and max -- fundamental\<close>

definition (in ord) min :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "min a b = (if a \<le> b then a else b)"

definition (in ord) max :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "max a b = (if a \<le> b then b else a)"

lemma min_absorb1: "x \<le> y \<Longrightarrow> min x y = x"
  by (simp add: min_def)

lemma max_absorb2: "x \<le> y \<Longrightarrow> max x y = y"
  by (simp add: max_def)

lemma min_absorb2: "(y::'a::order) \<le> x \<Longrightarrow> min x y = y"
  by (simp add:min_def)

lemma max_absorb1: "(y::'a::order) \<le> x \<Longrightarrow> max x y = x"
  by (simp add: max_def)

lemma max_min_same [simp]:
  fixes x y :: "'a :: linorder"
  shows "max x (min x y) = x" "max (min x y) x = x" "max (min x y) y = y" "max y (min x y) = y"
by(auto simp add: max_def min_def)

subsection \<open>(Unique) top and bottom elements\<close>

class bot =
  fixes bot :: 'a ("\<bottom>")

class order_bot = order + bot +
  assumes bot_least: "\<bottom> \<le> a"
begin

sublocale bot: ordering_top greater_eq greater bot
  by standard (fact bot_least)

lemma le_bot:
  "a \<le> \<bottom> \<Longrightarrow> a = \<bottom>"
  by (fact bot.extremum_uniqueI)

lemma bot_unique:
  "a \<le> \<bottom> \<longleftrightarrow> a = \<bottom>"
  by (fact bot.extremum_unique)

lemma not_less_bot:
  "\<not> a < \<bottom>"
  by (fact bot.extremum_strict)

lemma bot_less:
  "a \<noteq> \<bottom> \<longleftrightarrow> \<bottom> < a"
  by (fact bot.not_eq_extremum)

lemma max_bot[simp]: "max bot x = x"
by(simp add: max_def bot_unique)

lemma max_bot2[simp]: "max x bot = x"
by(simp add: max_def bot_unique)

lemma min_bot[simp]: "min bot x = bot"
by(simp add: min_def bot_unique)

lemma min_bot2[simp]: "min x bot = bot"
by(simp add: min_def bot_unique)

end

class top =
  fixes top :: 'a ("\<top>")

class order_top = order + top +
  assumes top_greatest: "a \<le> \<top>"
begin

sublocale top: ordering_top less_eq less top
  by standard (fact top_greatest)

lemma top_le:
  "\<top> \<le> a \<Longrightarrow> a = \<top>"
  by (fact top.extremum_uniqueI)

lemma top_unique:
  "\<top> \<le> a \<longleftrightarrow> a = \<top>"
  by (fact top.extremum_unique)

lemma not_top_less:
  "\<not> \<top> < a"
  by (fact top.extremum_strict)

lemma less_top:
  "a \<noteq> \<top> \<longleftrightarrow> a < \<top>"
  by (fact top.not_eq_extremum)

lemma max_top[simp]: "max top x = top"
by(simp add: max_def top_unique)

lemma max_top2[simp]: "max x top = top"
by(simp add: max_def top_unique)

lemma min_top[simp]: "min top x = x"
by(simp add: min_def top_unique)

lemma min_top2[simp]: "min x top = x"
by(simp add: min_def top_unique)

end

subsection \<open>Dense orders\<close>

class dense_order = order +
  assumes dense: "x < y \<Longrightarrow> (\<exists>z. x < z \<and> z < y)"

class dense_linorder = linorder + dense_order
begin

lemma dense_le:
  fixes y z :: 'a
  assumes "\<And>x. x < y \<Longrightarrow> x \<le> z"
  shows "y \<le> z"
proof (rule ccontr)
  assume "\<not> ?thesis"
  hence "z < y" by simp
  from dense[OF this]
  obtain x where "x < y" and "z < x" by safe
  moreover have "x \<le> z" using assms[OF \<open>x < y\<close>] .
  ultimately show False by auto
qed

lemma dense_le_bounded:
  fixes x y z :: 'a
  assumes "x < y"
  assumes *: "\<And>w. \<lbrakk> x < w ; w < y \<rbrakk> \<Longrightarrow> w \<le> z"
  shows "y \<le> z"
proof (rule dense_le)
  fix w assume "w < y"
  from dense[OF \<open>x < y\<close>] obtain u where "x < u" "u < y" by safe
  from linear[of u w]
  show "w \<le> z"
  proof (rule disjE)
    assume "u \<le> w"
    from less_le_trans[OF \<open>x < u\<close> \<open>u \<le> w\<close>] \<open>w < y\<close>
    show "w \<le> z" by (rule *)
  next
    assume "w \<le> u"
    from \<open>w \<le> u\<close> *[OF \<open>x < u\<close> \<open>u < y\<close>]
    show "w \<le> z" by (rule order_trans)
  qed
qed

lemma dense_ge:
  fixes y z :: 'a
  assumes "\<And>x. z < x \<Longrightarrow> y \<le> x"
  shows "y \<le> z"
proof (rule ccontr)
  assume "\<not> ?thesis"
  hence "z < y" by simp
  from dense[OF this]
  obtain x where "x < y" and "z < x" by safe
  moreover have "y \<le> x" using assms[OF \<open>z < x\<close>] .
  ultimately show False by auto
qed

lemma dense_ge_bounded:
  fixes x y z :: 'a
  assumes "z < x"
  assumes *: "\<And>w. \<lbrakk> z < w ; w < x \<rbrakk> \<Longrightarrow> y \<le> w"
  shows "y \<le> z"
proof (rule dense_ge)
  fix w assume "z < w"
  from dense[OF \<open>z < x\<close>] obtain u where "z < u" "u < x" by safe
  from linear[of u w]
  show "y \<le> w"
  proof (rule disjE)
    assume "w \<le> u"
    from \<open>z < w\<close> le_less_trans[OF \<open>w \<le> u\<close> \<open>u < x\<close>]
    show "y \<le> w" by (rule *)
  next
    assume "u \<le> w"
    from *[OF \<open>z < u\<close> \<open>u < x\<close>] \<open>u \<le> w\<close>
    show "y \<le> w" by (rule order_trans)
  qed
qed

end

class no_top = order +
  assumes gt_ex: "\<exists>y. x < y"

class no_bot = order +
  assumes lt_ex: "\<exists>y. y < x"

class unbounded_dense_linorder = dense_linorder + no_top + no_bot

subsection \<open>Wellorders\<close>

class wellorder = linorder +
  assumes less_induct [case_names less]: "(\<And>x. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x) \<Longrightarrow> P a"
begin

lemma wellorder_Least_lemma:
  fixes k :: 'a
  assumes "P k"
  shows LeastI: "P (LEAST x. P x)" and Least_le: "(LEAST x. P x) \<le> k"
proof -
  have "P (LEAST x. P x) \<and> (LEAST x. P x) \<le> k"
  using assms proof (induct k rule: less_induct)
    case (less x) then have "P x" by simp
    show ?case proof (rule classical)
      assume assm: "\<not> (P (LEAST a. P a) \<and> (LEAST a. P a) \<le> x)"
      have "\<And>y. P y \<Longrightarrow> x \<le> y"
      proof (rule classical)
        fix y
        assume "P y" and "\<not> x \<le> y"
        with less have "P (LEAST a. P a)" and "(LEAST a. P a) \<le> y"
          by (auto simp add: not_le)
        with assm have "x < (LEAST a. P a)" and "(LEAST a. P a) \<le> y"
          by auto
        then show "x \<le> y" by auto
      qed
      with \<open>P x\<close> have Least: "(LEAST a. P a) = x"
        by (rule Least_equality)
      with \<open>P x\<close> show ?thesis by simp
    qed
  qed
  then show "P (LEAST x. P x)" and "(LEAST x. P x) \<le> k" by auto
qed

\<comment> \<open>The following 3 lemmas are due to Brian Huffman\<close>
lemma LeastI_ex: "\<exists>x. P x \<Longrightarrow> P (Least P)"
  by (erule exE) (erule LeastI)

lemma LeastI2:
  "P a \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> Q (Least P)"
  by (blast intro: LeastI)

lemma LeastI2_ex:
  "\<exists>a. P a \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> Q (Least P)"
  by (blast intro: LeastI_ex)

lemma LeastI2_wellorder:
  assumes "P a"
  and "\<And>a. \<lbrakk> P a; \<forall>b. P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
  shows "Q (Least P)"
proof (rule LeastI2_order)
  show "P (Least P)" using \<open>P a\<close> by (rule LeastI)
next
  fix y assume "P y" thus "Least P \<le> y" by (rule Least_le)
next
  fix x assume "P x" "\<forall>y. P y \<longrightarrow> x \<le> y" thus "Q x" by (rule assms(2))
qed

lemma LeastI2_wellorder_ex:
  assumes "\<exists>x. P x"
  and "\<And>a. \<lbrakk> P a; \<forall>b. P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
  shows "Q (Least P)"
using assms by clarify (blast intro!: LeastI2_wellorder)

lemma not_less_Least: "k < (LEAST x. P x) \<Longrightarrow> \<not> P k"
apply (simp add: not_le [symmetric])
apply (erule contrapos_nn)
apply (erule Least_le)
done

lemma exists_least_iff: "(\<exists>n. P n) \<longleftrightarrow> (\<exists>n. P n \<and> (\<forall>m < n. \<not> P m))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs thus ?lhs by blast
next
  assume H: ?lhs then obtain n where n: "P n" by blast
  let ?x = "Least P"
  { fix m assume m: "m < ?x"
    from not_less_Least[OF m] have "\<not> P m" . }
  with LeastI_ex[OF H] show ?rhs by blast
qed

end

subsection \<open>Order on \<^typ>\<open>bool\<close>\<close>

instantiation bool :: "{order_bot, order_top, linorder}"
begin

definition
  le_bool_def [simp]: "P \<le> Q \<longleftrightarrow> P \<longrightarrow> Q"

definition
  [simp]: "(P::bool) < Q \<longleftrightarrow> \<not> P \<and> Q"

definition
  [simp]: "\<bottom> \<longleftrightarrow> False"

definition
  [simp]: "\<top> \<longleftrightarrow> True"

instance proof
qed auto

end

lemma le_boolI: "(P \<Longrightarrow> Q) \<Longrightarrow> P \<le> Q"
  by simp

lemma le_boolI': "P \<longrightarrow> Q \<Longrightarrow> P \<le> Q"
  by simp

lemma le_boolE: "P \<le> Q \<Longrightarrow> P \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
  by simp

lemma le_boolD: "P \<le> Q \<Longrightarrow> P \<longrightarrow> Q"
  by simp

lemma bot_boolE: "\<bottom> \<Longrightarrow> P"
  by simp

lemma top_boolI: \<top>
  by simp

subsection \<open>Order on \<^typ>\<open>_ \<Rightarrow> _\<close>\<close>

instantiation "fun" :: (type, ord) ord
begin

definition
  le_fun_def: "f \<le> g \<longleftrightarrow> (\<forall>x. f x \<le> g x)"

definition
  "(f::'a \<Rightarrow> 'b) < g \<longleftrightarrow> f \<le> g \<and> \<not> (g \<le> f)"

instance ..

end

instance "fun" :: (type, preorder) preorder proof
qed (auto simp add: le_fun_def less_fun_def
  intro: order_trans order.antisym)

instance "fun" :: (type, order) order proof
qed (auto simp add: le_fun_def intro: order.antisym)

instantiation "fun" :: (type, bot) bot
begin

definition
  "\<bottom> = (\<lambda>x. \<bottom>)"

instance ..

end

instantiation "fun" :: (type, order_bot) order_bot
begin

lemma bot_apply [simp, code]:
  "\<bottom> x = \<bottom>"
  by (simp add: bot_fun_def)

instance proof
qed (simp add: le_fun_def)

end

instantiation "fun" :: (type, top) top
begin

definition
  [no_atp]: "\<top> = (\<lambda>x. \<top>)"

instance ..

end

instantiation "fun" :: (type, order_top) order_top
begin

lemma top_apply [simp, code]:
  "\<top> x = \<top>"
  by (simp add: top_fun_def)

instance proof
qed (simp add: le_fun_def)

end

lemma le_funI: "(\<And>x. f x \<le> g x) \<Longrightarrow> f \<le> g"
  unfolding le_fun_def by simp

lemma le_funE: "f \<le> g \<Longrightarrow> (f x \<le> g x \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding le_fun_def by simp

lemma le_funD: "f \<le> g \<Longrightarrow> f x \<le> g x"
  by (rule le_funE)

subsection \<open>Order on unary and binary predicates\<close>

lemma predicate1I:
  assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
  shows "P \<le> Q"
  apply (rule le_funI)
  apply (rule le_boolI)
  apply (rule PQ)
  apply assumption
  done

lemma predicate1D:
  "P \<le> Q \<Longrightarrow> P x \<Longrightarrow> Q x"
  apply (erule le_funE)
  apply (erule le_boolE)
  apply assumption+
  done

lemma rev_predicate1D:
  "P x \<Longrightarrow> P \<le> Q \<Longrightarrow> Q x"
  by (rule predicate1D)

lemma predicate2I:
  assumes PQ: "\<And>x y. P x y \<Longrightarrow> Q x y"
  shows "P \<le> Q"
  apply (rule le_funI)+
  apply (rule le_boolI)
  apply (rule PQ)
  apply assumption
  done

lemma predicate2D:
  "P \<le> Q \<Longrightarrow> P x y \<Longrightarrow> Q x y"
  apply (erule le_funE)+
  apply (erule le_boolE)
  apply assumption+
  done

lemma rev_predicate2D:
  "P x y \<Longrightarrow> P \<le> Q \<Longrightarrow> Q x y"
  by (rule predicate2D)

lemma bot1E [no_atp]: "\<bottom> x \<Longrightarrow> P"
  by (simp add: bot_fun_def)

lemma bot2E: "\<bottom> x y \<Longrightarrow> P"
  by (simp add: bot_fun_def)

lemma top1I: "\<top> x"
  by (simp add: top_fun_def)

lemma top2I: "\<top> x y"
  by (simp add: top_fun_def)

subsection \<open>Name duplicates\<close>

lemmas antisym = order.antisym
lemmas eq_iff = order.eq_iff

lemmas order_eq_refl = preorder_class.eq_refl
lemmas order_less_irrefl = preorder_class.less_irrefl
lemmas order_less_imp_le = preorder_class.less_imp_le
lemmas order_less_not_sym = preorder_class.less_not_sym
lemmas order_less_asym = preorder_class.less_asym
lemmas order_less_trans = preorder_class.less_trans
lemmas order_le_less_trans = preorder_class.le_less_trans
lemmas order_less_le_trans = preorder_class.less_le_trans
lemmas order_less_imp_not_less = preorder_class.less_imp_not_less
lemmas order_less_imp_triv = preorder_class.less_imp_triv
lemmas order_less_asym' = preorder_class.less_asym'

lemmas order_less_le = order_class.less_le
lemmas order_le_less = order_class.le_less
lemmas order_le_imp_less_or_eq = order_class.le_imp_less_or_eq
lemmas order_less_imp_not_eq = order_class.less_imp_not_eq
lemmas order_less_imp_not_eq2 = order_class.less_imp_not_eq2
lemmas order_neq_le_trans = order_class.neq_le_trans
lemmas order_le_neq_trans = order_class.le_neq_trans
lemmas order_eq_iff = order_class.order.eq_iff
lemmas order_antisym_conv = order_class.antisym_conv

lemmas linorder_linear = linorder_class.linear
lemmas linorder_less_linear = linorder_class.less_linear
lemmas linorder_le_less_linear = linorder_class.le_less_linear
lemmas linorder_le_cases = linorder_class.le_cases
lemmas linorder_not_less = linorder_class.not_less
lemmas linorder_not_le = linorder_class.not_le
lemmas linorder_neq_iff = linorder_class.neq_iff
lemmas linorder_neqE = linorder_class.neqE

end