(*
  File:    Lambert_W.thy
  Author:  Manuel Eberl, TU München

  Definition and basic properties of the two real-valued branches of the Lambert W function,
*)
section \<open>The Lambert $W$ Function on the reals\<close>
theory Lambert_W
imports
  Complex_Main
  "HOL-Library.FuncSet"
  "HOL-Real_Asymp.Real_Asymp"
begin

(*<*)
text \<open>Some lemmas about asymptotic equivalence:\<close>

lemma asymp_equiv_sandwich':
  fixes f :: "'a \<Rightarrow> real"
  assumes "\<And>c'. c' \<in> {l<..<c} \<Longrightarrow> eventually (\<lambda>x. f x \<ge> c' * g x) F"
  assumes "\<And>c'. c' \<in> {c<..<u} \<Longrightarrow> eventually (\<lambda>x. f x \<le> c' * g x) F"
  assumes "l < c" "c < u" and [simp]: "c \<noteq> 0"
  shows   "f \<sim>[F] (\<lambda>x. c * g x)"
proof -
  have "(\<lambda>x. f x - c * g x) \<in> o[F](g)"
  proof (rule landau_o.smallI)
    fix e :: real assume e: "e > 0"
    define C1 where "C1 = min (c + e) ((c + u) / 2)"
    have C1: "C1 \<in> {c<..<u}" "C1 - c \<le> e"
      using e assms by (auto simp: C1_def min_def)
    define C2 where "C2 = max (c - e) ((c + l) / 2)"
    have C2: "C2 \<in> {l<..<c}" "c - C2 \<le> e"
      using e assms by (auto simp: C2_def max_def field_simps)

    show "eventually (\<lambda>x. norm (f x - c * g x) \<le> e * norm (g x)) F"
      using assms(2)[OF C1(1)] assms(1)[OF C2(1)]
    proof eventually_elim
      case (elim x)
      show ?case
      proof (cases "f x \<ge> c * g x")
        case True
        hence "norm (f x - c * g x) = f x - c * g x"
          by simp
        also have "\<dots> \<le> (C1 - c) * g x"
          using elim by (simp add: algebra_simps)
        also have "\<dots> \<le> (C1 - c) * norm (g x)"
          using C1 by (intro mult_left_mono) auto
        also have "\<dots> \<le> e * norm (g x)"
          using C1 elim by (intro mult_right_mono) auto
        finally show ?thesis using elim by simp
      next
        case False
        hence "norm (f x - c * g x) = c * g x - f x"
          by simp
        also have "\<dots> \<le> (c - C2) * g x"
          using elim by (simp add: algebra_simps)
        also have "\<dots> \<le> (c - C2) * norm (g x)"
          using C2 by (intro mult_left_mono) auto
        also have "\<dots> \<le> e * norm (g x)"
          using C2 elim by (intro mult_right_mono) auto
        finally show ?thesis using elim by simp
      qed
    qed
  qed
  also have "g \<in> O[F](\<lambda>x. c * g x)"
    by simp
  finally show ?thesis
    unfolding asymp_equiv_altdef by blast
qed

lemma asymp_equiv_sandwich'':
  fixes f :: "'a \<Rightarrow> real"
  assumes "\<And>c'. c' \<in> {l<..<1} \<Longrightarrow> eventually (\<lambda>x. f x \<ge> c' * g x) F"
  assumes "\<And>c'. c' \<in> {1<..<u} \<Longrightarrow> eventually (\<lambda>x. f x \<le> c' * g x) F"
  assumes "l < 1" "1 < u"
  shows   "f \<sim>[F] (g)"
  using asymp_equiv_sandwich'[of l 1 g f F u] assms by simp
(*>*)

subsection \<open>Properties of the function $x\mapsto x e^{x}$\<close>

lemma exp_times_self_gt:
  assumes "x \<noteq> -1"
  shows   "x * exp x > -exp (-1::real)"
