(*
    $Id: sol.thy,v 1.3 2011/06/28 18:11:38 webertj Exp $
*)

header {* Replace, Reverse and Delete *}

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

text{*
Define a function @{term replace}, such that @{term"replace x y zs"}
yields @{term zs} with every occurrence of @{term x} replaced by @{term y}.
*}

primrec replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "replace x y []     = []"
| "replace x y (z#zs) = (if z=x then y else z)#(replace x y zs)"

text {*
Prove or disprove (by counterexample) the following theorems.
You may have to prove some lemmas first.
*}

lemma replace_append: "replace x y (xs @ ys) = replace x y xs @ replace x y ys"
  apply (induct "xs")
  apply auto
done

theorem "rev(replace x y zs) = replace x y (rev zs)"
  apply (induct "zs")
  apply (auto simp add: replace_append)
done

theorem "replace x y (replace u v zs) = replace u v (replace x y zs)"
  quickcheck
oops

text {*
  A possible counterexample:
  u=0, v=1, x=0, y=-1, zs=[0]
*}

theorem "replace y z (replace x y zs) = replace x z zs"
  quickcheck
oops

text {*
  A possible counterexample:
  x=1, y=0, z=1, zs=[0]
*}

text{* Define two functions for removing elements from a list:
@{term"del1 x xs"} deletes the first occurrence (from the left) of
@{term x} in @{term xs}, @{term"delall x xs"} all of them. *}

primrec del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "del1 x []     = []"
| "del1 x (y#ys) = (if y=x then ys else y # del1 x ys)"

primrec delall :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "delall x []     = []"
| "delall x (y#ys) = (if y=x then delall x ys else y # delall x ys)"

text {*
Prove or disprove (by counterexample) the following theorems.
*}

theorem "del1 x (delall x xs) = delall x xs"
  apply (induct "xs")
  apply auto
done

theorem "delall x (delall x xs) = delall x xs"
  apply (induct "xs")
  apply auto
done

theorem delall_del1: "delall x (del1 x xs) = delall x xs"
  apply (induct "xs")
  apply auto
done

theorem "del1 x (del1 y zs) = del1 y (del1 x zs)"
  apply (induct "zs")
  apply auto
done

theorem "delall x (del1 y zs) = del1 y (delall x zs)"
  apply (induct "zs")
  apply (auto simp add: delall_del1)
done

theorem "delall x (delall y zs) = delall y (delall x zs)"
  apply (induct "zs")
  apply auto
done

theorem "del1 y (replace x y xs) = del1 x xs"
  quickcheck
oops

text {*
  A possible counterexample:
  x=1, xs=[0], y=0
*}

theorem "delall y (replace x y xs) = delall x xs"
  quickcheck
oops

text {*
  A possible counterexample:
  x=1, xs=[0], y=0
*}

theorem "replace x y (delall x zs) = delall x zs"
  apply (induct "zs")
  apply auto
done

theorem "replace x y (delall z zs) = delall z (replace x y zs)"
  quickcheck
oops

text {*
  A possible counterexample:
  x=1, y=0, z=0, zs=[1]
*}

theorem "rev(del1 x xs) = del1 x (rev xs)"
  quickcheck
oops

text {*
  A possible counterexample:
  x=1, xs=[1, 0, 1]
*}

lemma delall_append: "delall x (xs @ ys) = delall x xs @ delall x ys"
  apply (induct "xs")
  apply auto
done

theorem "rev(delall x xs) = delall x (rev xs)"
  apply (induct "xs")
  apply (auto simp add: delall_append)
done

(*<*) end (*>*)


header "Priority Queues Based on Braun Trees"

theory Priority_Queue_Braun
imports
  "~~/src/HOL/Library/Tree"
  "~~/src/HOL/Library/Multiset"
begin

subsection "Introduction"

