(*  Title:      HOL/Isar_Examples/Fibonacci.thy
    Author:     Gertrud Bauer
    Copyright   1999 Technische Universitaet Muenchen

The Fibonacci function.  Original
tactic script by Lawrence C Paulson.

Fibonacci numbers: proofs of laws taken from

  R. L. Graham, D. E. Knuth, O. Patashnik.
  Concrete Mathematics.
  (Addison-Wesley, 1989)
*)

section \<open>Fib and Gcd commute\<close>

theory Fibonacci
  imports "HOL-Computational_Algebra.Primes"
begin

text_raw \<open>\<^footnote>\<open>Isar version by Gertrud Bauer. Original tactic script by Larry
  Paulson. A few proofs of laws taken from \<^cite>\<open>"Concrete-Math"\<close>.\<close>\<close>

subsection \<open>Fibonacci numbers\<close>

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

text \<open>Alternative induction rule.\<close>

theorem fib_induct: "P 0 \<Longrightarrow> P 1 \<Longrightarrow> (\<And>n. P (n + 1) \<Longrightarrow> P n \<Longrightarrow> P (n + 2)) \<Longrightarrow> P n"
  for n :: nat
  by (induct rule: fib.induct) simp_all

subsection \<open>Fib and gcd commute\<close>

text \<open>A few laws taken from \<^cite>\<open>"Concrete-Math"\<close>.\<close>

lemma fib_add: "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n"
  (is "?P n")
  \<comment> \<open>see \<^cite>\<open>\<open>page 280\<close> in "Concrete-Math"\<close>\<close>
proof (induct n rule: fib_induct)
  show "?P 0" by simp
  show "?P 1" by simp
  fix n
  have "fib (n + 2 + k + 1)
    = fib (n + k + 1) + fib (n + 1 + k + 1)" by simp
  also assume "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n" (is " _ = ?R1")
  also assume "fib (n + 1 + k + 1) = fib (k + 1) * fib (n + 1 + 1) + fib k * fib (n + 1)"
    (is " _ = ?R2")
  also have "?R1 + ?R2 = fib (k + 1) * fib (n + 2 + 1) + fib k * fib (n + 2)"
    by (simp add: add_mult_distrib2)
  finally show "?P (n + 2)" .
qed

lemma coprime_fib_Suc: "coprime (fib n) (fib (n + 1))"
  (is "?P n")
proof (induct n rule: fib_induct)
  show "?P 0" by simp
  show "?P 1" by simp
  fix n
  assume P: "coprime (fib (n + 1)) (fib (n + 1 + 1))"
  have "fib (n + 2 + 1) = fib (n + 1) + fib (n + 2)"
    by simp
  also have "\<dots> = fib (n + 2) + fib (n + 1)"
    by simp
  also have "gcd (fib (n + 2)) \<dots> = gcd (fib (n + 2)) (fib (n + 1))"
    by (rule gcd_add2)
  also have "\<dots> = gcd (fib (n + 1)) (fib (n + 1 + 1))"
    by (simp add: gcd.commute)
  also have "\<dots> = 1"
    using P by simp
  finally show "?P (n + 2)"
    by (simp add: coprime_iff_gcd_eq_1)
qed

lemma gcd_mult_add: "(0::nat) < n \<Longrightarrow> gcd (n * k + m) n = gcd m n"
proof -
  assume "0 < n"
  then have "gcd (n * k + m) n = gcd n (m mod n)"
    by (simp add: gcd_non_0_nat add.commute)
  also from \<open>0 < n\<close> have "\<dots> = gcd m n"
    by (simp add: gcd_non_0_nat)
  finally show ?thesis .
qed

lemma gcd_fib_add: "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
proof (cases m)
  case 0
  then show ?thesis by simp
next
  case (Suc k)
  then have "gcd (fib m) (fib (n + m)) = gcd (fib (n + k + 1)) (fib (k + 1))"
    by (simp add: gcd.commute)
  also have "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n"
    by (rule fib_add)
  also have "gcd \<dots> (fib (k + 1)) = gcd (fib k * fib n) (fib (k + 1))"
    by (simp add: gcd_mult_add)
  also have "\<dots> = gcd (fib n) (fib (k + 1))"
    using coprime_fib_Suc [of k] gcd_mult_left_right_cancel [of "fib (k + 1)" "fib k" "fib n"]
    by (simp add: ac_simps)
  also have "\<dots> = gcd (fib m) (fib n)"
    using Suc by (simp add: gcd.commute)
  finally show ?thesis .
qed

lemma gcd_fib_diff: "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)" if "m \<le> n"
proof -
  have "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib (n - m + m))"
    by (simp add: gcd_fib_add)
  also from \<open>m \<le> n\<close> have "n - m + m = n"
    by simp
  finally show ?thesis .
qed

lemma gcd_fib_mod: "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" if "0 < m"
proof (induct n rule: nat_less_induct)
  case hyp: (1 n)
  show ?case
  proof -
    have "n mod m = (if n < m then n else (n - m) mod m)"
      by (rule mod_if)
    also have "gcd (fib m) (fib \<dots>) = gcd (fib m) (fib n)"
    proof (cases "n < m")
      case True
      then show ?thesis by simp
    next
      case False
      then have "m \<le> n" by simp
      from \<open>0 < m\<close> and False have "n - m < n"
        by simp
      with hyp have "gcd (fib m) (fib ((n - m) mod m))
          = gcd (fib m) (fib (n - m))" by simp
      also have "\<dots> = gcd (fib m) (fib n)"
        using \<open>m \<le> n\<close> by (rule gcd_fib_diff)
      finally have "gcd (fib m) (fib ((n - m) mod m)) =
          gcd (fib m) (fib n)" .
      with False show ?thesis by simp
    qed
    finally show ?thesis .
  qed
qed

theorem fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)"
  (is "?P m n")
proof (induct m n rule: gcd_nat_induct)
  fix m n :: nat
  show "fib (gcd m 0) = gcd (fib m) (fib 0)"
    by simp
  assume n: "0 < n"
  then have "gcd m n = gcd n (m mod n)"
    by (simp add: gcd_non_0_nat)
  also assume hyp: "fib \<dots> = gcd (fib n) (fib (m mod n))"
  also from n have "\<dots> = gcd (fib n) (fib m)"
    by (rule gcd_fib_mod)
  also have "\<dots> = gcd (fib m) (fib n)"
    by (rule gcd.commute)
  finally show "fib (gcd m n) = gcd (fib m) (fib n)" .