proof -
  define f where "f = (\<lambda>x::real. x * exp x)"
  define f' where "f' = (\<lambda>x::real. (x + 1) * exp x)"
  have "(f has_field_derivative f' x) (at x)" for x
    by (auto simp: f_def f'_def intro!: derivative_eq_intros simp: algebra_simps)
  define l r where "l = min x (-1)" and "r = max x (-1)"

  have "\<exists>z. z > l \<and> z < r \<and> f r - f l = (r - l) * f' z"
    unfolding f_def f'_def l_def r_def using assms
    by (intro MVT2) (auto intro!: derivative_eq_intros simp: algebra_simps)
  then obtain z where z: "z \<in> {l<..<r}" "f r - f l = (r - l) * f' z"
    by auto
  from z have "f x = f (-1) + (x + 1) * f' z"
    using assms by (cases "x \<ge> -1") (auto simp: l_def r_def max_def min_def algebra_simps)
  moreover have "sgn ((x + 1) * f' z) = 1"
    using z assms
    by (cases x "(-1) :: real" rule: linorder_cases; cases z "(-1) :: real" rule: linorder_cases)
       (auto simp: f'_def sgn_mult l_def r_def)
  hence "(x + 1) * f' z > 0" using sgn_greater by fastforce
  ultimately show ?thesis by (simp add: f_def)
qed

lemma exp_times_self_ge: "x * exp x \<ge> -exp (-1::real)"
  using exp_times_self_gt[of x] by (cases "x = -1") auto

lemma exp_times_self_strict_mono:
  assumes "x \<ge> -1" "x < (y :: real)"
  shows   "x * exp x < y * exp y"
  using assms(2)
proof (rule DERIV_pos_imp_increasing_open)
  fix t assume t: "x < t" "t < y"
  have "((\<lambda>x. x * exp x) has_real_derivative (t + 1) * exp t) (at t)"
    by (auto intro!: derivative_eq_intros simp: algebra_simps)
  moreover have "(t + 1) * exp t > 0"
    using t assms by (intro mult_pos_pos) auto
  ultimately show "\<exists>y. ((\<lambda>a. a * exp a) has_real_derivative y) (at t) \<and> 0 < y" by blast
qed (auto intro!: continuous_intros)

lemma exp_times_self_strict_antimono:
  assumes "y \<le> -1" "x < (y :: real)"
  shows   "x * exp x > y * exp y"
proof -
  have "-x * exp x < -y * exp y"
    using assms(2)
  proof (rule DERIV_pos_imp_increasing_open)
    fix t assume t: "x < t" "t < y"
    have "((\<lambda>x. -x * exp x) has_real_derivative (-(t + 1)) * exp t) (at t)"
      by (auto intro!: derivative_eq_intros simp: algebra_simps)
    moreover have "(-(t + 1)) * exp t > 0"
      using t assms by (intro mult_pos_pos) auto
    ultimately show "\<exists>y. ((\<lambda>a. -a * exp a) has_real_derivative y) (at t) \<and> 0 < y" by blast
  qed (auto intro!: continuous_intros)
  thus ?thesis by simp
qed

lemma exp_times_self_mono:
  assumes "x \<ge> -1" "x \<le> (y :: real)"
  shows   "x * exp x \<le> y * exp y"
  using exp_times_self_strict_mono[of x y] assms by (cases "x = y") auto

lemma exp_times_self_antimono:
  assumes "y \<le> -1" "x \<le> (y :: real)"
  shows   "x * exp x \<ge> y * exp y"
  using exp_times_self_strict_antimono[of y x] assms by (cases "x = y") auto

lemma exp_times_self_inj: "inj_on (\<lambda>x::real. x * exp x) {-1..}"
proof
  fix x y :: real
  assume "x \<in> {-1..}" "y \<in> {-1..}" "x * exp x = y * exp y"
  thus "x = y"
    using exp_times_self_strict_mono[of x y] exp_times_self_strict_mono[of y x]
    by (cases x y rule: linorder_cases) auto
qed

lemma exp_times_self_inj': "inj_on (\<lambda>x::real. x * exp x) {..-1}"
proof
  fix x y :: real
  assume "x \<in> {..-1}" "y \<in> {..-1}" "x * exp x = y * exp y"
  thus "x = y"
    using exp_times_self_strict_antimono[of x y] exp_times_self_strict_antimono[of y x]
    by (cases x y rule: linorder_cases) auto
qed

subsection \<open>Definition\<close>

text \<open>
  The following are the two branches $W_0(x)$ and $W_{-1}(x)$ of the Lambert $W$ function on the
  real numbers. These are the inverse functions of the function $x\mapsto xe^x$, i.\,e.\
  we have $W(x)e^{W(x)} = x$ for both branches wherever they are defined. The two branches
  meet at the point $x = -\frac{1}{e}$.

  $W_0(x)$ is the principal branch, whose domain is $[-\frac{1}{e}; \infty)$ and whose
  range is $[-1; \infty)$.
  $W_{-1}(x)$ has the domain $[-\frac{1}{e}; 0)$ and the range $(-\infty;-1]$.
  Figure~\ref{fig:lambertw} shows plots of these two branches for illustration.
\<close>

text \<open>
\definecolor{myblue}{HTML}{3869b1}
\definecolor{myred}{HTML}{cc2428}
\begin{figure}
\begin{center}
\begin{tikzpicture}
  \begin{axis}[
          xmin=-0.5, xmax=6.6, ymin=-3.8, ymax=1.5, axis lines=middle, ytick = {-3, -2, -1, 1}, xtick = {1,...,10}, yticklabel pos = right,
          yticklabel style={right,xshift=1mm},
          extra x tick style={tick label style={above,yshift=1mm}},
          extra x ticks={-0.367879441},
          extra x tick labels={$-\frac{1}{e}$},
          width=\textwidth, height=0.8\textwidth,
          xlabel={$x$}, tick style={thin,black}
  ]
  \addplot [color=black, line width=0.5pt, densely dashed, mark=none,domain=-5:0,samples=200] ({-exp(-1)}, {x});
  \addplot [color=myblue, line width=1pt, mark=none,domain=-1:1.5,samples=200] ({x*exp(x)}, {x});
  \addplot [color=myred, line width=1pt, mark=none,domain=-5:-1,samples=200] ({x*exp(x)}, {x});
  \end{axis}
\end{tikzpicture}
\end{center}
\caption{The two real branches of the Lambert $W$ function: $W_0$ (blue) and $W_{-1}$ (red).}
\label{fig:lambertw}
\end{figure}
\<close>

definition Lambert_W :: "real \<Rightarrow> real" where
  "Lambert_W x = (if x < -exp(-1) then -1 else (THE w. w \<ge> -1 \<and> w * exp w = x))"

definition Lambert_W' :: "real \<Rightarrow> real" where
  "Lambert_W' x = (if x \<in> {-exp(-1)..<0} then (THE w. w \<le> -1 \<and> w * exp w = x) else -1)"

lemma Lambert_W_ex1:
  assumes "(x::real) \<ge> -exp (-1)"
  shows   "\<exists>!w. w \<ge> -1 \<and> w * exp w = x"
proof (rule ex_ex1I)
  have "filterlim (\<lambda>w::real. w * exp w) at_top at_top"
    by real_asymp
  hence "eventually (\<lambda>w. w * exp w \<ge> x) at_top"
    by (auto simp: filterlim_at_top)
  hence "eventually (\<lambda>w. w \<ge> 0 \<and> w * exp w \<ge> x) at_top"
    by (intro eventually_conj eventually_ge_at_top)
  then obtain w' where w': "w' * exp w' \<ge> x" "w' \<ge> 0"
    by (auto simp: eventually_at_top_linorder)
  from w' assms have "\<exists>w. -1 \<le> w \<and> w \<le> w' \<and> w * exp w = x"
    by (intro IVT' continuous_intros) auto
  thus "\<exists>w. w \<ge> -1 \<and> w * exp w = x" by blast
next
  fix w w' :: real
  assume ww': "w \<ge> -1 \<and> w * exp w = x" "w' \<ge> -1 \<and> w' * exp w' = x"
  hence "w * exp w = w' * exp w'" by simp
  thus "w = w'"
    using exp_times_self_strict_mono[of w w'] exp_times_self_strict_mono[of w' w] ww'
    by (cases w w' rule: linorder_cases) auto
qed

lemma Lambert_W'_ex1:
  assumes "(x::real) \<in> {-exp (-1)..<0}"
  shows   "\<exists>!w. w \<le> -1 \<and> w * exp w = x"
proof (rule ex_ex1I)
  have "eventually (\<lambda>w. x \<le> w * exp w) at_bot"
    using assms by real_asymp
  hence "eventually (\<lambda>w. w \<le> -1 \<and> w * exp w \<ge> x) at_bot"
    by (intro eventually_conj eventually_le_at_bot)
  then obtain w' where w': "w' * exp w' \<ge> x" "w' \<le> -1"
    by (auto simp: eventually_at_bot_linorder)

  from w' assms have "\<exists>w. w' \<le> w \<and> w \<le> -1 \<and> w * exp w = x"
    by (intro IVT2' continuous_intros) auto
  thus "\<exists>w. w \<le> -1 \<and> w * exp w = x" by blast
next
  fix w w' :: real
  assume ww': "w \<le> -1 \<and> w * exp w = x" "w' \<le> -1 \<and> w' * exp w' = x"
  hence "w * exp w = w' * exp w'" by simp
  thus "w = w'"
    using exp_times_self_strict_antimono[of w w'] exp_times_self_strict_antimono[of w' w] ww'
    by (cases w w' rule: linorder_cases) auto
qed

lemma Lambert_W_times_exp_self:
  assumes "x \<ge> -exp (-1)"
  shows   "Lambert_W x * exp (Lambert_W x) = x"
  using theI'[OF Lambert_W_ex1[OF assms]] assms by (auto simp: Lambert_W_def)

lemma Lambert_W_times_exp_self':
  assumes "x \<ge> -exp (-1)"
  shows   "exp (Lambert_W x) * Lambert_W x = x"
  using Lambert_W_times_exp_self[of x] assms by (simp add: mult_ac)

lemma Lambert_W'_times_exp_self':
  assumes "x \<in> {-exp (-1)..<0}"
  shows   "exp (Lambert_W' x) * Lambert_W' x = x"
  using Lambert_W'_times_exp_self[of x] assms by (simp add: mult_ac)

lemma Lambert_W_ge: "Lambert_W x \<ge> -1"
  using theI'[OF Lambert_W_ex1[of x]] by (auto simp: Lambert_W_def)

lemma Lambert_W'_le: "Lambert_W' x \<le> -1"
  using theI'[OF Lambert_W'_ex1[of x]] by (auto simp: Lambert_W'_def)

lemma Lambert_W_eqI:
  assumes "w \<ge> -1" "w * exp w = x"
  shows   "Lambert_W x = w"
proof -
  from assms exp_times_self_ge[of w] have "x \<ge> -exp (-1)"
    by (cases "x \<ge> -exp (-1)") auto
  from Lambert_W_ex1[OF this] Lambert_W_times_exp_self[OF this] Lambert_W_ge[of x] assms
    show ?thesis by metis
  qed

lemma Lambert_W'_eqI:
  assumes "w \<le> -1" "w * exp w = x"
  shows   "Lambert_W' x = w"
proof -
  from assms exp_times_self_ge[of w] have "x \<ge> -exp (-1)"
    by (cases "x \<ge> -exp (-1)") auto
  moreover from assms have "w * exp w < 0"
    by (intro mult_neg_pos) auto
  ultimately have "x \<in> {-exp (-1)..<0}"
    using assms by auto

  from Lambert_W'_ex1[OF this(1)] Lambert_W'_times_exp_self[OF this(1)] Lambert_W'_le assms
    show ?thesis by metis
  qed

text \<open>
  $W_0(x)$ and $W_{-1}(x)$ together fully cover all solutions of $we^w = x$:
\<close>
lemma exp_times_self_eqD:
  assumes "w * exp w = x"
  shows   "x \<ge> -exp (-1)" and "w = Lambert_W x \<or> x < 0 \<and> w = Lambert_W' x"
proof -
  from assms show "x \<ge> -exp (-1)"
    using exp_times_self_ge[of w] by auto
  show "w = Lambert_W x \<or> x < 0 \<and> w = Lambert_W' x"
  proof (cases "w \<ge> -1")
    case True
    hence "Lambert_W x = w"
      using assms by (intro Lambert_W_eqI) auto
    thus ?thesis by auto
  next
    case False
    from False have "w * exp w < 0"
      by (intro mult_neg_pos) auto
    from False have "Lambert_W' x = w"
      using assms by (intro Lambert_W'_eqI) auto
    thus ?thesis using assms \<open>w * exp w < 0\<close> by auto
  qed
qed

theorem exp_times_self_eq_iff:
  "w * exp w = x \<longleftrightarrow> x \<ge> -exp (-1) \<and> (w = Lambert_W x \<or> x < 0 \<and> w = Lambert_W' x)"
  using exp_times_self_eqD[of w x]
  by (auto simp: Lambert_W_times_exp_self Lambert_W'_times_exp_self)

lemma Lambert_W_exp_times_self [simp]: "x \<ge> -1 \<Longrightarrow> Lambert_W (x * exp x) = x"
  by (rule Lambert_W_eqI) auto

lemma Lambert_W_exp_times_self' [simp]: "x \<ge> -1 \<Longrightarrow> Lambert_W (exp x * x) = x"
  by (rule Lambert_W_eqI) auto

lemma Lambert_W'_exp_times_self [simp]: "x \<le> -1 \<Longrightarrow> Lambert_W' (x * exp x) = x"
  by (rule Lambert_W'_eqI) auto

lemma Lambert_W'_exp_times_self' [simp]: "x \<le> -1 \<Longrightarrow> Lambert_W' (exp x * x) = x"
  by (rule Lambert_W'_eqI) auto

lemma Lambert_W_times_ln_self:
  assumes "x \<ge> exp (-1)"
  shows   "Lambert_W (x * ln x) = ln x"
proof -
  have "0 < exp (-1 :: real)"
    by simp
  also note \<open>\<dots> \<le> x\<close>
  finally have "x > 0" .
  from assms have "ln (exp (-1)) \<le> ln x"
    using \<open>x > 0\<close> by (subst ln_le_cancel_iff) auto
  hence "Lambert_W (exp (ln x) * ln x) = ln x"
    by (subst Lambert_W_exp_times_self') auto
  thus ?thesis using \<open>x > 0\<close> by simp
qed

lemma Lambert_W_times_ln_self':
  assumes "x \<ge> exp (-1)"
  shows   "Lambert_W (ln x  * x) = ln x"
  using Lambert_W_times_ln_self[OF assms] by (simp add: mult.commute)

lemma Lambert_W_eq_minus_exp_minus1 [simp]: "Lambert_W (-exp (-1)) = -1"
  by (rule Lambert_W_eqI) auto

lemma Lambert_W'_eq_minus_exp_minus1 [simp]: "Lambert_W' (-exp (-1)) = -1"
  by (rule Lambert_W'_eqI) auto

lemma Lambert_W_0 [simp]: "Lambert_W 0 = 0"
  by (rule Lambert_W_eqI) auto

subsection \<open>Monotonicity properties\<close>

lemma Lambert_W_strict_mono:
  assumes "x \<ge> -exp(-1)" "x < y"
  shows   "Lambert_W x < Lambert_W y"
proof (rule ccontr)
  assume "\<not>(Lambert_W x < Lambert_W y)"
  hence "Lambert_W x * exp (Lambert_W x) \<ge> Lambert_W y * exp (Lambert_W y)"
    by (intro exp_times_self_mono) (auto simp: Lambert_W_ge)
  hence "x \<ge> y"
    using assms by (simp add: Lambert_W_times_exp_self)
  with assms show False by simp
qed

lemma Lambert_W_mono:
  assumes "x \<ge> -exp(-1)" "x \<le> y"
  shows   "Lambert_W x \<le> Lambert_W y"
  using Lambert_W_strict_mono[of x y] assms by (cases "x = y") auto

lemma Lambert_W_eq_iff [simp]:
  "x \<ge> -exp(-1) \<Longrightarrow> y \<ge> -exp(-1) \<Longrightarrow> Lambert_W x = Lambert_W y \<longleftrightarrow> x = y"
  using Lambert_W_strict_mono[of x y] Lambert_W_strict_mono[of y x]
  by (cases x y rule: linorder_cases) auto

lemma Lambert_W_le_iff [simp]:
  "x \<ge> -exp(-1) \<Longrightarrow> y \<ge> -exp(-1) \<Longrightarrow> Lambert_W x \<le> Lambert_W y \<longleftrightarrow> x \<le> y"
  using Lambert_W_strict_mono[of x y] Lambert_W_strict_mono[of y x]
  by (cases x y rule: linorder_cases) auto

lemma Lambert_W_less_iff [simp]:
  "x \<ge> -exp(-1) \<Longrightarrow> y \<ge> -exp(-1) \<Longrightarrow> Lambert_W x < Lambert_W y \<longleftrightarrow> x < y"
  using Lambert_W_strict_mono[of x y] Lambert_W_strict_mono[of y x]
  by (cases x y rule: linorder_cases) auto

lemma Lambert_W_le_minus_one:
  assumes "x \<le> -exp(-1)"
  shows   "Lambert_W x = -1"
proof (cases "x = -exp(-1)")
  case False
  thus ?thesis using assms
    by (auto simp: Lambert_W_def)
qed auto

lemma Lambert_W_pos_iff [simp]: "Lambert_W x > 0 \<longleftrightarrow> x > 0"
proof (cases "x \<ge> -exp (-1)")
  case True
  thus ?thesis
    using Lambert_W_less_iff[of 0 x] by (simp del: Lambert_W_less_iff)
next
  case False
  hence "x < - exp(-1)" by auto
  also have "\<dots> \<le> 0" by simp
  finally show ?thesis using False
    by (auto simp: Lambert_W_le_minus_one)
qed

lemma Lambert_W_eq_0_iff [simp]: "Lambert_W x = 0 \<longleftrightarrow> x = 0"
  using Lambert_W_eq_iff[of x 0]
  by (cases "x \<ge> -exp (-1)") (auto simp: Lambert_W_le_minus_one simp del: Lambert_W_eq_iff)

lemma Lambert_W_neg_iff [simp]: "Lambert_W x < 0 \<longleftrightarrow> x < 0"
  using Lambert_W_nonneg_iff[of x] by (auto simp del: Lambert_W_nonneg_iff)

lemma Lambert_W_nonpos_iff [simp]: "Lambert_W x \<le> 0 \<longleftrightarrow> x \<le> 0"
  using Lambert_W_pos_iff[of x] by (auto simp del: Lambert_W_pos_iff)

lemma Lambert_W_geI:
  assumes "y * exp y \<le> x"
  shows   "Lambert_W x \<ge> y"
proof (cases "y \<ge> -1")
  case False
  hence "y \<le> -1" by simp
  also have "-1 \<le> Lambert_W x" by (rule Lambert_W_ge)
  finally show ?thesis .
next
  case True
  have "Lambert_W x \<ge> Lambert_W (y * exp y)"
    using assms exp_times_self_ge[of y] by (intro Lambert_W_mono) auto
  thus ?thesis using assms True by simp
qed

lemma Lambert_W_gtI:
  assumes "y * exp y < x"
  shows   "Lambert_W x > y"
proof (cases "y \<ge> -1")
  case False
  hence "y < -1" by simp
  also have "-1 \<le> Lambert_W x" by (rule Lambert_W_ge)
  finally show ?thesis .
next
  case True
  have "Lambert_W x > Lambert_W (y * exp y)"
    using assms exp_times_self_ge[of y] by (intro Lambert_W_strict_mono) auto
  thus ?thesis using assms True by simp
qed

lemma Lambert_W_leI:
  assumes "y * exp y \<ge> x" "y \<ge> -1" "x \<ge> -exp (-1)"
  shows   "Lambert_W x \<le> y"
proof -
  have "Lambert_W x \<le> Lambert_W (y * exp y)"
    using assms exp_times_self_ge[of y] by (intro Lambert_W_mono) auto
  thus ?thesis using assms by simp
qed

lemma Lambert_W_lessI:
  assumes "y * exp y > x" "y \<ge> -1" "x \<ge> -exp (-1)"
  shows   "Lambert_W x < y"
proof -
  have "Lambert_W x < Lambert_W (y * exp y)"
    using assms exp_times_self_ge[of y] by (intro Lambert_W_strict_mono) auto
  thus ?thesis using assms by simp
qed

lemma Lambert_W'_strict_antimono:
  assumes "-exp (-1) \<le> x" "x < y" "y < 0"
  shows   "Lambert_W' x > Lambert_W' y"
proof (rule ccontr)
  assume "\<not>(Lambert_W' x > Lambert_W' y)"
  hence "Lambert_W' x * exp (Lambert_W' x) \<ge> Lambert_W' y * exp (Lambert_W' y)"
    using assms by (intro exp_times_self_antimono Lambert_W'_le) auto
  hence "x \<ge> y"
    using assms by (simp add: Lambert_W'_times_exp_self)
  with assms show False by simp
qed

lemma Lambert_W'_antimono:
  assumes "x \<ge> -exp(-1)" "x \<le> y" "y < 0"
  shows   "Lambert_W' x \<ge> Lambert_W' y"
  using Lambert_W'_strict_antimono[of x y] assms by (cases "x = y") auto

lemma Lambert_W'_eq_iff [simp]:
  "x \<in> {-exp(-1)..<0} \<Longrightarrow> y \<in> {-exp(-1)..<0} \<Longrightarrow> Lambert_W' x = Lambert_W' y \<longleftrightarrow> x = y"
  using Lambert_W'_strict_antimono[of x y] Lambert_W'_strict_antimono[of y x]
  by (cases x y rule: linorder_cases) auto

lemma Lambert_W'_le_iff [simp]:
  "x \<in> {-exp(-1)..<0} \<Longrightarrow> y \<in> {-exp(-1)..<0} \<Longrightarrow> Lambert_W' x \<le> Lambert_W' y \<longleftrightarrow> x \<ge> y"
  using Lambert_W'_strict_antimono[of x y] Lambert_W'_strict_antimono[of y x]
  by (cases x y rule: linorder_cases) auto

lemma Lambert_W'_less_iff [simp]:
  "x \<in> {-exp(-1)..<0} \<Longrightarrow> y \<in> {-exp(-1)..<0} \<Longrightarrow> Lambert_W' x < Lambert_W' y \<longleftrightarrow> x > y"
  using Lambert_W'_strict_antimono[of x y] Lambert_W'_strict_antimono[of y x]
  by (cases x y rule: linorder_cases) auto

lemma Lambert_W'_le_minus_one:
  assumes "x \<le> -exp(-1)"
  shows   "Lambert_W' x = -1"
proof (cases "x = -exp(-1)")
  case False
  thus ?thesis using assms
    by (auto simp: Lambert_W'_def)
qed auto

lemma Lambert_W'_ge_zero: "x \<ge> 0 \<Longrightarrow> Lambert_W' x = -1"
  by (simp add: Lambert_W'_def)

lemma Lambert_W'_neg: "Lambert_W' x < 0"
  by (rule le_less_trans[OF Lambert_W'_le]) auto

lemma Lambert_W'_nz [simp]: "Lambert_W' x \<noteq> 0"
  using Lambert_W'_neg[of x] by simp

lemma Lambert_W'_geI:
  assumes "y * exp y \<ge> x" "y \<le> -1" "x \<ge> -exp(-1)"
  shows   "Lambert_W' x \<ge> y"
proof -
  from assms have "y * exp y < 0"
    by (intro mult_neg_pos) auto
  hence "Lambert_W' x \<ge> Lambert_W' (y * exp y)"
    using assms exp_times_self_ge[of y] by (intro Lambert_W'_antimono) auto
  thus ?thesis using assms by simp
qed

lemma Lambert_W'_gtI:
  assumes "y * exp y > x" "y \<le> -1" "x \<ge> -exp(-1)"
  shows   "Lambert_W' x \<ge> y"
proof -
  from assms have "y * exp y < 0"
    by (intro mult_neg_pos) auto
  hence "Lambert_W' x > Lambert_W' (y * exp y)"
    using assms exp_times_self_ge[of y] by (intro Lambert_W'_strict_antimono) auto
  thus ?thesis using assms by simp
qed

lemma Lambert_W'_leI:
  assumes "y * exp y \<le> x" "x < 0"
  shows   "Lambert_W' x \<le> y"
proof (cases "y \<le> -1")
  case True
  have "Lambert_W' x \<le> Lambert_W' (y * exp y)"
    using assms exp_times_self_ge[of y] by (intro Lambert_W'_antimono) auto
  thus ?thesis using assms True by simp
next
  case False
  have "Lambert_W' x \<le> -1"
    by (rule Lambert_W'_le)
  also have "\<dots> < y"
    using False by simp
  finally show ?thesis by simp
qed

lemma Lambert_W'_lessI:
  assumes "y * exp y < x" "x < 0"
  shows   "Lambert_W' x < y"
proof (cases "y \<le> -1")
  case True
  have "Lambert_W' x < Lambert_W' (y * exp y)"
    using assms exp_times_self_ge[of y] by (intro Lambert_W'_strict_antimono) auto
  thus ?thesis using assms True by simp
next
  case False
  have "Lambert_W' x \<le> -1"
    by (rule Lambert_W'_le)
  also have "\<dots> < y"
    using False by simp
  finally show ?thesis by simp
qed

lemma bij_betw_exp_times_self_atLeastAtMost:
  fixes a b :: real
  assumes "a \<ge> -1" "a \<le> b"
  shows   "bij_betw (\<lambda>x. x * exp x) {a..b} {a * exp a..b * exp b}"
  unfolding bij_betw_def
proof
  show "inj_on (\<lambda>x. x * exp x) {a..b}"
    by (rule inj_on_subset[OF exp_times_self_inj]) (use assms in auto)
next
  show "(\<lambda>x. x * exp x) ` {a..b} = {a * exp a..b * exp b}"
  proof safe
    fix x assume "x \<in> {a..b}"
    thus "x * exp x \<in> {a * exp a..b * exp b}"
      using assms by (auto intro!: exp_times_self_mono)
  next
    fix x assume x: "x \<in> {a * exp a..b * exp b}"
    have "(-1) * exp (-1) \<le> a * exp a"
      using assms by (intro exp_times_self_mono) auto
    also have "\<dots> \<le> x" using x by simp
    finally have "x \<ge> -exp (-1)" by simp

    have "Lambert_W x \<in> {a..b}"
      using x \<open>x \<ge> -exp (-1)\<close> assms by (auto intro!: Lambert_W_geI Lambert_W_leI)
    moreover have "Lambert_W x * exp (Lambert_W x) = x"
      using \<open>x \<ge> -exp (-1)\<close> by (simp add: Lambert_W_times_exp_self)
    ultimately show "x \<in> (\<lambda>x. x * exp x) ` {a..b}"
      unfolding image_iff by metis
  qed
qed

lemma bij_betw_exp_times_self_atLeastAtMost':
  fixes a b :: real
  assumes "a \<le> b" "b \<le> -1"
  shows   "bij_betw (\<lambda>x. x * exp x) {a..b} {b * exp b..a * exp a}"
  unfolding bij_betw_def
proof
  show "inj_on (\<lambda>x. x * exp x) {a..b}"
    by (rule inj_on_subset[OF exp_times_self_inj']) (use assms in auto)
next
  show "(\<lambda>x. x * exp x) ` {a..b} = {b * exp b..a * exp a}"
  proof safe
    fix x assume "x \<in> {a..b}"
    thus "x * exp x \<in> {b * exp b..a * exp a}"
      using assms by (auto intro!: exp_times_self_antimono)
  next
    fix x assume x: "x \<in> {b * exp b..a * exp a}"
    from assms have "a * exp a < 0"
      by (intro mult_neg_pos) auto
    with x have "x < 0" by auto
    have "(-1) * exp (-1) \<le> b * exp b"
      using assms by (intro exp_times_self_antimono) auto
    also have "\<dots> \<le> x" using x by simp
    finally have "x \<ge> -exp (-1)" by simp

    have "Lambert_W' x \<in> {a..b}"
      using x \<open>x \<ge> -exp (-1)\<close> \<open>x < 0\<close> assms
      by (auto intro!: Lambert_W'_geI Lambert_W'_leI)
    moreover have "Lambert_W' x * exp (Lambert_W' x) = x"
      using \<open>x \<ge> -exp (-1)\<close> \<open>x < 0\<close> by (auto simp: Lambert_W'_times_exp_self)
    ultimately show "x \<in> (\<lambda>x. x * exp x) ` {a..b}"
      unfolding image_iff by metis
  qed
qed

lemma bij_betw_exp_times_self_atLeast:
  fixes a :: real
  assumes "a \<ge> -1"
  shows   "bij_betw (\<lambda>x. x * exp x) {a..} {a * exp a..}"
  unfolding bij_betw_def
proof
  show "inj_on (\<lambda>x. x * exp x) {a..}"
    by (rule inj_on_subset[OF exp_times_self_inj]) (use assms in auto)
next
  show "(\<lambda>x. x * exp x) ` {a..} = {a * exp a..}"
  proof safe
    fix x assume "x \<ge> a"
    thus "x * exp x \<ge> a * exp a"
      using assms by (auto intro!: exp_times_self_mono)
  next
    fix x assume x: "x \<ge> a * exp a"
    have "(-1) * exp (-1) \<le> a * exp a"
      using assms by (intro exp_times_self_mono) auto
    also have "\<dots> \<le> x" using x by simp
    finally have "x \<ge> -exp (-1)" by simp

    have "Lambert_W x \<in> {a..}"
      using x \<open>x \<ge> -exp (-1)\<close> assms by (auto intro!: Lambert_W_geI Lambert_W_leI)
    moreover have "Lambert_W x * exp (Lambert_W x) = x"
      using \<open>x \<ge> -exp (-1)\<close> by (simp add: Lambert_W_times_exp_self)
    ultimately show "x \<in> (\<lambda>x. x * exp x) ` {a..}"
      unfolding image_iff by metis
  qed
qed

subsection \<open>Basic identities and bounds\<close>

lemma Lambert_W_2_ln_2 [simp]: "Lambert_W (2 * ln 2) = ln 2"
proof -
  have "-1 \<le> (0 :: real)"
    by simp
  also have "\<dots> \<le> ln 2"
    by simp
  finally have "-1 \<le> (ln 2 :: real)" .
  thus ?thesis
    by (intro Lambert_W_eqI) auto
qed

lemma Lambert_W_exp_1 [simp]: "Lambert_W (exp 1) = 1"
  by (rule Lambert_W_eqI) auto

lemma Lambert_W_neg_ln_over_self:
  assumes "x \<in> {exp (-1)..exp 1}"
  shows   "Lambert_W (-ln x / x) = -ln x"
proof -
  have "0 < (exp (-1) :: real)"
    by simp
  also have "\<dots> \<le> x"
    using assms by simp
  finally have "x > 0" .
  from \<open>x > 0\<close> assms have "ln x \<le> ln (exp 1)"
    by (subst ln_le_cancel_iff) auto
  also have "ln (exp 1) = (1 :: real)"
    by simp
  finally have "ln x \<le> 1" .
  show ?thesis
    using assms \<open>x > 0\<close> \<open>ln x \<le> 1\<close>
    by (intro Lambert_W_eqI) (auto simp: exp_minus field_simps)
qed

lemma Lambert_W'_neg_ln_over_self:
  assumes "x \<ge> exp 1"
  shows   "Lambert_W' (-ln x / x) = -ln x"
proof (rule Lambert_W'_eqI)
  have "0 < (exp 1 :: real)"
    by simp
  also have "\<dots> \<le> x"
    by fact
  finally have "x > 0" .
  from assms \<open>x > 0\<close> have "ln x \<ge> ln (exp 1)"
    by (subst ln_le_cancel_iff) auto
  thus "-ln x \<le> -1" by simp
  show "-ln x * exp (-ln x) = -ln x / x"
    using \<open>x > 0\<close> by (simp add: field_simps exp_minus)
qed

lemma exp_Lambert_W: "x \<ge> -exp (-1) \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> exp (Lambert_W x) = x / Lambert_W x"
  using Lambert_W_times_exp_self[of x] by (auto simp add: divide_simps mult_ac)

lemma exp_Lambert_W': "x \<in> {-exp (-1)..<0} \<Longrightarrow> exp (Lambert_W' x) = x / Lambert_W' x"
  using Lambert_W'_times_exp_self[of x] by (auto simp add: divide_simps mult_ac)

lemma ln_Lambert_W:
  assumes "x > 0"
  shows   "ln (Lambert_W x) = ln x - Lambert_W x"
proof -
  have "-exp (-1) \<le> (0 :: real)"
    by simp
  also have "\<dots> < x" by fact
  finally have x: "x > -exp(-1)" .

  have "exp (ln (Lambert_W x)) = exp (ln x - Lambert_W x)"
    using assms x by (subst exp_diff) (auto simp: exp_Lambert_W)
  thus ?thesis by (subst (asm) exp_inj_iff)
qed

lemma ln_minus_Lambert_W':
  assumes "x \<in> {-exp (-1)..<0}"
  shows   "ln (-Lambert_W' x) = ln (-x) - Lambert_W' x"
proof -
  have "exp (ln (-x) - Lambert_W' x) = -Lambert_W' x"
    using assms by (simp add: exp_diff exp_Lambert_W')
  also have "\<dots> = exp (ln (-Lambert_W' x))"
    using Lambert_W'_neg[of x] by simp
  finally show ?thesis by simp
qed

lemma Lambert_W_plus_Lambert_W_eq:
  assumes "x > 0" "y > 0"
  shows   "Lambert_W x + Lambert_W y = Lambert_W (x * y * (1 / Lambert_W x + 1 / Lambert_W y))"
proof (rule sym, rule Lambert_W_eqI)
  have "x > -exp(-1)" "y > -exp (-1)"
    by (rule less_trans[OF _ assms(1)] less_trans[OF _ assms(2)], simp)+
  with assms show "(Lambert_W x + Lambert_W y) * exp (Lambert_W x + Lambert_W y) =
                     x * y * (1 / Lambert_W x + 1 / Lambert_W y)"
    by (auto simp: field_simps exp_add exp_Lambert_W)
  have "-1 \<le> (0 :: real)"
    by simp
  also from assms have "\<dots> \<le> Lambert_W x + Lambert_W y"
    by (intro add_nonneg_nonneg) auto
  finally show "\<dots> \<ge> -1" .
qed

lemma Lambert_W'_plus_Lambert_W'_eq:
  assumes "x \<in> {-exp(-1)..<0}" "y \<in> {-exp(-1)..<0}"
  shows   "Lambert_W' x + Lambert_W' y = Lambert_W' (x * y * (1 / Lambert_W' x + 1 / Lambert_W' y))"
proof (rule sym, rule Lambert_W'_eqI)
  from assms show "(Lambert_W' x + Lambert_W' y) * exp (Lambert_W' x + Lambert_W' y) =
                     x * y * (1 / Lambert_W' x + 1 / Lambert_W' y)"
    by (auto simp: field_simps exp_add exp_Lambert_W')
  have "Lambert_W' x + Lambert_W' y \<le> -1 + -1"
    by (intro add_mono Lambert_W'_le)
  also have "\<dots> \<le> -1" by simp
  finally show "Lambert_W' x + Lambert_W' y \<le> -1" .
qed

lemma Lambert_W_gt_ln_minus_ln_ln:
  assumes "x > exp 1"
  shows   "Lambert_W x > ln x - ln (ln x)"
proof (rule Lambert_W_gtI)
  have "x > 1"
    by (rule less_trans[OF _ assms]) auto
  have "ln x > ln (exp 1)"
    by (subst ln_less_cancel_iff) (use \<open>x > 1\<close> assms in auto)
  thus "(ln x - ln (ln x)) * exp (ln x - ln (ln x)) < x"
    using assms \<open>x > 1\<close> by (simp add: exp_diff field_simps)
qed

lemma Lambert_W_less_ln:
  assumes "x > exp 1"
  shows   "Lambert_W x < ln x"
proof (rule Lambert_W_lessI)
  have "x > 0"
    by (rule less_trans[OF _ assms]) auto
  have "ln x > ln (exp 1)"
    by (subst ln_less_cancel_iff) (use \<open>x > 0\<close> assms in auto)
  thus "x < ln x * exp (ln x)"
    using \<open>x > 0\<close> by simp
  show "ln x \<ge> -1"
    by (rule less_imp_le[OF le_less_trans[OF _ \<open>ln x > _\<close>]]) auto
  show "x \<ge> -exp (-1)"
    by (rule less_imp_le[OF le_less_trans[OF _ \<open>x > 0\<close>]]) auto
qed

subsection \<open>Limits, continuity, and differentiability\<close>

lemma filterlim_Lambert_W_at_top [tendsto_intros]: "filterlim Lambert_W at_top at_top"
  unfolding filterlim_at_top
proof
  fix C :: real
  have "eventually (\<lambda>x. x \<ge> C * exp C) at_top"
    by (rule eventually_ge_at_top)
  thus "eventually (\<lambda>x. Lambert_W x \<ge> C) at_top"
  proof eventually_elim
    case (elim x)
    thus ?case
      by (intro Lambert_W_geI) auto
  qed
qed

lemma filterlim_Lambert_W_at_left_0 [tendsto_intros]:
  "filterlim Lambert_W' at_bot (at_left 0)"
  unfolding filterlim_at_bot
proof
  fix C :: real
  define C' where "C' = min C (-1)"
  have "C' < 0" "C' \<le> C"
    by (simp_all add: C'_def)
  have "C' * exp C' < 0"
    using \<open>C' < 0\<close> by (intro mult_neg_pos) auto
  hence "eventually (\<lambda>x. x \<ge> C' * exp C') (at_left 0)"
    by real_asymp
  moreover have "eventually (\<lambda>x::real. x < 0) (at_left 0)"
    by real_asymp
  ultimately show "eventually (\<lambda>x. Lambert_W' x \<le> C) (at_left 0)"
  proof eventually_elim
    case (elim x)
    hence "Lambert_W' x \<le> C'"
      by (intro Lambert_W'_leI) auto
    also have "\<dots> \<le> C" by fact
    finally show ?case .
  qed
qed

lemma continuous_on_Lambert_W [continuous_intros]: "continuous_on {-exp (-1)..} Lambert_W"
proof -
  have *: "continuous_on {-exp (-1)..b * exp b} Lambert_W" if "b \<ge> 0" for b
  proof -
    have "continuous_on ((\<lambda>x. x * exp x) ` {-1..b}) Lambert_W"
      by (rule continuous_on_inv) (auto intro!: continuous_intros)
    also have "(\<lambda>x. x * exp x) ` {-1..b} = {-exp (-1)..b * exp b}"
      using bij_betw_exp_times_self_atLeastAtMost[of "-1" b] \<open>b \<ge> 0\<close>
      by (simp add: bij_betw_def)
    finally show ?thesis .
  qed

  have "continuous (at x) Lambert_W" if "x \<ge> 0" for x
  proof -
    have x: "-exp (-1) < x"
      by (rule less_le_trans[OF _ that]) auto

    define b where "b = Lambert_W x + 1"
    have "b \<ge> 0"
      using Lambert_W_ge[of x] by (simp add: b_def)
    have "x = Lambert_W x * exp (Lambert_W x)"
      using that x by (subst Lambert_W_times_exp_self) auto
    also have "\<dots> < b * exp b"
      by (intro exp_times_self_strict_mono) (auto simp: b_def Lambert_W_ge)
    finally have "b * exp b > x" .
    have "continuous_on {-exp(-1)<..<b * exp b} Lambert_W"
      by (rule continuous_on_subset[OF *[of b]]) (use \<open>b \<ge> 0\<close> in auto)
    moreover have "x \<in> {-exp(-1)<..<b * exp b}"
      using \<open>b * exp b > x\<close> x by (auto simp: )
    ultimately show "continuous (at x) Lambert_W"
      by (subst (asm) continuous_on_eq_continuous_at) auto
  qed
  hence "continuous_on {0..} Lambert_W"
    by (intro continuous_at_imp_continuous_on) auto
  moreover have "continuous_on {-exp (-1)..0} Lambert_W"
    using *[of 0] by simp
  ultimately have "continuous_on ({-exp (-1)..0} \<union> {0..}) Lambert_W"
    by (intro continuous_on_closed_Un) auto
  also have "{-exp (-1)..0} \<union> {0..} = {-exp (-1::real)..}"
    using order.trans[of "-exp (-1)::real" 0] by auto
  finally show ?thesis .
qed

lemma continuous_on_Lambert_W_alt [continuous_intros]:
  assumes "continuous_on A f" "\<And>x. x \<in> A \<Longrightarrow> f x \<ge> -exp (-1)"
  shows   "continuous_on A (\<lambda>x. Lambert_W (f x))"
  using continuous_on_compose2[OF continuous_on_Lambert_W assms(1)] assms by auto

lemma continuous_on_Lambert_W' [continuous_intros]: "continuous_on {-exp (-1)..<0} Lambert_W'"
proof -
  have *: "continuous_on {-exp (-1)..-b * exp (-b)} Lambert_W'" if "b \<ge> 1" for b
  proof -
    have "continuous_on ((\<lambda>x. x * exp x) ` {-b..-1}) Lambert_W'"
      by (intro continuous_on_inv ballI) (auto intro!: continuous_intros)
    also have "(\<lambda>x. x * exp x) ` {-b..-1} = {-exp (-1)..-b * exp (-b)}"
      using bij_betw_exp_times_self_atLeastAtMost'[of "-b" "-1"] that
      by (simp add: bij_betw_def)
    finally show ?thesis .
  qed

  have "continuous (at x) Lambert_W'" if "x > -exp (-1)" "x < 0" for x
  proof -
    define b where "b = Lambert_W x + 1"
    have "eventually (\<lambda>b. -b * exp (-b) > x) at_top"
      using that by real_asymp
    hence "eventually (\<lambda>b. b \<ge> 1 \<and> -b * exp (-b) > x) at_top"
      by (intro eventually_conj eventually_ge_at_top)
    then obtain b where b: "b \<ge> 1" "-b * exp (-b) > x"
      by (auto simp: eventually_at_top_linorder)

    have "continuous_on {-exp(-1)<..<-b * exp (-b)} Lambert_W'"
      by (rule continuous_on_subset[OF *[of b]]) (use \<open>b \<ge> 1\<close> in auto)
    moreover have "x \<in> {-exp(-1)<..<-b * exp (-b)}"
      using b that by auto
    ultimately show "continuous (at x) Lambert_W'"
      by (subst (asm) continuous_on_eq_continuous_at) auto
  qed
  hence **: "continuous_on {-exp (-1)<..<0} Lambert_W'"
    by (intro continuous_at_imp_continuous_on) auto

  show ?thesis
    unfolding continuous_on_def
  proof
    fix x :: real assume x: "x \<in> {-exp(-1)..<0}"
    show "(Lambert_W' \<longlongrightarrow> Lambert_W' x) (at x within {-exp(-1)..<0})"
    proof (cases "x = -exp(-1)")
      case False
      hence "isCont Lambert_W' x"
        using x ** by (auto simp: continuous_on_eq_continuous_at)
      thus ?thesis
        using continuous_at filterlim_within_subset by blast
    next
      case True
      define a :: real where "a = -2 * exp (-2)"
      have a: "a > -exp (-1)"
        using exp_times_self_strict_antimono[of "-1" "-2"] by (auto simp: a_def)
      from True have "x \<in> {-exp (-1)..<a}"
        using a by (auto simp: a_def)
      have "continuous_on {-exp (-1)..<a} Lambert_W'"
        unfolding a_def by (rule continuous_on_subset[OF *[of 2]]) auto
      hence "(Lambert_W' \<longlongrightarrow> Lambert_W' x) (at x within {-exp (-1)..<a})"
        using \<open>x \<in> {-exp (-1)..<a}\<close> by (auto simp: continuous_on_def)
      also have "at x within {-exp (-1)..<a} = at_right x"
        using a by (intro at_within_nhd[of _ "{..<a}"]) (auto simp: True)
      also have "\<dots> = at x within {-exp (-1)..<0}"
        using a by (intro at_within_nhd[of _ "{..<0}"]) (auto simp: True)
      finally show ?thesis .
    qed
  qed
qed

lemma continuous_on_Lambert_W'_alt [continuous_intros]:
  assumes "continuous_on A f" "\<And>x. x \<in> A \<Longrightarrow> f x \<in> {-exp (-1)..<0}"
  shows   "continuous_on A (\<lambda>x. Lambert_W' (f x))"
  using continuous_on_compose2[OF continuous_on_Lambert_W' assms(1)] assms
  by (auto simp: subset_iff)

lemma tendsto_Lambert_W_1:
  assumes "(f \<longlongrightarrow> L) F" "eventually (\<lambda>x. f x \<ge> -exp (-1)) F"
  shows   "((\<lambda>x. Lambert_W (f x)) \<longlongrightarrow> Lambert_W L) F"
proof (cases "F = bot")
  case [simp]: False
  from tendsto_lowerbound[OF assms] have "L \<ge> -exp (-1)" by simp
  thus ?thesis
    using continuous_on_tendsto_compose[OF continuous_on_Lambert_W assms(1)] assms(2) by simp
qed auto

lemma tendsto_Lambert_W [tendsto_intros]:
  assumes "(f \<longlongrightarrow> L) F" "eventually (\<lambda>x. f x \<ge> -exp (-1)) F \<or> L > -exp (-1)"
  shows   "((\<lambda>x. Lambert_W (f x)) \<longlongrightarrow> Lambert_W L) F"
  using assms(2)
proof
  assume "L > -exp (-1)"
  from order_tendstoD(1)[OF assms(1) this] assms(1) show ?thesis
    by (intro tendsto_Lambert_W_1) (auto elim: eventually_mono)
qed (use tendsto_Lambert_W_1[OF assms(1)] in auto)

lemma tendsto_Lambert_W'_1:
  assumes "(f \<longlongrightarrow> L) F" "eventually (\<lambda>x. f x \<ge> -exp (-1)) F" "L < 0"
  shows   "((\<lambda>x. Lambert_W' (f x)) \<longlongrightarrow> Lambert_W' L) F"
proof (cases "F = bot")
  case [simp]: False
  from tendsto_lowerbound[OF assms(1,2)] have L_ge: "L \<ge> -exp (-1)" by simp
  from order_tendstoD(2)[OF assms(1,3)] have ev: "eventually (\<lambda>x. f x < 0) F"
    by auto
  with assms(2) have "eventually (\<lambda>x. f x \<in> {-exp (-1)..<0}) F"
    by eventually_elim auto
  thus ?thesis using L_ge assms(3)
    by (intro continuous_on_tendsto_compose[OF continuous_on_Lambert_W' assms(1)]) auto
qed auto

lemma tendsto_Lambert_W'_2:
  assumes "(f \<longlongrightarrow> L) F" "L > -exp (-1)" "L < 0"
  shows   "((\<lambda>x. Lambert_W' (f x)) \<longlongrightarrow> Lambert_W' L) F"
  using order_tendstoD(1)[OF assms(1,2)] assms
  by (intro tendsto_Lambert_W'_1) (auto elim: eventually_mono)

lemma tendsto_Lambert_W' [tendsto_intros]:
  assumes "(f \<longlongrightarrow> L) F" "eventually (\<lambda>x. f x \<ge> -exp (-1)) F \<or> L > -exp (-1)" "L < 0"
  shows   "((\<lambda>x. Lambert_W' (f x)) \<longlongrightarrow> Lambert_W' L) F"
  using assms(2)
proof
  assume "L > -exp (-1)"
  from order_tendstoD(1)[OF assms(1) this] assms(1,3) show ?thesis
    by (intro tendsto_Lambert_W'_1) (auto elim: eventually_mono)
qed (use tendsto_Lambert_W'_1[OF assms(1) _ assms(3)] in auto)

lemma continuous_Lambert_W [continuous_intros]:
  assumes "continuous F f" "f (Lim F (\<lambda>x. x)) > -exp (-1) \<or> eventually (\<lambda>x. f x \<ge> -exp (-1)) F"
  shows   "continuous F (\<lambda>x. Lambert_W (f x))"
  using assms unfolding continuous_def by (intro tendsto_Lambert_W) auto

lemma continuous_Lambert_W' [continuous_intros]:
  assumes "continuous F f" "f (Lim F (\<lambda>x. x)) > -exp (-1) \<or> eventually (\<lambda>x. f x \<ge> -exp (-1)) F"
          "f (Lim F (\<lambda>x. x)) < 0"
  shows   "continuous F (\<lambda>x. Lambert_W' (f x))"
  using assms unfolding continuous_def by (intro tendsto_Lambert_W') auto

lemma has_field_derivative_Lambert_W [derivative_intros]:
  assumes x: "x > -exp (-1)"
  shows   "(Lambert_W has_real_derivative inverse (x + exp (Lambert_W x))) (at x within A)"
proof -
  write Lambert_W ("W")
  from x have "W x > W (-exp (-1))"
    by (subst Lambert_W_less_iff) auto
  hence "W x > -1" by simp

  note [derivative_intros] = DERIV_inverse_function[where g = Lambert_W]
  have "((\<lambda>x. x * exp x) has_real_derivative (1 + W x) * exp (W x)) (at (W x))"
    by (auto intro!: derivative_eq_intros simp: algebra_simps)
  hence "(W has_real_derivative inverse ((1 + W x) * exp (W x))) (at x)"
    by (rule DERIV_inverse_function[where a = "-exp (-1)" and b = "x + 1"])
       (use x \<open>W x > -1\<close> in \<open>auto simp: Lambert_W_times_exp_self Lim_ident_at
                                  intro!: continuous_intros\<close>)
  also have "(1 + W x) * exp (W x) = x + exp (W x)"
    using x by (simp add: algebra_simps Lambert_W_times_exp_self)
  finally show ?thesis by (rule has_field_derivative_at_within)
qed

lemma has_field_derivative_Lambert_W_gen [derivative_intros]:
  assumes "(f has_real_derivative f') (at x within A)" "f x > -exp (-1)"
  shows   "((\<lambda>x. Lambert_W (f x)) has_real_derivative
             (f' / (f x + exp (Lambert_W (f x))))) (at x within A)"
  using DERIV_chain2[OF has_field_derivative_Lambert_W[OF assms(2)] assms(1)]
  by (simp add: field_simps)

lemma has_field_derivative_Lambert_W' [derivative_intros]:
  assumes x: "x \<in> {-exp (-1)<..<0}"
  shows   "(Lambert_W' has_real_derivative inverse (x + exp (Lambert_W' x))) (at x within A)"
proof -
  write Lambert_W' ("W")
  from x have "W x < W (-exp (-1))"
    by (subst Lambert_W'_less_iff) auto
  hence "W x < -1" by simp

  note [derivative_intros] = DERIV_inverse_function[where g = Lambert_W]
  have "((\<lambda>x. x * exp x) has_real_derivative (1 + W x) * exp (W x)) (at (W x))"
    by (auto intro!: derivative_eq_intros simp: algebra_simps)
  hence "(W has_real_derivative inverse ((1 + W x) * exp (W x))) (at x)"
    by (rule DERIV_inverse_function[where a = "-exp (-1)" and b = "0"])
       (use x \<open>W x < -1\<close> in \<open>auto simp: Lambert_W'_times_exp_self Lim_ident_at
                                        intro!: continuous_intros\<close>)
  also have "(1 + W x) * exp (W x) = x + exp (W x)"
    using x by (simp add: algebra_simps Lambert_W'_times_exp_self)
  finally show ?thesis by (rule has_field_derivative_at_within)
qed

lemma has_field_derivative_Lambert_W'_gen [derivative_intros]:
  assumes "(f has_real_derivative f') (at x within A)" "f x \<in> {-exp (-1)<..<0}"
  shows   "((\<lambda>x. Lambert_W' (f x)) has_real_derivative
             (f' / (f x + exp (Lambert_W' (f x))))) (at x within A)"
  using DERIV_chain2[OF has_field_derivative_Lambert_W'[OF assms(2)] assms(1)]
  by (simp add: field_simps)

subsection \<open>Asymptotic expansion\<close>

text \<open>
  Lastly, we prove some more detailed asymptotic expansions of $W$ and $W'$ at their
  singularities. First, we show that:
  \begin{align*}
    W(x) &= \log x - \log\log x + o(\log\log x) &&\text{for}\ x\to\infty\\
    W'(x) &= \log (-x) - \log (-\log (-x)) + o(\log (-\log (-x))) &&\text{for}\ x\to 0^{-}
  \end{align*}
\<close>
theorem Lambert_W_asymp_equiv_at_top:
  "(\<lambda>x. Lambert_W x - ln x) \<sim>[at_top] (\<lambda>x. -ln (ln x))"
proof -
  have "(\<lambda>x. Lambert_W x - ln x) \<sim>[at_top] (\<lambda>x. (-1) * ln (ln x))"
  proof (rule asymp_equiv_sandwich')
    fix c' :: real assume c': "c' \<in> {-2<..<-1}"
    have "eventually (\<lambda>x. (ln x + c' * ln (ln x)) * exp (ln x + c' * ln (ln x)) \<le> x) at_top"
         "eventually (\<lambda>x. ln x + c' * ln (ln x) \<ge> -1) at_top"
      using c' by real_asymp+
    thus "eventually (\<lambda>x. Lambert_W x - ln x \<ge> c' * ln (ln x)) at_top"
    proof eventually_elim
      case (elim x)
      hence "Lambert_W x \<ge> ln x + c' * ln (ln x)"
        by (intro Lambert_W_geI)
      thus ?case by simp
    qed
  next
    fix c' :: real assume c': "c' \<in> {-1<..<0}"
    have "eventually (\<lambda>x. (ln x + c' * ln (ln x)) * exp (ln x + c' * ln (ln x)) \<ge> x) at_top"
         "eventually (\<lambda>x. ln x + c' * ln (ln x) \<ge> -1) at_top"
      using c' by real_asymp+
    thus "eventually (\<lambda>x. Lambert_W x - ln x \<le> c' * ln (ln x)) at_top"
      using eventually_ge_at_top[of "-exp (-1)"]
    proof eventually_elim
      case (elim x)
      hence "Lambert_W x \<le> ln x + c' * ln (ln x)"
        by (intro Lambert_W_leI)
      thus ?case by simp
    qed
  qed auto
  thus ?thesis by simp
qed

lemma Lambert_W_asymp_equiv_at_top' [asymp_equiv_intros]:
  "Lambert_W \<sim>[at_top] ln"
proof -
  have "(\<lambda>x. Lambert_W x - ln x) \<in> \<Theta>(\<lambda>x. -ln (ln x))"
    by (intro asymp_equiv_imp_bigtheta Lambert_W_asymp_equiv_at_top)
  also have "(\<lambda>x::real. -ln (ln x)) \<in> o(ln)"
    by real_asymp
  finally show ?thesis by (simp add: asymp_equiv_altdef)
qed

theorem Lambert_W'_asymp_equiv_at_left_0:
  "(\<lambda>x. Lambert_W' x - ln (-x)) \<sim>[at_left 0] (\<lambda>x. -ln (-ln (-x)))"
proof -
  have "(\<lambda>x. Lambert_W' x - ln (-x)) \<sim>[at_left 0] (\<lambda>x. (-1) * ln (-ln (-x)))"
  proof (rule asymp_equiv_sandwich')
    fix c' :: real assume c': "c' \<in> {-2<..<-1}"
    have "eventually (\<lambda>x. x \<le> (ln (-x) + c' * ln (-ln (-x))) * exp (ln (-x) + c' * ln (-ln (-x)))) (at_left 0)"
         "eventually (\<lambda>x::real. ln (-x) + c' * ln (-ln (-x)) \<le> -1) (at_left 0)"
         "eventually (\<lambda>x::real. -exp (-1) \<le> x) (at_left 0)"
      using c' by real_asymp+
    thus "eventually (\<lambda>x. Lambert_W' x - ln (-x) \<ge> c' * ln (-ln (-x))) (at_left 0)"
    proof eventually_elim
      case (elim x)
      hence "Lambert_W' x \<ge> ln (-x) + c' * ln (-ln (-x))"
        by (intro Lambert_W'_geI)
      thus ?case by simp
    qed
  next
    fix c' :: real assume c': "c' \<in> {-1<..<0}"
    have "eventually (\<lambda>x. x \<ge> (ln (-x) + c' * ln (-ln (-x))) * exp (ln (-x) + c' * ln (-ln (-x)))) (at_left 0)"
      using c' by real_asymp
    moreover have "eventually (\<lambda>x::real. x < 0) (at_left 0)"
      by (auto simp: eventually_at intro: exI[of _ 1])
    ultimately show "eventually (\<lambda>x. Lambert_W' x - ln (-x) \<le> c' * ln (-ln (-x))) (at_left 0)"
    proof eventually_elim
      case (elim x)
      hence "Lambert_W' x \<le> ln (-x) + c' * ln (-ln (-x))"
        by (intro Lambert_W'_leI)
      thus ?case by simp
    qed
  qed auto
  thus ?thesis by simp
qed

lemma Lambert_W'_asymp_equiv'_at_left_0 [asymp_equiv_intros]:
  "Lambert_W' \<sim>[at_left 0] (\<lambda>x. ln (-x))"
proof -
  have "(\<lambda>x. Lambert_W' x - ln (-x)) \<in> \<Theta>[at_left 0](\<lambda>x. -ln (-ln (-x)))"
    by (intro asymp_equiv_imp_bigtheta Lambert_W'_asymp_equiv_at_left_0)
  also have "(\<lambda>x::real. -ln (-ln (-x))) \<in> o[at_left 0](\<lambda>x. ln (-x))"
    by real_asymp
  finally show ?thesis by (simp add: asymp_equiv_altdef)
qed

text \<open>
  Next, we look at the branching point $a := \tfrac{1}{e}$. Here, the asymptotic behaviour
  is as follows:
  \begin{align*}
    W(x) &= -1 + \sqrt{2e}(x - a)^{\frac{1}{2}} - \tfrac{2}{3}e(x-a) + o(x-a) &&\text{for} x\to a^+\\
    W'(x) &= -1 - \sqrt{2e}(x - a)^{\frac{1}{2}} - \tfrac{2}{3}e(x-a) + o(x-a) &&\text{for} x\to a^+
  \end{align*}
\<close>
lemma sqrt_sqrt_mult:
  assumes "x \<ge> (0 :: real)"
  shows   "sqrt x * (sqrt x * y) = x * y"
  using assms by (subst mult.assoc [symmetric]) auto

theorem Lambert_W_asymp_equiv_at_right_minus_exp_minus1:
  defines "e \<equiv> exp 1"
  defines "a \<equiv> -exp (-1)"
  defines "C1 \<equiv> sqrt (2 * exp 1)"
  defines "f \<equiv> (\<lambda>x. -1 + C1 * sqrt (x - a))"
  shows   "(\<lambda>x. Lambert_W x - f x) \<sim>[at_right a] (\<lambda>x. -2/3 * e * (x - a))"
proof -
  define C :: "real \<Rightarrow> real" where "C = (\<lambda>c. sqrt (2/e)/3 * (2*e+3*c))"
  have asymp_equiv: "(\<lambda>x. (f x + c * (x - a)) * exp (f x + c * (x - a)) - x)
                       \<sim>[at_right a] (\<lambda>x. C c * (x - a) powr (3/2))" if "c \<noteq> -2/3 * e" for c
  proof -
    from that have "C c \<noteq> 0"
      by (auto simp: C_def e_def)
    have "(\<lambda>x. (f x + c * (x - a)) * exp (f x + c * (x - a)) - x - C c * (x - a) powr (3/2))
            \<in> o[at_right a](\<lambda>x. (x - a) powr (3/2))"
      unfolding f_def a_def C_def C1_def e_def
      by (real_asymp simp: field_simps real_sqrt_mult real_sqrt_divide sqrt_sqrt_mult
                           exp_minus simp flip: sqrt_def)
    thus ?thesis
      using \<open>C c \<noteq> 0\<close> by (intro smallo_imp_asymp_equiv) auto
  qed

  show ?thesis
  proof (rule asymp_equiv_sandwich')
    fix c' :: real assume c': "c' \<in> {-e<..<-2/3*e}"
    hence neq: "c' \<noteq> -2/3 * e" by auto
    from c' have neg: "C c' < 0" unfolding C_def by (auto intro!: mult_pos_neg)
    hence "eventually (\<lambda>x. C c' * (x - a) powr (3 / 2) < 0) (at_right a)"
      by real_asymp
    hence "eventually (\<lambda>x. (f x + c' * (x - a)) * exp (f x + c' * (x - a)) - x < 0) (at_right a)"
      using asymp_equiv_eventually_neg_iff[OF asymp_equiv[OF neq]]
      by eventually_elim (use neg in auto)
    thus "eventually (\<lambda>x. Lambert_W x - f x \<ge> c' * (x - a)) (at_right a)"
    proof eventually_elim
      case (elim x)
      hence "Lambert_W x \<ge> f x + c' * (x - a)"
        by (intro Lambert_W_geI) auto
      thus ?case by simp
    qed
  next
    fix c' :: real assume c': "c' \<in> {-2/3*e<..<0}"
    hence neq: "c' \<noteq> -2/3 * e" by auto
    from c' have pos: "C c' > 0" unfolding C_def by auto
    hence "eventually (\<lambda>x. C c' * (x - a) powr (3 / 2) > 0) (at_right a)"
      by real_asymp
    hence "eventually (\<lambda>x. (f x + c' * (x - a)) * exp (f x + c' * (x - a)) - x > 0) (at_right a)"
      using asymp_equiv_eventually_pos_iff[OF asymp_equiv[OF neq]]
      by eventually_elim (use pos in auto)
    moreover have "eventually (\<lambda>x. - 1 \<le> f x + c' * (x - a)) (at_right a)"
                  "eventually (\<lambda>x. x > a) (at_right a)"
      unfolding a_def f_def C1_def c' by real_asymp+
    ultimately show "eventually (\<lambda>x. Lambert_W x - f x \<le> c' * (x - a)) (at_right a)"
    proof eventually_elim
      case (elim x)
      hence "Lambert_W x \<le> f x + c' * (x - a)"
        by (intro Lambert_W_leI) (auto simp: a_def)
      thus ?case by simp
    qed
  qed (auto simp: e_def)
qed

theorem Lambert_W'_asymp_equiv_at_right_minus_exp_minus1:
  defines "e \<equiv> exp 1"
  defines "a \<equiv> -exp (-1)"
  defines "C1 \<equiv> sqrt (2 * exp 1)"
  defines "f \<equiv> (\<lambda>x. -1 - C1 * sqrt (x - a))"
  shows   "(\<lambda>x. Lambert_W' x - f x) \<sim>[at_right a] (\<lambda>x. -2/3 * e * (x - a))"
proof -
  define C :: "real \<Rightarrow> real" where "C = (\<lambda>c. -sqrt (2/e)/3 * (2*e+3*c))"

  have asymp_equiv: "(\<lambda>x. (f x + c * (x - a)) * exp (f x + c * (x - a)) - x)
                       \<sim>[at_right a] (\<lambda>x. C c * (x - a) powr (3/2))" if "c \<noteq> -2/3 * e" for c
  proof -
    from that have "C c \<noteq> 0"
      by (auto simp: C_def e_def)
    have "(\<lambda>x. (f x + c * (x - a)) * exp (f x + c * (x - a)) - x - C c * (x - a) powr (3/2))
            \<in> o[at_right a](\<lambda>x. (x - a) powr (3/2))"
      unfolding f_def a_def C_def C1_def e_def
      by (real_asymp simp: field_simps real_sqrt_mult real_sqrt_divide sqrt_sqrt_mult
                           exp_minus simp flip: sqrt_def)
    thus ?thesis
      using \<open>C c \<noteq> 0\<close> by (intro smallo_imp_asymp_equiv) auto
  qed

  show ?thesis
  proof (rule asymp_equiv_sandwich')
    fix c' :: real assume c': "c' \<in> {-e<..<-2/3*e}"
    hence neq: "c' \<noteq> -2/3 * e" by auto
    from c' have pos: "C c' > 0" unfolding C_def by (auto intro!: mult_pos_neg)
    hence "eventually (\<lambda>x. C c' * (x - a) powr (3 / 2) > 0) (at_right a)"
      by real_asymp
    hence "eventually (\<lambda>x. (f x + c' * (x - a)) * exp (f x + c' * (x - a)) - x > 0) (at_right a)"
      using asymp_equiv_eventually_pos_iff[OF asymp_equiv[OF neq]]
      by eventually_elim (use pos in auto)
    moreover have "eventually (\<lambda>x. x > a) (at_right a)"
                  "eventually (\<lambda>x. f x + c' * (x - a) \<le> -1) (at_right a)"
      unfolding a_def f_def C1_def c' by real_asymp+
    ultimately show "eventually (\<lambda>x. Lambert_W' x - f x \<ge> c' * (x - a)) (at_right a)"
    proof eventually_elim
      case (elim x)
      hence "Lambert_W' x \<ge> f x + c' * (x - a)"
        by (intro Lambert_W'_geI) (auto simp: a_def)
      thus ?case by simp
    qed
  next
    fix c' :: real assume c': "c' \<in> {-2/3*e<..<0}"
    hence neq: "c' \<noteq> -2/3 * e" by auto
    from c' have neg: "C c' < 0" unfolding C_def by auto
    hence "eventually (\<lambda>x. C c' * (x - a) powr (3 / 2) < 0) (at_right a)"
      by real_asymp
    hence "eventually (\<lambda>x. (f x + c' * (x - a)) * exp (f x + c' * (x - a)) - x < 0) (at_right a)"
      using asymp_equiv_eventually_neg_iff[OF asymp_equiv[OF neq]]
      by eventually_elim (use neg in auto)
    moreover have "eventually (\<lambda>x. x < 0) (at_right a)"
      unfolding a_def by real_asymp
    ultimately show "eventually (\<lambda>x. Lambert_W' x - f x \<le> c' * (x - a)) (at_right a)"
    proof eventually_elim
      case (elim x)
      hence "Lambert_W' x \<le> f x + c' * (x - a)"
        by (intro Lambert_W'_leI) auto
      thus ?case by simp
    qed
  qed (auto simp: e_def)
qed

text \<open>
  Lastly, just for fun, we derive a slightly more accurate expansion of $W_0(x)$ for $x\to\infty$:
\<close>
theorem Lambert_W_asymp_equiv_at_top'':
  "(\<lambda>x. Lambert_W x - ln x + ln (ln x)) \<sim>[at_top] (\<lambda>x. ln (ln x) / ln x)"
proof -
  have "(\<lambda>x. Lambert_W x - ln x + ln (ln x)) \<sim>[at_top] (\<lambda>x. 1 * (ln (ln x) / ln x))"
  proof (rule asymp_equiv_sandwich')
    fix c' :: real assume c': "c' \<in> {0<..<1}"
    define a where "a = (\<lambda>x::real. ln x - ln (ln x) + c' * (ln (ln x) / ln x))"
    have "eventually (\<lambda>x. a x * exp (a x) \<le> x) at_top"
      using c' unfolding a_def by real_asymp+
    thus "eventually (\<lambda>x. Lambert_W x - ln x + ln (ln x) \<ge> c' * (ln (ln x) / ln x)) at_top"
    proof eventually_elim
      case (elim x)
      hence "Lambert_W x \<ge> a x"
        by (intro Lambert_W_geI)
      thus ?case by (simp add: a_def)
    qed
  next
    fix c' :: real assume c': "c' \<in> {1<..<2}"
    define a where "a = (\<lambda>x::real. ln x - ln (ln x) + c' * (ln (ln x) / ln x))"
    have "eventually (\<lambda>x. a x * exp (a x) \<ge> x) at_top"
         "eventually (\<lambda>x. a x \<ge> -1) at_top"
      using c' unfolding a_def by real_asymp+
    thus "eventually (\<lambda>x. Lambert_W x - ln x + ln (ln x) \<le> c' * (ln (ln x) / ln x)) at_top"
      using eventually_ge_at_top[of "-exp (-1)"]
    proof eventually_elim
      case (elim x)
      hence "Lambert_W x \<le> a x"
        by (intro Lambert_W_leI)
      thus ?case by (simp add: a_def)
    qed
  qed auto
  thus ?thesis by simp
qed

end


text \<open>The following proof follows the HOL-Light implementation by John Harrison at
      https://github.com/jrh13/hol-light/blob/master/100/polyhedron.ml\<close>

subsection \<open>Interpret which "side" of a hyperplane a point is on.\<close>

default_sort "real_inner"

type_synonym 'v hyperplane = "'v \<times> real"
type_synonym 'v arrangement = "('v hyperplane) set"

fun hyperplane_side :: "'v hyperplane \<Rightarrow> 'v  \<Rightarrow> real" where
  "hyperplane_side (a, b) x = sgn (a \<bullet> x - b)"

subsection \<open>Equivalence relation imposed by hyperplane arrangement.\<close>

definition hyperplane_equiv  :: "'v arrangement \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> bool" where
  "hyperplane_equiv A x y \<equiv> \<forall>h\<in>A. hyperplane_side h x = hyperplane_side h y"

lemma hyperplane_equiv_refl:
  "hyperplane_equiv A x x"
  by (smt hyperplane_equiv_def)

lemma hyperplane_equiv_sym:
  "hyperplane_equiv A x y \<equiv> hyperplane_equiv A y x"
  by (smt hyperplane_equiv_def)

lemma hyperplane_equiv_trans:
  "hyperplane_equiv A x y \<and> hyperplane_equiv A y z \<Longrightarrow> hyperplane_equiv A x z"
  by (smt hyperplane_equiv_def)

lemma hyperplane_equiv_union:
  "hyperplane_equiv (A\<union>B) x y \<equiv>
   hyperplane_equiv A x y \<and> hyperplane_equiv B x y"
  by (smt Un_iff hyperplane_equiv_def)

subsection \<open>Cells of a hyperplane arrangement\<close>

\<comment> \<open>Harrison seems to define hyperplane_cell as a partially applied function,
   and then immediately proves a lemma that shows it's a set. Maybe this is some
   kind of magic thing in HOL/Light? I'll use the set definition directly and
   hope for the best.\<close>

definition hyperplane_cell :: "'v arrangement \<Rightarrow> ('v set) \<Rightarrow> bool" where
  "hyperplane_cell A c \<equiv> \<exists>x. c = {y. hyperplane_equiv A x y}"

\<^cancel>\<open>lemma hyperplane_cell:   \<comment> \<open>Do I need this?\<close>
  "hyperplane_cell A c \<equiv> (\<exists>x. c = {y. hyperplane_equiv A x y})"
  by (fact hyperplane_cell_def)\<close>

lemma not_hyperplane_cell_empty: "\<not> hyperplane_cell A {}"
  using hyperplane_cell_def hyperplane_equiv_refl by fastforce

lemma nonempty_hyperplane_cell: "hyperplane_cell A c \<Longrightarrow> \<not>(c = {})"
  using hyperplane_cell_def hyperplane_equiv_refl by fastforce

\<comment> \<open>This is saying the union of all hyperplane cells in the arrangement is the entire
   real^N space. I am somewhat impressed that sledgehammer managed to prove this, once I
   broke it down into sub-cases.\<close>
lemma unions_hyperplane_cells: "\<Union> {c. hyperplane_cell A c} = UNIV"
proof
  show "\<Union> {c. hyperplane_cell A c} \<subseteq> UNIV" by simp
next
  show "UNIV \<subseteq> \<Union> {c. hyperplane_cell A c}"
    by (metis (mono_tags, hide_lams) UnionI hyperplane_cell_def hyperplane_equiv_refl mem_Collect_eq subsetI)
qed

lemma disjoint_hyperplane_cells:
  assumes "hyperplane_cell A c1" and "hyperplane_cell A c2" and "\<not>(c1=c2)"
  shows "disjoint {c1, c2}"
  sorry

lemma disjoint_hyperplane_cells_eq:
  "hyperplane_cell A c1 \<and> hyperplane_cell A c2 \<Longrightarrow> (disjoint {c1,c2} \<equiv> \<not>(c1=c2))"
  sorry

lemma hyperplane_cell_empty: "hyperplane_cell {} c \<equiv> c = UNIV"
  by (simp add: hyperplane_cell_def hyperplane_equiv_def)

lemma hyperplane_cell_sing_cases:
  assumes "hyperplane_cell {(a,b)} c"
  shows "c = {x. a \<bullet> x = b} \<or>
         c = {x. a \<bullet> x < b} \<or>
         c = {x. a \<bullet> x > b}"
  sorry

\<^cancel>\<open>
let HYPERPLANE_CELL_SING = prove
 (`!a b c.
        hyperplane_cell {(a,b)} c <=>
        if a = vec 0 then c = (:real^N)
        else c = {x | a dot x = b} \/
             c = {x | a dot x < b} \/
             c = {x | a dot x > b}`,

let HYPERPLANE_CELL_UNION = prove
 (`!A B c:real^N->bool.
        hyperplane_cell (A UNION B) c <=>
        ~(c = {}) /\
        ?c1 c2. hyperplane_cell A c1 /\
                hyperplane_cell B c2 /\
                c = c1 INTER c2`,

let FINITE_HYPERPLANE_CELLS = prove
 (`!A. FINITE A ==> FINITE {c:real^N->bool | hyperplane_cell A c}`,

let FINITE_RESTRICT_HYPERPLANE_CELLS = prove
 (`!P A. FINITE A ==> FINITE {c:real^N->bool | hyperplane_cell A c /\ P c}`,

let FINITE_SET_OF_HYPERPLANE_CELLS = prove
 (`!A C. FINITE A /\ (!c:real^N->bool. c IN C ==> hyperplane_cell A c)
         ==> FINITE C`,

let PAIRWISE_DISJOINT_HYPERPLANE_CELLS = prove
 (`!A C. (!c. c IN C ==> hyperplane_cell A c)
         ==> pairwise DISJOINT C`,

let HYPERPLANE_CELL_INTER_OPEN_AFFINE = prove
 (`!A c:real^N->bool.
        FINITE A /\ hyperplane_cell A c
        ==> ?s t. open s /\ affine t /\ c = s INTER t`,

let HYPERPLANE_CELL_RELATIVELY_OPEN = prove
 (`!A c:real^N->bool.
        FINITE A /\ hyperplane_cell A c
        ==> open_in (subtopology euclidean (affine hull c)) c`,

let HYPERPLANE_CELL_RELATIVE_INTERIOR = prove
 (`!A c:real^N->bool.
        FINITE A /\ hyperplane_cell A c
        ==> relative_interior c = c`,

let HYPERPLANE_CELL_CONVEX = prove
 (`!A c:real^N->bool. hyperplane_cell A c ==> convex c`,

let HYPERPLANE_CELL_INTERS = prove
 (`!A C. (!c:real^N->bool. c IN C ==> hyperplane_cell A c) /\
         ~(C = {}) /\ ~(INTERS C = {})
         ==> hyperplane_cell A (INTERS C)`,

let HYPERPLANE_CELL_INTER = prove
 (`!A s t:real^N->bool.
        hyperplane_cell A s /\ hyperplane_cell A t /\ ~(s INTER t = {})
        ==> hyperplane_cell A (s INTER t)`,
\<close>

subsection \<open>A cell complex is considered to be a union of such cells\<close>

\<^cancel>\<open>
let hyperplane_cellcomplex = new_definition
 `hyperplane_cellcomplex A s <=>
        ?t. (!c. c IN t ==> hyperplane_cell A c) /\
            s = UNIONS t`;;

let HYPERPLANE_CELLCOMPLEX_EMPTY = prove
 (`!A:real^N#real->bool. hyperplane_cellcomplex A {}`,

let HYPERPLANE_CELL_CELLCOMPLEX = prove
 (`!A c:real^N->bool. hyperplane_cell A c ==> hyperplane_cellcomplex A c`,

let HYPERPLANE_CELLCOMPLEX_UNIONS = prove
 (`!A C. (!s:real^N->bool. s IN C ==> hyperplane_cellcomplex A s)
         ==> hyperplane_cellcomplex A (UNIONS C)`

let HYPERPLANE_CELLCOMPLEX_UNION = prove
 (`!A s t.
        hyperplane_cellcomplex A s /\ hyperplane_cellcomplex A t
        ==> hyperplane_cellcomplex A (s UNION t)`

let HYPERPLANE_CELLCOMPLEX_UNIV = prove
 (`!A. hyperplane_cellcomplex A (:real^N)`

let HYPERPLANE_CELLCOMPLEX_INTERS = prove
 (`!A C. (!s:real^N->bool. s IN C ==> hyperplane_cellcomplex A s)
         ==> hyperplane_cellcomplex A (INTERS C)`,

let HYPERPLANE_CELLCOMPLEX_INTER = prove
 (`!A s t.
        hyperplane_cellcomplex A s /\ hyperplane_cellcomplex A t
        ==> hyperplane_cellcomplex A (s INTER t)`

let HYPERPLANE_CELLCOMPLEX_COMPL = prove
 (`!A s. hyperplane_cellcomplex A s
         ==> hyperplane_cellcomplex A ((:real^N) DIFF s)`,

let HYPERPLANE_CELLCOMPLEX_DIFF = prove
 (`!A s t.
        hyperplane_cellcomplex A s /\ hyperplane_cellcomplex A t
        ==> hyperplane_cellcomplex A (s DIFF t)`,

let HYPERPLANE_CELLCOMPLEX_MONO = prove
 (`!A B s:real^N->bool.
        hyperplane_cellcomplex A s /\ A SUBSET B
        ==> hyperplane_cellcomplex B s`,

let FINITE_HYPERPLANE_CELLCOMPLEXES = prove
 (`!A. FINITE A ==> FINITE {c:real^N->bool | hyperplane_cellcomplex A c}`,

let FINITE_RESTRICT_HYPERPLANE_CELLCOMPLEXES = prove
 (`!P A. FINITE A
         ==> FINITE {c:real^N->bool | hyperplane_cellcomplex A c /\ P c}`,

let FINITE_SET_OF_HYPERPLANE_CELLS = prove
 (`!A C. FINITE A /\ (!c:real^N->bool. c IN C ==> hyperplane_cellcomplex A c)
         ==> FINITE C`,

let CELL_SUBSET_CELLCOMPLEX = prove
 (`!A s c:real^N->bool.
        hyperplane_cell A c /\ hyperplane_cellcomplex A s
        ==> (c SUBSET s <=> ~(DISJOINT c s))`,
\<close>

subsection \<open>Euler Characteristic\<close>

\<^cancel>\<open>
let euler_characteristic = new_definition
 `euler_characteristic A (s:real^N->bool) =
        sum {c | hyperplane_cell A c /\ c SUBSET s}
            (\c. (-- &1) pow (num_of_int(aff_dim c)))`;;

let EULER_CHARACTERISTIC_EMPTY = prove
 (`euler_characteristic A {} = &0`,

let EULER_CHARACTERISTIC_CELL_UNIONS = prove
 (`!A C. (!c:real^N->bool. c IN C ==> hyperplane_cell A c)
         ==> euler_characteristic A (UNIONS C) =
             sum C (\c. (-- &1) pow (num_of_int(aff_dim c)))`

let EULER_CHARACTERISTIC_CELL = prove
 (`!A c. hyperplane_cell A c
         ==> euler_characteristic A c =  (-- &1) pow (num_of_int(aff_dim c))`,

let EULER_CHARACTERISTIC_CELLCOMPLEX_UNION = prove
 (`!A s t:real^N->bool.
        FINITE A /\
        hyperplane_cellcomplex A s /\
        hyperplane_cellcomplex A t /\
        DISJOINT s t
        ==> euler_characteristic A (s UNION t) =
            euler_characteristic A s + euler_characteristic A t`,

let EULER_CHARACTERISTIC_CELLCOMPLEX_UNIONS = prove
 (`!A C. FINITE A /\
         (!c:real^N->bool. c IN C ==> hyperplane_cellcomplex A c) /\
         pairwise DISJOINT C
         ==> euler_characteristic A (UNIONS C) =
             sum C (\c. euler_characteristic A c)`,

let EULER_CHARACTERISTIC = prove
 (`!A s:real^N->bool.
        FINITE A
        ==> euler_characteristic A s =
            sum (0..dimindex(:N))
                (\d. (-- &1) pow d *
                     &(CARD {c | hyperplane_cell A c /\ c SUBSET s /\
                                 aff_dim c = &d}))`,
\<close>

subsection \<open>Show that the characteristic is invariant w.r.t. hyperplane arrangement.\<close>

\<^cancel>\<open>
let HYPERPLANE_CELLS_DISTINCT_LEMMA = prove
 (`!a b. {x | a dot x = b} INTER {x | a dot x < b} = {} /\
         {x | a dot x = b} INTER {x | a dot x > b} = {} /\
         {x | a dot x < b} INTER {x | a dot x = b} = {} /\
         {x | a dot x < b} INTER {x | a dot x > b} = {} /\
         {x | a dot x > b} INTER {x | a dot x = b} = {} /\
         {x | a dot x > b} INTER {x | a dot x < b} = {}`,
  REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; NOT_IN_EMPTY] THEN
  REAL_ARITH_TAC);;

let EULER_CHARACTERSTIC_LEMMA = prove
 (`!A h s:real^N->bool.
        FINITE A /\ hyperplane_cellcomplex A s
        ==> euler_characteristic (h INSERT A) s = euler_characteristic A s`,

let EULER_CHARACTERSTIC_INVARIANT = prove
 (`!A B h s:real^N->bool.
        FINITE A /\ FINITE B /\
        hyperplane_cellcomplex A s /\ hyperplane_cellcomplex B s
        ==> euler_characteristic A s = euler_characteristic B s`,
  SUBGOAL_THEN
   `!A s:real^N->bool.
        FINITE A /\ hyperplane_cellcomplex A s
        ==> !B. FINITE B
                ==> euler_characteristic (A UNION B) s =
                    euler_characteristic A s`

let EULER_CHARACTERISTIC_INCLUSION_EXCLUSION = prove
 (`!A s:(real^N->bool)->bool.
        FINITE A /\ FINITE s /\ (!k. k IN s ==> hyperplane_cellcomplex A k)
        ==> euler_characteristic A (UNIONS s) =
            sum {t | t SUBSET s /\ ~(t = {})}
                (\t. (-- &1) pow (CARD t + 1) *
                     euler_characteristic A (INTERS t))`,
\<close>

subsection \<open>Euler-type relation for full-dimensional proper polyhedral cones.\<close>

\<^cancel>\<open>

let EULER_POLYHEDRAL_CONE = prove
 (`!s. polyhedron s /\ conic s /\ ~(interior s = {}) /\ ~(s = (:real^N))
       ==> sum (0..dimindex(:N))
               (\d. (-- &1) pow d *
                    &(CARD {f | f face_of s /\ aff_dim f = &d })) = &0`,

\<comment> \<open> ! HOL/Light proof is gigantic...\<close>\<close>

subsection \<open>Euler-Poincare relation for special (n-1)-dimensional polytope.\<close>

\<^cancel>\<open>let EULER_POINCARE_LEMMA = prove
 (`!p:real^N->bool.
        2 <= dimindex(:N) /\ polytope p /\ affine hull p = {x | x$1 = &1}
        ==> sum (0..dimindex(:N)-1)
               (\d. (-- &1) pow d *
                    &(CARD {f | f face_of p /\ aff_dim f = &d })) = &1`,
\<comment> \<open>another gigantic proof\<close>

let EULER_POINCARE_SPECIAL = prove
 (`!p:real^N->bool.
        2 <= dimindex(:N) /\ polytope p /\ affine hull p = {x | x$1 = &0}
        ==> sum (0..dimindex(:N)-1)
               (\d. (-- &1) pow d *
                    &(CARD {f | f face_of p /\ aff_dim f = &d })) = &1`,
\<close>

lemma euler_poincare_lemma:
  assumes "polytope p" and "aff_dim p \<le> 2"
      and "affine hull p = {x. x$1 =1 }"
  shows "euler_char p = 1"
  sorry

lemma euser_poincare_special:
  assumes "polytope p" and "aff_dim p \<le> 2"
     and "affine hull p = {x. x$1 = 0}"
  shows "euler_char p = 1"
  sorry

section \<open>Euler characteristic\<close>


(* Author: Tobias Nipkow *)

section {* Lists Sorted wrt $<$ *}

theory Sorted_Less
imports Less_False
begin

hide_const sorted

text \<open>Is a list sorted without duplicates, i.e., wrt @{text"<"}?
Could go into theory List under a name like @{term sorted_less}.\<close>

fun sorted :: "'a::linorder list \<Rightarrow> bool" where
"sorted [] = True" |
"sorted [x] = True" |
"sorted (x#y#zs) = (x < y \<and> sorted(y#zs))"

lemma sorted_Cons_iff:
  "sorted(x # xs) = (sorted xs \<and> (\<forall>y \<in> set xs. x < y))"
by(induction xs rule: sorted.induct) auto

lemma sorted_snoc_iff:
  "sorted(xs @ [x]) = (sorted xs \<and> (\<forall>y \<in> set xs. y < x))"
by(induction xs rule: sorted.induct) auto

lemma sorted_cons: "sorted (x#xs) \<Longrightarrow> sorted xs"
by(simp add: sorted_Cons_iff)

lemma sorted_cons': "ASSUMPTION (sorted (x#xs)) \<Longrightarrow> sorted xs"
by(rule ASSUMPTION_D [THEN sorted_cons])

lemma sorted_snoc: "sorted (xs @ [y]) \<Longrightarrow> sorted xs"
by(simp add: sorted_snoc_iff)

lemma sorted_snoc': "ASSUMPTION (sorted (xs @ [y])) \<Longrightarrow> sorted xs"
by(rule ASSUMPTION_D [THEN sorted_snoc])

lemma sorted_mid_iff:
  "sorted(xs @ y # ys) = (sorted(xs @ [y]) \<and> sorted(y # ys))"
by(induction xs rule: sorted.induct) auto

lemma sorted_mid_iff2:
  "sorted(x # xs @ y # ys) =
  (sorted(x # xs) \<and> x < y \<and> sorted(xs @ [y]) \<and> sorted(y # ys))"
by(induction xs rule: sorted.induct) auto

lemma sorted_mid_iff': "NO_MATCH [] ys \<Longrightarrow>
  sorted(xs @ y # ys) = (sorted(xs @ [y]) \<and> sorted(y # ys))"
by(rule sorted_mid_iff)

lemmas sorted_lems = sorted_mid_iff' sorted_mid_iff2 sorted_cons' sorted_snoc'

text\<open>Splay trees need two additional @{const sorted} lemmas:\<close>

lemma sorted_snoc_le:
  "ASSUMPTION(sorted(xs @ [x])) \<Longrightarrow> x \<le> y \<Longrightarrow> sorted (xs @ [y])"
by (auto simp add: Sorted_Less.sorted_snoc_iff ASSUMPTION_def)

lemma sorted_Cons_le:
  "ASSUMPTION(sorted(x # xs)) \<Longrightarrow> y \<le> x \<Longrightarrow> sorted (y # xs)"
by (auto simp add: Sorted_Less.sorted_Cons_iff ASSUMPTION_def)

end


(*  Title:      HOL/ex/PER.thy
    Author:     Oscar Slotosch and Markus Wenzel, TU Muenchen
*)

section \<open>Partial equivalence relations\<close>

theory PER
imports Main
begin

text \<open>
  Higher-order quotients are defined over partial equivalence
  relations (PERs) instead of total ones.  We provide axiomatic type
  classes @{text "equiv < partial_equiv"} and a type constructor
  @{text "'a quot"} with basic operations.  This development is based
  on:

  Oscar Slotosch: \emph{Higher Order Quotients and their
  Implementation in Isabelle HOL.}  Elsa L. Gunter and Amy Felty,
  editors, Theorem Proving in Higher Order Logics: TPHOLs '97,
  Springer LNCS 1275, 1997.
\<close>

subsection \<open>Partial equivalence\<close>

text \<open>
  Type class @{text partial_equiv} models partial equivalence
  relations (PERs) using the polymorphic @{text "\<sim> :: 'a \<Rightarrow> 'a \<Rightarrow>
  bool"} relation, which is required to be symmetric and transitive,
  but not necessarily reflexive.
\<close>

class partial_equiv =
  fixes eqv :: "'a \<Rightarrow> 'a \<Rightarrow> bool"    (infixl "\<sim>" 50)
  assumes partial_equiv_sym [elim?]: "x \<sim> y \<Longrightarrow> y \<sim> x"
  assumes partial_equiv_trans [trans]: "x \<sim> y \<Longrightarrow> y \<sim> z \<Longrightarrow> x \<sim> z"

text \<open>
  \medskip The domain of a partial equivalence relation is the set of
  reflexive elements.  Due to symmetry and transitivity this
  characterizes exactly those elements that are connected with
  \emph{any} other one.
\<close>

definition
  "domain" :: "'a::partial_equiv set" where
  "domain = {x. x \<sim> x}"

lemma domainI [intro]: "x \<sim> x \<Longrightarrow> x \<in> domain"
  unfolding domain_def by blast

lemma domainD [dest]: "x \<in> domain \<Longrightarrow> x \<sim> x"
  unfolding domain_def by blast

theorem domainI' [elim?]: "x \<sim> y \<Longrightarrow> x \<in> domain"
proof
  assume xy: "x \<sim> y"
  also from xy have "y \<sim> x" ..
  finally show "x \<sim> x" .
qed

subsection \<open>Equivalence on function spaces\<close>

text \<open>
  The @{text \<sim>} relation is lifted to function spaces.  It is
  important to note that this is \emph{not} the direct product, but a
  structural one corresponding to the congruence property.
\<close>

instantiation "fun" :: (partial_equiv, partial_equiv) partial_equiv
begin

definition "f \<sim> g \<longleftrightarrow> (\<forall>x \<in> domain. \<forall>y \<in> domain. x \<sim> y \<longrightarrow> f x \<sim> g y)"

lemma partial_equiv_funI [intro?]:
    "(\<And>x y. x \<in> domain \<Longrightarrow> y \<in> domain \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g y) \<Longrightarrow> f \<sim> g"
  unfolding eqv_fun_def by blast

lemma partial_equiv_funD [dest?]:
    "f \<sim> g \<Longrightarrow> x \<in> domain \<Longrightarrow> y \<in> domain \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g y"
  unfolding eqv_fun_def by blast

text \<open>
  The class of partial equivalence relations is closed under function
  spaces (in \emph{both} argument positions).
\<close>

instance proof
  fix f g h :: "'a::partial_equiv \<Rightarrow> 'b::partial_equiv"
  assume fg: "f \<sim> g"
  show "g \<sim> f"
  proof
    fix x y :: 'a
    assume x: "x \<in> domain" and y: "y \<in> domain"
    assume "x \<sim> y" then have "y \<sim> x" ..
    with fg y x have "f y \<sim> g x" ..
    then show "g x \<sim> f y" ..
  qed
  assume gh: "g \<sim> h"
  show "f \<sim> h"
  proof
    fix x y :: 'a
    assume x: "x \<in> domain" and y: "y \<in> domain" and "x \<sim> y"
    with fg have "f x \<sim> g y" ..
    also from y have "y \<sim> y" ..
    with gh y y have "g y \<sim> h y" ..
    finally show "f x \<sim> h y" .
  qed
qed

end

subsection \<open>Total equivalence\<close>

text \<open>
  The class of total equivalence relations on top of PERs.  It
  coincides with the standard notion of equivalence, i.e.\ @{text "\<sim>
  :: 'a \<Rightarrow> 'a \<Rightarrow> bool"} is required to be reflexive, transitive and
  symmetric.
\<close>

class equiv =
  assumes eqv_refl [intro]: "x \<sim> x"

text \<open>
  On total equivalences all elements are reflexive, and congruence
  holds unconditionally.
\<close>

theorem equiv_domain [intro]: "(x::'a::equiv) \<in> domain"
proof
  show "x \<sim> x" ..
qed

theorem equiv_cong [dest?]: "f \<sim> g \<Longrightarrow> x \<sim> y \<Longrightarrow> f x \<sim> g (y::'a::equiv)"
proof -
  assume "f \<sim> g"
  moreover have "x \<in> domain" ..
  moreover have "y \<in> domain" ..
  moreover assume "x \<sim> y"
  ultimately show ?thesis ..
qed

subsection \<open>Quotient types\<close>

text \<open>
  The quotient type @{text "'a quot"} consists of all
  \emph{equivalence classes} over elements of the base type @{typ 'a}.
\<close>

definition "quot = {{x. a \<sim> x}| a::'a::partial_equiv. True}"

typedef 'a quot = "quot :: 'a::partial_equiv set set"
  unfolding quot_def by blast

lemma quotI [intro]: "{x. a \<sim> x} \<in> quot"
  unfolding quot_def by blast

lemma quotE [elim]: "R \<in> quot \<Longrightarrow> (\<And>a. R = {x. a \<sim> x} \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding quot_def by blast

text \<open>
  \medskip Abstracted equivalence classes are the canonical
  representation of elements of a quotient type.
\<close>

definition eqv_class :: "('a::partial_equiv) \<Rightarrow> 'a quot"  ("\<lfloor>_\<rfloor>")
  where "\<lfloor>a\<rfloor> = Abs_quot {x. a \<sim> x}"

theorem quot_rep: "\<exists>a. A = \<lfloor>a\<rfloor>"
proof (cases A)
  fix R assume R: "A = Abs_quot R"
  assume "R \<in> quot" then have "\<exists>a. R = {x. a \<sim> x}" by blast
  with R have "\<exists>a. A = Abs_quot {x. a \<sim> x}" by blast
  then show ?thesis by (unfold eqv_class_def)
qed

lemma quot_cases [cases type: quot]:
  obtains (rep) a where "A = \<lfloor>a\<rfloor>"
  using quot_rep by blast

subsection \<open>Equality on quotients\<close>

text \<open>
  Equality of canonical quotient elements corresponds to the original
  relation as follows.
\<close>

theorem eqv_class_eqI [intro]: "a \<sim> b \<Longrightarrow> \<lfloor>a\<rfloor> = \<lfloor>b\<rfloor>"
proof -
  assume ab: "a \<sim> b"
  have "{x. a \<sim> x} = {x. b \<sim> x}"
  proof (rule Collect_cong)
    fix x show "a \<sim> x \<longleftrightarrow> b \<sim> x"
    proof
      from ab have "b \<sim> a" ..
      also assume "a \<sim> x"
      finally show "b \<sim> x" .
    next
      note ab
      also assume "b \<sim> x"
      finally show "a \<sim> x" .
    qed
  qed
  then show ?thesis by (simp only: eqv_class_def)
qed

theorem eqv_class_eqD' [dest?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<Longrightarrow> a \<in> domain \<Longrightarrow> a \<sim> b"
proof (unfold eqv_class_def)
  assume "Abs_quot {x. a \<sim> x} = Abs_quot {x. b \<sim> x}"
  then have "{x. a \<sim> x} = {x. b \<sim> x}" by (simp only: Abs_quot_inject quotI)
  moreover assume "a \<in> domain" then have "a \<sim> a" ..
  ultimately have "a \<in> {x. b \<sim> x}" by blast
  then have "b \<sim> a" by blast
  then show "a \<sim> b" ..
qed

theorem eqv_class_eqD [dest?]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<Longrightarrow> a \<sim> (b::'a::equiv)"
proof (rule eqv_class_eqD')
  show "a \<in> domain" ..
qed

lemma eqv_class_eq' [simp]: "a \<in> domain \<Longrightarrow> \<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> b"
  using eqv_class_eqI eqv_class_eqD' by (blast del: eqv_refl)

lemma eqv_class_eq [simp]: "\<lfloor>a\<rfloor> = \<lfloor>b\<rfloor> \<longleftrightarrow> a \<sim> (b::'a::equiv)"
  using eqv_class_eqI eqv_class_eqD by blast

subsection \<open>Picking representing elements\<close>

definition pick :: "'a::partial_equiv quot \<Rightarrow> 'a"
  where "pick A = (SOME a. A = \<lfloor>a\<rfloor>)"

theorem pick_eqv' [intro?, simp]: "a \<in> domain \<Longrightarrow> pick \<lfloor>a\<rfloor> \<sim> a"
proof (unfold pick_def)
  assume a: "a \<in> domain"
  show "(SOME x. \<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>) \<sim> a"
  proof (rule someI2)
    show "\<lfloor>a\<rfloor> = \<lfloor>a\<rfloor>" ..
    fix x assume "\<lfloor>a\<rfloor> = \<lfloor>x\<rfloor>"
    from this and a have "a \<sim> x" ..
    then show "x \<sim> a" ..
  qed
qed

theorem pick_eqv [intro, simp]: "pick \<lfloor>a\<rfloor> \<sim> (a::'a::equiv)"
proof (rule pick_eqv')
  show "a \<in> domain" ..
qed

theorem pick_inverse: "\<lfloor>pick A\<rfloor> = (A::'a::equiv quot)"
proof (cases A)
  fix a assume a: "A = \<lfloor>a\<rfloor>"
  then have "pick A \<sim> a" by simp
  then have "\<lfloor>pick A\<rfloor> = \<lfloor>a\<rfloor>" by simp
  with a show ?thesis by simp
qed

end


section {* Unrestriction *}

theory utp_unrest
  imports utp_expr
begin

text {* Unrestriction is an encoding of semantic freshness, that allows us to reason about the
        presence of variables in predicates without being concerned with abstract syntax trees.
        An expression $p$ is unrestricted by variable $x$, written $x \mathop{\sharp} p$, if
        altering the value of $x$ has no effect on the valuation of $p$. This is a sufficient
        notion to prove many laws that would ordinarily rely on an \emph{fv} function. *}

consts
  unrest :: "'a \<Rightarrow> 'b \<Rightarrow> bool"

syntax
  "_unrest" :: "salpha \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" (infix "\<sharp>" 20)

translations
  "_unrest x p" == "CONST unrest x p"

named_theorems unrest

method unrest_tac = (simp add: unrest)?

lift_definition unrest_upred :: "('a, '\<alpha>) uvar \<Rightarrow> ('b, '\<alpha>) uexpr \<Rightarrow> bool"
is "\<lambda> x e. \<forall> b v. e (put\<^bsub>x\<^esub> b v) = e b" .

adhoc_overloading
  unrest unrest_upred

lemma unrest_var_comp [unrest]:
  "\<lbrakk> x \<sharp> P; y \<sharp> P \<rbrakk> \<Longrightarrow> x;y \<sharp> P"
  by (transfer, simp add: lens_defs)

lemma unrest_lit [unrest]: "x \<sharp> \<guillemotleft>v\<guillemotright>"
  by (transfer, simp)

text {* The following law demonstrates why we need variable independence: a variable
        expression is unrestricted by another variable only when the two variables are independent. *}

lemma unrest_var [unrest]: "\<lbrakk> vwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> y \<sharp> var x"
  by (transfer, auto)

lemma unrest_iuvar [unrest]: "\<lbrakk> vwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> $y \<sharp> $x"
  by (metis in_var_indep in_var_uvar unrest_var)

lemma unrest_ouvar [unrest]: "\<lbrakk> vwb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> $y\<acute> \<sharp> $x\<acute>"
  by (metis out_var_indep out_var_uvar unrest_var)

lemma unrest_iuvar_ouvar [unrest]:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "vwb_lens y"
  shows "$x \<sharp> $y\<acute>"
  by (metis prod.collapse unrest_upred.rep_eq var.rep_eq var_lookup_out var_update_in)

lemma unrest_ouvar_iuvar [unrest]:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "vwb_lens y"
  shows "$x\<acute> \<sharp> $y"
  by (metis prod.collapse unrest_upred.rep_eq var.rep_eq var_lookup_in var_update_out)

lemma unrest_uop [unrest]: "x \<sharp> e \<Longrightarrow> x \<sharp> uop f e"
  by (transfer, simp)

lemma unrest_bop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> bop f u v"
  by (transfer, simp)

lemma unrest_trop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w \<rbrakk> \<Longrightarrow> x \<sharp> trop f u v w"
  by (transfer, simp)

lemma unrest_qtop [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v; x \<sharp> w; x \<sharp> y \<rbrakk> \<Longrightarrow> x \<sharp> qtop f u v w y"
  by (transfer, simp)

lemma unrest_eq [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u =\<^sub>u v"
  by (simp add: eq_upred_def, transfer, simp)

lemma unrest_zero [unrest]: "x \<sharp> 0"
  by (simp add: unrest_lit zero_uexpr_def)

lemma unrest_one [unrest]: "x \<sharp> 1"
  by (simp add: one_uexpr_def unrest_lit)

lemma unrest_numeral [unrest]: "x \<sharp> (numeral n)"
  by (simp add: numeral_uexpr_simp unrest_lit)

lemma unrest_sgn [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> sgn u"
  by (simp add: sgn_uexpr_def unrest_uop)

lemma unrest_abs [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> abs u"
  by (simp add: abs_uexpr_def unrest_uop)

lemma unrest_plus [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u + v"
  by (simp add: plus_uexpr_def unrest)

lemma unrest_uminus [unrest]: "x \<sharp> u \<Longrightarrow> x \<sharp> - u"
  by (simp add: uminus_uexpr_def unrest)

lemma unrest_minus [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u - v"
  by (simp add: minus_uexpr_def unrest)

lemma unrest_times [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u * v"
  by (simp add: times_uexpr_def unrest)

lemma unrest_divide [unrest]: "\<lbrakk> x \<sharp> u; x \<sharp> v \<rbrakk> \<Longrightarrow> x \<sharp> u / v"
  by (simp add: divide_uexpr_def unrest)

lemma unrest_ulambda [unrest]:
  "\<lbrakk> \<And> x. v \<sharp> F x \<rbrakk> \<Longrightarrow> v \<sharp> (\<lambda> x \<bullet> F x)"
  by (transfer, simp)
end