text{* Braun, Rem and Hoogerwoord \cite{BraunRem,Hoogerwoord} used
specific balanced binary trees, often called Braun trees (where in
each node with subtrees $l$ and $r$, $size(r) \le size(l) \le
size(r)+1$), to implement flexible arrays. Paulson \cite{Paulson}
(based on code supplied by Okasaki)
implemented priority queues via Braun trees. This theory verifies
Paulsons's implementation, including the logarithmic bounds.  *}

(* FIXME mv to Tree *)

lemma size_0_iff_Leaf[simp]: "size t = 0 \<longleftrightarrow> t = Leaf"
by(cases t) auto

fun height :: "'a tree \<Rightarrow> nat" where
"height Leaf = 0" |
"height (Node l x r) = max (height l) (height r) + 1"

lemma size1_height: "size t + 1 \<le> 2 ^ height t"
proof(induction t)
  case (Node l a r)
  show ?case
  proof (cases "height l \<le> height r")
    case True
    have "size(Node l a r) + 1 = (size l + 1) + (size r + 1)" by simp
    also have "size l + 1 \<le> 2 ^ height l" by(rule Node.IH(1))
    also have "size r + 1 \<le> 2 ^ height r" by(rule Node.IH(2))
    also have "(2::nat) ^ height l \<le> 2 ^ height r" using True by simp
    finally show ?thesis using True by (auto simp: max_def mult_2)
  next
    case False
    have "size(Node l a r) + 1 = (size l + 1) + (size r + 1)" by simp
    also have "size l + 1 \<le> 2 ^ height l" by(rule Node.IH(1))
    also have "size r + 1 \<le> 2 ^ height r" by(rule Node.IH(2))
    also have "(2::nat) ^ height r \<le> 2 ^ height l" using False by simp
    finally show ?thesis using False by (auto simp: max_def mult_2)
  qed
qed simp

fun heap :: "'a::linorder tree \<Rightarrow> bool" where
"heap Leaf = True" |
"heap (Node l m r) =
  (heap l \<and> heap r \<and> (\<forall>x \<in> set_tree l \<union> set_tree r. m \<le> x))"

(* eomv *)

subsection {* Multiset of tree *}

definition mset_tree :: "'a tree \<Rightarrow> 'a multiset" where
"mset_tree t = multiset_of (inorder t)"

lemma mset_Leaf[simp]: "mset_tree Leaf = {#}"
by(simp add: mset_tree_def)

lemma mset_Node[simp]:
  "mset_tree (Node l x r) = {#x#} + mset_tree l + mset_tree r"
by(simp add: mset_tree_def ac_simps)

lemma set_mset_tree: "set_of(mset_tree t) = set_tree t"
by (simp add: mset_tree_def)

lemma mset_iff_set_tree: "x \<in># mset_tree t \<longleftrightarrow> x \<in> set_tree t"
by(induction t arbitrary: x) auto

subsection {* Braun predicate *}

fun braun :: "'a tree \<Rightarrow> bool" where
"braun Leaf = True" |
"braun (Node l x r) = (size r \<le> size l \<and> size l \<le> Suc(size r) \<and> braun l \<and> braun r)"

lemma height_size_braun: "braun t \<Longrightarrow> 2 ^ (height t) \<le> 2 * size t + 1"
proof(induction t)
  case (Node t1)
  show ?case
  proof (cases "height t1")
    case 0 thus ?thesis using Node by simp
  next
    case (Suc n)
    hence "2 ^ n \<le> size t1" using Node by simp
    thus ?thesis using Suc Node by(auto simp: max_def)
  qed
qed simp

subsection {* Insertion *}

fun insert_pq :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert_pq a Leaf = Node Leaf a Leaf" |
"insert_pq a (Node l x r) =
 (if a < x then Node (insert_pq x r) a l else Node (insert_pq a r) x l)"

value "fold insert_pq [0::int,1,2,3,-55,-5] Leaf"

lemma size_insert_pq[simp]: "size(insert_pq x t) = size t + 1"
by(induction t arbitrary: x) auto

lemma mset_insert_pq[simp]: "mset_tree(insert_pq x t) = {#x#} + mset_tree t"
by(induction t arbitrary: x) (auto simp: ac_simps)

lemma set_insert_pq[simp]: "set_tree(insert_pq x t) = insert x (set_tree t)"
by(induction t arbitrary: x) auto

lemma braun_insert_pq: "braun t \<Longrightarrow> braun(insert_pq x t)"
by(induction t arbitrary: x) auto

lemma heap_insert_pq: "heap t \<Longrightarrow> heap(insert_pq x t)"
by(induction t arbitrary: x) (auto  simp add: ball_Un)

subsection {* Deletion *}

fun del_left :: "'a tree \<Rightarrow> 'a * 'a tree" where
"del_left (Node Leaf x Leaf) = (x,Leaf)" |
"del_left (Node l x r) = (let (y,l') = del_left l in (y,Node r x l'))"

lemma del_left_size:
  "del_left t = (x,t') \<Longrightarrow> braun t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> size t = size t' + 1"
apply(induction t arbitrary: x t' rule: del_left.induct)
apply(auto split: prod.splits)
by fastforce

lemma del_left_braun:
  "del_left t = (x,t') \<Longrightarrow> braun t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> braun t'"
apply(induction t arbitrary: x t' rule: del_left.induct)
apply(fastforce dest: del_left_size split: prod.splits)+
done

lemma del_left_elem:
  "del_left t = (x,t') \<Longrightarrow> braun t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> x \<in> set_tree t"
apply(induction t arbitrary: x t' rule: del_left.induct)
apply(fastforce split: prod.splits)+
done

lemma del_left_set:
  "del_left t = (x,t') \<Longrightarrow> braun t \<Longrightarrow> t \<noteq> Leaf
  \<Longrightarrow> set_tree t = insert x (set_tree t')"
apply(induction t arbitrary: x t' rule: del_left.induct)
apply(fastforce split: prod.splits)+
done

lemma del_left_mset:
  "del_left t = (x,t') \<Longrightarrow> braun t \<Longrightarrow> t \<noteq> Leaf
  \<Longrightarrow> mset_tree t' = mset_tree t - {#x#}"
apply(induction t arbitrary: x t' rule: del_left.induct)
   apply(auto simp: ac_simps mset_iff_set_tree[symmetric]
     dest!: del_left_elem split: prod.splits)
   apply(simp add: multiset_eq_iff)
  apply(simp add: multiset_eq_iff)
 apply(simp add: multiset_eq_iff)
apply(fastforce simp: multiset_eq_iff)
done

lemma del_left_heap:
  "del_left t = (x,t') \<Longrightarrow> heap t \<Longrightarrow> braun t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> heap t'"
proof(induction t arbitrary: x t' rule: del_left.induct)
  case ("2_1" ll a lr b r)
  from "2_1.prems"(1) obtain l' where
    "del_left (Node ll a lr) = (x,l')" and [simp]: "t' = Node r b l'"
    by(auto split: prod.splits)
  from del_left_set[OF this(1)] "2_1.IH"[OF this(1)] "2_1.prems"
  show ?case by(auto)
next
  case "2_2" thus ?case by(fastforce dest: del_left_set split: prod.splits)
next
qed auto

function (sequential) sift_down :: "'a::linorder tree \<Rightarrow> 'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"sift_down Leaf a Leaf = Node Leaf a Leaf" |
"sift_down (Node Leaf x Leaf) a Leaf =
  (if a \<le> x then Node (Node Leaf x Leaf) a Leaf
   else Node (Node Leaf a Leaf) x Leaf)" |
"sift_down (Node l1 x1 r1) a (Node l2 x2 r2) =
  (if a \<le> x1 \<and> a \<le> x2
   then Node (Node l1 x1 r1) a (Node l2 x2 r2)
   else if x1 \<le> x2 then Node (sift_down l1 a r1) x1 (Node l2 x2 r2)
        else Node (Node l1 x1 r1) x2 (sift_down l2 a r2))"
by pat_completeness auto
termination
by (relation "measure (%(l,a,r). size l + size r)") auto

lemma size_sift_down:
  "braun(Node l a r) \<Longrightarrow> size(sift_down l a r) = size l + size r + 1"
by(induction l a r rule: sift_down.induct) auto

lemma braun_sift_down:
  "braun(Node l a r) \<Longrightarrow> braun(sift_down l a r)"
by(induction l a r rule: sift_down.induct) (auto simp: size_sift_down)

lemma mset_sift_down:
  "braun(Node l a r) \<Longrightarrow> mset_tree(sift_down l a r) = {#a#} + (mset_tree l + mset_tree r)"
by(induction l a r rule: sift_down.induct) (auto simp: ac_simps)

lemma set_sift_down: "braun(Node l a r)
  \<Longrightarrow> set_tree(sift_down l a r) = insert a (set_tree l \<union> set_tree r)"
by(drule arg_cong[where f=set_of, OF mset_sift_down]) (simp add:set_mset_tree)

lemma heap_sift_down:
  "braun(Node l a r) \<Longrightarrow> heap l \<Longrightarrow> heap r \<Longrightarrow> heap(sift_down l a r)"
by (induction l a r rule: sift_down.induct) (auto simp: set_sift_down ball_Un)

fun del_min :: "'a::linorder tree \<Rightarrow> 'a tree" where
"del_min Leaf = Leaf" |
"del_min (Node Leaf x r) = Leaf" |
"del_min (Node l x r) = (let (y,l') = del_left l in sift_down r y l')"

lemma braun_del_min: "braun t \<Longrightarrow> braun(del_min t)"
apply(cases t rule: del_min.cases)
  apply simp
 apply simp
apply (fastforce split: prod.split intro!: braun_sift_down
  dest: del_left_size del_left_braun)
done

lemma heap_del_min: "heap t \<Longrightarrow> braun t \<Longrightarrow> heap(del_min t)"
apply(cases t rule: del_min.cases)
  apply simp
 apply simp
apply (fastforce split: prod.split intro!: heap_sift_down
  dest: del_left_size del_left_braun del_left_heap)
done

lemma mset_del_min: assumes "braun t" "heap t" "t \<noteq> Leaf"
shows "mset_tree t = {#val t#} + mset_tree(del_min t)"
proof(cases t rule: del_min.cases)
  case 1 with assms show ?thesis by simp
next
  case 2 with assms show ?thesis by simp
next
  case (3 ll b lr a r)[simp]
  { fix y l' assume del: "del_left (Node ll b lr) = (y,l')"
    have "mset_tree t = {#a#} + mset_tree(sift_down r y l')"
      using assms del_left_mset[OF del] del_left_size[OF del]
        del_left_braun[OF del]del_left_elem[OF del]
      by(subst mset_sift_down)
        (auto simp: ac_simps multiset_eq_iff mset_iff_set_tree[symmetric]) }
  thus ?thesis by(auto split: prod.split)
qed

lemma set_del_min: "\<lbrakk> braun t; heap t; t \<noteq> Leaf \<rbrakk>
  \<Longrightarrow> set_tree t = insert (val t) (set_tree(del_min t))"
by(drule (2) arg_cong[where f=set_of, OF mset_del_min]) (simp add:set_mset_tree)

end


theory Ex16
imports Main
begin

(*Proof A \<or> B \<longleftrightarrow> B \<or> A, commutativity of or*)

lemma "A \<or> B \<longleftrightarrow> B \<or> A"
proof -
{
  assume "A \<or> B"
  moreover
  {
    assume A
    hence "B \<or> A" by (rule disjI2)
  }
  moreover
  {
    assume B
    hence "B \<or> A" by (rule disjI1)
  }
  ultimately have "B \<or> A" by (rule disjE)
}
moreover
{
  assume "B \<or> A"
  moreover
  {
    assume B
    hence "A \<or> B" by (rule disjI2)
  }
  moreover
  {
    assume A
    hence "A \<or> B" by (rule disjI1)
  }
  ultimately have "A \<or> B" by (rule disjE)
}
ultimately show ?thesis by (rule iffI)
qed


theory NatDoubleInduction imports Main begin

hide_const Suc
datatype nat = Zero | Suc nat

section "How to define custom induction rules"
subsection "Example for cutom induction rules"
lemma nat_induct: "\<lbrakk> P Zero; \<And>n. P n \<Longrightarrow> P (Suc n) \<rbrakk> \<Longrightarrow> P n"
  apply(rule nat.induct)
  apply(assumption)
  apply(assumption)
  done

fun nat_eq :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  nat_eq_ZeroZero: "nat_eq Zero Zero = True" |
  nat_eq_SucZero:  "nat_eq (Suc n) Zero = False" |
  nat_eq_ZeroSuc:  "nat_eq Zero (Suc m) = False" |
  nat_eq_SucSuc:   "nat_eq (Suc n) (Suc m) = nat_eq n m"

text "Single-induction example using the custom induction rule"
lemma nat_eq_refl: "nat_eq n n"
  apply(rule nat_induct)
  apply(subst nat_eq_ZeroZero)
  apply(rule TrueI)
  apply(subst nat_eq_SucSuc)
  apply(assumption)
  done

lemma nat_eq_sym[rule_format]: "\<forall>n. nat_eq m n \<longleftrightarrow> nat_eq n m"
  apply(rule nat_induct)
  apply(rule allI)
  apply(rule_tac y=n in nat.exhaust)
  apply(erule ssubst)
  apply(subst (1 2) nat_eq_ZeroZero)
  apply(rule refl)
  apply(erule ssubst)
  apply(subst nat_eq_SucZero)
  apply(subst nat_eq_ZeroSuc)
  apply(rule refl)
  apply(rule allI)
  apply(rule_tac y=na in nat.exhaust)
  apply(erule ssubst)
  apply(subst nat_eq_SucZero)
  apply(subst nat_eq_ZeroSuc)
  apply(rule refl)
  apply(erule ssubst)
  apply(subst (1 2) nat_eq_SucSuc)
  apply(drule_tac x=x2 in spec)
  apply(assumption)
  done

fun nat_plus :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  nat_plus_ZeroFree: "nat_plus Zero n = n" |
  nat_plus_SucFree:  "nat_plus (Suc m) n = nat_plus m (Suc n)"

lemma nat_plus_FreeSuc[rule_format]: "\<forall>n. nat_plus m (Suc n) = Suc (nat_plus m n)"
  apply(rule_tac n=m in nat_induct)
  apply(subst (1 2) nat_plus_ZeroFree)
  apply(rule allI)
  apply(rule refl)

  apply(simp only: nat_plus_SucFree)
  apply(rule allI)
  apply(subst nat.simps(1))
  apply(subst nat.simps(1))
  apply(rule refl)
  done

subsection "Double-induction example using the custom induction rule"
lemma "nat_eq (nat_plus m n) (nat_plus n m)"
  apply(rule_tac n=m in nat_induct)
  apply(rule_tac n=n in nat_induct)
  apply(unfold nat_plus_ZeroFree nat_eq_ZeroZero)
  apply(rule TrueI)

  apply(rule_tac y=n in nat.exhaust)
  apply(clarify)
  apply(unfold nat_plus_SucFree nat_plus_ZeroFree nat_eq_SucSuc nat_eq_ZeroZero)
  apply(rule TrueI)

  apply(clarify)
  apply(unfold nat_plus_SucFree nat_plus_ZeroFree nat_plus_FreeSuc nat_eq_SucSuc)
  apply(assumption)
  apply(assumption)
  done

section "How to define double-induction rules"
subsection "Lemmas to proof the double induction rule"
lemma nat_induct_N_M: "\<lbrakk> P Zero Zero; \<And>m n. P m n \<Longrightarrow> P (Suc m) n; \<And>m n. P m n \<Longrightarrow> P m (Suc n) \<rbrakk> \<Longrightarrow> P m n"
  apply(rule_tac n=m in nat_induct)
  apply(rule_tac n=n in nat_induct)
  apply(assumption)

  apply(drule_tac P="\<lambda>m. (\<And>n. P m n \<Longrightarrow> P m (Suc n))"  and x="Zero" in meta_spec)
  apply(drule_tac P="\<lambda>n. (P Zero n \<Longrightarrow> P Zero (Suc n))"  and x="n" in meta_spec)
  apply(drule meta_mp)
  apply(assumption)
  apply(assumption)

  apply(drule_tac P="\<lambda>m. (\<And>n. P m n \<Longrightarrow> P (Suc m) n)" and x="na" in meta_spec)
  apply(drule_tac P="\<lambda>n. (P na n \<Longrightarrow> P (Suc na) n)" and x="n" in meta_spec)
  apply(drule meta_mp)
  apply(assumption)
  apply(assumption)
  done

subsection "Proof using the custom double-induction rule"
lemma "nat_eq (nat_plus m n) (nat_plus n m)"
  apply(rule_tac n=n and m=m in nat_induct_N_M)
  apply(unfold nat_plus_ZeroFree)
  apply(subst nat_eq_ZeroZero)
  apply(rule TrueI)
  apply(unfold nat_plus_SucFree nat_plus_FreeSuc nat_eq_SucSuc)
  apply(assumption)
  apply(assumption)
  done
end


(* Title: Block_Designs.thy
   Author: Chelsea Edmonds
*)

section \<open> Block and Balanced Designs \<close>
text \<open> We define a selection of the many different types of block and balanced designs, building up
to properties required for defining a BIBD, in addition to several base generalisations \<close>

theory Block_Designs imports Design_Operations
begin

subsection \<open>Block Designs\<close>
text \<open>A block design is a design where all blocks have the same size.\<close>

subsubsection \<open>K Block Designs \<close>
text \<open>An important generalisation of a typical block design is the $\mathcal{K}$ block design,
where all blocks must have a size $x$ where $x \in \mathcal{K}$\<close>
locale K_block_design = proper_design +
  fixes sizes :: "nat set" ("\<K>")
  assumes block_sizes: "bl \<in># \<B> \<Longrightarrow> (card bl) \<in> \<K>"
  assumes positive_ints: "x \<in> \<K> \<Longrightarrow> x > 0"
begin

lemma sys_block_size_subset: "sys_block_sizes \<subseteq> \<K>"
  using block_sizes sys_block_sizes_obtain_bl by blast

end

subsubsection\<open>Uniform Block Design\<close>
text \<open>The typical uniform block design is defined below \<close>
locale block_design = proper_design +
  fixes u_block_size :: nat ("\<k>")
  assumes uniform [simp]: "bl \<in># \<B> \<Longrightarrow> card bl = \<k>"
begin

lemma k_non_zero: "\<k> \<ge> 1"
proof -
  obtain bl where bl_in: "bl \<in># \<B>"
    using design_blocks_nempty by auto
  then have "card bl \<ge> 1" using block_size_gt_0
    by (metis less_not_refl less_one not_le_imp_less)
  thus ?thesis by (simp add: bl_in)
qed

lemma uniform_alt_def_all: "\<forall> bl \<in># \<B> .card bl = \<k>"
  using uniform by auto

lemma uniform_unfold_point_set: "bl \<in># \<B> \<Longrightarrow> card {p \<in> \<V>. p \<in> bl} = \<k>"
  using uniform wellformed by (simp add: Collect_conj_eq inf.absorb_iff2)

lemma uniform_unfold_point_set_mset: "bl \<in># \<B> \<Longrightarrow> size {#p \<in># mset_set \<V>. p \<in> bl #} = \<k>"
  using uniform_unfold_point_set by (simp add: finite_sets)

lemma sys_block_sizes_uniform [simp]:  "sys_block_sizes  = {\<k>}"
proof -
  have "sys_block_sizes = {bs . \<exists> bl . bs = card bl \<and> bl\<in># \<B>}" by (simp add: sys_block_sizes_def)
  then have "sys_block_sizes  = {bs . bs = \<k>}" using uniform uniform_unfold_point_set
      b_positive block_set_nempty_imp_block_ex
    by (smt (verit, best) Collect_cong design_blocks_nempty)
  thus ?thesis by auto
qed

lemma sys_block_sizes_uniform_single: "is_singleton (sys_block_sizes)"
  by simp

lemma uniform_size_incomp: "\<k> \<le> \<v> - 1 \<Longrightarrow> bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  using uniform k_non_zero
  by (metis block_size_lt_v diff_diff_cancel diff_is_0_eq' less_numeral_extra(1) nat_less_le)

lemma uniform_complement_block_size:
  assumes "bl \<in># \<B>\<^sup>C"
  shows "card bl = \<v> - \<k>"
proof -
  obtain bl' where bl_assm: "bl = bl'\<^sup>c \<and> bl' \<in># \<B>"
    using wellformed assms by (auto simp add: complement_blocks_def)
  then have "int (card bl') = \<k>" by simp
  thus ?thesis using bl_assm block_complement_size wellformed
    by (simp add: block_size_lt_order of_nat_diff)
qed

lemma uniform_complement[intro]:
  assumes "\<k> \<le> \<v> - 1"
  shows "block_design \<V> \<B>\<^sup>C (\<v> - \<k>)"
proof -
  interpret des: proper_design \<V> "\<B>\<^sup>C"
    using  uniform_size_incomp assms complement_proper_design by auto
  show ?thesis using assms uniform_complement_block_size by (unfold_locales) (simp)
qed

lemma block_size_lt_v: "\<k> \<le> \<v>"
  using v_non_zero block_size_lt_v design_blocks_nempty uniform by auto

end

lemma (in proper_design) block_designI[intro]: "(\<And> bl . bl \<in># \<B> \<Longrightarrow> card bl = k)
  \<Longrightarrow> block_design \<V> \<B> k"
  by (unfold_locales) (auto)

context block_design
begin

lemma block_design_multiple: "n > 0 \<Longrightarrow> block_design \<V> (multiple_blocks n) \<k>"
  using elem_in_repeat_in_original multiple_proper_design proper_design.block_designI
  by (metis uniform_alt_def_all)

end
text \<open>A uniform block design is clearly a type of $K$\_block\_design with a singleton $K$ set \<close>
sublocale block_design \<subseteq> K_block_design \<V> \<B> "{\<k>}"
  using k_non_zero uniform by unfold_locales simp_all

subsubsection \<open>Incomplete Designs \<close>
text \<open> An incomplete design is a design where $k < v$, i.e. no block is equal to the point set \<close>
locale incomplete_design = block_design +
  assumes incomplete: "\<k> < \<v>"

begin

lemma incomplete_imp_incomp_block: "bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  using incomplete uniform uniform_size_incomp by fastforce

lemma incomplete_imp_proper_subset: "bl \<in># \<B> \<Longrightarrow> bl \<subset> \<V>"
  using incomplete_block_proper_subset incomplete_imp_incomp_block by auto

end

lemma (in block_design) incomplete_designI[intro]: "\<k> < \<v> \<Longrightarrow> incomplete_design \<V> \<B> \<k>"
  by unfold_locales auto

context incomplete_design
begin

lemma multiple_incomplete: "n > 0 \<Longrightarrow> incomplete_design \<V> (multiple_blocks n) \<k>"
  using block_design_multiple incomplete by (simp add: block_design.incomplete_designI)

lemma complement_incomplete: "incomplete_design \<V> (\<B>\<^sup>C) (\<v> - \<k>)"
proof -
  have "\<v> - \<k> < \<v>" using v_non_zero k_non_zero by linarith
  thus ?thesis using uniform_complement incomplete incomplete_designI
    by (simp add: block_design.incomplete_designI)
qed

end

subsection \<open>Balanced Designs \<close>
text \<open> t-wise balance is a design with the property that all point subsets of size $t$ occur in
$\lambda_t$ blocks \<close>

locale t_wise_balance = proper_design +
  fixes grouping :: nat ("\<t>") and index :: nat ("\<Lambda>\<^sub>t")
  assumes t_non_zero: "\<t> \<ge> 1"
  assumes t_lt_order: "\<t> \<le> \<v>"
  assumes balanced [simp]: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps = \<Lambda>\<^sub>t"
begin

lemma t_non_zero_suc: "\<t> \<ge> Suc 0"
  using t_non_zero by auto

lemma balanced_alt_def_all: "\<forall> ps \<subseteq> \<V> . card ps = \<t> \<longrightarrow> \<B> index ps = \<Lambda>\<^sub>t"
  using balanced by auto

end

lemma (in proper_design) t_wise_balanceI[intro]: "\<t> \<le> \<v> \<Longrightarrow> \<t> \<ge> 1 \<Longrightarrow>
  (\<And> ps . ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t>  \<Longrightarrow> \<B> index ps = \<Lambda>\<^sub>t) \<Longrightarrow> t_wise_balance \<V> \<B> \<t> \<Lambda>\<^sub>t"
  by (unfold_locales) auto

context t_wise_balance
begin

lemma obtain_t_subset_points:
  obtains T where "T \<subseteq> \<V>" "card T = \<t>" "finite T"
  using obtain_subset_with_card_n design_points_nempty t_lt_order t_non_zero finite_sets by auto

lemma multiple_t_wise_balance_index [simp]:
  assumes "ps \<subseteq> \<V>"
  assumes "card ps = \<t>"
  shows "(multiple_blocks n) index ps = \<Lambda>\<^sub>t * n"
  using multiple_point_index balanced assms by fastforce

lemma multiple_t_wise_balance:
  assumes "n > 0"
  shows "t_wise_balance \<V> (multiple_blocks n) \<t> (\<Lambda>\<^sub>t * n)"
proof -
  interpret des: proper_design \<V> "(multiple_blocks n)" by (simp add: assms multiple_proper_design)
  show ?thesis using t_non_zero t_lt_order multiple_t_wise_balance_index
    by (unfold_locales) (simp_all)
qed

lemma twise_set_pair_index: "ps \<subseteq> \<V> \<Longrightarrow> ps2 \<subseteq> \<V> \<Longrightarrow> ps \<noteq> ps2 \<Longrightarrow> card ps = \<t> \<Longrightarrow> card ps2 = \<t>
  \<Longrightarrow> \<B> index ps = \<B> index ps2"
  using balanced by simp

lemma t_wise_balance_alt: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps = l2
  \<Longrightarrow> (\<And> ps . ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps = l2)"
  using twise_set_pair_index by blast

lemma index_1_imp_mult_1 [simp]:
  assumes "\<Lambda>\<^sub>t = 1"
  assumes "bl \<in># \<B>"
  assumes "card bl \<ge> \<t>"
  shows "multiplicity bl = 1"
proof (rule ccontr)
  assume "\<not> (multiplicity bl = 1)"
  then have not: "multiplicity bl \<noteq> 1" by simp
  have "multiplicity bl \<noteq> 0" using assms by simp
  then have m: "multiplicity bl \<ge> 2" using not by linarith
  obtain ps where ps: "ps \<subseteq> bl \<and> card ps = \<t>"
    using assms obtain_t_subset_points
    by (metis obtain_subset_with_card_n)
  then have "\<B> index ps \<ge> 2"
    using m points_index_count_min ps by blast
  then show False using balanced ps antisym_conv2 not_numeral_less_zero numeral_le_one_iff
      points_index_ps_nin semiring_norm(69) zero_neq_numeral assms(1)
    by (metis assms(1))
qed

end

subsubsection \<open>Sub-types of t-wise balance\<close>

text \<open>Pairwise balance is when $t = 2$. These are commonly of interest \<close>
locale pairwise_balance = t_wise_balance \<V> \<B> 2 \<Lambda>
  for point_set ("\<V>") and block_collection ("\<B>") and index ("\<Lambda>")

text \<open>We can combine the balance properties with $K$\_block design to define tBD's
(t-wise balanced designs), and PBD's (pairwise balanced designs) \<close>

locale tBD = t_wise_balance + K_block_design +
  assumes block_size_gt_t: "k \<in> \<K> \<Longrightarrow> k \<ge> \<t>"

locale \<Lambda>_PBD = pairwise_balance + K_block_design +
  assumes block_size_gt_t: "k \<in> \<K> \<Longrightarrow> k \<ge> 2"

sublocale \<Lambda>_PBD \<subseteq> tBD \<V> \<B> 2 \<Lambda> \<K>
  using t_lt_order block_size_gt_t by (unfold_locales) (simp_all)

locale PBD = \<Lambda>_PBD \<V> \<B> 1 \<K> for point_set ("\<V>") and block_collection ("\<B>") and sizes ("\<K>")
begin
lemma multiplicity_is_1:
  assumes "bl \<in># \<B>"
  shows "multiplicity bl = 1"
  using block_size_gt_t index_1_imp_mult_1 by (simp add: assms block_sizes)

end

sublocale PBD \<subseteq> simple_design
  using multiplicity_is_1 by (unfold_locales)

text \<open>PBD's are often only used in the case where $k$ is uniform, defined here. \<close>
locale k_\<Lambda>_PBD = pairwise_balance + block_design +
  assumes block_size_t: "2 \<le> \<k>"

sublocale k_\<Lambda>_PBD \<subseteq> \<Lambda>_PBD \<V> \<B> \<Lambda> "{\<k>}"
  using k_non_zero uniform block_size_t by(unfold_locales) (simp_all)

locale k_PBD = k_\<Lambda>_PBD \<V> \<B> 1 \<k> for point_set ("\<V>") and block_collection ("\<B>") and u_block_size ("\<k>")

sublocale k_PBD \<subseteq> PBD \<V> \<B> "{\<k>}"
  using  block_size_t by (unfold_locales, simp_all)

subsubsection \<open>Covering and Packing Designs \<close>
text \<open> Covering and packing designs involve a looser balance restriction. Upper/lower bounds
are placed on the points index, instead of a strict equality \<close>

text \<open> A t-covering design is a relaxed version of a tBD, where, for all point subsets of size t,
a lower bound is put on the points index \<close>
locale t_covering_design = block_design +
  fixes grouping :: nat ("\<t>")
  fixes min_index :: nat ("\<Lambda>\<^sub>t")
  assumes covering: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps \<ge> \<Lambda>\<^sub>t"
  assumes block_size_t: "\<t> \<le> \<k>"
  assumes t_non_zero: "\<t> \<ge> 1"
begin

lemma covering_alt_def_all: "\<forall> ps \<subseteq> \<V> . card ps = \<t> \<longrightarrow> \<B> index ps \<ge> \<Lambda>\<^sub>t"
  using covering by auto

end

lemma (in block_design) t_covering_designI [intro]: "t \<le> \<k> \<Longrightarrow> t \<ge> 1 \<Longrightarrow>
  (\<And> ps. ps \<subseteq> \<V> \<Longrightarrow> card ps = t \<Longrightarrow> \<B> index ps \<ge> \<Lambda>\<^sub>t) \<Longrightarrow> t_covering_design \<V> \<B> \<k> t \<Lambda>\<^sub>t"
  by (unfold_locales) simp_all

text \<open> A t-packing design is a relaxed version of a tBD, where, for all point subsets of size t,
an upper bound is put on the points index \<close>
locale t_packing_design = block_design +
  fixes grouping :: nat ("\<t>")
  fixes min_index :: nat ("\<Lambda>\<^sub>t")
  assumes packing: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B> index ps \<le> \<Lambda>\<^sub>t"
  assumes block_size_t: "\<t> \<le> \<k>"
  assumes t_non_zero: "\<t> \<ge> 1"
begin

lemma packing_alt_def_all: "\<forall> ps \<subseteq> \<V> . card ps = \<t> \<longrightarrow> \<B> index ps \<le> \<Lambda>\<^sub>t"
  using packing by auto

end

lemma (in block_design) t_packing_designI [intro]: "t \<le> \<k> \<Longrightarrow> t \<ge> 1 \<Longrightarrow>
  (\<And> ps . ps \<subseteq> \<V> \<Longrightarrow> card ps = t \<Longrightarrow> \<B> index ps \<le> \<Lambda>\<^sub>t) \<Longrightarrow> t_packing_design \<V> \<B> \<k> t \<Lambda>\<^sub>t"
  by (unfold_locales) simp_all

lemma packing_covering_imp_balance:
  assumes "t_packing_design V B k t \<Lambda>\<^sub>t"
  assumes "t_covering_design V B k t \<Lambda>\<^sub>t"
  shows "t_wise_balance V B t \<Lambda>\<^sub>t"
proof -
  from assms interpret des: proper_design V B
    using block_design.axioms(1) t_covering_design.axioms(1) by blast
  show ?thesis
  proof (unfold_locales)
    show "1 \<le> t" using assms t_packing_design.t_non_zero by auto
    show "t \<le> des.\<v>" using block_design.block_size_lt_v t_packing_design.axioms(1)
      by (metis assms(1) dual_order.trans t_packing_design.block_size_t)
    show "\<And>ps. ps \<subseteq> V \<Longrightarrow> card ps = t \<Longrightarrow> B index ps = \<Lambda>\<^sub>t"
      using t_packing_design.packing t_covering_design.covering by (metis assms dual_order.antisym)
  qed
qed

subsection \<open>Constant Replication Design \<close>
text \<open> When the replication number for all points in a design is constant, it is the
design replication number.\<close>
locale constant_rep_design = proper_design +
  fixes design_rep_number :: nat ("\<r>")
  assumes rep_number [simp]: "x \<in> \<V> \<Longrightarrow>  \<B> rep x = \<r>"

begin

lemma rep_number_alt_def_all: "\<forall> x \<in> \<V>. \<B> rep x = \<r>"
  by (simp)

lemma rep_number_unfold_set: "x \<in> \<V> \<Longrightarrow> size {#bl \<in># \<B> . x \<in> bl#} = \<r>"
  using rep_number by (simp add: point_replication_number_def)

lemma rep_numbers_constant [simp]: "replication_numbers  = {\<r>}"
  unfolding replication_numbers_def using rep_number design_points_nempty Collect_cong finite.cases
    finite_sets insertCI singleton_conv fst_conv snd_conv
  by (smt (z3))

lemma replication_number_single: "is_singleton (replication_numbers)"
  using is_singleton_the_elem by simp

lemma constant_rep_point_pair: "x1 \<in> \<V> \<Longrightarrow> x2 \<in> \<V> \<Longrightarrow> x1 \<noteq> x2 \<Longrightarrow> \<B> rep x1 = \<B> rep x2"
  using rep_number by auto

lemma constant_rep_alt: "x1 \<in> \<V> \<Longrightarrow> \<B> rep x1 = r2 \<Longrightarrow> (\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x = r2)"
  by (simp)

lemma constant_rep_point_not_0:
  assumes "x \<in> \<V>"
  shows "\<B> rep x \<noteq> 0"
proof (rule ccontr)
  assume "\<not> \<B> rep x \<noteq> 0"
  then have "\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x = 0" using rep_number assms by auto
  then have "\<And> x . x \<in> \<V> \<Longrightarrow>  size {#bl \<in># \<B> . x \<in> bl#} = 0"
    by (simp add: point_replication_number_def)
  then show False using design_blocks_nempty wf_design wf_design_iff wf_invalid_point
    by (metis ex_in_conv filter_mset_empty_conv multiset_nonemptyE size_eq_0_iff_empty)
qed

lemma rep_not_zero: "\<r> \<noteq> 0"
  using rep_number constant_rep_point_not_0 design_points_nempty by auto

lemma r_gzero: "\<r> > 0"
  using point_replication_number_def rep_number constant_rep_design.rep_not_zero
  using rep_not_zero by auto

lemma r_lt_eq_b: "\<r> \<le> \<b>"
  using rep_number max_point_rep
  by (metis all_not_in_conv design_points_nempty)

lemma complement_rep_number:
  assumes "\<And> bl . bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  shows "constant_rep_design \<V> \<B>\<^sup>C (\<b> - \<r>)"
proof -
  interpret d: proper_design \<V> "(\<B>\<^sup>C)" using complement_proper_design
    by (simp add: assms)
  show ?thesis using complement_rep_number rep_number by (unfold_locales) simp
qed

lemma multiple_rep_number:
  assumes "n > 0"
  shows "constant_rep_design \<V> (multiple_blocks n) (\<r> * n)"
proof -
  interpret d: proper_design \<V> "(multiple_blocks n)" using multiple_proper_design
    by (simp add: assms)
  show ?thesis using multiple_point_rep_num by (unfold_locales) (simp_all)
qed
end

lemma (in proper_design) constant_rep_designI [intro]: "(\<And> x . x \<in> \<V> \<Longrightarrow> \<B> rep x = \<r>)
    \<Longrightarrow> constant_rep_design \<V> \<B> \<r>"
  by unfold_locales auto

subsection \<open> T-designs \<close>
text \<open>All the before mentioned designs build up to the concept of a t-design, which has uniform
block size and is t-wise balanced. We limit $t$ to be less than $k$, so the balance condition has
relevance \<close>
locale t_design = incomplete_design + t_wise_balance +
  assumes block_size_t: "\<t> \<le> \<k>"
begin

lemma point_indices_balanced: "point_indices \<t> = {\<Lambda>\<^sub>t}"
proof -
  have "point_indices \<t> = {i . \<exists> ps . i = \<B> index ps \<and> card ps = \<t> \<and> ps \<subseteq> \<V>}"
    by (simp add: point_indices_def)
  then have "point_indices  \<t> = {i . i = \<Lambda>\<^sub>t}" using balanced Collect_cong obtain_t_subset_points
    by (smt (verit, best))
  thus ?thesis by auto
qed

lemma point_indices_singleton: "is_singleton (point_indices \<t>)"
  using point_indices_balanced is_singleton_the_elem by simp

end

lemma t_designI [intro]:
  assumes "incomplete_design V B k"
  assumes "t_wise_balance V B t \<Lambda>\<^sub>t"
  assumes "t \<le> k"
  shows "t_design V B k t \<Lambda>\<^sub>t"
  by (simp add: assms(1) assms(2) assms(3) t_design.intro t_design_axioms.intro)

sublocale t_design \<subseteq> t_covering_design \<V> \<B> \<k> \<t> \<Lambda>\<^sub>t
  using t_non_zero by (unfold_locales) (auto simp add: block_size_t)

sublocale t_design \<subseteq> t_packing_design \<V> \<B> \<k> \<t> \<Lambda>\<^sub>t
  using t_non_zero by (unfold_locales) (auto simp add: block_size_t)

lemma t_design_pack_cov [intro]:
  assumes "k < card V"
  assumes "t_covering_design V B k t \<Lambda>\<^sub>t"
  assumes "t_packing_design V B k t \<Lambda>\<^sub>t"
  shows "t_design V B k t \<Lambda>\<^sub>t"
proof -
  from assms interpret id: incomplete_design V B k
    using block_design.incomplete_designI t_packing_design.axioms(1)
    by blast
  from assms interpret balance: t_wise_balance V B t \<Lambda>\<^sub>t
    using packing_covering_imp_balance by blast
  show ?thesis using assms(3)
    by (unfold_locales) (simp_all add: t_packing_design.block_size_t)
qed

sublocale t_design \<subseteq> tBD \<V> \<B> \<t> \<Lambda>\<^sub>t "{\<k>}"
  using uniform k_non_zero block_size_t by (unfold_locales) simp_all

context t_design
begin

lemma multiple_t_design: "n > 0 \<Longrightarrow> t_design \<V> (multiple_blocks n) \<k> \<t> (\<Lambda>\<^sub>t * n)"
  using multiple_t_wise_balance multiple_incomplete block_size_t by (simp add: t_designI)

lemma t_design_min_v: "\<v> > 1"
  using k_non_zero incomplete by simp

end

subsection \<open>Steiner Systems \<close>

text \<open>Steiner systems are a special type of t-design where $\Lambda_t = 1$ \<close>
locale steiner_system = t_design \<V> \<B> \<k> \<t> 1
  for point_set ("\<V>") and block_collection ("\<B>") and u_block_size ("\<k>") and grouping ("\<t>")

begin

lemma block_multiplicity [simp]:
  assumes "bl \<in># \<B>"
  shows "multiplicity bl = 1"
  by (simp add: assms block_size_t)

end

sublocale steiner_system \<subseteq> simple_design
  by unfold_locales (simp)

lemma (in t_design) steiner_systemI[intro]: "\<Lambda>\<^sub>t = 1 \<Longrightarrow> steiner_system \<V> \<B> \<k> \<t>"
  using t_non_zero t_lt_order block_size_t
  by unfold_locales auto

subsection \<open>Combining block designs \<close>
text \<open>We define some closure properties for various block designs under the combine operator.
This is done using locales to reason on multiple instances of the same type of design, building
on what was presented in the design operations theory\<close>

locale two_t_wise_eq_points = two_designs_proper \<V> \<B> \<V> \<B>' + des1: t_wise_balance \<V> \<B> \<t> \<Lambda>\<^sub>t +
  des2: t_wise_balance \<V> \<B>' \<t> \<Lambda>\<^sub>t' for \<V> \<B> \<t> \<Lambda>\<^sub>t \<B>' \<Lambda>\<^sub>t'
begin

lemma combine_t_wise_balance_index: "ps \<subseteq> \<V> \<Longrightarrow> card ps = \<t> \<Longrightarrow> \<B>\<^sup>+ index ps = (\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
  using des1.balanced des2.balanced by (simp add: combine_points_index)

lemma combine_t_wise_balance: "t_wise_balance \<V>\<^sup>+ \<B>\<^sup>+ \<t> (\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
proof (unfold_locales, simp add: des1.t_non_zero_suc)
  have "card \<V>\<^sup>+  \<ge> card \<V>" by simp
  then show "\<t> \<le> card (\<V>\<^sup>+)" using des1.t_lt_order by linarith
  show "\<And>ps. ps \<subseteq> \<V>\<^sup>+ \<Longrightarrow> card ps = \<t> \<Longrightarrow> (\<B>\<^sup>+ index ps) = \<Lambda>\<^sub>t + \<Lambda>\<^sub>t'"
    using combine_t_wise_balance_index by blast
qed

sublocale combine_t_wise_des: t_wise_balance "\<V>\<^sup>+" "\<B>\<^sup>+" "\<t>" "(\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
  using combine_t_wise_balance by auto

end

locale two_k_block_designs = two_designs_proper \<V> \<B> \<V>' \<B>' + des1: block_design \<V> \<B> \<k> +
  des2: block_design \<V>' \<B>' \<k> for \<V> \<B> \<k> \<V>' \<B>'
begin

lemma block_design_combine: "block_design \<V>\<^sup>+ \<B>\<^sup>+ \<k>"
  using des1.uniform des2.uniform by (unfold_locales) (auto)

sublocale combine_block_des: block_design "\<V>\<^sup>+" "\<B>\<^sup>+" "\<k>"
  using block_design_combine by simp

end

locale two_rep_designs_eq_points = two_designs_proper \<V> \<B> \<V> \<B>' + des1: constant_rep_design \<V> \<B> \<r> +
  des2: constant_rep_design \<V> \<B>' \<r>' for \<V> \<B> \<r> \<B>' \<r>'
begin

lemma combine_rep_number: "constant_rep_design \<V>\<^sup>+ \<B>\<^sup>+ (\<r> + \<r>')"
  using combine_rep_number des1.rep_number des2.rep_number by (unfold_locales) (simp)

sublocale combine_const_rep: constant_rep_design "\<V>\<^sup>+" "\<B>\<^sup>+" "(\<r> + \<r>')"
  using combine_rep_number by simp

end

locale two_incomplete_designs = two_k_block_designs \<V> \<B> \<k> \<V>' \<B>' + des1: incomplete_design \<V> \<B> \<k> +
  des2: incomplete_design \<V>' \<B>' \<k> for \<V> \<B> \<k> \<V>' \<B>'
begin

lemma combine_is_incomplete: "incomplete_design \<V>\<^sup>+ \<B>\<^sup>+ \<k>"
  using combine_order des1.incomplete des2.incomplete by (unfold_locales) (simp)

sublocale combine_incomplete: incomplete_design "\<V>\<^sup>+" "\<B>\<^sup>+" "\<k>"
  using combine_is_incomplete by simp
end

locale two_t_designs_eq_points = two_incomplete_designs \<V> \<B> \<k> \<V> \<B>'
  + two_t_wise_eq_points \<V> \<B> \<t> \<Lambda>\<^sub>t \<B>' \<Lambda>\<^sub>t' + des1: t_design \<V> \<B> \<k> \<t> \<Lambda>\<^sub>t +
  des2: t_design \<V> \<B>' \<k> \<t> \<Lambda>\<^sub>t' for \<V> \<B> \<k> \<B>' \<t> \<Lambda>\<^sub>t \<Lambda>\<^sub>t'
begin

lemma combine_is_t_des: "t_design \<V>\<^sup>+ \<B>\<^sup>+ \<k> \<t> (\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
  using des1.block_size_t des2.block_size_t by (unfold_locales)

sublocale combine_t_des: t_design "\<V>\<^sup>+" "\<B>\<^sup>+" "\<k>" "\<t>" "(\<Lambda>\<^sub>t + \<Lambda>\<^sub>t')"
  using combine_is_t_des by blast

end
end


theory condes_dilemmas imports Main begin

text {*
  Proving the constructive and destructive dilemmas in propositional calculus
*}

lemma "(P\<longrightarrow>Q) \<Longrightarrow>(R\<longrightarrow>S) \<Longrightarrow>(P\<or>R) \<Longrightarrow>(Q\<or>S)"
  apply(erule disjE)
   apply(erule impE)
    apply assumption
   apply(rule disjI1)
   apply assumption
  apply(rule disjI2)
  apply (erule mp)
  apply assumption
  done

lemma "(P\<longrightarrow>Q) \<Longrightarrow>(R\<longrightarrow>S) \<Longrightarrow>(\<not>Q\<or>\<not>S)\<Longrightarrow>(\<not>P\<or>\<not>R) "
  apply(erule disjE)
   apply(rule disjI1)
   apply(rule notI)
   apply(erule notE)
   apply (erule mp)
   apply assumption
  apply(rule disjI2)
  apply(rule notI)
  apply(erule notE)
  apply(erule mp)
  apply assumption
  done


(*  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

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

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

print_theorems

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 \<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 transitivity 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> "transitivity 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 "Transitivity" (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 ==> f b < (c::'c::order) ==>
  (!!x y. x < y ==> f x < f y) ==> f a < c"
proof -
  assume r: "!!x y. x < y ==> 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 ==> (b::'b::order) < c ==>
  (!!x y. x < y ==> f x < f y) ==> a < f c"
proof -
  assume r: "!!x y. x < y ==> 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 ==> f b < (c::'c::order) ==>
  (!!x y. x <= y ==> f x <= f y) ==> f a < c"
proof -
  assume r: "!!x y. x <= y ==> 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 ==> (b::'b::order) < c ==>
  (!!x y. x < y ==> f x < f y) ==> a < f c"
proof -
  assume r: "!!x y. x < y ==> 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 ==> f b <= (c::'c::order) ==>
  (!!x y. x < y ==> f x < f y) ==> f a < c"
proof -
  assume r: "!!x y. x < y ==> 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 ==> (b::'b::order) <= c ==>
  (!!x y. x <= y ==> f x <= f y) ==> a < f c"
proof -
  assume r: "!!x y. x <= y ==> 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 ==> (b::'b::order) <= c ==>
  (!!x y. x <= y ==> f x <= f y) ==> a <= f c"
proof -
  assume r: "!!x y. x <= y ==> 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 ==> f b <= (c::'c::order) ==>
  (!!x y. x <= y ==> f x <= f y) ==> f a <= c"
proof -
  assume r: "!!x y. x <= y ==> 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 ==> f b = c ==>
  (!!x y. x <= y ==> f x <= f y) ==> f a <= c"
proof -
  assume r: "!!x y. x <= y ==> 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 ==> b <= c ==>
  (!!x y. x <= y ==> f x <= f y) ==> a <= f c"
proof -
  assume r: "!!x y. x <= y ==> 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 ==> f b = c ==>
  (!!x y. x < y ==> f x < f y) ==> f a < c"
proof -
  assume r: "!!x y. x < y ==> 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 ==> b < c ==>
  (!!x y. x < y ==> f x < f y) ==> a < f c"
proof -
  assume r: "!!x y. x < y ==> 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 >= b >= 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]:
  "(a::'a::order) >= f b ==> b >= c ==> (!!x y. x >= y ==> f x >= f y) ==> a >= f c"
by (subgoal_tac "f b >= f c", force, force)

lemma xt3 [no_atp]: "(a::'a::order) >= b ==> (f b::'b::order) >= c ==>
    (!!x y. x >= y ==> f x >= f y) ==> f a >= c"
by (subgoal_tac "f a >= f b", force, force)

lemma xt4 [no_atp]: "(a::'a::order) > f b ==> (b::'b::order) >= c ==>
  (!!x y. x >= y ==> f x >= f y) ==> a > f c"
by (subgoal_tac "f b >= f c", force, force)

lemma xt5 [no_atp]: "(a::'a::order) > b ==> (f b::'b::order) >= c==>
    (!!x y. x > y ==> f x > f y) ==> f a > c"
by (subgoal_tac "f a > f b", force, force)

lemma xt6 [no_atp]: "(a::'a::order) >= f b ==> b > c ==>
    (!!x y. x > y ==> f x > f y) ==> a > f c"
by (subgoal_tac "f b > f c", force, force)

lemma xt7 [no_atp]: "(a::'a::order) >= b ==> (f b::'b::order) > c ==>
    (!!x y. x >= y ==> f x >= f y) ==> f a > c"
by (subgoal_tac "f a >= f b", force, force)

lemma xt8 [no_atp]: "(a::'a::order) > f b ==> (b::'b::order) > c ==>
    (!!x y. x > y ==> f x > f y) ==> a > f c"
by (subgoal_tac "f b > f c", force, force)

lemma xt9 [no_atp]: "(a::'a::order) > b ==> (f b::'b::order) > c ==>
    (!!x y. x > y ==> f x > f y) ==> f a > c"
by (subgoal_tac "f a > f b", force, force)

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

(*
  Since "a >= b" abbreviates "b <= 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 >= b" (is "_ >= ?rhs")
    sorry
  also have "?rhs >= c" (is "_ >= ?rhs")
    sorry
  also (xtrans) have "?rhs = d" (is "_ = ?rhs")
    sorry
  also (xtrans) have "?rhs >= e" (is "_ >= ?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>Monotonicity\<close>

context order
begin

definition mono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
  "mono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y)"

lemma monoI [intro?]:
  fixes f :: "'a \<Rightarrow> 'b::order"
  shows "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> mono f"
  unfolding mono_def by iprover

lemma monoD [dest?]:
  fixes f :: "'a \<Rightarrow> 'b::order"
  shows "mono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  unfolding mono_def by iprover

lemma monoE:
  fixes f :: "'a \<Rightarrow> 'b::order"
  assumes "mono f"
  assumes "x \<le> y"
  obtains "f x \<le> f y"
proof
  from assms show "f x \<le> f y" by (simp add: mono_def)
qed

definition antimono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
  "antimono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<ge> f y)"

lemma antimonoI [intro?]:
  fixes f :: "'a \<Rightarrow> 'b::order"
  shows "(\<And>x y. x \<le> y \<Longrightarrow> f x \<ge> f y) \<Longrightarrow> antimono f"
  unfolding antimono_def by iprover

lemma antimonoD [dest?]:
  fixes f :: "'a \<Rightarrow> 'b::order"
  shows "antimono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
  unfolding antimono_def by iprover

lemma antimonoE:
  fixes f :: "'a \<Rightarrow> 'b::order"
  assumes "antimono f"
  assumes "x \<le> y"
  obtains "f x \<ge> f y"
proof
  from assms show "f x \<ge> f y" by (simp add: antimono_def)
qed

definition strict_mono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
  "strict_mono f \<longleftrightarrow> (\<forall>x y. x < y \<longrightarrow> f x < f y)"

lemma strict_monoI [intro?]:
  assumes "\<And>x y. x < y \<Longrightarrow> f x < f y"
  shows "strict_mono f"
  using assms unfolding strict_mono_def by auto

lemma strict_monoD [dest?]:
  "strict_mono f \<Longrightarrow> x < y \<Longrightarrow> f x < f y"
  unfolding strict_mono_def by auto

lemma strict_mono_mono [dest?]:
  assumes "strict_mono f"
  shows "mono f"
proof (rule monoI)
  fix x y
  assume "x \<le> y"
  show "f x \<le> f y"
  proof (cases "x = y")
    case True then show ?thesis by simp
  next
    case False with \<open>x \<le> y\<close> have "x < y" by simp
    with assms strict_monoD have "f x < f y" by auto
    then show ?thesis by simp

  qed
qed

end

context linorder
begin

lemma mono_invE:
  fixes f :: "'a \<Rightarrow> 'b::order"
  assumes "mono f"
  assumes "f x < f y"
  obtains "x \<le> y"
proof
  show "x \<le> y"
  proof (rule ccontr)
    assume "\<not> x \<le> y"
    then have "y \<le> x" by simp
    with \<open>mono f\<close> obtain "f y \<le> f x" by (rule monoE)
    with \<open>f x < f y\<close> show False by simp
  qed
qed

lemma mono_strict_invE:
  fixes f :: "'a \<Rightarrow> 'b::order"
  assumes "mono f"
  assumes "f x < f y"
  obtains "x < y"
proof
  show "x < y"
  proof (rule ccontr)
    assume "\<not> x < y"
    then have "y \<le> x" by simp
    with \<open>mono f\<close> obtain "f y \<le> f x" by (rule monoE)
    with \<open>f x < f y\<close> show False by simp
  qed
qed

lemma strict_mono_eq:
  assumes "strict_mono f"
  shows "f x = f y \<longleftrightarrow> x = y"
proof
  assume "f x = f y"
  show "x = y" proof (cases x y rule: linorder_cases)
    case less with assms strict_monoD have "f x < f y" by auto
    with \<open>f x = f y\<close> show ?thesis by simp
  next
    case equal then show ?thesis .
  next
    case greater with assms strict_monoD have "f y < f x" by auto
    with \<open>f x = f y\<close> show ?thesis by simp
  qed
qed simp

lemma strict_mono_less_eq:
  assumes "strict_mono f"
  shows "f x \<le> f y \<longleftrightarrow> x \<le> y"
proof
  assume "x \<le> y"
  with assms strict_mono_mono monoD show "f x \<le> f y" by auto
next
  assume "f x \<le> f y"
  show "x \<le> y" proof (rule ccontr)
    assume "\<not> x \<le> y" then have "y < x" by simp
    with assms strict_monoD have "f y < f x" by auto
    with \<open>f x \<le> f y\<close> show False by simp
  qed
qed

lemma strict_mono_less:
  assumes "strict_mono f"
  shows "f x < f y \<longleftrightarrow> x < y"
  using assms
    by (auto simp add: less_le Orderings.less_le strict_mono_eq strict_mono_less_eq)

end

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)

lemma mono_compose: "mono Q \<Longrightarrow> mono (\<lambda>i x. Q i (f x))"
  unfolding mono_def le_fun_def by auto

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