qed

end


(* Title:      Residuated Boolean Algebras
   Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Residuated Boolean Algebras\<close>

theory Residuated_Boolean_Algebras
  imports Residuated_Lattices
begin

unbundle lattice_syntax

subsection \<open>Conjugation on Boolean Algebras\<close>

text \<open>
  Similarly, as in the previous section, we define the conjugation for
  arbitrary residuated functions on boolean algebras.
\<close>

context boolean_algebra
begin

lemma inf_bot_iff_le: "x \<sqinter> y = \<bottom> \<longleftrightarrow> x \<le> -y"
  by (metis le_iff_inf inf_sup_distrib1 inf_top_right sup_bot.left_neutral sup_compl_top compl_inf_bot inf.assoc inf_bot_right)

lemma le_iff_inf_bot: "x \<le> y \<longleftrightarrow> x \<sqinter> -y = \<bottom>"
  by (metis inf_bot_iff_le compl_le_compl_iff inf_commute)

lemma indirect_eq: "(\<And>z. x \<le> z \<longleftrightarrow> y \<le> z) \<Longrightarrow> x = y"
  by (metis order.eq_iff)

text \<open>
  Let $B$ be a boolean algebra. The maps $f$ and $g$ on $B$ are
  a pair of conjugates if and only if for all $x, y \in B$,
  $f(x) \sqcap y = \bot \Leftrightarrow x \sqcap g(t) = \bot$.
\<close>

definition conjugation_pair :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "conjugation_pair f g \<equiv> \<forall>x y. f(x) \<sqinter> y = \<bottom> \<longleftrightarrow> x \<sqinter> g(y) = \<bottom>"

lemma conjugation_pair_commute: "conjugation_pair f g \<Longrightarrow> conjugation_pair g f"
  by (auto simp: conjugation_pair_def inf_commute)

lemma conjugate_iff_residuated: "conjugation_pair f g = residuated_pair f (\<lambda>x. -g(-x))"
  apply (clarsimp simp: conjugation_pair_def residuated_pair_def inf_bot_iff_le)
  by (metis double_compl)

lemma conjugate_residuated: "conjugation_pair f g \<Longrightarrow> residuated_pair f (\<lambda>x. -g(-x))"
  by (metis conjugate_iff_residuated)

lemma residuated_iff_conjugate: "residuated_pair f g = conjugation_pair f (\<lambda>x. -g(-x))"
  apply (clarsimp simp: conjugation_pair_def residuated_pair_def inf_bot_iff_le)
  by (metis double_compl)

text \<open>
  A map $f$ has a conjugate pair if and only if it is residuated.
\<close>

lemma conj_residuatedI1: "\<exists>g. conjugation_pair f g \<Longrightarrow> residuated f"
  by (metis conjugate_iff_residuated residuated_def)

lemma conj_residuatedI2: "\<exists>g. conjugation_pair g f \<Longrightarrow> residuated f"
  by (metis conj_residuatedI1 conjugation_pair_commute)

lemma exist_conjugateI[intro]: "residuated f \<Longrightarrow> \<exists>g. conjugation_pair f g"
  by (metis residuated_def residuated_iff_conjugate)

lemma exist_conjugateI2[intro]: "residuated f \<Longrightarrow> \<exists>g. conjugation_pair g f"
  by (metis exist_conjugateI conjugation_pair_commute)

text \<open>
  The conjugate of a residuated function $f$ is unique.
\<close>

lemma unique_conjugate[intro]: "residuated f \<Longrightarrow> \<exists>!g. conjugation_pair f g"
proof -
  {
    fix g h x assume "conjugation_pair f g" and "conjugation_pair f h"
    hence "g = h"
      apply (unfold conjugation_pair_def)
      apply (rule ext)
      apply (rule order.antisym)
      by (metis le_iff_inf_bot inf_commute inf_compl_bot)+
  }
  moreover assume "residuated f"
  ultimately show ?thesis by force
qed

lemma unique_conjugate2[intro]: "residuated f \<Longrightarrow> \<exists>!g. conjugation_pair g f"
  by (metis unique_conjugate conjugation_pair_commute)

text \<open>
  Since the conjugate of a residuated map is unique, we define a
  conjugate operation.
\<close>

definition conjugate :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "conjugate f \<equiv> THE g. conjugation_pair g f"

lemma conjugate_iff_def: "residuated f \<Longrightarrow> f(x) \<sqinter> y = \<bottom> \<longleftrightarrow> x \<sqinter> conjugate f y = \<bottom>"
  apply (clarsimp simp: conjugate_def dest!: unique_conjugate)
  apply (subgoal_tac "(THE g. conjugation_pair g f) = g")
  apply (clarsimp simp add: conjugation_pair_def)
  apply (rule the1_equality)
  by (auto intro: conjugation_pair_commute)

lemma conjugateI1: "residuated f \<Longrightarrow> f(x) \<sqinter> y = \<bottom> \<Longrightarrow> x \<sqinter> conjugate f y = \<bottom>"
  by (metis conjugate_iff_def)

lemma conjugateI2: "residuated f \<Longrightarrow> x \<sqinter> conjugate f y = \<bottom> \<Longrightarrow> f(x) \<sqinter> y = \<bottom>"
  by (metis conjugate_iff_def)

text \<open>
  Few more lemmas about conjugation follow.
\<close>

lemma residuated_conj1: "residuated f \<Longrightarrow> conjugation_pair f (conjugate f)"
  using conjugateI1 conjugateI2 conjugation_pair_def by auto

lemma residuated_conj2: "residuated f \<Longrightarrow> conjugation_pair (conjugate f) f"
  using conjugateI1 conjugateI2 conjugation_pair_def inf_commute by auto

lemma conj_residuated: "residuated f \<Longrightarrow> residuated (conjugate f)"
  by (force dest!: residuated_conj2 intro: conj_residuatedI1)

lemma conj_involution: "residuated f \<Longrightarrow> conjugate (conjugate f) = f"
  by (metis conj_residuated residuated_conj1 residuated_conj2 unique_conjugate)

lemma residual_conj_eq: "residuated f \<Longrightarrow> residual (conjugate f) = (\<lambda>x. -f(-x))"
  apply (unfold residual_def)
  apply (rule the1_equality)
  apply (rule residual_unique)
  apply (auto intro: conj_residuated conjugate_residuated residuated_conj2)
done

lemma residual_conj_eq_ext: "residuated f \<Longrightarrow> residual (conjugate f) x = -f(-x)"
  by (metis residual_conj_eq)

lemma conj_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> conjugate f x \<le> conjugate f y"
  by (metis conj_residuated res_iso)

lemma conjugate_strict: "residuated f \<Longrightarrow> conjugate f \<bottom> = \<bottom>"
  by (metis conj_residuated residuated_strict)

lemma conjugate_sup: "residuated f \<Longrightarrow> conjugate f (x \<squnion> y) = conjugate f x \<squnion> conjugate f y"
  by (metis conj_residuated residuated_sup)

lemma conjugate_subinf: "residuated f \<Longrightarrow> conjugate f (x \<sqinter> y) \<le> conjugate f x \<sqinter> conjugate f y"
  by (auto simp: conj_iso)

text \<open>
  Next we prove some lemmas from Maddux's article. Similar lemmas have been proved in AFP entry
  for relation algebras. They should be consolidated in the future.
\<close>

lemma maddux1: "residuated f \<Longrightarrow> f(x \<sqinter> - conjugate f(y)) \<le> f(x) \<sqinter> -y"
proof -
  assume assm: "residuated f"
  hence "f(x \<sqinter> - conjugate f(y)) \<le> f x"
    by (metis inf_le1 res_iso)
  moreover have "f(x \<sqinter> - conjugate f (y)) \<sqinter> y = \<bottom>"
    by (metis assm conjugateI2 inf_bot_iff_le inf_le2)
  ultimately show ?thesis
    by (metis inf_bot_iff_le le_inf_iff)
qed

lemma maddux1': "residuated f \<Longrightarrow> conjugate f(x \<sqinter> -f(y)) \<le> conjugate f(x) \<sqinter> -y"
  by (metis conj_involution conj_residuated maddux1)

lemma maddux2: "residuated f \<Longrightarrow> f(x) \<sqinter> y \<le> f(x \<sqinter> conjugate f y)"
proof -
  assume resf: "residuated f"
  obtain z where z_def: "z = f(x \<sqinter> conjugate f y)" by auto
  hence "f(x \<sqinter> conjugate f y) \<sqinter> -z = \<bottom>"
    by (metis inf_compl_bot)
  hence "x \<sqinter> conjugate f y \<sqinter> conjugate f (-z) = \<bottom>"
    by (metis conjugate_iff_def resf)
  hence "x \<sqinter> conjugate f (y \<sqinter> -z) = \<bottom>"
    apply (subgoal_tac "conjugate f (y \<sqinter> -z) \<le> conjugate f y \<sqinter> conjugate f (-z)")
    apply (metis (no_types, opaque_lifting) dual_order.trans inf.commute inf_bot_iff_le inf_left_commute)
    by (metis conj_iso inf_le2 inf_top.left_neutral le_inf_iff resf)
  hence "f(x) \<sqinter> y \<sqinter> -z = \<bottom>"
    by (metis conjugateI2 inf.assoc resf)
  thus ?thesis
    by (metis double_compl inf_bot_iff_le z_def)
qed

lemma maddux2': "residuated f \<Longrightarrow> conjugate f(x) \<sqinter> y \<le> conjugate f(x \<sqinter> f y)"
  by (metis conj_involution conj_residuated maddux2)

lemma residuated_conjugate_ineq: "residuated f \<Longrightarrow> conjugate f x \<le> y \<longleftrightarrow> x \<le> -f(-y)"
  by (metis conj_residuated residual_galois residual_conj_eq)

lemma residuated_comp_closed: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> residuated (f o g)"
  by (auto simp add: residuated_def residuated_pair_def)

lemma conjugate_comp: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> conjugate (f o g) = conjugate g o conjugate f"
proof (rule ext, rule indirect_eq)
  fix x y
  assume assms: "residuated f" "residuated g"
  have "conjugate (f o g) x \<le> y \<longleftrightarrow> x \<le> -f(g(-y))"
    apply (subst residuated_conjugate_ineq)
    using assms by (auto intro!: residuated_comp_closed)
  also have "... \<longleftrightarrow> conjugate g (conjugate f x) \<le> y"
    using assms by (simp add: residuated_conjugate_ineq)
  finally show "(conjugate (f \<circ> g) x \<le> y) = ((conjugate g \<circ> conjugate f) x \<le> y)"
    by auto
qed

lemma conjugate_comp_ext: "residuated f \<Longrightarrow> residuated g \<Longrightarrow> conjugate (\<lambda>x. f (g x)) x = conjugate g (conjugate f x)"
  using conjugate_comp by (simp add: comp_def)

end (* boolean_algebra *)

context complete_boolean_algebra begin

text \<open>
  On a complete boolean algebra, it is possible to give an explicit
  definition of conjugation.
\<close>

lemma conjugate_eq: "residuated f \<Longrightarrow> conjugate f y = \<Sqinter>{x. y \<le> -f(-x)}"
proof -
  assume assm: "residuated f" obtain g where g_def: "g = conjugate f" by auto
  have "g y = \<Sqinter>{x. x \<ge> g y}"
    by (auto intro!: order.antisym Inf_lower Inf_greatest)
  also have "... = \<Sqinter>{x. -x \<sqinter> g y = \<bottom>}"
    by (simp add: inf_bot_iff_le)
  also have "... = \<Sqinter>{x. f(-x) \<sqinter> y = \<bottom>}"
    by (metis conjugate_iff_def assm g_def)
  finally show ?thesis
    by (simp add: g_def le_iff_inf_bot inf_commute)
qed

end (* complete_boolean_algebra *)

subsection \<open>Residuated Boolean Structures\<close>

text \<open>
  In this section, we present various residuated structures based on
  boolean algebras.
  The left and right conjugation of the multiplicative operation is
  defined, and a number of facts is derived.
\<close>

class residuated_boolean_algebra = boolean_algebra + residuated_pogroupoid
begin

subclass residuated_lgroupoid ..

definition conjugate_l :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<lhd>" 60) where
  "x \<lhd> y \<equiv> -(-x \<leftarrow> y)"

definition conjugate_r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<rhd>" 60) where
  "x \<rhd> y \<equiv> -(x \<rightarrow> -y)"

lemma residual_conjugate_r: "x \<rightarrow> y = -(x \<rhd> -y)"
  by (metis conjugate_r_def double_compl)

lemma residual_conjugate_l: "x \<leftarrow> y = -(-x \<lhd> y)"
  by (metis conjugate_l_def double_compl)

lemma conjugation_multl: "x\<cdot>y \<sqinter> z = \<bottom> \<longleftrightarrow> x \<sqinter> (z \<lhd> y) = \<bottom>"
  by (metis conjugate_l_def double_compl le_iff_inf_bot resl_galois)

lemma conjugation_multr: "x\<cdot>y \<sqinter> z = \<bottom> \<longleftrightarrow> y \<sqinter> (x \<rhd> z) = \<bottom>"
  by (metis conjugate_r_def inf_bot_iff_le le_iff_inf_bot resr_galois)

lemma conjugation_conj: "(x \<lhd> y) \<sqinter> z = \<bottom> \<longleftrightarrow> y \<sqinter> (z \<rhd> x) = \<bottom>"
  by (metis inf_commute conjugation_multr conjugation_multl)

lemma conjugation_pair_multl [simp]: "conjugation_pair (\<lambda>x. x\<cdot>y) (\<lambda>x. x \<lhd> y)"
  by (simp add: conjugation_pair_def conjugation_multl)

lemma conjugation_pair_multr [simp]: "conjugation_pair (\<lambda>x. y\<cdot>x) (\<lambda>x. y \<rhd> x)"
  by (simp add: conjugation_pair_def conjugation_multr)

lemma conjugation_pair_conj [simp]: "conjugation_pair (\<lambda>x. y \<lhd> x) (\<lambda>x. x \<rhd> y)"
  by (simp add: conjugation_pair_def conjugation_conj)

lemma residuated_conjl1 [simp]: "residuated (\<lambda>x. x \<lhd> y)"
  by (metis conj_residuatedI2 conjugation_pair_multl)

lemma residuated_conjl2 [simp]: "residuated (\<lambda>x. y \<lhd> x)"
  by (metis conj_residuatedI1 conjugation_pair_conj)

lemma residuated_conjr1 [simp]: "residuated (\<lambda>x. y \<rhd> x)"
  by (metis conj_residuatedI2 conjugation_pair_multr)

lemma residuated_conjr2 [simp]: "residuated (\<lambda>x. x \<rhd> y)"
  by (metis conj_residuatedI2 conjugation_pair_conj)

lemma conjugate_multr [simp]: "conjugate (\<lambda>x. y\<cdot>x) = (\<lambda>x. y \<rhd> x)"
  by (metis conjugation_pair_multr residuated_conj1 residuated_multr unique_conjugate)

lemma conjugate_conjr1 [simp]: "conjugate (\<lambda>x. y \<rhd> x) = (\<lambda>x. y\<cdot>x)"
  by (metis conjugate_multr conj_involution residuated_multr)

lemma conjugate_multl [simp]: "conjugate (\<lambda>x. x\<cdot>y) = (\<lambda>x. x \<lhd> y)"
  by (metis conjugation_pair_multl residuated_conj1 residuated_multl unique_conjugate)

lemma conjugate_conjl1 [simp]: "conjugate (\<lambda>x. x \<lhd> y) = (\<lambda>x. x\<cdot>y)"
proof -
  have "conjugate (conjugate (\<lambda>x. x\<cdot>y)) = conjugate (\<lambda>x. x \<lhd> y)" by simp
  thus ?thesis
    by (metis conj_involution[OF residuated_multl])
qed

lemma conjugate_conjl2[simp]: "conjugate (\<lambda>x. y \<lhd> x) = (\<lambda>x. x \<rhd> y)"
  by (metis conjugation_pair_conj unique_conjugate residuated_conj1 residuated_conjl2)

lemma conjugate_conjr2[simp]: "conjugate (\<lambda>x. x \<rhd> y) = (\<lambda>x. y \<lhd> x)"
proof -
  have "conjugate (conjugate (\<lambda>x. y \<lhd> x)) = conjugate (\<lambda>x. x \<rhd> y)" by simp
  thus ?thesis
    by (metis conj_involution[OF residuated_conjl2])
qed

lemma conjl1_iso: "x \<le> y \<Longrightarrow> x \<lhd> z \<le> y \<lhd> z"
  by (metis conjugate_l_def compl_mono resl_iso)

lemma conjl2_iso: "x \<le> y \<Longrightarrow> z \<lhd> x \<le> z \<lhd> y"
  by (metis res_iso residuated_conjl2)

lemma conjr1_iso: "x \<le> y \<Longrightarrow> z \<rhd> x \<le> z \<rhd> y"
  by (metis res_iso residuated_conjr1)

lemma conjr2_iso: "x \<le> y \<Longrightarrow> x \<rhd> z \<le> y \<rhd> z"
  by (metis conjugate_r_def compl_mono resr_antitonel)

lemma conjl1_sup: "z \<lhd> (x \<squnion> y) = (z \<lhd> x) \<squnion> (z \<lhd> y)"
  by (metis conjugate_l_def compl_inf resl_distr)

lemma conjl2_sup: "(x \<squnion> y) \<lhd> z = (x \<lhd> z) \<squnion> (y \<lhd> z)"
  by (metis (poly_guards_query) residuated_sup residuated_conjl1)

lemma conjr1_sup: "z \<rhd> (x \<squnion> y) = (z \<rhd> x) \<squnion> (z \<rhd> y)"
  by (metis residuated_sup residuated_conjr1)

lemma conjr2_sup: "(x \<squnion> y) \<rhd> z = (x \<rhd> z) \<squnion> (y \<rhd> z)"
  by (metis conjugate_r_def compl_inf resr_distl)

lemma conjl1_strict: "\<bottom> \<lhd> x = \<bottom>"
  by (metis residuated_strict residuated_conjl1)

lemma conjl2_strict: "x \<lhd> \<bottom> = \<bottom>"
  by (metis residuated_strict residuated_conjl2)

lemma conjr1_strict: "\<bottom> \<rhd> x = \<bottom>"
  by (metis residuated_strict residuated_conjr2)

lemma conjr2_strict: "x \<rhd> \<bottom> = \<bottom>"
  by (metis residuated_strict residuated_conjr1)

lemma conjl1_iff: "x \<lhd> y \<le> z \<longleftrightarrow> x \<le> -(-z\<cdot>y)"
  by (metis conjugate_l_def compl_le_swap1 compl_le_swap2 resl_galois)

lemma conjl2_iff: "x \<lhd> y \<le> z \<longleftrightarrow> y \<le> -(-z \<rhd> x)"
  by (metis conjl1_iff conjugate_r_def compl_le_swap2 double_compl resr_galois)

lemma conjr1_iff: "x \<rhd> y \<le> z \<longleftrightarrow> y \<le> -(x\<cdot>-z)"
  by (metis conjugate_r_def compl_le_swap1 double_compl resr_galois)

lemma conjr2_iff: "x \<rhd> y \<le> z \<longleftrightarrow> x \<le> -(y \<lhd> -z)"
  by (metis conjugation_conj double_compl inf.commute le_iff_inf_bot)

text \<open>
  We apply Maddux's lemmas regarding conjugation of an arbitrary residuated function
  for each of the 6 functions.
\<close>

lemma maddux1a: "a\<cdot>(x \<sqinter> -(a \<rhd> y)) \<le> a\<cdot>x"
  by (insert maddux1 [of "\<lambda>x. a\<cdot>x"]) simp

lemma maddux1a': "a\<cdot>(x \<sqinter> -(a \<rhd> y)) \<le> -y"
  by (insert maddux1 [of "\<lambda>x. a\<cdot>x"]) simp

lemma maddux1b: "(x \<sqinter> -(y \<lhd> a))\<cdot>a \<le> x\<cdot>a"
  by (insert maddux1 [of "\<lambda>x. x\<cdot>a"]) simp

lemma maddux1b': "(x \<sqinter> -(y \<lhd> a))\<cdot>a \<le> -y"
  by (insert maddux1 [of "\<lambda>x. x\<cdot>a"]) simp

lemma maddux1c: " a \<lhd> x \<sqinter> -(y \<rhd> a) \<le> a \<lhd> x"
  by (insert maddux1 [of "\<lambda>x. a \<lhd> x"]) simp

lemma maddux1c': "a \<lhd> x \<sqinter> -(y \<rhd> a) \<le> -y"
  by (insert maddux1 [of "\<lambda>x. a \<lhd> x"]) simp

lemma maddux1d: "a \<rhd> x \<sqinter> -(a\<cdot>y) \<le> a \<rhd> x"
  by (insert maddux1 [of "\<lambda>x. a \<rhd> x"]) simp

lemma maddux1d': "a \<rhd> x \<sqinter> -(a\<cdot>y) \<le> -y"
  by (insert maddux1 [of "\<lambda>x. a \<rhd> x"]) simp

lemma maddux1e: "x \<sqinter> -(y\<cdot>a) \<lhd> a \<le> x \<lhd> a"
  by (insert maddux1 [of "\<lambda>x. x \<lhd> a"]) simp

lemma maddux1e': "x \<sqinter> -(y\<cdot>a) \<lhd> a \<le> -y"
  by (insert maddux1 [of "\<lambda>x. x \<lhd> a"]) simp

lemma maddux1f: "x \<sqinter> -(a \<lhd> y) \<rhd> a \<le> x \<rhd> a"
  by (insert maddux1 [of "\<lambda>x. x \<rhd> a"]) simp

lemma maddux1f': "x \<sqinter> -(a \<lhd> y) \<rhd> a \<le> -y"
  by (insert maddux1 [of "\<lambda>x. x \<rhd> a"]) simp

lemma maddux2a: "a\<cdot>x \<sqinter> y \<le> a\<cdot>(x \<sqinter> (a \<rhd> y))"
  by (insert maddux2 [of "\<lambda>x. a\<cdot>x"]) simp

lemma maddux2b: "x\<cdot>a \<sqinter> y \<le> (x \<sqinter> (y \<lhd> a))\<cdot>a"
  by (insert maddux2 [of "\<lambda>x. x\<cdot>a"]) simp

lemma maddux2c: "(a \<lhd> x) \<sqinter> y \<le> a \<lhd> (x \<sqinter> (y \<rhd> a))"
  by (insert maddux2 [of "\<lambda>x. a \<lhd> x"]) simp

lemma maddux2d: "(a \<rhd> x) \<sqinter> y \<le> a \<rhd> (x \<sqinter> (a\<cdot>y))"
  by (insert maddux2 [of "\<lambda>x. a \<rhd> x"]) simp

lemma maddux2e: "(x \<lhd> a) \<sqinter> y \<le> (x \<sqinter> (y\<cdot>a)) \<lhd> a"
  by (insert maddux2 [of "\<lambda>x. x \<lhd> a"]) simp

lemma maddux2f: "(x \<rhd> a) \<sqinter> y \<le> (x \<sqinter> (a \<lhd> y)) \<rhd> a"
  by (insert maddux2 [of "\<lambda>x. x \<rhd> a"]) simp

text \<open>
  The multiplicative operation $\cdot$ on a residuated boolean algebra is generally not
  associative. We prove some equivalences related to associativity.
\<close>

lemma res_assoc_iff1: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z)"
proof safe
  fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
  thus "x \<rhd> (y \<rhd> z) = y \<cdot> x \<rhd> z"
    using conjugate_comp_ext[of "\<lambda>z. y\<cdot>z" "\<lambda>z. x\<cdot>z"] by auto
