(* Author: Tobias Nipkow *)

section "Sorting"

theory Sorting
imports
  Complex_Main
  "HOL-Library.Multiset"
begin

hide_const List.insort

declare Let_def [simp]

subsection "Insertion Sort"

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

fun insort :: "'a::linorder list \<Rightarrow> 'a list" where
"insort [] = []" |
"insort (x#xs) = insort1 x (insort xs)"

subsubsection "Functional Correctness"

lemma mset_insort1: "mset (insort1 x xs) = {#x#} + mset xs"
apply(induction xs)
apply auto
done

lemma mset_insort: "mset (insort xs) = mset xs"
apply(induction xs)
apply simp
apply (simp add: mset_insort1)
done

lemma set_insort1: "set (insort1 x xs) = {x} \<union> set xs"
by(simp add: mset_insort1 flip: set_mset_mset)

lemma sorted_insort1: "sorted (insort1 a xs) = sorted xs"
apply(induction xs)
apply(auto simp add: set_insort1)
done

lemma sorted_insort: "sorted (insort xs)"
apply(induction xs)
apply(auto simp: sorted_insort1)
done

subsubsection "Time Complexity"

text \<open>We count the number of function calls.\<close>

text\<open>
\<open>insort1 x [] = [x]\<close>
\<open>insort1 x (y#ys) =
  (if x \<le> y then x#y#ys else y#(insort1 x ys))\<close>
\<close>
fun T_insort1 :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> nat" where
"T_insort1 x [] = 1" |
"T_insort1 x (y#ys) =
  (if x \<le> y then 0 else T_insort1 x ys) + 1"

text\<open>
\<open>insort [] = []\<close>
\<open>insort (x#xs) = insort1 x (insort xs)\<close>
\<close>
fun T_insort :: "'a::linorder list \<Rightarrow> nat" where
"T_insort [] = 1" |
"T_insort (x#xs) = T_insort xs + T_insort1 x (insort xs) + 1"

lemma T_insort1_length: "T_insort1 x xs \<le> length xs + 1"
apply(induction xs)
apply auto
done

lemma length_insort1: "length (insort1 x xs) = length xs + 1"
apply(induction xs)
apply auto
done

lemma length_insort: "length (insort xs) = length xs"
apply(induction xs)
apply (auto simp: length_insort1)
done

lemma T_insort_length: "T_insort xs \<le> (length xs + 1) ^ 2"
proof(induction xs)
  case Nil show ?case by simp
next
  case (Cons x xs)
  have "T_insort (x#xs) = T_insort xs + T_insort1 x (insort xs) + 1" by simp
  also have "\<dots> \<le> (length xs + 1) ^ 2 + T_insort1 x (insort xs) + 1"
    using Cons.IH by simp
  also have "\<dots> \<le> (length xs + 1) ^ 2 + length xs + 1 + 1"
    using T_insort1_length[of x "insort xs"] by (simp add: length_insort)
  also have "\<dots> \<le> (length(x#xs) + 1) ^ 2"
    by (simp add: power2_eq_square)
  finally show ?case .
qed

subsection "Merge Sort"

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

fun msort :: "'a::linorder list \<Rightarrow> 'a list" where
"msort xs = (let n = length xs in
  if n \<le> 1 then xs
  else merge (msort (take (n div 2) xs)) (msort (drop (n div 2) xs)))"

declare msort.simps [simp del]

subsubsection "Functional Correctness"

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

lemma mset_msort: "mset (msort xs) = mset xs"
proof(induction xs rule: msort.induct)
  case (1 xs)
  let ?n = "length xs"
  let ?ys = "take (?n div 2) xs"
  let ?zs = "drop (?n div 2) xs"
  show ?case
  proof cases
    assume "?n \<le> 1"
    thus ?thesis by(simp add: msort.simps[of xs])
  next
    assume "\<not> ?n \<le> 1"
    hence "mset (msort xs) = mset (msort ?ys) + mset (msort ?zs)"
      by(simp add: msort.simps[of xs] mset_merge)
    also have "\<dots> = mset ?ys + mset ?zs"
      using \<open>\<not> ?n \<le> 1\<close> by(simp add: "1.IH")
    also have "\<dots> = mset (?ys @ ?zs)" by (simp del: append_take_drop_id)
    also have "\<dots> = mset xs" by simp
    finally show ?thesis .
  qed
qed

text \<open>Via the previous lemma or directly:\<close>

lemma set_merge: "set(merge xs ys) = set xs \<union> set ys"
by (metis mset_merge set_mset_mset set_mset_union)

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

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

lemma sorted_msort: "sorted (msort xs)"
proof(induction xs rule: msort.induct)
  case (1 xs)
  let ?n = "length xs"
  show ?case
  proof cases
    assume "?n \<le> 1"
    thus ?thesis by(simp add: msort.simps[of xs] sorted01)
  next
    assume "\<not> ?n \<le> 1"
    thus ?thesis using "1.IH"
      by(simp add: sorted_merge msort.simps[of xs])
  qed
qed

subsubsection "Time Complexity"

text \<open>We only count the number of comparisons between list elements.\<close>

fun C_merge :: "'a::linorder list \<Rightarrow> 'a list \<Rightarrow> nat" where
"C_merge [] ys = 0" |
"C_merge xs [] = 0" |
"C_merge (x#xs) (y#ys) = 1 + (if x \<le> y then C_merge xs (y#ys) else C_merge (x#xs) ys)"

lemma C_merge_ub: "C_merge xs ys \<le> length xs + length ys"
by (induction xs ys rule: C_merge.induct) auto

fun C_msort :: "'a::linorder list \<Rightarrow> nat" where
"C_msort xs =
  (let n = length xs;
       ys = take (n div 2) xs;
       zs = drop (n div 2) xs
   in if n \<le> 1 then 0
      else C_msort ys + C_msort zs + C_merge (msort ys) (msort zs))"

declare C_msort.simps [simp del]

lemma length_merge: "length(merge xs ys) = length xs + length ys"
apply (induction xs ys rule: merge.induct)
apply auto
done

lemma length_msort: "length(msort xs) = length xs"
proof (induction xs rule: msort.induct)
  case (1 xs)
  show ?case
    by (auto simp: msort.simps [of xs] 1 length_merge)
qed
text \<open>Why structured proof?
   To have the name "xs" to specialize msort.simps with xs
   to ensure that msort.simps cannot be used recursively.
Also works without this precaution, but that is just luck.\<close>

lemma C_msort_le: "length xs = 2^k \<Longrightarrow> C_msort xs \<le> k * 2^k"
proof(induction k arbitrary: xs)
  case 0 thus ?case by (simp add: C_msort.simps)
next
  case (Suc k)
  let ?n = "length xs"
  let ?ys = "take (?n div 2) xs"
  let ?zs = "drop (?n div 2) xs"
  show ?case
  proof (cases "?n \<le> 1")
    case True
    thus ?thesis by(simp add: C_msort.simps)
  next
    case False
    have "C_msort(xs) =
      C_msort ?ys + C_msort ?zs + C_merge (msort ?ys) (msort ?zs)"
      by (simp add: C_msort.simps msort.simps)
    also have "\<dots> \<le> C_msort ?ys + C_msort ?zs + length ?ys + length ?zs"
      using C_merge_ub[of "msort ?ys" "msort ?zs"] length_msort[of ?ys] length_msort[of ?zs]
      by arith
    also have "\<dots> \<le> k * 2^k + C_msort ?zs + length ?ys + length ?zs"
      using Suc.IH[of ?ys] Suc.prems by simp
    also have "\<dots> \<le> k * 2^k + k * 2^k + length ?ys + length ?zs"
      using Suc.IH[of ?zs] Suc.prems by simp
    also have "\<dots> = 2 * k * 2^k + 2 * 2 ^ k"
      using Suc.prems by simp
    finally show ?thesis by simp
  qed
qed

(* Beware of implicit conversions: *)
lemma C_msort_log: "length xs = 2^k \<Longrightarrow> C_msort xs \<le> length xs * log 2 (length xs)"
using C_msort_le[of xs k] apply (simp add: log_nat_power algebra_simps)
by (metis (mono_tags) numeral_power_eq_of_nat_cancel_iff of_nat_le_iff of_nat_mult)

subsection "Bottom-Up Merge Sort"

fun merge_adj :: "('a::linorder) list list \<Rightarrow> 'a list list" where
"merge_adj [] = []" |
"merge_adj [xs] = [xs]" |
"merge_adj (xs # ys # zss) = merge xs ys # merge_adj zss"

text \<open>For the termination proof of \<open>merge_all\<close> below.\<close>
lemma length_merge_adjacent[simp]: "length (merge_adj xs) = (length xs + 1) div 2"
by (induction xs rule: merge_adj.induct) auto

fun merge_all :: "('a::linorder) list list \<Rightarrow> 'a list" where
"merge_all [] = []" |
"merge_all [xs] = xs" |
"merge_all xss = merge_all (merge_adj xss)"

definition msort_bu :: "('a::linorder) list \<Rightarrow> 'a list" where
"msort_bu xs = merge_all (map (\<lambda>x. [x]) xs)"

subsubsection "Functional Correctness"

abbreviation mset_mset :: "'a list list \<Rightarrow> 'a multiset" where
"mset_mset xss \<equiv> \<Sum>\<^sub># (image_mset mset (mset xss))"

lemma mset_merge_adj:
  "mset_mset (merge_adj xss) = mset_mset xss"
by(induction xss rule: merge_adj.induct) (auto simp: mset_merge)

lemma mset_merge_all:
  "mset (merge_all xss) = mset_mset xss"
by(induction xss rule: merge_all.induct) (auto simp: mset_merge mset_merge_adj)

lemma mset_msort_bu: "mset (msort_bu xs) = mset xs"
by(simp add: msort_bu_def mset_merge_all multiset.map_comp comp_def)

lemma sorted_merge_adj:
  "\<forall>xs \<in> set xss. sorted xs \<Longrightarrow> \<forall>xs \<in> set (merge_adj xss). sorted xs"
by(induction xss rule: merge_adj.induct) (auto simp: sorted_merge)

lemma sorted_merge_all:
  "\<forall>xs \<in> set xss. sorted xs \<Longrightarrow> sorted (merge_all xss)"
apply(induction xss rule: merge_all.induct)
using [[simp_depth_limit=3]] by (auto simp add: sorted_merge_adj)

lemma sorted_msort_bu: "sorted (msort_bu xs)"
by(simp add: msort_bu_def sorted_merge_all)

subsubsection "Time Complexity"

fun C_merge_adj :: "('a::linorder) list list \<Rightarrow> nat" where
"C_merge_adj [] = 0" |
"C_merge_adj [xs] = 0" |
"C_merge_adj (xs # ys # zss) = C_merge xs ys + C_merge_adj zss"

fun C_merge_all :: "('a::linorder) list list \<Rightarrow> nat" where
"C_merge_all [] = 0" |
"C_merge_all [xs] = 0" |
"C_merge_all xss = C_merge_adj xss + C_merge_all (merge_adj xss)"

definition C_msort_bu :: "('a::linorder) list \<Rightarrow> nat" where
"C_msort_bu xs = C_merge_all (map (\<lambda>x. [x]) xs)"

lemma length_merge_adj:
  "\<lbrakk> even(length xss); \<forall>xs \<in> set xss. length xs = m \<rbrakk>
  \<Longrightarrow> \<forall>xs \<in> set (merge_adj xss). length xs = 2*m"
by(induction xss rule: merge_adj.induct) (auto simp: length_merge)

lemma C_merge_adj: "\<forall>xs \<in> set xss. length xs = m \<Longrightarrow> C_merge_adj xss \<le> m * length xss"
proof(induction xss rule: C_merge_adj.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 x y) thus ?case using C_merge_ub[of x y] by (simp add: algebra_simps)
qed

lemma C_merge_all: "\<lbrakk> \<forall>xs \<in> set xss. length xs = m; length xss = 2^k \<rbrakk>
  \<Longrightarrow> C_merge_all xss \<le> m * k * 2^k"
proof (induction xss arbitrary: k m rule: C_merge_all.induct)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 xs ys xss)
  let ?xss = "xs # ys # xss"
  let ?xss2 = "merge_adj ?xss"
  obtain k' where k': "k = Suc k'" using "3.prems"(2)
    by (metis length_Cons nat.inject nat_power_eq_Suc_0_iff nat.exhaust)
  have "even (length ?xss)" using "3.prems"(2) k' by auto
  from length_merge_adj[OF this "3.prems"(1)]
  have *: "\<forall>x \<in> set(merge_adj ?xss). length x = 2*m" .
  have **: "length ?xss2 = 2 ^ k'" using "3.prems"(2) k' by auto
  have "C_merge_all ?xss = C_merge_adj ?xss + C_merge_all ?xss2" by simp
  also have "\<dots> \<le> m * 2^k + C_merge_all ?xss2"
    using "3.prems"(2) C_merge_adj[OF "3.prems"(1)] by (auto simp: algebra_simps)
  also have "\<dots> \<le> m * 2^k + (2*m) * k' * 2^k'"
    using "3.IH"[OF * **] by simp
  also have "\<dots> = m * k * 2^k"
    using k' by (simp add: algebra_simps)
  finally show ?case .
qed

corollary C_msort_bu: "length xs = 2 ^ k \<Longrightarrow> C_msort_bu xs \<le> k * 2 ^ k"
using C_merge_all[of "map (\<lambda>x. [x]) xs" 1] by (simp add: C_msort_bu_def)

subsection "Quicksort"

fun quicksort :: "('a::linorder) list \<Rightarrow> 'a list" where
"quicksort []     = []" |
"quicksort (x#xs) = quicksort (filter (\<lambda>y. y < x) xs) @ [x] @ quicksort (filter (\<lambda>y. x \<le> y) xs)"

lemma mset_quicksort: "mset (quicksort xs) = mset xs"
apply (induction xs rule: quicksort.induct)
apply (auto simp: not_le)
done

lemma set_quicksort: "set (quicksort xs) = set xs"
by(rule mset_eq_setD[OF mset_quicksort])

lemma sorted_quicksort: "sorted (quicksort xs)"
apply (induction xs rule: quicksort.induct)
apply (auto simp add: sorted_append set_quicksort)
done

subsection "Insertion Sort w.r.t. Keys and Stability"

hide_const List.insort_key

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

fun insort_key :: "('a \<Rightarrow> 'k::linorder) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"insort_key f [] = []" |
"insort_key f (x # xs) = insort1_key f x (insort_key f xs)"

subsubsection "Standard functional correctness"

lemma mset_insort1_key: "mset (insort1_key f x xs) = {#x#} + mset xs"
by(induction xs) simp_all

lemma mset_insort_key: "mset (insort_key f xs) = mset xs"
by(induction xs) (simp_all add: mset_insort1_key)

(* Inductive proof simpler than derivation from mset lemma: *)
lemma set_insort1_key: "set (insort1_key f x xs) = {x} \<union> set xs"
by (induction xs) auto

lemma sorted_insort1_key: "sorted (map f (insort1_key f a xs)) = sorted (map f xs)"
by(induction xs)(auto simp: set_insort1_key)

lemma sorted_insort_key: "sorted (map f (insort_key f xs))"
by(induction xs)(simp_all add: sorted_insort1_key)

subsubsection "Stability"

lemma insort1_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort1_key f a xs = a # xs"
by (cases xs) auto

lemma filter_insort1_key_neg:
  "\<not> P x \<Longrightarrow> filter P (insort1_key f x xs) = filter P xs"
by (induction xs) simp_all

lemma filter_insort1_key_pos:
  "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort1_key f x xs) = insort1_key f x (filter P xs)"
by (induction xs) (auto, subst insort1_is_Cons, auto)

lemma sort_key_stable: "filter (\<lambda>y. f y = k) (insort_key f xs) = filter (\<lambda>y. f y = k) xs"
proof (induction xs)
  case Nil thus ?case by simp
next
  case (Cons a xs)
  thus ?case
  proof (cases "f a = k")
    case False thus ?thesis  by (simp add: Cons.IH filter_insort1_key_neg)
  next
    case True
    have "filter (\<lambda>y. f y = k) (insort_key f (a # xs))
      = filter (\<lambda>y. f y = k) (insort1_key f a (insort_key f xs))"  by simp
    also have "\<dots> = insort1_key f a (filter (\<lambda>y. f y = k) (insort_key f xs))"
      by (simp add: True filter_insort1_key_pos sorted_insort_key)
    also have "\<dots> = insort1_key f a (filter (\<lambda>y. f y = k) xs)"  by (simp add: Cons.IH)
    also have "\<dots> = a # (filter (\<lambda>y. f y = k) xs)"  by(simp add: True insort1_is_Cons)
    also have "\<dots> = filter (\<lambda>y. f y = k) (a # xs)" by (simp add: True)
    finally show ?thesis .
  qed
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_TSortSorts
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype Tree = TNode "Tree" "Nat" "Tree" | TNil

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

fun ordered :: "Nat list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

fun flatten :: "Tree => Nat list => Nat list" where
"flatten (TNode q z r) y = flatten q (cons2 z (flatten r y))"
| "flatten (TNil) y = y"

fun add :: "Nat => Tree => Tree" where
"add x (TNode q z r) =
   (if le x z then TNode (add x q) z r else TNode q z (add x r))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "Nat list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

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

theorem property0 :
  "ordered (tsort xs)"
  oops

end


(*  Title:      HOL/Isar_Examples/Mutilated_Checkerboard.thy
    Author:     Markus Wenzel, TU Muenchen (Isar document)
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory (original scripts)
*)

section \<open>The Mutilated Checker Board Problem\<close>

theory Mutilated_Checkerboard
  imports Main
begin

text \<open>
  The Mutilated Checker Board Problem, formalized inductively. See \<^cite>\<open>"paulson-mutilated-board"\<close> for the original tactic script version.
\<close>

subsection \<open>Tilings\<close>

inductive_set tiling :: "'a set set \<Rightarrow> 'a set set" for A :: "'a set set"
  where
    empty: "{} \<in> tiling A"
  | Un: "a \<union> t \<in> tiling A" if "a \<in> A" and "t \<in> tiling A" and "a \<subseteq> - t"

text \<open>The union of two disjoint tilings is a tiling.\<close>

lemma tiling_Un:
  assumes "t \<in> tiling A"
    and "u \<in> tiling A"
    and "t \<inter> u = {}"
  shows "t \<union> u \<in> tiling A"
proof -
  let ?T = "tiling A"
  from \<open>t \<in> ?T\<close> and \<open>t \<inter> u = {}\<close>
  show "t \<union> u \<in> ?T"
  proof (induct t)
    case empty
    with \<open>u \<in> ?T\<close> show "{} \<union> u \<in> ?T" by simp
  next
    case (Un a t)
    show "(a \<union> t) \<union> u \<in> ?T"
    proof -
      have "a \<union> (t \<union> u) \<in> ?T"
        using \<open>a \<in> A\<close>
      proof (rule tiling.Un)
        from \<open>(a \<union> t) \<inter> u = {}\<close> have "t \<inter> u = {}" by blast
        then show "t \<union> u \<in> ?T" by (rule Un)
        from \<open>a \<subseteq> - t\<close> and \<open>(a \<union> t) \<inter> u = {}\<close>
        show "a \<subseteq> - (t \<union> u)" by blast
      qed
      also have "a \<union> (t \<union> u) = (a \<union> t) \<union> u"
        by (simp only: Un_assoc)
      finally show ?thesis .
    qed
  qed
qed

subsection \<open>Basic properties of ``below''\<close>

definition below :: "nat \<Rightarrow> nat set"
  where "below n = {i. i < n}"

lemma below_less_iff [iff]: "i \<in> below k \<longleftrightarrow> i < k"
  by (simp add: below_def)

lemma below_0: "below 0 = {}"
  by (simp add: below_def)

lemma Sigma_Suc1: "m = n + 1 \<Longrightarrow> below m \<times> B = ({n} \<times> B) \<union> (below n \<times> B)"
  by (simp add: below_def less_Suc_eq) blast

lemma Sigma_Suc2:
  "m = n + 2 \<Longrightarrow>
    A \<times> below m = (A \<times> {n}) \<union> (A \<times> {n + 1}) \<union> (A \<times> below n)"
  by (auto simp add: below_def)

lemmas Sigma_Suc = Sigma_Suc1 Sigma_Suc2

subsection \<open>Basic properties of ``evnodd''\<close>

definition evnodd :: "(nat \<times> nat) set \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set"
  where "evnodd A b = A \<inter> {(i, j). (i + j) mod 2 = b}"

lemma evnodd_iff: "(i, j) \<in> evnodd A b \<longleftrightarrow> (i, j) \<in> A  \<and> (i + j) mod 2 = b"
  by (simp add: evnodd_def)

lemma evnodd_subset: "evnodd A b \<subseteq> A"
  unfolding evnodd_def by (rule Int_lower1)

lemma evnoddD: "x \<in> evnodd A b \<Longrightarrow> x \<in> A"
  by (rule subsetD) (rule evnodd_subset)

lemma evnodd_finite: "finite A \<Longrightarrow> finite (evnodd A b)"
  by (rule finite_subset) (rule evnodd_subset)

lemma evnodd_Un: "evnodd (A \<union> B) b = evnodd A b \<union> evnodd B b"
  unfolding evnodd_def by blast

lemma evnodd_Diff: "evnodd (A - B) b = evnodd A b - evnodd B b"
  unfolding evnodd_def by blast

lemma evnodd_empty: "evnodd {} b = {}"
  by (simp add: evnodd_def)

lemma evnodd_insert: "evnodd (insert (i, j) C) b =
    (if (i + j) mod 2 = b
      then insert (i, j) (evnodd C b) else evnodd C b)"
  by (simp add: evnodd_def)

subsection \<open>Dominoes\<close>

inductive_set domino :: "(nat \<times> nat) set set"
  where
    horiz: "{(i, j), (i, j + 1)} \<in> domino"
  | vertl: "{(i, j), (i + 1, j)} \<in> domino"

lemma dominoes_tile_row:
  "{i} \<times> below (2 * n) \<in> tiling domino"
  (is "?B n \<in> ?T")
proof (induct n)
  case 0
  show ?case by (simp add: below_0 tiling.empty)
next
  case (Suc n)
  let ?a = "{i} \<times> {2 * n + 1} \<union> {i} \<times> {2 * n}"
  have "?B (Suc n) = ?a \<union> ?B n"
    by (auto simp add: Sigma_Suc Un_assoc)
  also have "\<dots> \<in> ?T"
  proof (rule tiling.Un)
    have "{(i, 2 * n), (i, 2 * n + 1)} \<in> domino"
      by (rule domino.horiz)
    also have "{(i, 2 * n), (i, 2 * n + 1)} = ?a" by blast
    finally show "\<dots> \<in> domino" .
    show "?B n \<in> ?T" by (rule Suc)
    show "?a \<subseteq> - ?B n" by blast
  qed
  finally show ?case .
qed

lemma dominoes_tile_matrix:
  "below m \<times> below (2 * n) \<in> tiling domino"
  (is "?B m \<in> ?T")
proof (induct m)
  case 0
  show ?case by (simp add: below_0 tiling.empty)
next
  case (Suc m)
  let ?t = "{m} \<times> below (2 * n)"
  have "?B (Suc m) = ?t \<union> ?B m" by (simp add: Sigma_Suc)
  also have "\<dots> \<in> ?T"
  proof (rule tiling_Un)
    show "?t \<in> ?T" by (rule dominoes_tile_row)
    show "?B m \<in> ?T" by (rule Suc)
    show "?t \<inter> ?B m = {}" by blast
  qed
  finally show ?case .
qed

lemma domino_singleton:
  assumes "d \<in> domino"
    and "b < 2"
  shows "\<exists>i j. evnodd d b = {(i, j)}"  (is "?P d")
  using assms
proof induct
  from \<open>b < 2\<close> have b_cases: "b = 0 \<or> b = 1" by arith
  fix i j
  note [simp] = evnodd_empty evnodd_insert mod_Suc
  from b_cases show "?P {(i, j), (i, j + 1)}" by rule auto
  from b_cases show "?P {(i, j), (i + 1, j)}" by rule auto
qed

lemma domino_finite:
  assumes "d \<in> domino"
  shows "finite d"
  using assms
proof induct
  fix i j :: nat
  show "finite {(i, j), (i, j + 1)}" by (intro finite.intros)
  show "finite {(i, j), (i + 1, j)}" by (intro finite.intros)
qed

subsection \<open>Tilings of dominoes\<close>

lemma tiling_domino_finite:
  assumes t: "t \<in> tiling domino"  (is "t \<in> ?T")
  shows "finite t"  (is "?F t")
  using t
proof induct
  show "?F {}" by (rule finite.emptyI)
  fix a t assume "?F t"
  assume "a \<in> domino"
  then have "?F a" by (rule domino_finite)
  from this and \<open>?F t\<close> show "?F (a \<union> t)" by (rule finite_UnI)
qed

lemma tiling_domino_01:
  assumes t: "t \<in> tiling domino"  (is "t \<in> ?T")
  shows "card (evnodd t 0) = card (evnodd t 1)"
  using t
proof induct
  case empty
  show ?case by (simp add: evnodd_def)
next
  case (Un a t)
  let ?e = evnodd
  note hyp = \<open>card (?e t 0) = card (?e t 1)\<close>
    and at = \<open>a \<subseteq> - t\<close>
  have card_suc: "card (?e (a \<union> t) b) = Suc (card (?e t b))" if "b < 2" for b :: nat
  proof -
    have "?e (a \<union> t) b = ?e a b \<union> ?e t b" by (rule evnodd_Un)
    also obtain i j where e: "?e a b = {(i, j)}"
    proof -
      from \<open>a \<in> domino\<close> and \<open>b < 2\<close>
      have "\<exists>i j. ?e a b = {(i, j)}" by (rule domino_singleton)
      then show ?thesis by (blast intro: that)
    qed
    also have "\<dots> \<union> ?e t b = insert (i, j) (?e t b)" by simp
    also have "card \<dots> = Suc (card (?e t b))"
    proof (rule card_insert_disjoint)
      from \<open>t \<in> tiling domino\<close> have "finite t"
        by (rule tiling_domino_finite)
      then show "finite (?e t b)"
        by (rule evnodd_finite)
      from e have "(i, j) \<in> ?e a b" by simp
      with at show "(i, j) \<notin> ?e t b" by (blast dest: evnoddD)
    qed
    finally show ?thesis .
  qed
  then have "card (?e (a \<union> t) 0) = Suc (card (?e t 0))" by simp
  also from hyp have "card (?e t 0) = card (?e t 1)" .
  also from card_suc have "Suc \<dots> = card (?e (a \<union> t) 1)"
    by simp
  finally show ?case .
qed

subsection \<open>Main theorem\<close>

definition mutilated_board :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set"
  where "mutilated_board m n =
    below (2 * (m + 1)) \<times> below (2 * (n + 1)) - {(0, 0)} - {(2 * m + 1, 2 * n + 1)}"

theorem mutil_not_tiling: "mutilated_board m n \<notin> tiling domino"
proof (unfold mutilated_board_def)
  let ?T = "tiling domino"
  let ?t = "below (2 * (m + 1)) \<times> below (2 * (n + 1))"
  let ?t' = "?t - {(0, 0)}"
  let ?t'' = "?t' - {(2 * m + 1, 2 * n + 1)}"

  show "?t'' \<notin> ?T"
  proof
    have t: "?t \<in> ?T" by (rule dominoes_tile_matrix)
    assume t'': "?t'' \<in> ?T"

    let ?e = evnodd
    have fin: "finite (?e ?t 0)"
      by (rule evnodd_finite, rule tiling_domino_finite, rule t)

    note [simp] = evnodd_iff evnodd_empty evnodd_insert evnodd_Diff
    have "card (?e ?t'' 0) < card (?e ?t' 0)"
    proof -
      have "card (?e ?t' 0 - {(2 * m + 1, 2 * n + 1)})
        < card (?e ?t' 0)"
      proof (rule card_Diff1_less)
        from _ fin show "finite (?e ?t' 0)"
          by (rule finite_subset) auto
        show "(2 * m + 1, 2 * n + 1) \<in> ?e ?t' 0" by simp
      qed
      then show ?thesis by simp
    qed
    also have "\<dots> < card (?e ?t 0)"
    proof -
      have "(0, 0) \<in> ?e ?t 0" by simp
      with fin have "card (?e ?t 0 - {(0, 0)}) < card (?e ?t 0)"
        by (rule card_Diff1_less)
      then show ?thesis by simp
    qed
    also from t have "\<dots> = card (?e ?t 1)"
      by (rule tiling_domino_01)
    also have "?e ?t 1 = ?e ?t'' 1" by simp
    also from t'' have "card \<dots> = card (?e ?t'' 0)"
      by (rule tiling_domino_01 [symmetric])
    finally have "\<dots> < \<dots>" . then show False ..
  qed
qed

end


theory YT_tut_1 imports Main begin

value "2 + (2 :: nat)"
value "(2 :: nat) * (5+3)"

lemma "(x :: nat) + y = y + x" by auto

lemma "(x :: nat) + (y + z) = (x + y) + z" by auto

fun count :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
  "count [] _ = 0"
| "count (x#xs) x' = (if x = x' then Suc (count xs x') else count xs x')"

value "count [1,2,3,0,0] (0::nat)"

theorem "count xs x \<le> length xs"
apply (induction xs) apply auto done

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc [] x     = [x]"
| "snoc (x#xs) x' = x # (snoc xs x')"

value "snoc [86, 1] (42::nat)"
lemma "snoc [86, 1] (42::nat) = [86, 1, 42]" by auto

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse []     = []"
| "reverse (x#xs) = snoc (reverse xs) x"

value "reverse [1::nat,2,3,4]"

lemma reverse_snoc: "reverse (snoc ys a) = a # (reverse ys)" apply (induction ys) by auto

theorem "reverse (reverse xs) = xs" apply (induction xs) by (auto simp: reverse_snoc)

end


theory TeslDenotationalTickNum

imports "../TeslDenotationalOperators"

begin

text {*
  Number of ticks of clock c in a window [s, s+w]
*}
definition tick_num
where
  "tick_num c h s w \<equiv> card {i. s \<le> i \<and> i \<le> s+w \<and> ticks c (h i)}"

fun tick_num_fun :: "('a, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> nat \<Rightarrow> nat"
where
  "tick_num_fun c h s 0 = (if ticks c (h s) then 1 else 0)"
| "tick_num_fun c h s (Suc w) = (if ticks c (h (s + (Suc w)))
                                 then Suc (tick_num_fun c h s w)
                                 else tick_num_fun c h s w)"

text {*
  Some lemmas about cardinals
*}
lemma card_sing:"card {i. i = k \<and> P i} = (if P k then 1 else 0)"
proof (cases "P k")
  case True
    hence "{i. i = k \<and> P i} = {k}" by auto
    hence "card {i. i = k \<and> P i} = 1" by simp
    thus ?thesis using True by simp
next
  case False
    hence "{i. i = k \<and> P i} = {}" by auto
    hence "card {i. i = k \<and> P i} = 0" by simp
    thus ?thesis using False by simp
qed

lemma card_suc:"card {i. l \<le> i \<and> i \<le> l + (Suc h) \<and> P i} =
                  (if P (l + Suc h) then Suc (card {i. l \<le> i \<and> i \<le> l + h \<and> P i})
                                else card {i. l \<le> i \<and> i \<le> l + h \<and> P i})"
proof (cases "P (l + Suc h)")
  case True
    hence "{i. l \<le> i \<and> i \<le> l + (Suc h) \<and> P i} = {i. l \<le> i \<and> i \<le> l + h \<and> P i} \<union> {l + Suc h}" by auto
    hence "card {i. l \<le> i \<and> i \<le> l + (Suc h) \<and> P i} = Suc (card {i. l \<le> i \<and> i \<le> l + h \<and> P i})" by simp
    thus ?thesis using True by simp
next
  case False
    hence "{i. l \<le> i \<and> i \<le> l + (Suc h) \<and> P i} = {i. l \<le> i \<and> i \<le> l + h \<and> P i}" using le_Suc_eq by auto
    hence "card {i. l \<le> i \<and> i \<le> l + (Suc h) \<and> P i} = card {i. l \<le> i \<and> i \<le> l + h \<and> P i}" by simp
    thus ?thesis using False by simp
qed

text {*
  Equivalence of the denotational and the function definitions of tick_num.
*}
lemma tick_num_is_fun:"tick_num c h s w = tick_num_fun c h s w"
proof (induction w)
  case 0
    have "tick_num c h s 0 = card {i. s \<le> i \<and> i \<le> s+0 \<and> ticks c (h i)}" using tick_num_def by blast
    also have "... = card {i. s = i \<and> ticks c (h i)}" by (simp add: eq_iff)
    also have "... = card {i. i = s \<and> ticks c (h i)}" using eq_sym_conv[of _ "s"] by simp
    also have "... = (if ticks c (h s) then 1 else 0)" using card_sing[of "s" "\<lambda>i. ticks c (h i)"] .
    finally show ?case by simp
next
  case (Suc v)
    have "tick_num c h s (Suc v) = card {i. s \<le> i \<and> i \<le> s + (Suc v) \<and> ticks c (h i)}" using tick_num_def by blast
    also have "... = (if ticks c (h (s + Suc v))
                      then Suc (card {i. s \<le> i \<and> i \<le> s + v \<and> ticks c (h i)})
                      else card {i. s \<le> i \<and> i \<le> s + v \<and> ticks c (h i)})"  using card_suc by simp
    also have "... = (if ticks c (h (s + Suc v))
                      then Suc (tick_num c h s v)
                      else tick_num c h s v)" using tick_num_def[of "c" "h" "s" "v",symmetric] by simp
    finally show ?case using Suc.IH by simp