next
  fix x y z assume "\<forall>x y z. x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z"
  thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
    using conjugate_comp_ext[of "\<lambda>z. y \<rhd> z" "\<lambda>z. x \<rhd> z"] by auto
qed

lemma res_assoc_iff2: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y)"
proof safe
  fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
  hence "\<forall>x y z. (x\<cdot>y)\<cdot>z = x\<cdot>(y\<cdot>z)" by simp
  thus "x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
    using conjugate_comp_ext[of "\<lambda>x. x\<cdot>z" "\<lambda>x. x\<cdot>y"] by auto
next
  fix x y z assume "\<forall>x y z. x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
  hence "\<forall>x y z. (x \<lhd> z) \<lhd> y = x \<lhd> (y \<cdot> z)" by simp
  thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
    using conjugate_comp_ext[of "\<lambda>z. z \<lhd> y" "\<lambda>x. x \<lhd> z"] by auto
qed

lemma res_assoc_iff3: "(\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z) \<longleftrightarrow> (\<forall>x y z. (x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z))"
proof safe
  fix x y z assume "\<forall>x y z. x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
  thus "(x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
    using conjugate_comp_ext[of "\<lambda>u. x\<cdot>u" "\<lambda>u. u\<cdot>z"] and
    conjugate_comp_ext[of "\<lambda>u. u\<cdot>z" "\<lambda>u. x\<cdot>u", symmetric]
    by auto
next
  fix x y z assume "\<forall>x y z. (x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
  thus "x\<cdot>(y\<cdot>z) = (x\<cdot>y)\<cdot>z"
    using conjugate_comp_ext[of "\<lambda>u. x \<rhd> u" "\<lambda>u. u \<lhd> z"] and
    conjugate_comp_ext[of "\<lambda>u. u \<lhd> z" "\<lambda>u. x \<rhd> u", symmetric]
    by auto
qed

end (* residuated_boolean_algebra *)

class unital_residuated_boolean = residuated_boolean_algebra + one +
  assumes mult_onel [simp]: "x\<cdot>1 = x"
  and mult_oner [simp]: "1\<cdot>x = x"
begin

text \<open>
  The following equivalences are taken from J{\'o}sson and Tsinakis.
\<close>

lemma jonsson1a: "(\<exists>f. \<forall>x y. x \<rhd> y = f(x)\<cdot>y) \<longleftrightarrow> (\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y)"
  apply standard
  apply force
  apply (rule_tac x="\<lambda>x. x \<rhd> 1" in exI)
  apply force
  done

lemma jonsson1b: "(\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y) \<longleftrightarrow> (\<forall>x y. x\<cdot>y = (x \<rhd> 1) \<rhd> y)"
proof safe
  fix x y
  assume "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
  hence "conjugate (\<lambda>y. x \<rhd> y) = conjugate (\<lambda>y. (x \<rhd> 1)\<cdot>y)" by metis
  thus "x\<cdot>y = (x \<rhd> 1) \<rhd> y" by simp
next
  fix x y
  assume "\<forall>x y. x \<cdot> y = x \<rhd> 1 \<rhd> y"
  thus "x \<rhd> y = (x \<rhd> 1) \<cdot> y"
    by (metis mult_onel)
qed

lemma jonsson1c: "(\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y) \<longleftrightarrow> (\<forall>x y. y \<lhd> x = 1 \<lhd> (x \<lhd> y))"
proof safe
  fix x y
  assume "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
  hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. (x \<rhd> 1)\<cdot>y)" by metis
  hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. x\<cdot>y) o (\<lambda>x. x \<rhd> 1)" by force
  hence "conjugate (\<lambda>x. y \<lhd> x) = (\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x)" by simp
  hence "conjugate (conjugate (\<lambda>x. y \<lhd> x)) = conjugate ((\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x))" by simp
  hence "(\<lambda>x. y \<lhd> x) = conjugate ((\<lambda>x. x\<cdot>y) o conjugate (\<lambda>x. 1 \<lhd> x))" by simp
  also have "... = conjugate (conjugate (\<lambda>x. 1 \<lhd> x)) o conjugate (\<lambda>x. x\<cdot>y)"
    by (subst conjugate_comp[symmetric]) simp_all
  finally show "y \<lhd> x = 1 \<lhd> (x \<lhd> y)" by simp