qed

text {*
  hasticked clk hmt from width n = clock clk, in a system with hamlet hmt, has ticked n times
                               in the interval [from, from+width]
*}
inductive hasticked :: "('a, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
where
  (* Base case for a singleton interval *)
  "\<not> ticks clk (hmt from) \<Longrightarrow> hasticked clk hmt from 0 0"
| "  ticks clk (hmt from) \<Longrightarrow> hasticked clk hmt from 0 1"
  (* Induction for larger intervals *)
| "hasticked clk hmt from w d \<and> \<not> ticks clk (hmt (from + (Suc w))) \<Longrightarrow> hasticked clk hmt from (Suc w) d"
| "hasticked clk hmt from w d \<and> ticks clk (hmt (from + (Suc w))) \<Longrightarrow> hasticked clk hmt from (Suc w) (Suc d)"

inductive_cases Ticked00[elim!]: "hasticked clk hmt from 0 0"
thm Ticked00
inductive_cases Ticked01[elim!]: "hasticked clk hmt from 0 1"
thm Ticked01
inductive_cases Tickedw0[elim!]: "hasticked clk hmt from (Suc w) d"
inductive_cases Tickedwd[elim!]: "hasticked clk hmt from (Suc w) (Suc d)"
inductive_cases Ticked0d[elim!]:"hasticked clk hmt from 0 d"
thm Ticked0d
inductive_cases Ticked0sd[elim!]:"hasticked clk hmt from 0 (Suc d)"
thm Ticked0sd