next
  fix x y
  assume "\<forall>x y. y \<lhd> x = 1 \<lhd> (x \<lhd> y)"
  hence "(\<lambda>x. y \<lhd> x) = (\<lambda>x. 1 \<lhd> (x \<lhd> y))" by metis
  hence "(\<lambda>x. y \<lhd> x) = (\<lambda>x. 1 \<lhd> x) o conjugate (\<lambda>x. x\<cdot>y)" by force
  hence "conjugate (\<lambda>x. y \<lhd> x) = conjugate ((\<lambda>x. 1 \<lhd> x) o conjugate (\<lambda>x. x\<cdot>y))" by metis
  also have "... = conjugate (conjugate (\<lambda>x. x\<cdot>y)) o conjugate (\<lambda>x. 1 \<lhd> x)"
    by (subst conjugate_comp[symmetric]) simp_all
  finally have "(\<lambda>x. x \<rhd> y) = (\<lambda>x. x\<cdot>y) o (\<lambda>x. x \<rhd> 1)" by simp
  hence "(\<lambda>x. x \<rhd> y) = (\<lambda>x. (x \<rhd> 1) \<cdot> y)" by (simp add: comp_def)
  thus "x \<rhd> y = (x \<rhd> 1) \<cdot> y" by metis
qed

lemma jonsson2a: "(\<exists>g. \<forall>x y. x \<lhd> y = x\<cdot>g(y)) \<longleftrightarrow> (\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y))"
  apply standard
  apply force
  apply (rule_tac x="\<lambda>x. 1 \<lhd> x" in exI)
  apply force
  done

lemma jonsson2b: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. x\<cdot>y = x \<lhd> (1 \<lhd> y))"
proof safe
  fix x y
  assume "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
  hence "conjugate (\<lambda>x. x \<lhd> y) = conjugate (\<lambda>x. x\<cdot>(1 \<lhd> y))" by metis
  thus "x\<cdot>y = x \<lhd> (1 \<lhd> y)" by simp metis
next
  fix x y
  assume "\<forall>x y. x\<cdot>y = x \<lhd> (1 \<lhd> y)"
  hence "(\<lambda>x. x\<cdot>y) = (\<lambda>x. x \<lhd> (1 \<lhd> y))" by metis
  hence "conjugate (\<lambda>x. x\<cdot>y) = conjugate (\<lambda>x. x \<lhd> (1 \<lhd> y))" by metis
  thus "x \<lhd> y = x \<cdot> (1 \<lhd> y)" by simp metis
qed

lemma jonsson2c: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. y \<rhd> x = (x \<rhd> y) \<rhd> 1)"
proof safe
  fix x y
  assume "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
  hence "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>(1 \<lhd> y))" by metis
  hence "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>y) o (\<lambda>y. 1 \<lhd> y)" by force
  hence "conjugate (\<lambda>y. y \<rhd> x) = (\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1)" by force
  hence "conjugate (conjugate (\<lambda>y. y \<rhd> x)) = conjugate ((\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1))" by metis
  hence "(\<lambda>y. y \<rhd> x) = conjugate ((\<lambda>y. x\<cdot>y) o conjugate (\<lambda>y. y \<rhd> 1))" by simp
  also have "... = conjugate (conjugate (\<lambda>y. y \<rhd> 1)) o conjugate (\<lambda>y. x\<cdot>y)"
    by (subst conjugate_comp[symmetric]) simp_all
  finally have "(\<lambda>y. y \<rhd> x) = (\<lambda>y. x \<rhd> y \<rhd> 1)" by (simp add: comp_def)
  thus "y \<rhd> x = x \<rhd> y \<rhd> 1" by metis