lemmas hasticked.intros[intro]

text {*
  Functional version of the inductive predicate
*}
fun hasticked_fun :: "('a, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "hasticked_fun clk hmt from 0 0 = (\<not>ticks clk (hmt from))"
| "hasticked_fun clk hmt from 0 (Suc 0) = ticks clk (hmt from)"
| "hasticked_fun clk hmt from (Suc w) 0 =
    (hasticked_fun clk hmt from w 0 \<and> \<not>ticks clk (hmt (from + (Suc w))))"
| "hasticked_fun clk hmt from (Suc w) (Suc d) = (
    (hasticked_fun clk hmt from w (Suc d) \<and> \<not>ticks clk (hmt (from + (Suc w))))
  \<or> (hasticked_fun clk hmt from w d \<and> ticks clk (hmt (from + (Suc w))))
   )"
| "hasticked_fun clk hmt from _ _ = False"

text {*
  Proof of equivalence of the two definitions.
*}
lemma hasticked_is_fun[code]: "hasticked clk hmt from w d = hasticked_fun clk hmt from w d"
proof (induction d arbitrary: w)
  case 0 thus ?case by (induction w, auto)
next
  case (Suc d') thus ?case
    proof (induction w)
      case 0 thus ?case
        proof (cases "d' = 0")
          case True thus ?thesis by (metis One_nat_def Ticked01 hasticked_fun.simps(2) hasticked.intros(2))
        next
          case False
            hence "\<not>hasticked clk hmt from 0 (Suc d')" using Ticked0sd by blast
            moreover have "\<not>hasticked_fun clk hmt from 0 (Suc d')" by (metis False hasticked_fun.simps(5) lessI less_Suc_eq_0_disj)
            ultimately show ?thesis by simp
        qed
    next
      case (Suc w') thus ?case by auto
    qed
qed

text {*
  hasjustticked clk hmt from width n = clock c, in a system with hamlet h, has ticked for the nth time
                                       at the end of the interval [from, from+width]
*}
inductive hasjustticked :: "('a, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "ticks clk (hmt from) \<Longrightarrow> hasjustticked clk hmt from 0 1"
| "hasticked clk hmt from w d \<and> ticks clk (hmt (from + (Suc w)))
    \<Longrightarrow> hasjustticked clk hmt from (Suc w) (Suc d)"

fun hasjustticked_fun :: "('a, 'b)\<H> \<Rightarrow> hamlet \<Rightarrow> instant \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "hasjustticked_fun clk hmt from 0 (Suc 0) = ticks clk (hmt from)"
| "hasjustticked_fun clk hmt from (Suc w) (Suc d)
    = (hasticked_fun clk hmt from w d \<and> ticks clk (hmt (from + (Suc w))))"
| "hasjustticked_fun clk hmt from w 0 = False"
| "hasjustticked_fun clk hmt from 0 (Suc (Suc d)) = False"

end


(*  Title:       Partitions
    Authors:     Thomas Tuerk <tuerk@in.tum.de>
*)

section \<open> Partition \<close>

theory Partition
imports Main
begin

definition is_partition :: "'a set \<Rightarrow> ('a set) set \<Rightarrow> bool" where
  "is_partition Q P \<longleftrightarrow>
   (\<Union>P = Q) \<and> ({} \<notin> P) \<and> (\<forall>p1 p2. p1 \<in> P \<and> p2 \<in> P \<and> p1 \<noteq> p2 \<longrightarrow> p1 \<inter> p2 = {})"

lemma is_partitionI [intro!]:
  "\<lbrakk>\<And>q. q \<in> Q \<Longrightarrow> q \<in> \<Union>P;
    \<And>p. p \<in> P \<Longrightarrow> p \<subseteq> Q;
    \<And>p. p \<in> P \<Longrightarrow> p \<noteq> {};
    \<And>q p1 p2. \<lbrakk>p1 \<in> P; p2 \<in> P; q \<in> p1; q \<in> p2\<rbrakk> \<Longrightarrow> p1 = p2
   \<rbrakk> \<Longrightarrow> is_partition Q P"
unfolding is_partition_def
by auto metis+

lemma is_partition_Nil_Q :
  "is_partition {} P \<longleftrightarrow> P = {}"
unfolding is_partition_def
by auto

lemma is_partition_Nil [simp] :
  "is_partition Q {} \<longleftrightarrow> Q = {}"
unfolding is_partition_def
by auto

lemma is_partition_Insert :
assumes p_nin: "p \<notin> P"
shows "is_partition Q (insert p P) \<longleftrightarrow>
       (p \<noteq> {}) \<and> (p \<subseteq> Q) \<and> is_partition (Q - p) P"
proof (cases "p \<noteq> {} \<and> ({} \<notin> P) \<and> p \<subseteq> Q")
  case False thus ?thesis
    unfolding is_partition_def
    by (rule_tac iffI, auto)
next
  case True
  note p_not_Emp = conjunct1 [OF True]
  note P_not_Emp = conjunct1 [OF conjunct2 [OF True]]
  note p_subset = conjunct2 [OF conjunct2 [OF True]]

  have "(p \<union> \<Union>P = Q \<and>
        (\<forall>p1 p2. (p1 = p \<or> p1 \<in> P) \<and> (p2 = p \<or> p2 \<in> P) \<and> p1 \<noteq> p2 \<longrightarrow> p1 \<inter> p2 = {})) =
        (\<Union>P = Q - p \<and> (\<forall>p1 p2. p1 \<in> P \<and> p2 \<in> P \<and> p1 \<noteq> p2 \<longrightarrow> p1 \<inter> p2 = {}))"
     (is "?l1 \<and> ?l2 \<longleftrightarrow> ?r1 \<and> ?r2")
  proof (intro iffI conjI)
    assume r12: "?r1 \<and> ?r2"
    note r1 = conjunct1 [OF r12]
    note r2 = conjunct2 [OF r12]

    from r1 show "?l1" using p_subset by auto

    have p_disjoint : "\<And>p'. p' \<in> P \<Longrightarrow> p \<inter> p' = {}"
    proof -
      fix p'
      assume "p' \<in> P"
      with r1 have "p' \<subseteq> Q - p"
        by auto
      thus "p \<inter> p' = {}" by auto
    qed

    with r2 show ?l2 by blast
  next
    assume l12: "?l1 \<and> ?l2"
    note l1 = conjunct1 [OF l12]
    note l2 = conjunct2 [OF l12]

    from l2 show ?r2 by blast

    from l2 p_nin
    have p_disjoint : "\<And>p'. p' \<in> P \<Longrightarrow> p \<inter> p' = {}" by blast
    with l1 show ?r1 by auto
  qed
  with p_not_Emp P_not_Emp p_subset show ?thesis
    unfolding is_partition_def
    by simp
qed

lemma is_partition_in_subset :
assumes is_part: "is_partition Q P"
    and p_in: "p \<in> P"
shows "p \<subseteq> Q"
using assms
unfolding is_partition_def
by auto

lemma is_partition_memb_finite :
assumes fin_Q: "finite Q"
    and is_part: "is_partition Q P"
    and p_in: "p \<in> P"
shows "finite p"
by (metis finite_subset[OF _ fin_Q] is_partition_in_subset[OF is_part p_in])

lemma is_partition_distinct_subset :
assumes is_part: "is_partition Q P"
    and p_in: "p \<in> P"
    and p'_sub: "p' \<subseteq> p"
shows "p' \<notin> P - {p}"
proof (rule notI)
  assume p'_in: "p' \<in> P - {p}"

  with is_part have "p' \<noteq> {}"
    unfolding is_partition_def by auto
  hence "p' \<inter> p \<noteq> {}" using p'_sub by auto

  with is_part show False
    using p'_in p_in
    unfolding is_partition_def
    by blast
qed

lemma is_partition_finite :
assumes fin_Q: "finite Q"
    and is_part: "is_partition Q P"
shows "finite P"
proof -
  from is_part have "P \<subseteq> Pow Q"
    unfolding is_partition_def by auto
  moreover
  from fin_Q have "finite (Pow Q)" by blast
  ultimately show "finite P"
    by (metis finite_subset)
qed

lemma is_partition_card :
assumes fin_Q: "finite Q"
    and is_part: "is_partition Q P"
shows "card Q = sum card P"
proof -
  have fin_P: "finite P"
    using is_partition_finite [OF fin_Q is_part]
    .

  have "finite P \<Longrightarrow> finite Q \<Longrightarrow> is_partition Q P \<Longrightarrow> card Q = sum card P"
  proof (induct arbitrary: Q rule: finite_induct)
    case empty thus ?case by simp
  next
    case (insert p P Q)
    note fin_P = insert(1)
    note p_nin_P = insert(2)
    note ind_hyp = insert(3)
    note fin_Q = insert(4)
    note is_part_pP = insert(5)

    from is_part_pP p_nin_P have is_part_P: "is_partition (Q - p) P"
      and p_neq_Nil: "p \<noteq> {}" and p_subset: "p \<subseteq> Q"
      by (simp_all add: is_partition_Insert)

    from p_subset fin_Q have fin_p: "finite p" by (metis finite_subset)
    from fin_Q have fin_Q_p: "finite (Q - p)" by simp
    from p_subset have card_p: "card p \<le> card Q"
      using card_mono [OF fin_Q] by simp

    show ?case
      using sum.insert [OF fin_P p_nin_P, of card]
            card_Diff_subset [OF fin_p p_subset]
            ind_hyp[OF fin_Q_p is_part_P, symmetric]
            card_p
      by simp
  qed
  with fin_Q fin_P is_part
  show ?thesis by simp
qed

lemma is_partition_card_P :
assumes fin_Q: "finite Q"
    and is_part: "is_partition Q P"
shows "card P \<le> card Q"
proof -
  from is_partition_card [OF fin_Q is_part]
  have "card Q = sum card P" .
  moreover
  have "sum (\<lambda>p. 1) P \<le> sum card P"
  proof (rule sum_mono)
    fix p
    assume "p \<in> P"
    with is_part have p_neq_Nil: "p \<noteq> {}" and p_sub: "p \<subseteq> Q"
      unfolding is_partition_def
      by auto
    from p_sub fin_Q have "finite p" by (metis finite_subset)
    with p_neq_Nil have "card p \<noteq> 0"
      by (simp add: card_eq_0_iff)
    thus "1 \<le> card p" by auto
  qed
  moreover
  have "sum (\<lambda>p. 1) P = card P"
    by (metis card_eq_sum)
  ultimately show ?thesis by simp
qed

lemma is_partition_find :
assumes is_part: "is_partition Q P"
    and q_in_Q: "q \<in> Q"
shows "\<exists>!p. p \<in> P \<and> q \<in> p"
using assms
unfolding is_partition_def
by auto

lemma is_partition_refine :
assumes fin_Q:         "finite Q"
    and p_nin:         "p \<notin> P"
    and is_part:       "is_partition Q (insert p P)"
    and p1_p2_neq_emp: "p1 \<noteq> {}" "p2 \<noteq> {}"
    and p1_p2_disj: "p1 \<inter> p2 = {}"
    and p1_p2_union: "p = p1 \<union> p2"
shows "is_partition Q (insert p1 (insert p2 P)) \<and>
       card (insert p1 (insert p2 P)) = Suc (card (insert p P))"
proof
  from p1_p2_neq_emp p1_p2_disj
  have p1_neq_p2: "p1 \<noteq> p2" by auto

  have q_disj: "\<And>p'. p' \<subseteq> p \<Longrightarrow> p' \<notin> P"
  proof (rule notI)
    fix p'
    assume p'_sub: "p' \<subseteq> p"
    assume p'_in: "p' \<in> P"

    from is_part p'_in p_nin have "p' \<inter> p = {} \<and> p' \<noteq> {}"
      unfolding is_partition_def by blast
    with p'_sub show "False" by auto
  qed
  hence p1_nin: "p1 \<notin> insert p2 P" and
        p2_nin: "p2 \<notin> P"
    unfolding p1_p2_union using p1_neq_p2 by auto

  have "Q - p = Q - p1 - p2"
    unfolding p1_p2_union by auto
  with is_part p1_p2_disj
  show "is_partition Q (insert p1 (insert p2 P))"
    using p_nin p1_nin p2_nin
    apply (simp add: is_partition_Insert p1_p2_neq_emp)
    apply (simp add: p1_p2_union)
    apply auto
  done

  have "finite P" using is_partition_finite[OF fin_Q is_part] by simp
  thus "card (insert p1 (insert p2 P)) = Suc (card (insert p P))"
    using p_nin p2_nin p1_nin
    by (simp add: card_insert_if)
qed

subsection \<open> Partitions and Equivalence Relations \<close>

lemma quotient_of_equiv_relation_is_partition :
assumes eq_r: "equiv Q r"
shows "is_partition Q (Q//r)"
proof -
  note Q_eq = Union_quotient[OF eq_r]
  note quot_disj = quotient_disj [OF eq_r]

  from eq_r have "\<And>q. q \<in> Q \<Longrightarrow> (q, q) \<in> r"
    unfolding equiv_def refl_on_def by simp
  hence emp_nin: "{} \<notin> Q // r"
    by (simp add: quotient_def Image_def) blast

  from Q_eq quot_disj emp_nin
  show ?thesis by blast
qed

definition relation_of_partition where
  "relation_of_partition P = {(q1, q2). \<exists>Q \<in> P. q1 \<in> Q \<and> q2 \<in> Q}"

lemma relation_of_partition_is_equiv :
assumes part_P: "is_partition Q P"
shows "equiv Q (relation_of_partition P)"
using is_partition_in_subset[OF part_P] is_partition_find[OF part_P]
unfolding equiv_def relation_of_partition_def refl_on_def sym_def trans_def
by (auto simp add: subset_iff Ball_def Bex_def) metis+

definition partition_less_eq where
"partition_less_eq P1 P2 \<longleftrightarrow> relation_of_partition P1 \<subseteq> relation_of_partition P2"

lemma relation_of_partition_inverse :
assumes part_P: "is_partition Q P"
shows "Q // (relation_of_partition P) = P"
  (is "?ls = ?rs")
proof
  {
    fix q
    assume q_in: "q \<in> Q"
    from is_partition_find[OF part_P q_in]
    obtain p where p_props: "p \<in> P" "q \<in> p" "\<And>p'. \<lbrakk>p' \<in> P; q \<in> p'\<rbrakk> \<Longrightarrow> p' = p" by auto

    have "{q2. \<exists>Q\<in>P. q \<in> Q \<and> q2 \<in> Q} = p"
      apply (intro set_eqI)
      apply (simp add: Bex_def)
      apply (metis p_props)
    done
    with p_props(1)
    have "{q2. \<exists>Q\<in>P. q \<in> Q \<and> q2 \<in> Q} \<in> P" by simp
  }
  thus "?ls \<subseteq> ?rs"
    unfolding relation_of_partition_def quotient_def
    by auto
next
  {
    fix p
    assume p_in: "p \<in> P"
    from p_in part_P have "p \<noteq> {}" unfolding is_partition_def by blast
    then obtain q where q_in_p: "q \<in> p" by auto

    with is_partition_in_subset[OF part_P p_in] have q_in_Q: "q \<in> Q" by blast

    from is_partition_find[OF part_P q_in_Q] p_in q_in_p
    have p_dist: "\<And>p'. \<lbrakk>p' \<in> P; q \<in> p'\<rbrakk> \<Longrightarrow> p' = p" by auto

    have "{q2. \<exists>Q\<in>P. q \<in> Q \<and> q2 \<in> Q} = p"
      apply (intro set_eqI)
      apply (simp add: Bex_def)
      apply (metis p_dist p_in q_in_p)
    done
    hence "\<exists>q\<in>Q. p = {q2. \<exists>Q\<in>P. q \<in> Q \<and> q2 \<in> Q}"
      unfolding Bex_def
      apply (rule_tac exI [where x = q])
      apply (simp add: q_in_Q)
    done
  }
  thus "?rs \<subseteq> ?ls"
    unfolding relation_of_partition_def quotient_def
    by auto
qed

lemma quotient_inverse :
assumes eq_r: "equiv Q r"
shows "(relation_of_partition (Q // r)) = r"
  (is "?ls = ?rs")
using eq_r
unfolding relation_of_partition_def quotient_def
apply (rule_tac set_eqI)
apply auto
apply (metis equiv_def sym_def trans_def)
apply (simp add: equiv_def refl_on_def subset_iff sym_def)
apply metis
done

end