next
  fix x y
  assume "\<forall>x y. y \<rhd> x = x \<rhd> y \<rhd> 1"
  hence "(\<lambda>y. y \<rhd> x) = (\<lambda>y. x \<rhd> y \<rhd> 1)" by force
  hence "(\<lambda>y. y \<rhd> x) = (\<lambda>y. y \<rhd> 1) o conjugate (\<lambda>y. x\<cdot>y)" by force
  hence "conjugate (\<lambda>y. y \<rhd> x) = conjugate ((\<lambda>y. y \<rhd> 1) o conjugate (\<lambda>y. x\<cdot>y))" by metis
  also have "... = conjugate (conjugate (\<lambda>y. x\<cdot>y)) o conjugate (\<lambda>y. y \<rhd> 1)"
    by (subst conjugate_comp[symmetric]) simp_all
  finally have "(\<lambda>y. x \<lhd> y) = (\<lambda>y. x\<cdot>y) o (\<lambda>y. 1 \<lhd> y)"
    by (metis conjugate_conjr1 conjugate_conjr2 conjugate_multr)
  thus "x \<lhd> y = x \<cdot> (1 \<lhd> y)" by (simp add: comp_def)
qed

lemma jonsson3a: "(\<forall>x. (x \<rhd> 1) \<rhd> 1 = x) \<longleftrightarrow> (\<forall>x. 1 \<lhd> (1 \<lhd> x) = x)"
proof safe
  fix x assume "\<forall>x. x \<rhd> 1 \<rhd> 1 = x"
  thus "1 \<lhd> (1 \<lhd> x) = x"
    by (metis compl_le_swap1 compl_le_swap2 conjr2_iff order.eq_iff)
next
  fix x assume "\<forall>x. 1 \<lhd> (1 \<lhd> x) = x"
  thus "x \<rhd> 1 \<rhd> 1 = x"
    by (metis conjugate_l_def conjugate_r_def double_compl jipsen2r)
qed

lemma jonsson3b: "(\<forall>x. (x \<rhd> 1) \<rhd> 1 = x) \<Longrightarrow> (x \<sqinter> y) \<rhd> 1 = (x \<rhd> 1) \<sqinter> (y \<rhd> 1)"
proof (rule order.antisym, auto simp: conjr2_iso)
  assume assm: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x"
  hence "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1 = x \<sqinter> (((x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1) \<sqinter> y)"
    by (metis (no_types) conjr2_iso inf.cobounded2 inf.commute inf.orderE)
  hence "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<rhd> 1 \<le> x \<sqinter> y"
    using inf.orderI inf_left_commute by presburger
  thus "(x \<rhd> 1) \<sqinter> (y \<rhd> 1) \<le> x \<sqinter> y \<rhd> 1"
    using assm by (metis (no_types) conjr2_iso)
qed

lemma jonsson3c: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x \<Longrightarrow> x \<rhd> 1 = 1 \<lhd> x"
proof (rule indirect_eq)
  fix z
  assume assms: "\<forall>x. (x \<rhd> 1) \<rhd> 1 = x"
  hence "(x \<rhd> 1) \<sqinter> -z = \<bottom> \<longleftrightarrow> ((x \<rhd> 1) \<sqinter> -z) \<rhd> 1 = \<bottom>"
    by (metis compl_sup conjugation_conj double_compl inf_bot_right sup_bot.left_neutral)
  also have "... \<longleftrightarrow> -z\<cdot>x \<sqinter> 1 = \<bottom>"
    by (metis assms jonsson3b conjugation_multr)
  finally have "(x \<rhd> 1) \<sqinter> -z = \<bottom> \<longleftrightarrow> (1 \<lhd> x) \<sqinter> -z = \<bottom>"
    by (metis conjugation_multl inf.commute)
  thus "(x \<rhd> 1 \<le> z) \<longleftrightarrow> (1 \<lhd> x \<le> z)"
    by (metis le_iff_inf_bot)
qed

end (* unital_residuated_boolean *)

class residuated_boolean_semigroup = residuated_boolean_algebra + semigroup_mult
begin

subclass residuated_boolean_algebra ..

text \<open>
  The following lemmas hold trivially, since they are equivalent to associativity.
\<close>

lemma res_assoc1: "x \<rhd> (y \<rhd> z) = y\<cdot>x \<rhd> z"
  by (metis res_assoc_iff1 mult_assoc)

lemma res_assoc2: "x \<lhd> (y \<cdot> z) = (x \<lhd> z) \<lhd> y"
  by (metis res_assoc_iff2 mult_assoc)

lemma res_assoc3: "(x \<rhd> y) \<lhd> z = x \<rhd> (y \<lhd> z)"
  by (metis res_assoc_iff3 mult_assoc)

end (*residuated_boolean_semigroup *)

class residuated_boolean_monoid = residuated_boolean_algebra + monoid_mult
begin

subclass unital_residuated_boolean
  by standard auto

subclass residuated_lmonoid ..

lemma jonsson4: "(\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)) \<longleftrightarrow> (\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y)"
proof safe
  fix x y assume assms: "\<forall>x y. x \<lhd> y = x\<cdot>(1 \<lhd> y)"
  have "x \<rhd> y = (y \<rhd> x) \<rhd> 1"
    by (metis assms jonsson2c)
  also have "... = (y \<rhd> ((x \<rhd> 1) \<rhd> 1)) \<rhd> 1"
    by (metis assms jonsson2b jonsson3a mult_oner)
  also have "... = (((x \<rhd> 1)\<cdot>y) \<rhd> 1) \<rhd> 1"
    by (metis conjugate_r_def double_compl resr3)
  also have "... = (x \<rhd> 1)\<cdot>y"
    by (metis assms jonsson2b jonsson3a mult_oner)
  finally show "x \<rhd> y = (x \<rhd> 1)\<cdot>y" .
next
  fix x y assume assms: "\<forall>x y. x \<rhd> y = (x \<rhd> 1)\<cdot>y"
  have "y \<lhd> x = 1 \<lhd> (x \<lhd> y)"
    by (metis assms jonsson1c)
  also have "... = 1 \<lhd> ((1 \<lhd> (1 \<lhd> x)) \<lhd> y)"
    by (metis assms conjugate_l_def double_compl jonsson1c mult_1_right resl3)
  also have "... = 1 \<lhd> (1 \<lhd> (y\<cdot>(1 \<lhd> x)))"
    by (metis conjugate_l_def double_compl resl3)
  also have "... = y\<cdot>(1 \<lhd> x)"
    by (metis assms jonsson1b jonsson1c jonsson3c mult_onel)
  finally show "y \<lhd> x = y\<cdot>(1 \<lhd> x)" .
qed

end (* residuated_boolean_monoid *)

end


section "Splay Heap"

theory Splay_Heap
imports
  "HOL-Library.Tree_Multiset"
begin

text\<open>Splay heaps were invented by Okasaki~\cite{Okasaki}. They represent
priority queues by splay trees, not by heaps!\<close>

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

fun partition :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree * 'a tree" where
"partition p Leaf = (Leaf,Leaf)" |
"partition p (Node al a ar) =
  (if a \<le> p then
     case ar of
       Leaf \<Rightarrow> (Node al a ar, Leaf) |
       Node bl b br \<Rightarrow>
         if b \<le> p
         then let (pl,pr) = partition p br in (Node (Node al a bl) b pl, pr)
         else let (pl,pr) = partition p bl in (Node al a pl, Node pr b br)
   else case al of
       Leaf \<Rightarrow> (Leaf, Node al a ar) |
       Node bl b br \<Rightarrow>
         if b \<le> p
         then let (pl,pr) = partition p br in (Node bl b pl, Node pr a ar)
         else let (pl,pr) = partition p bl in (pl, Node pr b (Node br a ar)))"

definition insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x h = (let (l,r) = partition x h in Node l x r)"

fun del_min :: "'a::linorder tree \<Rightarrow> 'a tree" where
"del_min Leaf = Leaf" |
"del_min (Node Leaf _ r) = r" |
"del_min (Node (Node ll a lr) b r) =
  (if ll = Leaf then Node lr b r else Node (del_min ll) a (Node lr b r))"

lemma get_min_in:
  "h \<noteq> Leaf \<Longrightarrow> get_min h \<in> set_tree h"
by(induction h) auto

lemma get_min_min:
  "\<lbrakk> bst_wrt (\<le>) h; h \<noteq> Leaf \<rbrakk> \<Longrightarrow> \<forall>x \<in> set_tree h. get_min h \<le> x"
proof(induction h)
  case (Node l x r) thus ?case using get_min_in[of l] get_min_in[of r]
    by auto (blast intro: order_trans)
qed simp

lemma size_partition: "partition p t = (l',r') \<Longrightarrow> size t = size l' + size r'"
by (induction p t arbitrary: l' r' rule: partition.induct)
   (auto split: if_splits tree.splits prod.splits)

lemma set_partition: "\<lbrakk> bst_wrt (\<le>) t; partition p t = (l',r') \<rbrakk>
 \<Longrightarrow> set_tree t = set_tree l' \<union> set_tree r'"
by (metis mset_partition set_mset_tree set_mset_union)

lemma bst_partition:
  "partition p t = (l',r') \<Longrightarrow> bst_wrt (\<le>) t \<Longrightarrow> bst_wrt (\<le>) (Node l' p r')"
proof(induction p t arbitrary: l' r' rule: partition.induct)
  case 1 thus ?case by simp
next
  case (2 p l a r)
  show ?case
  proof cases
    assume "a \<le> p"
    show ?thesis
    proof (cases r)
      case Leaf thus ?thesis using \<open>a \<le> p\<close> "2.prems" by fastforce
    next
      case (Node rl b rr)
      show ?thesis
      proof cases
        assume "b \<le> p"
        thus ?thesis
          using Node \<open>a \<le> p\<close> "2.prems" "2.IH"(1)[OF _ Node] set_partition[of rr]
          by (fastforce split: prod.splits)
      next
        assume "\<not> b \<le> p"
        thus ?thesis
          using Node \<open>a \<le> p\<close> "2.prems" "2.IH"(2)[OF _ Node] set_partition[of rl]
          by (fastforce split: prod.splits)
      qed
    qed
  next
    assume "\<not> a \<le> p"
    show ?thesis
    proof (cases l)
      case Leaf thus ?thesis using \<open>\<not> a \<le> p\<close> "2.prems" by fastforce
    next
      case (Node ll b lr)
      show ?thesis
      proof cases
        assume "b \<le> p"
        thus ?thesis
          using Node \<open>\<not> a \<le> p\<close> "2.prems" "2.IH"(3)[OF _ Node] set_partition[of lr]
          by (fastforce split: prod.splits)
      next
        assume "\<not> b \<le> p"
        thus ?thesis
          using Node \<open>\<not> a \<le> p\<close> "2.prems" "2.IH"(4)[OF _ Node] set_partition[of ll]
          by (fastforce split: prod.splits)
      qed
    qed
  qed
qed

lemma size_del_min[simp]: "size(del_min t) = size t - 1"
by(induction t rule: del_min.induct) (auto simp: neq_Leaf_iff)

lemma mset_del_min: "mset_tree (del_min h) = mset_tree h - {# get_min h #}"
proof(induction h rule: del_min.induct)
  case (3 ll)
  show ?case
  proof cases
    assume "ll = Leaf" thus ?thesis using 3 by (simp add: ac_simps)
  next
    assume "ll \<noteq> Leaf"
    hence "get_min ll \<in># mset_tree ll"
      by (simp add: get_min_in)
    then obtain A where "mset_tree ll = add_mset (get_min ll) A"
      by (blast dest: multi_member_split)
    then show ?thesis using 3 by auto
  qed
qed auto

lemma bst_del_min: "bst_wrt (\<le>) t \<Longrightarrow> bst_wrt (\<le>) (del_min t)"
apply(induction t rule: del_min.induct)
  apply simp
 apply simp
apply auto
by (metis Multiset.diff_subset_eq_self subsetD set_mset_mono set_mset_tree mset_del_min)

end