theory Partial_Functions
imports Setup "HOL-Library.Monad_Syntax"
begin

section \<open>Partial Functions \label{sec:partial}\<close>

text \<open>We demonstrate three approaches to defining executable partial recursive functions,
i.e.\ functions that do not terminate for all inputs.
The main points are the definitions of the functions and the inductive proofs about them.

Our concrete example represents a typical termination problem: following a data structure that
may contain cycles. We want to follow a mapping from \<open>nat\<close> to \<open>nat\<close> to the end
(until we leave its domain). The mapping is represented by a list \<open>ns :: nat list\<close>
that maps \<open>n\<close> to \<open>ns ! n\<close>.
The details of the example are in some sense irrelevant but make the exposition more realistic.
However, we hide most proofs or show only the characteristic opening.\<close>

text \<open>The list representation of the mapping can be abstracted to a relation.
The order @{term "(ns!n, n)"} is the order that @{const wf} expects.\<close>

definition rel :: "nat list \<Rightarrow> (nat * nat) set" where
"rel ns = set(zip ns [0..<length ns])"

lemma finite_rel[simp]: "finite(rel ns)"
(*<*)by(simp add: rel_def)(*>*)

text \<open>\noindent This relation should be acyclic
 to guarantee termination of the partial functions defined below.\<close>

subsection \<open>Tail recursion\<close>

text \<open>If a function is tail-recursive, an executable definition is easy:\<close>

partial_function (tailrec) follow :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
"follow ns n = (if n < length ns then follow ns (ns!n) else n)"

text \<open>Informing the code generator:\<close>

declare follow.simps[code]

text \<open>Now @{const follow} is executable:\<close>

value "follow [1,2,3] 0"

text \<open>For proofs about @{const follow} we need a @{const wf} relation on @{term "(ns,n)"} pairs
that decreases with each recursive call. The first component stays the same but must be acyclic.
The second component must decrease w.r.t @{const rel}:\<close>

definition "rel_follow = same_fst (acyclic o rel) rel"

lemma wf_follow: "wf rel_follow"
(*<*)
by (auto intro: wf_same_fst simp: rel_follow_def finite_acyclic_wf)

text \<open>A more explicit formulation of \<open>rel_follow\<close>:
The first component stays the same but must be acyclic.
The second component decreases w.r.t \<open>rel\<close>:\<close>

lemma rel_follow_step:
  "\<lbrakk> m < length ms; acyclic (rel ms) \<rbrakk> \<Longrightarrow> ((ms, ms ! m), (ms, m)) \<in> rel_follow"
by(force simp: rel_follow_def rel_def in_set_zip)
(*>*)

text \<open>This is how you start an inductive proof about @{const follow} along @{const rel_follow}:\<close>

lemma "acyclic(rel ms) \<Longrightarrow> follow ms m = n \<Longrightarrow> length ms \<le> n"
proof (induction "(ms,m)" arbitrary: m n rule: wf_induct_rule[OF wf_follow])
(*<*)
  case 1
  thus ?case using follow.simps rel_follow_step by fastforce
qed
(*>*)

subsection \<open>Option\<close>

text \<open>If the function is not tail-recursive, not all is lost: if we rewrite it to return an \<open>option\<close>
type, it can still be defined. In this case @{term "Some x"} represents the result \<open>x\<close>
and @{term None} represents represents nontermination.
For example, counting the length of the chain represented by \<open>ns\<close> can be defined like this:\<close>

partial_function (option) count :: "nat list \<Rightarrow> nat \<Rightarrow> nat option" where
"count ns n
= (if n < length ns then do {k \<leftarrow> count ns (ns!n); Some (k+1)} else Some 0)"

text \<open>\noindent We use a Haskell-like \<open>do\<close> notation (import @{theory "HOL-Library.Monad_Syntax"})
to abbreviate the clumsy explicit

\noindent
@{term "case count ns (ns!n) of Some k \<Rightarrow> Some(k+1) | None \<Rightarrow> None"}.

\noindent
The branch \<open>None \<Rightarrow> None\<close> represents the requirement
that nontermination of a recursive call must lead to nontermination of the function.

Now we can prove that @{const count} terminates for all acyclic maps:\<close>

lemma "acyclic(rel ms) \<Longrightarrow> \<exists>k. count ms m = Some k"
proof (induction "(ms,m)" arbitrary: ms m rule: wf_induct_rule[OF wf_follow])
(*<*)
  case 1
  thus ?case
    by (metis bind.bind_lunit count.simps rel_follow_step)
qed
(*>*)

subsection \<open>Subtype\<close>

text \<open>In this approach we define a new type that contains only elements on which the function
in question terminates.
In our example that is the subtype of all \<open>ns :: nat list\<close> such that @{term "rel ns"} is acyclic.
Then @{const follow} can be defined as a total function on that subtype.\<close>

text \<open>The subtype is not empty:\<close>

lemma acyclic_rel_Nil: "acyclic(rel [])"
(*<*)by (simp add: rel_def acyclic_def)(*>*)

text \<open>Definition of subtype \<open>acyc\<close>:\<close>

typedef acyc = "{ns. acyclic(rel ns)}"
morphisms rep_acyc abs_acyc
using acyclic_rel_Nil by auto

text \<open>\noindent This defines two functions @{term [source] "rep_acyc :: acyc \<Rightarrow> nat list"}
and @{const abs_acyc} \<open>::\<close> \mbox{@{typ "nat list \<Rightarrow> acyc"}}.
Function @{const abs_acyc} is only defined on acyclic lists and not executable for that reason.
Type \<open>dlist\<close> in Section~\ref{sec:partiality} is defined in the same manner.

The following command sets up infrastructure for lifting functions on @{typ "nat list"}
to @{typ acyc} (used by @{command_def lift_definition} below) \<^cite>\<open>"isabelle-isar-ref"\<close>.\<close>

setup_lifting type_definition_acyc

text \<open>This is how @{const follow} can be defined on @{typ acyc}:\<close>

function follow2 :: "acyc \<Rightarrow> nat \<Rightarrow> nat" where
"follow2 ac n
= (let ns = rep_acyc ac in if n < length ns then follow2 ac (ns!n) else n)"
by pat_completeness auto

text \<open>Now we prepare for the termination proof.
 Relation \<open>rel_follow2\<close> is almost identical to @{const rel_follow}.\<close>

definition "rel_follow2 = same_fst (acyclic o rel o rep_acyc) (rel o rep_acyc)"

lemma wf_follow2: "wf rel_follow2"
(*<*)
by (auto intro: wf_same_fst simp add: rel_follow2_def finite_acyclic_wf)

text \<open>A more explicit formulation of \<open>rel_follow2\<close>:\<close>

lemma rel_follow2_step:
  "\<lbrakk> ns = rep_acyc ac; m < length ns; acyclic (rel ns) \<rbrakk> \<Longrightarrow> ((ac, ns ! m), (ac, m)) \<in> rel_follow2"
by(force simp add: rel_follow2_def rel_def in_set_zip)
(*>*)

text \<open>Here comes the actual termination proof:\<close>

termination follow2
proof
  show "wf rel_follow2"
(*<*)    by (auto intro: wf_same_fst simp add: rel_follow2_def finite_acyclic_wf)(*>*)

next
  show "\<And>ac n ns. \<lbrakk> ns = rep_acyc ac; n < length ns \<rbrakk>
              \<Longrightarrow> ((ac, ns ! n), (ac, n)) \<in> rel_follow2"
(*<*)    using rel_follow2_step rep_acyc by simp(*>*)

qed

text \<open>Inductive proofs about @{const follow2} can now simply use computation induction:\<close>

lemma "follow2 ac m = n \<Longrightarrow> length (rep_acyc ac) \<le> n"
proof (induction ac m arbitrary: n rule: follow2.induct)
(*<*)
  case 1
  thus ?case by (metis (full_types) follow2.simps linorder_not_le)
qed
(*>*)

text \<open>A complication with the subtype approach is that injection into the subtype
(function \<open>abs_acyc\<close> in our example) is not executable. But to call @{const follow2},
we need an argument of type \<open>acyc\<close> and we need to obtain it in an executable manner.
There are two approaches.\<close>

text \<open>In the first approach we check wellformedness (i.e. acyclicity) explicitly.
This check needs to be executable (which @{const acyclic} and @{const rel} are).
If the check fails, @{term "[]"} is returned (which is acyclic).\<close>

lift_definition is_acyc :: "nat list \<Rightarrow> acyc" is
  "\<lambda>ns. if acyclic(rel ns) then ns else []"
(*<*)by (auto simp: acyclic_rel_Nil)(*>*)

text \<open>\noindent This works because we can easily prove that for any \<open>ns\<close>,
 the \<open>\<lambda>\<close>-term produces an acyclic list.
But it requires the possibly expensive check @{prop "acyclic(rel ns)"}.\<close>

definition "follow_test ns n = follow2 (is_acyc ns) n"

text \<open>The relation is acyclic (a chain):\<close>

value "follow_test [1,2,3] 1"

text \<open>In the second approach, wellformedness of the argument is guaranteed by construction.
In our example \<open>[1..<n+1]\<close> represents an acyclic chain \<open>i \<mapsto> i+1\<close>\<close>

lemma acyclic_chain: "acyclic (rel [1..<n+1])"
(*<*)
apply(induction n)
 apply (simp add: rel_def acyclic_def)
apply (auto simp add: rel_def)
by (metis atLeast_upt lessI lessThan_iff order_less_asym' rtranclE set_zip_rightD)
(*>*)

text \<open>\<close>
lift_definition acyc_chain :: "nat \<Rightarrow> acyc" is "\<lambda>n. [1..<n+1]"
(*<*)by (use acyclic_chain in auto)(*>*)

text \<open>\<close>
definition "follow_chain m n = follow2 (acyc_chain m) n"

value "follow_chain 5 1"

text \<open>The subtype approach requires neither tail-recursion nor \<open>option\<close> but you cannot easily modify
arguments of the subtype except via existing functions on the subtype. Otherwise you need to inject
some value into the subtype and that injection is not computable.
\<close>
(*<*)
text \<open>The problem with subtypes: the Abs function must not be used explicitly.
This can be avoided by using \<open>lift_definition\<close>. Example:\<close>

typedef nat1 = "{n::nat. n > 0}"
by auto
print_theorems

setup_lifting type_definition_nat1

(* just boiler plate *)
lift_definition mk1 :: "nat \<Rightarrow> nat1" is
  "\<lambda>n. if n>0 then n else 1"
by auto

lift_definition g :: "nat1 \<Rightarrow> nat1" is
"\<lambda>n. if n \<ge> 2 then n-1 else n"
by auto
print_theorems
text \<open>This generates
 \<open>g.rep_eq: Rep_nat1 (g x) = (if 2 \<le> Rep_nat1 x then Rep_nat1 x - 1 else Rep_nat1 x)\<close>
which is acceptable as an abstract code eqn. The manual definition of
 \<open>g n1 = (let n = Rep_nat1 n1 in if 2 \<le> n then Abs_nat1 (n - 1) else Abs_nat1 n)\<close>
looks non-executable but \<open>g.rep_eq\<close> can be derived from it.\<close>

value "g (mk1 3)"

text \<open>However, this trick does not work when passing an Abs-term as an argument,
eg in a recursive call, because the Abs-term is `hidden' by the function call.\<close>
(*>*)
end


(*  Title:      HOL/Cardinals/Order_Union.thy
    Author:     Andrei Popescu, TU Muenchen

The ordinal-like sum of two orders with disjoint fields
*)

section \<open>Order Union\<close>

theory Order_Union
imports Order_Relation
begin

definition Osum :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel"  (infix "Osum" 60) where
  "r Osum r' = r \<union> r' \<union> {(a, a'). a \<in> Field r \<and> a' \<in> Field r'}"

notation Osum  (infix "\<union>o" 60)

lemma Field_Osum: "Field (r \<union>o r') = Field r \<union> Field r'"
  unfolding Osum_def Field_def by blast

lemma Osum_wf:
assumes FLD: "Field r Int Field r' = {}" and
        WF: "wf r" and WF': "wf r'"
shows "wf (r Osum r')"
unfolding wf_eq_minimal2 unfolding Field_Osum
proof(intro allI impI, elim conjE)
  fix A assume *: "A \<subseteq> Field r \<union> Field r'" and **: "A \<noteq> {}"
  obtain B where B_def: "B = A Int Field r" by blast
  show "\<exists>a\<in>A. \<forall>a'\<in>A. (a', a) \<notin> r \<union>o r'"
  proof(cases "B = {}")
    assume Case1: "B \<noteq> {}"
    hence "B \<noteq> {} \<and> B \<le> Field r" using B_def by auto
    then obtain a where 1: "a \<in> B" and 2: "\<forall>a1 \<in> B. (a1,a) \<notin> r"
    using WF unfolding wf_eq_minimal2 by blast
    hence 3: "a \<in> Field r \<and> a \<notin> Field r'" using B_def FLD by auto
    (*  *)
    have "\<forall>a1 \<in> A. (a1,a) \<notin> r Osum r'"
    proof(intro ballI)
      fix a1 assume **: "a1 \<in> A"
      {assume Case11: "a1 \<in> Field r"
       hence "(a1,a) \<notin> r" using B_def ** 2 by auto
       moreover
       have "(a1,a) \<notin> r'" using 3 by (auto simp add: Field_def)
       ultimately have "(a1,a) \<notin> r Osum r'"
       using 3 unfolding Osum_def by auto
      }
      moreover
      {assume Case12: "a1 \<notin> Field r"
       hence "(a1,a) \<notin> r" unfolding Field_def by auto
       moreover
       have "(a1,a) \<notin> r'" using 3 unfolding Field_def by auto
       ultimately have "(a1,a) \<notin> r Osum r'"
       using 3 unfolding Osum_def by auto
      }
      ultimately show "(a1,a) \<notin> r Osum r'" by blast
    qed
    thus ?thesis using 1 B_def by auto
  next
    assume Case2: "B = {}"
    hence 1: "A \<noteq> {} \<and> A \<le> Field r'" using * ** B_def by auto
    then obtain a' where 2: "a' \<in> A" and 3: "\<forall>a1' \<in> A. (a1',a') \<notin> r'"
    using WF' unfolding wf_eq_minimal2 by blast
    hence 4: "a' \<in> Field r' \<and> a' \<notin> Field r" using 1 FLD by blast
    (*  *)
    have "\<forall>a1' \<in> A. (a1',a') \<notin> r Osum r'"
    proof(unfold Osum_def, auto simp add: 3)
      fix a1' assume "(a1', a') \<in> r"
      thus False using 4 unfolding Field_def by blast
    next
      fix a1' assume "a1' \<in> A" and "a1' \<in> Field r"
      thus False using Case2 B_def by auto
    qed
    thus ?thesis using 2 by blast
  qed
qed

lemma Osum_Refl:
assumes FLD: "Field r Int Field r' = {}" and
        REFL: "Refl r" and REFL': "Refl r'"
shows "Refl (r Osum r')"
using assms
unfolding refl_on_def Field_Osum unfolding Osum_def by blast

lemma Osum_trans:
assumes FLD: "Field r Int Field r' = {}" and
        TRANS: "trans r" and TRANS': "trans r'"
shows "trans (r Osum r')"
proof(unfold trans_def, auto)
  fix x y z assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, z) \<in> r \<union>o r'"
  show  "(x, z) \<in> r \<union>o r'"
  proof-
    {assume Case1: "(x,y) \<in> r"
     hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume Case11: "(y,z) \<in> r"
        hence "(x,z) \<in> r" using Case1 TRANS trans_def[of r] by blast
        hence ?thesis unfolding Osum_def by auto
       }
       moreover
       {assume Case12: "(y,z) \<in> r'"
        hence "y \<in> Field r'" unfolding Field_def by auto
        hence False using FLD 1 by auto
       }
       moreover
       {assume Case13: "z \<in> Field r'"
        hence ?thesis using 1 unfolding Osum_def by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case2: "(x,y) \<in> r'"
     hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume Case21: "(y,z) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD 2 by auto
       }
       moreover
       {assume Case22: "(y,z) \<in> r'"
        hence "(x,z) \<in> r'" using Case2 TRANS' trans_def[of r'] by blast
        hence ?thesis unfolding Osum_def by auto
       }
       moreover
       {assume Case23: "y \<in> Field r"
        hence False using FLD 2 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
     have ?thesis
     proof-
       {assume Case31: "(y,z) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD Case3 by auto
       }
       moreover
       {assume Case32: "(y,z) \<in> r'"
        hence "z \<in> Field r'" unfolding Field_def by blast
        hence ?thesis unfolding Osum_def using Case3 by auto
       }
       moreover
       {assume Case33: "y \<in> Field r"
        hence False using FLD Case3 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    ultimately show ?thesis using * unfolding Osum_def by blast
  qed
qed

lemma Osum_Preorder:
"\<lbrakk>Field r Int Field r' = {}; Preorder r; Preorder r'\<rbrakk> \<Longrightarrow> Preorder (r Osum r')"
unfolding preorder_on_def using Osum_Refl Osum_trans by blast

lemma Osum_antisym:
assumes FLD: "Field r Int Field r' = {}" and
        AN: "antisym r" and AN': "antisym r'"
shows "antisym (r Osum r')"
proof(unfold antisym_def, auto)
  fix x y assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, x) \<in> r \<union>o r'"
  show  "x = y"
  proof-
    {assume Case1: "(x,y) \<in> r"
     hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
     have ?thesis
     proof-
       have "(y,x) \<in> r \<Longrightarrow> ?thesis"
       using Case1 AN antisym_def[of r] by blast
       moreover
       {assume "(y,x) \<in> r'"
        hence "y \<in> Field r'" unfolding Field_def by auto
        hence False using FLD 1 by auto
       }
       moreover
       have "x \<in> Field r' \<Longrightarrow> False" using FLD 1 by auto
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case2: "(x,y) \<in> r'"
     hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume "(y,x) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD 2 by auto
       }
       moreover
       have "(y,x) \<in> r' \<Longrightarrow> ?thesis"
       using Case2 AN' antisym_def[of r'] by blast
       moreover
       {assume "y \<in> Field r"
        hence False using FLD 2 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
     have ?thesis
     proof-
       {assume "(y,x) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD Case3 by auto
       }
       moreover
       {assume Case32: "(y,x) \<in> r'"
        hence "x \<in> Field r'" unfolding Field_def by blast
        hence False using FLD Case3 by auto
       }
       moreover
       have "\<not> y \<in> Field r" using FLD Case3 by auto
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    ultimately show ?thesis using * unfolding Osum_def by blast
  qed
qed

lemma Osum_Partial_order:
"\<lbrakk>Field r Int Field r' = {}; Partial_order r; Partial_order r'\<rbrakk> \<Longrightarrow>
 Partial_order (r Osum r')"
unfolding partial_order_on_def using Osum_Preorder Osum_antisym by blast

lemma Osum_Total:
assumes FLD: "Field r Int Field r' = {}" and
        TOT: "Total r" and TOT': "Total r'"
shows "Total (r Osum r')"
using assms
unfolding total_on_def  Field_Osum unfolding Osum_def by blast

lemma Osum_Linear_order:
"\<lbrakk>Field r Int Field r' = {}; Linear_order r; Linear_order r'\<rbrakk> \<Longrightarrow>
 Linear_order (r Osum r')"
unfolding linear_order_on_def using Osum_Partial_order Osum_Total by blast

lemma Osum_minus_Id1:
assumes "r \<le> Id"
shows "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
proof-
  let ?Left = "(r Osum r') - Id"
  let ?Right = "(r' - Id) \<union> (Field r \<times> Field r')"
  {fix a::'a and b assume *: "(a,b) \<notin> Id"
   {assume "(a,b) \<in> r"
    with * have False using assms by auto
   }
   moreover
   {assume "(a,b) \<in> r'"
    with * have "(a,b) \<in> r' - Id" by auto
   }
   ultimately
   have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
   unfolding Osum_def by auto
  }
  thus ?thesis by auto
qed

lemma Osum_minus_Id2:
assumes "r' \<le> Id"
shows "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
proof-
  let ?Left = "(r Osum r') - Id"
  let ?Right = "(r - Id) \<union> (Field r \<times> Field r')"
  {fix a::'a and b assume *: "(a,b) \<notin> Id"
   {assume "(a,b) \<in> r'"
    with * have False using assms by auto
   }
   moreover
   {assume "(a,b) \<in> r"
    with * have "(a,b) \<in> r - Id" by auto
   }
   ultimately
   have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
   unfolding Osum_def by auto
  }
  thus ?thesis by auto
qed

lemma Osum_minus_Id:
assumes TOT: "Total r" and TOT': "Total r'" and
        NID: "\<not> (r \<le> Id)" and NID': "\<not> (r' \<le> Id)"
shows "(r Osum r') - Id \<le> (r - Id) Osum (r' - Id)"
proof-
  {fix a a' assume *: "(a,a') \<in> (r Osum r')" and **: "a \<noteq> a'"
   have "(a,a') \<in> (r - Id) Osum (r' - Id)"
   proof-
     {assume "(a,a') \<in> r \<or> (a,a') \<in> r'"
      with ** have ?thesis unfolding Osum_def by auto
     }
     moreover
     {assume "a \<in> Field r \<and> a' \<in> Field r'"
      hence "a \<in> Field(r - Id) \<and> a' \<in> Field (r' - Id)"
      using assms Total_Id_Field by blast
      hence ?thesis unfolding Osum_def by auto
     }
     ultimately show ?thesis using * unfolding Osum_def by fast
   qed
  }
  thus ?thesis by(auto simp add: Osum_def)
qed

lemma wf_Int_Times:
assumes "A Int B = {}"
shows "wf(A \<times> B)"
unfolding wf_def using assms by blast

lemma Osum_wf_Id:
assumes TOT: "Total r" and TOT': "Total r'" and
        FLD: "Field r Int Field r' = {}" and
        WF: "wf(r - Id)" and WF': "wf(r' - Id)"
shows "wf ((r Osum r') - Id)"
proof(cases "r \<le> Id \<or> r' \<le> Id")
  assume Case1: "\<not>(r \<le> Id \<or> r' \<le> Id)"
  have "Field(r - Id) Int Field(r' - Id) = {}"
  using FLD mono_Field[of "r - Id" r]  mono_Field[of "r' - Id" r']
            Diff_subset[of r Id] Diff_subset[of r' Id] by blast
  thus ?thesis
  using Case1 Osum_minus_Id[of r r'] assms Osum_wf[of "r - Id" "r' - Id"]
        wf_subset[of "(r - Id) \<union>o (r' - Id)" "(r Osum r') - Id"] by auto
next
  have 1: "wf(Field r \<times> Field r')"
  using FLD by (auto simp add: wf_Int_Times)
  assume Case2: "r \<le> Id \<or> r' \<le> Id"
  moreover
  {assume Case21: "r \<le> Id"
   hence "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
   using Osum_minus_Id1[of r r'] by simp
   moreover
   {have "Domain(Field r \<times> Field r') Int Range(r' - Id) = {}"
    using FLD unfolding Field_def by blast
    hence "wf((r' - Id) \<union> (Field r \<times> Field r'))"
    using 1 WF' wf_Un[of "Field r \<times> Field r'" "r' - Id"]
    by (auto simp add: Un_commute)
   }
   ultimately have ?thesis using wf_subset by blast
  }
  moreover
  {assume Case22: "r' \<le> Id"
   hence "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
   using Osum_minus_Id2[of r' r] by simp
   moreover
   {have "Range(Field r \<times> Field r') Int Domain(r - Id) = {}"
    using FLD unfolding Field_def by blast
    hence "wf((r - Id) \<union> (Field r \<times> Field r'))"
    using 1 WF wf_Un[of "r - Id" "Field r \<times> Field r'"]
    by (auto simp add: Un_commute)
   }
   ultimately have ?thesis using wf_subset by blast
  }
  ultimately show ?thesis by blast
qed

lemma Osum_Well_order:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "Well_order (r Osum r')"
proof-
  have "Total r \<and> Total r'" using WELL WELL'
  by (auto simp add: order_on_defs)
  thus ?thesis using assms unfolding well_order_on_def
  using Osum_Linear_order Osum_wf_Id by blast
qed

end


section \<open> Example UTP theory: Boyle's laws \<close>
(*<*)
theory utp_boyle
imports "UTP1.utp_theory"
begin
(*>*)

text \<open> In order to exemplify the use of Isabelle/UTP, we mechanise a simple theory representing
        Boyle's law. Boyle's law states that, for an ideal gas at fixed temperature, pressure @{term p} is inversely
        proportional to volume @{term V}, or more formally that for @{term "k = p*V"} is invariant, for
        constant @{term k}. We here encode this as a simple UTP theory. We first create a record to
        represent the alphabet of the theory consisting of the three variables \emph{k}, \emph{p}
        and \emph{V}. \<close>

alphabet boyle =
  k :: real
  p :: real
  V :: real

type_synonym boyle_rel = "boyle hrel"

declare boyle.splits [alpha_splits]

text \<open>
  The two locale interpretations below are a technicality to improve automatic
  proof support via the predicate and relational tactics. This is to enable the
  (re-)interpretation of state spaces to remove any occurrences of lens types
  after the proof tactics @{method pred_simp} and @{method rel_simp}, or any
  of their derivatives have been applied. Eventually, it would be desirable to
  automate both interpretations as part of a custom outer command for defining
  alphabets.
\<close>

interpretation boyle_prd: \<comment> \<open> Closed records are sufficient here. \<close>
  lens_interp "\<lambda>r::boyle. (k\<^sub>v r, p\<^sub>v r, V\<^sub>v r)"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

interpretation boyle_rel: \<comment> \<open> Closed records are sufficient here. \<close>
  lens_interp "\<lambda>(r::boyle, r'::boyle).
    (k\<^sub>v r, k\<^sub>v r', p\<^sub>v r, p\<^sub>v r', V\<^sub>v r, V\<^sub>v r')"
apply (unfold_locales)
apply (rule injI)
apply (clarsimp)
done

subsection \<open> Static invariant \<close>

text \<open> We first create a simple UTP theory representing Boyle's laws on a single state, as a static
        invariant healthiness condition. We state Boyle's law using the function \emph{B}, which recalculates
        the value of the constant @{term k} based on @{term p} and @{term V}. \<close>

definition "B(\<phi>) = ((\<exists> k \<bullet> \<phi>) \<and> (&k =\<^sub>u &p*&V))"
(*<*)
declare B_def [upred_defs]
(*>*)

text \<open> \noindent We can then prove that B is both idempotent and monotone simply by application of
        the predicate tactic. Idempotence means that healthy predicates cannot be made
        more healthy. Together with idempotence, monotonicity ensures that image of the healthiness functions
        forms a complete lattice, which is useful to allow the representation of recursive and
        iterative constructions with the theory. \<close>

lemma B_idempotent: "B(B(P)) = B(P)"
  by pred_auto

lemma B_monotone: "X \<sqsubseteq> Y \<Longrightarrow> B(X) \<sqsubseteq> B(Y)"
  by pred_blast

text \<open> We also create some example observations; the first (@{term "\<phi>\<^sub>1"}) satisfies Boyle's law and
        the second doesn't (@{term "\<phi>\<^sub>2"}). \<close>

definition(*<*)[upred_defs]:(*>*) "\<phi>\<^sub>1 = ((&p =\<^sub>u 10) \<and> (&V =\<^sub>u 5) \<and> (&k =\<^sub>u 50))"
definition(*<*)[upred_defs]:(*>*) "\<phi>\<^sub>2 = ((&p =\<^sub>u 10) \<and> (&V =\<^sub>u 5) \<and> (&k =\<^sub>u 100))"

text \<open> We first prove an obvious property: that these two predicates are different observations. We must
        show that there exists a valuation of one which is not of the other. This is achieved through
        application of \emph{pred-tac}, followed by \emph{sledgehammer}~\cite{Blanchette2011} which yields a \emph{metis} proof. \<close>

lemma \<phi>\<^sub>1_diff_\<phi>\<^sub>2: "\<phi>\<^sub>1 \<noteq> \<phi>\<^sub>2"
  by (pred_simp, fastforce)

text \<open> We prove that @{const "\<phi>\<^sub>1"} satisfies Boyle's law by application of the predicate calculus
        tactic, \emph{pred-tac}. \<close>

lemma B_\<phi>\<^sub>1: "\<phi>\<^sub>1 is B"
  by (pred_auto)

text \<open> We prove that @{const "\<phi>\<^sub>2"} does not satisfy Boyle's law by showing that applying \emph{B} to
        it results in @{const "\<phi>\<^sub>1"}. We prove this using Isabelle's natural proof language, Isar. \<close>

lemma B_\<phi>\<^sub>2: "B(\<phi>\<^sub>2) = \<phi>\<^sub>1"
proof -
  have "B(\<phi>\<^sub>2) = B(&p =\<^sub>u 10 \<and> &V =\<^sub>u 5 \<and> &k =\<^sub>u 100)"
    by (simp add: \<phi>\<^sub>2_def)
  also have "... = ((\<exists> k \<bullet> &p =\<^sub>u 10 \<and> &V =\<^sub>u 5 \<and> &k =\<^sub>u 100) \<and> &k =\<^sub>u &p*&V)"
    by (simp add: B_def)
  also have "... = (&p =\<^sub>u 10 \<and> &V =\<^sub>u 5 \<and> &k =\<^sub>u &p*&V)"
    by pred_auto
  also have "... = (&p =\<^sub>u 10 \<and> &V =\<^sub>u 5 \<and> &k =\<^sub>u 50)"
    by pred_auto
  also have "... = \<phi>\<^sub>1"
    by (simp add: \<phi>\<^sub>1_def)
  finally show ?thesis .
qed

subsection \<open> Dynamic invariants \<close>

text \<open> Next we build a relational theory that allows the pressure and volume to be changed,
        whilst still respecting Boyle's law. We create two dynamic invariants for this purpose. \<close>

definition "D1(P) = (($k =\<^sub>u $p*$V \<Rightarrow> $k\<acute> =\<^sub>u $p\<acute>*$V\<acute>) \<and> P)"
definition "D2(P) = ($k\<acute> =\<^sub>u $k \<and> P)"
(*<*)
declare D1_def [upred_defs]
declare D2_def [upred_defs]
(*>*)

text \<open> @{term "D1"} states that if Boyle's law satisfied in the previous state, then it should
        be satisfied in the next state. We define this by conjunction of the formal specification
        of this property with the predicate. The annotations @{term "$p"} and @{term "$p\<acute>"} refer to
        relational variables $p$ and $p'$. @{term "D2"} states that the constant @{term k} indeed
        remains constant throughout the evolution of the system, which is also specified as a conjunctive
        healthiness condition. As before we demonstrate that @{term D1} and @{term D2} are both idempotent
        and monotone. \<close>

lemma D1_idempotent: "D1(D1(P)) = D1(P)" by rel_auto
lemma D2_idempotent: "D2(D2(P)) = D2(P)" by rel_auto

lemma D1_monotone: "X \<sqsubseteq> Y \<Longrightarrow> D1(X) \<sqsubseteq> D1(Y)" by rel_auto
lemma D2_monotone: "X \<sqsubseteq> Y \<Longrightarrow> D2(X) \<sqsubseteq> D2(Y)" by rel_auto

text \<open> Since these properties are relational, we discharge them using our relational calculus tactic
        \emph{rel-tac}. Next we specify three operations that make up the signature of the theory. \<close>

definition InitSys :: "real \<Rightarrow> real \<Rightarrow> boyle_rel" where
  (*<*)[upred_defs]:(*>*) "InitSys ip iV
  = [(\<guillemotleft>ip\<guillemotright> > 0 \<and> \<guillemotleft>iV\<guillemotright> > 0)]\<^sup>\<top> ;; (p,V,k) := (\<guillemotleft>ip\<guillemotright>,\<guillemotleft>iV\<guillemotright>,(\<guillemotleft>ip\<guillemotright>*\<guillemotleft>iV\<guillemotright>))"

definition ChPres :: "real \<Rightarrow> boyle_rel" where
  (*<*)[upred_defs]:(*>*) "ChPres dp
  = ([(&p + \<guillemotleft>dp\<guillemotright> > 0)]\<^sup>\<top> ;; p := (&p + \<guillemotleft>dp\<guillemotright>) ;; V := (&k/&p))"

definition ChVol :: "real \<Rightarrow> boyle_rel" where
  (*<*)[upred_defs]:(*>*) "ChVol dV
  = ([(&V + \<guillemotleft>dV\<guillemotright> > 0)]\<^sup>\<top> ;; V := (&V + \<guillemotleft>dV\<guillemotright>) ;; p := (&k/&V))"

text \<open> @{const InitSys} initialises the system with a given initial pressure ($ip$) and volume ($iV$).
        It assumes that both are greater than 0 using the assumption construct @{term "[c]\<^sup>\<top>"} which equates to @{term II}
        if @{term c} is true and @{term false} (i.e. errant) otherwise. It then creates a state assignment
        for $p$ and $V$, uses the @{term B} healthiness condition to make it healthy (by calculating $k$),
        and finally turns the predicate into a postcondition using the @{term "\<lceil>P\<rceil>\<^sub>>"} function.

        @{const ChPres} raises or lowers the pressure based on an input \emph{dp}. It assumes
        that the resulting pressure change would not result in a zero or negative pressure,
        i.e. $p + dp > 0$. It assigns the updated value to $p$ and recalculates $V$ using the original
        value of $k$. @{const ChVol} is similar but updates the volume.
 \<close>

lemma D1_InitSystem: "D1 (InitSys ip iV) = InitSys ip iV"
  by rel_auto

text \<open> @{const InitSys} is @{const D1}, since it establishes the invariant for the system. However,
  it is not @{const D2} since it sets the global value of $k$ and thus can change its value. We can
  however show that both @{const ChPres} and @{const ChVol} are healthy relations. \<close>

lemma D1: "D1 (ChPres dp) = ChPres dp" and "D1 (ChVol dV) = ChVol dV"
  by (rel_auto, rel_auto)

lemma D2: "D2 (ChPres dp) = ChPres dp" and "D2 (ChVol dV) = ChVol dV"
  by (rel_auto, rel_auto)

text \<open> Finally we show a calculation a simple animation of Boyle's law, where the initial pressure
  and volume are set to 10 and 4, respectively, and then the pressure is lowered by 2. \<close>

lemma ChPres_example:
  "(InitSys 10 4 ;; ChPres (-2)) = p,V,k := 8,5,40"
proof -
  \<comment> \<open> @{const InitSys} yields an assignment to the three variables \<close>
  have "InitSys 10 4 = p,V,k := 10,4,40"
    by (rel_auto)
  \<comment> \<open> This assignment becomes a substitution \<close>
  hence "(InitSys 10 4 ;; ChPres (-2))
          = (ChPres (-2))\<lbrakk>10,4,40/$p,$V,$k\<rbrakk>"
    by (simp add: assigns_r_comp alpha usubst)
  \<comment> \<open> Unfold definition of @{const ChPres} \<close>
  also have "... = ([((&p - 2) > 0)]\<^sup>\<top>\<lbrakk>10,4,40/$p,$V,$k\<rbrakk>
                        ;; p := (&p - 2) ;; V := (&k / &p))"
    by (simp add: ChPres_def lit_numeral lit_uminus usubst unrest)
  \<comment> \<open> Unfold definition of assumption \<close>
  also have "... = ((p,V,k) := (10,4,40) \<triangleleft> (8 :\<^sub>u real) >\<^sub>u 0 \<triangleright> false)
                    ;; p := (&p - 2) ;; V := (&k / &p)"
    by rel_auto
  \<comment> \<open> @{term "8 > 0"} is true; simplify conditional  \<close>
  also have "... = (p,V,k) := (10,4,40) ;; p := (&p - 2) ;; V := (&k / &p)"
    by rel_auto
  \<comment> \<open> Application of both assignments \<close>
  also have "... = p,V,k := 8,5,40"
    by rel_auto
  finally show ?thesis .
qed

hide_const k
hide_const p
hide_const V
hide_const B

(************************)
(* Added by Frank Zeyda *)
(************************)

(*
lemma "(<x::nat> := 1 ;; <x::nat> := &<x::nat> + 1) = <x::nat> := 2"
apply (rel_auto)
apply (simp add: numeral_2_eq_2)
apply (simp add: numeral_2_eq_2)
done

lemma "({x::nat} := 1 ;; {x::nat} := &{x::nat} + 1) = {x::nat} := 2"
apply (rel_auto)
apply (simp add: numeral_2_eq_2)
apply (simp add: numeral_2_eq_2)
done
*)
(*<*)
end
(*>*)


section \<open>Lens algebraic operators\<close>

theory Lens_Algebra
imports Lens_Laws
begin

subsection \<open>Lens composition, plus, unit, and identity\<close>

text \<open>We introduce the algebraic lens operators; for more information please see our paper~\cite{Foster16a}.
      Lens composition constructs a lens by composing the source of one lens with the view of another.\<close>

definition lens_comp :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> ('a \<Longrightarrow> 'c)" (infixr ";\<^sub>L" 80) where
[lens_defs]: "lens_comp Y X = \<lparr> lens_get = lens_get Y \<circ> lens_get X
                              , lens_put = (\<lambda> \<sigma> v. lens_put X \<sigma> (lens_put Y (lens_get X \<sigma>) v)) \<rparr>"

text \<open>Lens plus parallel composes two indepedent lenses, resulting in a lens whose view is the
  product of the two underlying lens views.\<close>

definition lens_plus :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Longrightarrow> 'c" (infixr "+\<^sub>L" 75) where
[lens_defs]: "X +\<^sub>L Y = \<lparr> lens_get = (\<lambda> \<sigma>. (lens_get X \<sigma>, lens_get Y \<sigma>))
                       , lens_put = (\<lambda> \<sigma> (u, v). lens_put X (lens_put Y \<sigma> v) u) \<rparr>"

text \<open>The product functor lens similarly parallel composes two lenses, but in this case the lenses
  have different sources and so the resulting source is also a product.\<close>

definition lens_prod :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'd) \<Rightarrow> ('a \<times> 'b \<Longrightarrow> 'c \<times> 'd)" (infixr "\<times>\<^sub>L" 85) where
[lens_defs]: "lens_prod X Y = \<lparr> lens_get = map_prod get\<^bsub>X\<^esub> get\<^bsub>Y\<^esub>
                              , lens_put = \<lambda> (u, v) (x, y). (put\<^bsub>X\<^esub> u x, put\<^bsub>Y\<^esub> v y) \<rparr>"

text \<open>The $\lfst$ and $\lsnd$ lenses project the first and second elements, respectively, of a
  product source type.\<close>

definition fst_lens :: "'a \<Longrightarrow> 'a \<times> 'b" ("fst\<^sub>L") where
[lens_defs]: "fst\<^sub>L = \<lparr> lens_get = fst, lens_put = (\<lambda> (\<sigma>, \<rho>) u. (u, \<rho>)) \<rparr>"

definition snd_lens :: "'b \<Longrightarrow> 'a \<times> 'b" ("snd\<^sub>L") where
[lens_defs]: "snd\<^sub>L = \<lparr> lens_get = snd, lens_put = (\<lambda> (\<sigma>, \<rho>) u. (\<sigma>, u)) \<rparr>"

lemma get_fst_lens [simp]: "get\<^bsub>fst\<^sub>L\<^esub> (x, y) = x"
  by (simp add: fst_lens_def)

lemma get_snd_lens [simp]: "get\<^bsub>snd\<^sub>L\<^esub> (x, y) = y"
  by (simp add: snd_lens_def)

text \<open>The swap lens is a bijective lens which swaps over the elements of the product source type.\<close>

abbreviation swap_lens :: "'a \<times> 'b \<Longrightarrow> 'b \<times> 'a" ("swap\<^sub>L") where
"swap\<^sub>L \<equiv> snd\<^sub>L +\<^sub>L fst\<^sub>L"

text \<open>The zero lens is an ineffectual lens whose view is a unit type. This means the zero lens
  cannot distinguish or change the source type.\<close>

definition zero_lens :: "unit \<Longrightarrow> 'a" ("0\<^sub>L") where
[lens_defs]: "0\<^sub>L = \<lparr> lens_get = (\<lambda> _. ()), lens_put = (\<lambda> \<sigma> x. \<sigma>) \<rparr>"

text \<open>The identity lens is a bijective lens where the source and view type are the same.\<close>

definition id_lens :: "'a \<Longrightarrow> 'a" ("1\<^sub>L") where
[lens_defs]: "1\<^sub>L = \<lparr> lens_get = id, lens_put = (\<lambda> _. id) \<rparr>"

text \<open>The quotient operator $X \lquot Y$ shortens lens $X$ by cutting off $Y$ from the end. It is
  thus the dual of the composition operator.\<close>

definition lens_quotient :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> 'a \<Longrightarrow> 'b" (infixr "'/\<^sub>L" 90) where
[lens_defs]: "X /\<^sub>L Y = \<lparr> lens_get = \<lambda> \<sigma>. get\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>)
                       , lens_put = \<lambda> \<sigma> v. get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>) v) \<rparr>"

text \<open>Lens override uses a lens to override part of a source type.\<close>

definition lens_override :: "'a \<Rightarrow> 'a \<Rightarrow> ('b \<Longrightarrow> 'a) \<Rightarrow> 'a" ("_ \<oplus>\<^sub>L _ on _" [95,0,96] 95) where
[lens_defs]: "S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X = put\<^bsub>X\<^esub> S\<^sub>1 (get\<^bsub>X\<^esub> S\<^sub>2)"

text \<open>Lens inversion take a bijective lens and swaps the source and view types.\<close>

definition lens_inv :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b \<Longrightarrow> 'a)" ("inv\<^sub>L") where
[lens_defs]: "lens_inv x = \<lparr> lens_get = create\<^bsub>x\<^esub>, lens_put = \<lambda> \<sigma>. get\<^bsub>x\<^esub> \<rparr>"

subsection \<open>Closure properties\<close>

lemma id_wb_lens: "wb_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma unit_wb_lens: "wb_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma comp_wb_lens: "\<lbrakk> wb_lens x; wb_lens y \<rbrakk> \<Longrightarrow> wb_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma comp_mwb_lens: "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> mwb_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma id_vwb_lens: "vwb_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma unit_vwb_lens: "vwb_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma comp_vwb_lens: "\<lbrakk> vwb_lens x; vwb_lens y \<rbrakk> \<Longrightarrow> vwb_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma unit_ief_lens: "ief_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma plus_mwb_lens:
  assumes "mwb_lens x" "mwb_lens y" "x \<bowtie> y"
  shows "mwb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales)
  apply (simp_all add: lens_plus_def prod.case_eq_if lens_indep_sym)
  apply (simp add: lens_indep_comm)
done

lemma plus_wb_lens:
  assumes "wb_lens x" "wb_lens y" "x \<bowtie> y"
  shows "wb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
  apply (simp add: lens_indep_sym prod.case_eq_if)
done

lemma plus_vwb_lens:
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "vwb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
  apply (simp add: lens_indep_sym prod.case_eq_if)
  apply (simp add: lens_indep_comm prod.case_eq_if)
done

lemma prod_mwb_lens:
  "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_wb_lens:
  "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_vwb_lens:
  "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_bij_lens:
  "\<lbrakk> bij_lens X; bij_lens Y \<rbrakk> \<Longrightarrow> bij_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma fst_vwb_lens: "vwb_lens fst\<^sub>L"
  by (unfold_locales, simp_all add: fst_lens_def prod.case_eq_if)

lemma snd_vwb_lens: "vwb_lens snd\<^sub>L"
  by (unfold_locales, simp_all add: snd_lens_def prod.case_eq_if)

lemma id_bij_lens: "bij_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma inv_id_lens: "inv\<^sub>L 1\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_inv_def id_lens_def lens_create_def)

lemma lens_inv_bij: "bij_lens X \<Longrightarrow> bij_lens (inv\<^sub>L X)"
  by (unfold_locales, simp_all add: lens_inv_def lens_create_def)

lemma swap_bij_lens: "bij_lens swap\<^sub>L"
  by (unfold_locales, simp_all add: lens_plus_def prod.case_eq_if fst_lens_def snd_lens_def)

subsection \<open>Composition laws\<close>

lemma lens_comp_assoc: "(X ;\<^sub>L Y) ;\<^sub>L Z = X ;\<^sub>L (Y ;\<^sub>L Z)"
  by (auto simp add: lens_comp_def)

lemma lens_comp_left_id [simp]: "1\<^sub>L ;\<^sub>L X = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_right_id [simp]: "X ;\<^sub>L 1\<^sub>L = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_anhil [simp]: "wb_lens X \<Longrightarrow> 0\<^sub>L ;\<^sub>L X = 0\<^sub>L"
  by (simp add: zero_lens_def lens_comp_def comp_def)

subsection \<open>Independence laws\<close>

lemma zero_lens_indep: "0\<^sub>L \<bowtie> X"
  by (auto simp add: zero_lens_def lens_indep_def)

lemma lens_indep_quasi_irrefl: "\<lbrakk> wb_lens x; eff_lens x \<rbrakk> \<Longrightarrow> \<not> (x \<bowtie> x)"
  by (auto simp add: lens_indep_def ief_lens_def ief_lens_axioms_def, metis (full_types) wb_lens.get_put)

lemma lens_indep_left_comp [simp]:
  "\<lbrakk> mwb_lens z; x \<bowtie> y \<rbrakk> \<Longrightarrow> (x ;\<^sub>L z) \<bowtie> (y ;\<^sub>L z)"
  apply (rule lens_indepI)
  apply (auto simp add: lens_comp_def)
  apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_comp:
  "y \<bowtie> z \<Longrightarrow> (x ;\<^sub>L y) \<bowtie> (x ;\<^sub>L z)"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
  using lens_indep_comm lens_indep_sym apply fastforce
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_left_ext [intro]:
  "y \<bowtie> z \<Longrightarrow> (x ;\<^sub>L y) \<bowtie> z"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
  apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_ext [intro]:
  "x \<bowtie> z \<Longrightarrow> x \<bowtie> (y ;\<^sub>L z)"
  by (simp add: lens_indep_left_ext lens_indep_sym)

lemma fst_snd_lens_indep:
  "fst\<^sub>L \<bowtie> snd\<^sub>L"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma split_prod_lens_indep:
  assumes "mwb_lens X"
  shows "(fst\<^sub>L ;\<^sub>L X) \<bowtie> (snd\<^sub>L ;\<^sub>L X)"
  using assms fst_snd_lens_indep lens_indep_left_comp vwb_lens_mwb by blast

lemma plus_pres_lens_indep: "\<lbrakk> X \<bowtie> Z; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) \<bowtie> Z"
  apply (rule lens_indepI)
  apply (simp_all add: lens_plus_def prod.case_eq_if)
  apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_comp_indep_cong_left:
  "\<lbrakk> mwb_lens Z; X ;\<^sub>L Z \<bowtie> Y ;\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<bowtie> Y"
  apply (rule lens_indepI)
  apply (rename_tac u v \<sigma>)
  apply (drule_tac u=u and v=v and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_comm)
  apply (simp add: lens_comp_def)
  apply (meson mwb_lens_weak weak_lens.view_determination)
  apply (rename_tac v \<sigma>)
  apply (drule_tac v=v and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_get)
  apply (simp add: lens_comp_def)
  apply (drule lens_indep_sym)
  apply (rename_tac u \<sigma>)
  apply (drule_tac v=u and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_get)
  apply (simp add: lens_comp_def)
done

lemma lens_comp_indep_cong:
  "mwb_lens Z \<Longrightarrow> (X ;\<^sub>L Z) \<bowtie> (Y ;\<^sub>L Z) \<longleftrightarrow> X \<bowtie> Y"
  using lens_comp_indep_cong_left lens_indep_left_comp by blast

lemma lens_indep_prod:
  "\<lbrakk> X\<^sub>1 \<bowtie> X\<^sub>2; Y\<^sub>1 \<bowtie> Y\<^sub>2 \<rbrakk> \<Longrightarrow> X\<^sub>1 \<times>\<^sub>L Y\<^sub>1 \<bowtie> X\<^sub>2 \<times>\<^sub>L Y\<^sub>2"
  apply (rule lens_indepI)
  apply (auto simp add: lens_prod_def prod.case_eq_if lens_indep_comm map_prod_def)
  apply (simp_all add: lens_indep_sym)
done

subsection \<open>Algebraic laws\<close>

lemma fst_lens_plus:
  "wb_lens y \<Longrightarrow> fst\<^sub>L ;\<^sub>L (x +\<^sub>L y) = x"
  by (simp add: fst_lens_def lens_plus_def lens_comp_def comp_def)

text {* The second law requires independence as we have to apply x first, before y *}

lemma snd_lens_plus:
  "\<lbrakk> wb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> snd\<^sub>L ;\<^sub>L (x +\<^sub>L y) = y"
  apply (simp add: snd_lens_def lens_plus_def lens_comp_def comp_def)
  apply (subst lens_indep_comm)
  apply (simp_all)
done

lemma lens_plus_swap:
  "X \<bowtie> Y \<Longrightarrow> (snd\<^sub>L +\<^sub>L fst\<^sub>L) ;\<^sub>L (X +\<^sub>L Y) = (Y +\<^sub>L X)"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def lens_comp_def lens_indep_comm)

lemma prod_as_plus: "X \<times>\<^sub>L Y = X ;\<^sub>L fst\<^sub>L +\<^sub>L Y ;\<^sub>L snd\<^sub>L"
  by (auto simp add: lens_prod_def fst_lens_def snd_lens_def lens_comp_def lens_plus_def)

lemma prod_lens_id_equiv:
  "1\<^sub>L \<times>\<^sub>L 1\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_prod_def id_lens_def)

lemma prod_lens_comp_plus:
  "X\<^sub>2 \<bowtie> Y\<^sub>2 \<Longrightarrow> ((X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) ;\<^sub>L (X\<^sub>2 +\<^sub>L Y\<^sub>2)) = (X\<^sub>1 ;\<^sub>L X\<^sub>2) +\<^sub>L (Y\<^sub>1 ;\<^sub>L Y\<^sub>2)"
  by (auto simp add: lens_comp_def lens_plus_def lens_prod_def prod.case_eq_if fun_eq_iff)

lemma fst_snd_id_lens: "fst\<^sub>L +\<^sub>L snd\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def)

lemma swap_lens_idem: "swap\<^sub>L ;\<^sub>L swap\<^sub>L = 1\<^sub>L"
  by (simp add: fst_snd_id_lens fst_snd_lens_indep lens_indep_sym lens_plus_swap)

lemma swap_lens_fst: "fst\<^sub>L ;\<^sub>L swap\<^sub>L = snd\<^sub>L"
  by (simp add: fst_lens_plus fst_vwb_lens)

lemma swap_lens_snd: "snd\<^sub>L ;\<^sub>L swap\<^sub>L = fst\<^sub>L"
  by (simp add: fst_snd_lens_indep lens_indep_sym snd_lens_plus snd_vwb_lens)
end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

header {* Multiset Extension Preserves Well-Quasi-Orders *}

theory Wqo_Multiset
imports
  Multiset_Extension
  Well_Quasi_Orders
begin

lemma list_emb_imp_reflclp_mulex_on:
  assumes "xs \<in> lists A" and "ys \<in> lists A"
    and "list_emb P xs ys"
  shows "(mulex_on P A)\<^sup>=\<^sup>= (multiset_of xs) (multiset_of ys)"
using assms(3, 1, 2)
proof (induct)
  case (list_emb_Nil ys)
  then show ?case
    by (cases ys) (auto intro!: empty_mulex_on simp: multisets_def)
next
  case (list_emb_Cons xs ys y)
  then show ?case by (auto intro!: mulex_on_self_add_right simp: multisets_def)
next
  case (list_emb_Cons2 x y xs ys)
  then show ?case
    by (auto intro: union_mulex_on_mono mulex_on_union'
             intro!: singleton_mulex_onI mulex_on_union
             simp: multisets_def)
qed

text {*The (reflexive closure of the) multiset extension of an almost-full relation
is almost-full.*}
lemma almost_full_on_multisets:
  assumes "almost_full_on P A"
  shows "almost_full_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)"
proof -
  let ?P = "(mulex_on P A)\<^sup>=\<^sup>="
  from almost_full_on_hom [OF _ almost_full_on_lists, of A P ?P multiset_of,
    OF list_emb_imp_reflclp_mulex_on, simplified]
    show ?thesis using assms by blast
qed

lemma wqo_on_multisets:
  assumes "wqo_on P A"
  shows "wqo_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)"
proof
  from transp_on_mulex_on [of P A "multisets A"]
    show "transp_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)"
    unfolding transp_on_def by blast
next
  from almost_full_on_multisets [OF assms [THEN wqo_on_imp_almost_full_on]]
    show "almost_full_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)" .
qed

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Jeremy Dawson, NICTA *)

section \<open>Dedicated operation for the most significant bit\<close>

theory Most_significant_bit
  imports
    "HOL-Library.Word"
    Bit_Shifts_Infix_Syntax
    More_Word
    More_Arithmetic
begin

class msb =
  fixes msb :: \<open>'a \<Rightarrow> bool\<close>

instantiation int :: msb
begin

definition \<open>msb x \<longleftrightarrow> x < 0\<close> for x :: int

instance ..

end

lemma msb_bin_rest [simp]: "msb (x div 2) = msb x"
  for x :: int
  by (simp add: msb_int_def)

context
  includes bit_operations_syntax
begin

lemma int_msb_and [simp]: "msb ((x :: int) AND y) \<longleftrightarrow> msb x \<and> msb y"
by(simp add: msb_int_def)

lemma int_msb_or [simp]: "msb ((x :: int) OR y) \<longleftrightarrow> msb x \<or> msb y"
by(simp add: msb_int_def)

lemma int_msb_xor [simp]: "msb ((x :: int) XOR y) \<longleftrightarrow> msb x \<noteq> msb y"
by(simp add: msb_int_def)

lemma int_msb_not [simp]: "msb (NOT (x :: int)) \<longleftrightarrow> \<not> msb x"
by(simp add: msb_int_def not_less)

end

lemma msb_shiftl [simp]: "msb ((x :: int) << n) \<longleftrightarrow> msb x"
  by (simp add: msb_int_def shiftl_def)

lemma msb_shiftr [simp]: "msb ((x :: int) >> r) \<longleftrightarrow> msb x"
  by (simp add: msb_int_def shiftr_def)

lemma msb_0 [simp]: "msb (0 :: int) = False"
by(simp add: msb_int_def)

lemma msb_1 [simp]: "msb (1 :: int) = False"
by(simp add: msb_int_def)

lemma msb_numeral [simp]:
  "msb (numeral n :: int) = False"
  "msb (- numeral n :: int) = True"
by(simp_all add: msb_int_def)

instantiation word :: (len) msb
begin

definition msb_word :: \<open>'a word \<Rightarrow> bool\<close>
  where msb_word_iff_bit: \<open>msb w \<longleftrightarrow> bit w (LENGTH('a) - Suc 0)\<close> for w :: \<open>'a::len word\<close>

instance ..

end

lemma msb_word_eq:
  \<open>msb w \<longleftrightarrow> bit w (LENGTH('a) - 1)\<close> for w :: \<open>'a::len word\<close>
  by (simp add: msb_word_iff_bit)

lemma word_msb_sint: "msb w \<longleftrightarrow> sint w < 0"
  by (simp add: msb_word_eq bit_last_iff)

lemma msb_word_iff_sless_0:
  \<open>msb w \<longleftrightarrow> w <s 0\<close>
  by (simp add: word_msb_sint word_sless_alt)

lemma msb_word_of_int:
  "msb (word_of_int x::'a::len word) = bit x (LENGTH('a) - 1)"
  by (simp add: msb_word_iff_bit bit_simps)

lemma word_msb_numeral [simp]:
  "msb (numeral w::'a::len word) = bit (numeral w :: int) (LENGTH('a) - 1)"
  unfolding word_numeral_alt by (rule msb_word_of_int)

lemma word_msb_neg_numeral [simp]:
  "msb (- numeral w::'a::len word) = bit (- numeral w :: int) (LENGTH('a) - 1)"
  unfolding word_neg_numeral_alt by (rule msb_word_of_int)

lemma word_msb_0 [simp]: "\<not> msb (0::'a::len word)"
  by (simp add: msb_word_iff_bit)

lemma word_msb_1 [simp]: "msb (1::'a::len word) \<longleftrightarrow> LENGTH('a) = 1"
  by (simp add: msb_word_iff_bit le_Suc_eq)

lemma word_msb_nth: "msb w = bit (uint w) (LENGTH('a) - 1)"
  for w :: "'a::len word"
  by (simp add: msb_word_iff_bit bit_simps)

lemma msb_nth: "msb w = bit w (LENGTH('a) - 1)"
  for w :: "'a::len word"
  by (fact msb_word_eq)

lemma word_msb_n1 [simp]: "msb (-1::'a::len word)"
  by (simp add: msb_word_eq not_le)

lemma msb_shift: "msb w \<longleftrightarrow> w >> LENGTH('a) - 1 \<noteq> 0"
  for w :: "'a::len word"
  by (simp add: drop_bit_eq_zero_iff_not_bit_last msb_word_eq shiftr_def)

lemmas word_ops_msb = msb1 [unfolded msb_nth [symmetric, unfolded One_nat_def]]

lemma word_sint_msb_eq: "sint x = uint x - (if msb x then 2 ^ size x else 0)"
  apply (cases \<open>LENGTH('a)\<close>)
  apply (simp_all add: msb_word_iff_bit word_size)
  apply transfer
  apply (simp add: signed_take_bit_eq_take_bit_minus)
  done

lemma word_sle_msb_le: "x <=s y \<longleftrightarrow> (msb y \<longrightarrow> msb x) \<and> ((msb x \<and> \<not> msb y) \<or> x \<le> y)"
  apply (simp add: word_sle_eq word_sint_msb_eq word_size word_le_def)
  apply safe
   apply (rule order_trans[OF _ uint_ge_0])
   apply (simp add: order_less_imp_le)
  apply (erule notE[OF leD])
  apply (rule order_less_le_trans[OF _ uint_ge_0])
  apply simp
  done

lemma word_sless_msb_less: "x <s y \<longleftrightarrow> (msb y \<longrightarrow> msb x) \<and> ((msb x \<and> \<not> msb y) \<or> x < y)"
  by (auto simp add: word_sless_eq word_sle_msb_le)

lemma not_msb_from_less:
  "(v :: 'a word) < 2 ^ (LENGTH('a :: len) - 1) \<Longrightarrow> \<not> msb v"
  apply (clarsimp simp add: msb_nth)
  apply (drule less_mask_eq)
  apply (drule word_eqD, drule(1) iffD2)
  apply (simp add: bit_simps)
  done

lemma scast_eq_ucast:
  "\<not> msb x \<Longrightarrow> scast x = ucast x"
  apply (cases \<open>LENGTH('a)\<close>)
  apply simp
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_signed_iff bit_unsigned_iff min_def msb_word_eq)
  apply (erule notE)
  apply (metis le_less_Suc_eq test_bit_bin)
  done

lemma msb_ucast_eq:
    "LENGTH('a) = LENGTH('b) \<Longrightarrow>
         msb (ucast x :: ('a::len) word) = msb (x :: ('b::len) word)"
  by (simp add: msb_word_eq bit_simps)

lemma msb_big:
  \<open>msb a \<longleftrightarrow> 2 ^ (LENGTH('a) - Suc 0) \<le> a\<close>
  for a :: \<open>'a::len word\<close>
  using bang_is_le [of a \<open>LENGTH('a) - Suc 0\<close>]
  apply (auto simp add: msb_nth word_le_not_less)
  apply (rule ccontr)
  apply (erule notE)
  apply (rule ccontr)
  apply (clarsimp simp: not_less)
  apply (subgoal_tac "a = take_bit (LENGTH('a) - Suc 0) a")
   apply (cut_tac and_mask_less' [where w=a and n="LENGTH('a) - Suc 0"])
    apply auto
  apply (simp flip: take_bit_eq_mask)
  apply (rule sym)
  apply (simp add: take_bit_eq_self_iff_drop_bit_eq_0 drop_bit_eq_zero_iff_not_bit_last)
  done

instantiation integer :: msb
begin

context
  includes integer.lifting
begin

lift_definition msb_integer :: \<open>integer \<Rightarrow> bool\<close> is msb .

instance ..

end

end

end


(*<*)
theory Three_Steps
imports "../Consensus_Misc"
begin
(*>*)
subsection \<open>Step definitions for 3-step algorithms\<close>

abbreviation (input) "nr_steps \<equiv> 3"

definition three_phase where "three_phase (r::nat) \<equiv> r div nr_steps"

definition three_step where "three_step (r::nat) \<equiv> r mod nr_steps"

lemma three_phase_zero [simp]: "three_phase 0 = 0"
by (simp add: three_phase_def)

lemma three_step_zero [simp]: "three_step 0 = 0"
by (simp add: three_step_def)

lemma three_phase_step: "(three_phase r * nr_steps) + three_step r = r"
  by (auto simp add: three_phase_def three_step_def)

lemma three_step_Suc:
  "three_step r = 0 \<Longrightarrow> three_step (Suc (Suc r)) = 2"
  "three_step r = 0 \<Longrightarrow> three_step (Suc r) = 1"
  "three_step r = (Suc 0) \<Longrightarrow> three_step (Suc r) = 2"
  "three_step r = (Suc 0) \<Longrightarrow> three_step (Suc (Suc r)) = 0"
  "three_step r = (Suc (Suc 0)) \<Longrightarrow> three_step ((Suc r)) = 0"
  by(unfold three_step_def, simp_all add: mod_Suc)

lemma three_step_phase_Suc:
  "three_step r = 0 \<Longrightarrow> three_phase (Suc r) = three_phase r"
  "three_step r = 0 \<Longrightarrow> three_phase (Suc (Suc r)) = three_phase r"
  "three_step r = 0 \<Longrightarrow> three_phase (Suc (Suc (Suc r))) = Suc (three_phase r)"
  "three_step r = (Suc 0) \<Longrightarrow> three_phase (Suc r) = three_phase r"
  "three_step r = (Suc 0) \<Longrightarrow> three_phase (Suc (Suc r)) = Suc (three_phase r)"
  "three_step r = (Suc (Suc 0)) \<Longrightarrow> three_phase (Suc r) = Suc (three_phase r)"
  by(simp_all add: three_step_def three_phase_def mod_Suc div_Suc)

lemma three_step2_phase_Suc:
  "three_step r = 2 \<Longrightarrow> (3 * (Suc (three_phase r)) - 1) = r"
  apply(simp add: three_step_def three_phase_def)
  by (metis add_2_eq_Suc' mult_div_mod_eq)

lemma three_stepE:
  "\<lbrakk> three_step r = 0 \<Longrightarrow> P; three_step r = 1 \<Longrightarrow> P; three_step r = 2 \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by(unfold three_step_def, arith)

end


section \<open>Examples for the \<open>real_asymp\<close> method\<close>
theory Real_Asymp_Examples
  imports Real_Asymp
begin

context
  includes asymp_equiv_notation
begin

subsection \<open>Dominik Gruntz's examples\<close>

lemma "((\<lambda>x::real. exp x * (exp (1/x - exp (-x)) - exp (1/x))) \<longlongrightarrow> -1) at_top"
  by real_asymp

lemma "((\<lambda>x::real. exp x * (exp (1/x + exp (-x) + exp (-(x^2))) -
                     exp (1/x - exp (-exp x)))) \<longlongrightarrow> 1) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. exp (exp (x - exp (-x)) / (1 - 1/x)) - exp (exp x)) at_top at_top"
  by real_asymp

text \<open>This example is notable because it produces an expansion of level 9.\<close>
lemma "filterlim (\<lambda>x::real. exp (exp (exp x / (1 - 1/x))) -
                    exp (exp (exp x / (1 - 1/x - ln x powr (-ln x))))) at_bot at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. exp (exp (exp (x + exp (-x)))) / exp (exp (exp x))) at_top at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. exp (exp (exp x)) / (exp (exp (exp (x - exp (-exp x)))))) at_top at_top"
  by real_asymp

lemma "((\<lambda>x::real. exp (exp (exp x)) / exp (exp (exp x - exp (-exp (exp x))))) \<longlongrightarrow> 1) at_top"
  by real_asymp

lemma "((\<lambda>x::real. exp (exp x) / exp (exp x - exp (-exp (exp x)))) \<longlongrightarrow> 1) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. ln x ^ 2 * exp (sqrt (ln x) * ln (ln x) ^ 2 *
         exp (sqrt (ln (ln x)) * ln (ln (ln x)) ^ 3)) / sqrt x) (at_right 0) at_top"
  by real_asymp

lemma "((\<lambda>x::real. (x * ln x * ln (x * exp x - x^2) ^ 2) /
                    ln (ln (x^2 + 2*exp (exp (3*x^3*ln x))))) \<longlongrightarrow> 1/3) at_top"
  by real_asymp

lemma "((\<lambda>x::real. (exp (x * exp (-x) / (exp (-x) + exp (-(2*x^2)/(x+1)))) - exp x) / x)
          \<longlongrightarrow> -exp 2) at_top"
  by real_asymp

lemma "((\<lambda>x::real. (3 powr x + 5 powr x) powr (1/x)) \<longlongrightarrow> 5) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. x / (ln (x powr (ln x powr (ln 2 / ln x))))) at_top at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. exp (exp (2*ln (x^5 + x) * ln (ln x))) /
                     exp (exp (10*ln x * ln (ln x)))) at_top at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. 4/9 * (exp (exp (5/2*x powr (-5/7) + 21/8*x powr (6/11) +
              2*x powr (-8) + 54/17*x powr (49/45))) ^ 8) / (ln (ln (-ln (4/3*x powr (-5/14))))))
         at_top at_top"
  by real_asymp

lemma "((\<lambda>x::real. (exp (4*x*exp (-x) /
                    (1/exp x + 1/exp (2*x^2/(x+1)))) - exp x) / ((exp x)^4)) \<longlongrightarrow> 1) at_top "
  by real_asymp

lemma "((\<lambda>x::real. exp (x*exp (-x) / (exp (-x) + exp (-2*x^2/(x+1))))/exp x) \<longlongrightarrow> 1) at_top"
  by real_asymp

lemma "((\<lambda>x::real. exp (exp (-x/(1+exp (-x)))) * exp (-x/(1+exp (-x/(1+exp (-x))))) *
           exp (exp (-x+exp (-x/(1+exp (-x))))) / (exp (-x/(1+exp (-x))))^2 - exp x + x)
         \<longlongrightarrow> 2) at_top"
  by real_asymp

lemma "((\<lambda>x::real. (ln(ln x + ln (ln x)) - ln (ln x)) /
                      (ln (ln x + ln (ln (ln x)))) * ln x) \<longlongrightarrow> 1) at_top"
  by real_asymp

lemma "((\<lambda>x::real. exp (ln (ln (x + exp (ln x * ln (ln x)))) /
                       (ln (ln (ln (exp x + x + ln x)))))) \<longlongrightarrow> exp 1) at_top"
  by real_asymp

lemma "((\<lambda>x::real. exp x * (sin (1/x + exp (-x)) - sin (1/x + exp (-(x^2))))) \<longlongrightarrow> 1) at_top"
  by real_asymp

lemma "((\<lambda>x::real. exp (exp x) * (exp (sin (1/x + exp (-exp x))) - exp (sin (1/x)))) \<longlongrightarrow> 1) at_top"
  by real_asymp

lemma "((\<lambda>x::real. max x (exp x) / ln (min (exp (-x)) (exp (-exp x)))) \<longlongrightarrow> -1) at_top"
  by real_asymp

text \<open>The following example is taken from the paper by Richardson \<^emph>\<open>et al\<close>.\<close>
lemma
  defines "f \<equiv> (\<lambda>x::real. ln (ln (x * exp (x * exp x) + 1)) - exp (exp (ln (ln x) + 1 / x)))"
  shows   "(f \<longlongrightarrow> 0) at_top" (is ?thesis1)
          "f \<sim> (\<lambda>x. -(ln x ^ 2) / (2*x))" (is ?thesis2)
  unfolding f_def by real_asymp+

subsection \<open>Asymptotic inequalities related to the Akra--Bazzi theorem\<close>

definition "akra_bazzi_asymptotic1 b hb e p x \<longleftrightarrow>
  (1 - hb * inverse b * ln x powr -(1+e)) powr p * (1 + ln (b*x + hb*x/ln x powr (1+e)) powr (-e/2))
  \<ge> 1 + (ln x powr (-e/2) :: real)"
definition "akra_bazzi_asymptotic1' b hb e p x \<longleftrightarrow>
  (1 + hb * inverse b * ln x powr -(1+e)) powr p * (1 + ln (b*x + hb*x/ln x powr (1+e)) powr (-e/2))
  \<ge> 1 + (ln x powr (-e/2) :: real)"
definition "akra_bazzi_asymptotic2 b hb e p x \<longleftrightarrow>
  (1 + hb * inverse b * ln x powr -(1+e)) powr p * (1 - ln (b*x + hb*x/ln x powr (1+e)) powr (-e/2))
      \<le> 1 - ln x powr (-e/2 :: real)"
definition "akra_bazzi_asymptotic2' b hb e p x \<longleftrightarrow>
  (1 - hb * inverse b * ln x powr -(1+e)) powr p * (1 - ln (b*x + hb*x/ln x powr (1+e)) powr (-e/2))
      \<le> 1 - ln x powr (-e/2 :: real)"
definition "akra_bazzi_asymptotic3 e x \<longleftrightarrow> (1 + (ln x powr (-e/2))) / 2 \<le> (1::real)"
definition "akra_bazzi_asymptotic4 e x \<longleftrightarrow> (1 - (ln x powr (-e/2))) * 2 \<ge> (1::real)"
definition "akra_bazzi_asymptotic5 b hb e x \<longleftrightarrow>
  ln (b*x - hb*x*ln x powr -(1+e)) powr (-e/2::real) < 1"

definition "akra_bazzi_asymptotic6 b hb e x \<longleftrightarrow> hb / ln x powr (1 + e :: real) < b/2"
definition "akra_bazzi_asymptotic7 b hb e x \<longleftrightarrow> hb / ln x powr (1 + e :: real) < (1 - b) / 2"
definition "akra_bazzi_asymptotic8 b hb e x \<longleftrightarrow> x*(1 - b - hb / ln x powr (1 + e :: real)) > 1"

definition "akra_bazzi_asymptotics b hb e p x \<longleftrightarrow>
  akra_bazzi_asymptotic1 b hb e p x \<and> akra_bazzi_asymptotic1' b hb e p x \<and>
  akra_bazzi_asymptotic2 b hb e p x \<and> akra_bazzi_asymptotic2' b hb e p x \<and>
  akra_bazzi_asymptotic3 e x \<and> akra_bazzi_asymptotic4 e x \<and> akra_bazzi_asymptotic5 b hb e x \<and>
  akra_bazzi_asymptotic6 b hb e x \<and> akra_bazzi_asymptotic7 b hb e x \<and>
  akra_bazzi_asymptotic8 b hb e x"

lemmas akra_bazzi_asymptotic_defs =
  akra_bazzi_asymptotic1_def akra_bazzi_asymptotic1'_def
  akra_bazzi_asymptotic2_def akra_bazzi_asymptotic2'_def akra_bazzi_asymptotic3_def
  akra_bazzi_asymptotic4_def akra_bazzi_asymptotic5_def akra_bazzi_asymptotic6_def
  akra_bazzi_asymptotic7_def akra_bazzi_asymptotic8_def akra_bazzi_asymptotics_def

lemma akra_bazzi_asymptotics:
  assumes "\<And>b. b \<in> set bs \<Longrightarrow> b \<in> {0<..<1}" and "e > 0"
  shows "eventually (\<lambda>x. \<forall>b\<in>set bs. akra_bazzi_asymptotics b hb e p x) at_top"
proof (intro eventually_ball_finite ballI)
  fix b assume "b \<in> set bs"
  with assms have "b \<in> {0<..<1}" by simp
  with \<open>e > 0\<close> show "eventually (\<lambda>x. akra_bazzi_asymptotics b hb e p x) at_top"
    unfolding akra_bazzi_asymptotic_defs
    by (intro eventually_conj; real_asymp simp: mult_neg_pos)
qed simp

lemma
  fixes b \<epsilon> :: real
  assumes "b \<in> {0<..<1}" and "\<epsilon> > 0"
  shows "filterlim (\<lambda>x. (1 - H / (b * ln x powr (1 + \<epsilon>))) powr p *
           (1 + ln (b * x + H * x / ln x powr (1+\<epsilon>)) powr (-\<epsilon>/2)) -
           (1 + ln x powr (-\<epsilon>/2))) (at_right 0) at_top"
  using assms by (real_asymp simp: mult_neg_pos)

context
  fixes b e p :: real
  assumes assms: "b > 0" "e > 0"
begin

lemmas [simp] = mult_neg_pos

real_limit "(\<lambda>x. ((1 - 1 / (b * ln x powr (1 + e))) powr p *
               (1 + ln (b * x +  x / ln x powr (1+e)) powr (-e/2)) -
               (1 + ln x powr (-e/2))) * ln x powr ((e / 2) + 1))"
  facts: assms

end

context
  fixes b \<epsilon> :: real
  assumes assms: "b > 0" "\<epsilon> > 0" "\<epsilon> < 1 / 4"
begin

real_expansion "(\<lambda>x. (1 - H / (b * ln x powr (1 + \<epsilon>))) powr p *
           (1 + ln (b * x + H * x / ln x powr (1+\<epsilon>)) powr (-\<epsilon>/2)) -
           (1 + ln x powr (-\<epsilon>/2)))"
  terms: 10 (strict)
  facts: assms

end

context
  fixes e :: real
  assumes e: "e > 0" "e < 1 / 4"
begin

real_expansion "(\<lambda>x. (1 - 1 / (1/2 * ln x powr (1 + e))) *
           (1 + ln (1/2 * x + x / ln x powr (1+e)) powr (-e/2)) -
           (1 + ln x powr (-e/2)))"
  terms: 10 (strict)
  facts: e

end

subsection \<open>Concrete Mathematics\<close>

text \<open>The following inequalities are discussed on p.\ 441 in Concrete Mathematics.\<close>
lemma
  fixes c \<epsilon> :: real
  assumes "0 < \<epsilon>" "\<epsilon> < 1" "1 < c"
    shows "(\<lambda>_::real. 1) \<in> o(\<lambda>x. ln (ln x))"
      and "(\<lambda>x::real. ln (ln x)) \<in> o(\<lambda>x. ln x)"
      and "(\<lambda>x::real. ln x) \<in> o(\<lambda>x. x powr \<epsilon>)"
      and "(\<lambda>x::real. x powr \<epsilon>) \<in> o(\<lambda>x. x powr c)"
      and "(\<lambda>x. x powr c) \<in> o(\<lambda>x. x powr ln x)"
      and "(\<lambda>x. x powr ln x) \<in> o(\<lambda>x. c powr x)"
      and "(\<lambda>x. c powr x) \<in> o(\<lambda>x. x powr x)"
      and "(\<lambda>x. x powr x) \<in> o(\<lambda>x. c powr (c powr x))"
  using assms by (real_asymp (verbose))+

subsection \<open>Stack Exchange\<close>

text \<open>
  http://archives.math.utk.edu/visual.calculus/1/limits.15/
\<close>
lemma "filterlim (\<lambda>x::real. (x * sin x) / abs x) (at_right 0) (at 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. x^2 / (sqrt (x^2 + 12) - sqrt (12))) (nhds (12 / sqrt 3)) (at 0)"
proof -
  note [simp] = powr_half_sqrt sqrt_def (* TODO: Better simproc for sqrt/root? *)
  have "sqrt (12 :: real) = sqrt (4 * 3)"
    by simp
  also have "\<dots> = 2 * sqrt 3" by (subst real_sqrt_mult) simp
  finally show ?thesis by real_asymp
qed

text \<open>\<^url>\<open>http://math.stackexchange.com/questions/625574\<close>\<close>
lemma "(\<lambda>x::real. (1 - 1/2 * x^2 - cos (x / (1 - x^2))) / x^4) \<midarrow>0\<rightarrow> 23/24"
  by real_asymp

text \<open>\<^url>\<open>http://math.stackexchange.com/questions/122967\<close>\<close>

real_limit "\<lambda>x. (x + 1) powr (1 + 1 / x) - x powr (1 + 1 / (x + a))"

lemma "((\<lambda>x::real. ((x + 1) powr (1 + 1/x) - x powr (1 + 1 / (x + a)))) \<longlongrightarrow> 1) at_top"
  by real_asymp

real_limit "\<lambda>x. x ^ 2 * (arctan x - pi / 2) + x"

lemma "filterlim (\<lambda>x::real. x^2 * (arctan x - pi/2) + x) (at_right 0) at_top"
  by real_asymp

real_limit "\<lambda>x. (root 3 (x ^ 3 + x ^ 2 + x + 1) - sqrt (x ^ 2 + x + 1) * ln (exp x + x) / x)"

lemma "((\<lambda>x::real. root 3 (x^3 + x^2 + x + 1) - sqrt (x^2 + x + 1) * ln (exp x + x) / x)
           \<longlongrightarrow> -1/6) at_top"
  by real_asymp

context
  fixes a b :: real
  assumes ab: "a > 0" "b > 0"
begin
real_limit "\<lambda>x. ((a powr x - x * ln a) / (b powr x - x * ln b)) powr (1 / x ^ 2)"
  limit: "at_right 0" facts: ab
real_limit "\<lambda>x. ((a powr x - x * ln a) / (b powr x - x * ln b)) powr (1 / x ^ 2)"
  limit: "at_left 0" facts: ab
lemma "(\<lambda>x. ((a powr x - x * ln a) / (b powr x - x * ln b)) powr (1 / x ^ 2))
         \<midarrow>0\<rightarrow> exp (ln a * ln a / 2 - ln b * ln b / 2)" using ab by real_asymp
end

text \<open>\<^url>\<open>http://math.stackexchange.com/questions/547538\<close>\<close>
lemma "(\<lambda>x::real. ((x+4) powr (3/2) + exp x - 9) / x) \<midarrow>0\<rightarrow> 4"
  by real_asymp

text \<open>\<^url>\<open>https://www.freemathhelp.com/forum/threads/93513\<close>\<close>
lemma "((\<lambda>x::real. ((3 powr x + 4 powr x) / 4) powr (1/x)) \<longlongrightarrow> 4) at_top"
  by real_asymp

lemma "((\<lambda>x::real. x powr (3/2) * (sqrt (x + 1) + sqrt (x - 1) - 2 * sqrt x)) \<longlongrightarrow> -1/4) at_top"
  by real_asymp

text \<open>\<^url>\<open>https://www.math.ucdavis.edu/~kouba/CalcOneDIRECTORY/limcondirectory/LimitConstant.html\<close>\<close>
lemma  "(\<lambda>x::real. (cos (2*x) - 1) / (cos x - 1)) \<midarrow>0\<rightarrow> 4"
  by real_asymp

lemma "(\<lambda>x::real. tan (2*x) / (x - pi/2)) \<midarrow>pi/2\<rightarrow> 2"
  by real_asymp

text \<open>@url{"https://www.math.ucdavis.edu/~kouba/CalcOneDIRECTORY/liminfdirectory/LimitInfinity.html"}\<close>
lemma "filterlim (\<lambda>x::real. (3 powr x + 3 powr (2*x)) powr (1/x)) (nhds 9) at_top"
  using powr_def[of 3 "2::real"] by real_asymp

text \<open>\<^url>\<open>https://www.math.ucdavis.edu/~kouba/CalcOneDIRECTORY/lhopitaldirectory/LHopital.html\<close>\<close>
lemma "filterlim (\<lambda>x::real. (x^2 - 1) / (x^2 + 3*x - 4)) (nhds (2/5)) (at 1)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (x - 4) / (sqrt x - 2)) (nhds 4) (at 4)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. sin x / x) (at_left 1) (at 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (3 powr x - 2 powr x) / (x^2 - x)) (nhds (ln (2/3))) (at 0)"
  by (real_asymp simp: ln_div)

lemma "filterlim (\<lambda>x::real. (1/x - 1/3) / (x^2 - 9)) (nhds (-1/54)) (at 3)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (x * tan x) / sin (3*x)) (nhds 0) (at 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. sin (x^2) / (x * tan x)) (at 1) (at 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (x^2 * exp x) / tan x ^ 2) (at 1) (at 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. exp (-1/x^2) / x^2) (at 0) (at 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. exp x / (5 * x + 200)) at_top at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (3 + ln x) / (x^2 + 7)) (at 0) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (x^2 + 3*x - 10) / (7*x^2 - 5*x + 4)) (at_right (1/7)) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (ln x ^ 2) / exp (2*x)) (at_right 0) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (3 * x + 2 powr x) / (2 * x + 3 powr x)) (at 0) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (exp x + 2 / x) / (exp x + 5 / x)) (at_left 1) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. sqrt (x^2 + 1) - sqrt (x + 1)) at_top at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. x * ln x) (at_left 0) (at_right 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. x * ln x ^ 2) (at_right 0) (at_right 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. ln x * tan x) (at_left 0) (at_right 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. x powr sin x) (at_left 1) (at_right 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (1 + 3 / x) powr x) (at_left (exp 3)) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (1 - x) powr (1 / x)) (at_left (exp (-1))) (at_right 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. (tan x) powr x^2) (at_left 1) (at_right 0)"
  by real_asymp

lemma "filterlim (\<lambda>x::real. x powr (1 / sqrt x)) (at_right 1) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. ln x powr (1/x)) (at_right 1) at_top"
  by (real_asymp (verbose))

lemma "filterlim (\<lambda>x::real. x powr (x powr x)) (at_right 0) (at_right 0)"
  by (real_asymp (verbose))

text \<open>\<^url>\<open>http://calculus.nipissingu.ca/problems/limit_problems.html\<close>\<close>
lemma "((\<lambda>x::real. (x^2 - 1) / \<bar>x - 1\<bar>) \<longlongrightarrow> -2) (at_left 1)"
      "((\<lambda>x::real. (x^2 - 1) / \<bar>x - 1\<bar>) \<longlongrightarrow> 2) (at_right 1)"
  by real_asymp+

lemma "((\<lambda>x::real. (root 3 x - 1) / \<bar>sqrt x - 1\<bar>) \<longlongrightarrow> -2 / 3) (at_left 1)"
      "((\<lambda>x::real. (root 3 x - 1) / \<bar>sqrt x - 1\<bar>) \<longlongrightarrow> 2 / 3) (at_right 1)"
  by real_asymp+

text \<open>\<^url>\<open>https://math.stackexchange.com/questions/547538\<close>\<close>

lemma "(\<lambda>x::real. ((x + 4) powr (3/2) + exp x - 9) / x) \<midarrow>0\<rightarrow> 4"
  by real_asymp

text \<open>\<^url>\<open>https://math.stackexchange.com/questions/625574\<close>\<close>
lemma "(\<lambda>x::real. (1 - x^2 / 2 - cos (x / (1 - x^2))) / x^4) \<midarrow>0\<rightarrow> 23/24"
  by real_asymp

text \<open>\<^url>\<open>https://www.mapleprimes.com/questions/151308-A-Hard-Limit-Question\<close>\<close>
lemma "(\<lambda>x::real. x / (x - 1) - 1 / ln x) \<midarrow>1\<rightarrow> 1 / 2"
  by real_asymp

text \<open>\<^url>\<open>https://www.freemathhelp.com/forum/threads/93513-two-extremely-difficult-limit-problems\<close>\<close>
lemma "((\<lambda>x::real. ((3 powr x + 4 powr x) / 4) powr (1/x)) \<longlongrightarrow> 4) at_top"
  by real_asymp

lemma "((\<lambda>x::real. x powr 1.5 * (sqrt (x + 1) + sqrt (x - 1) - 2 * sqrt x)) \<longlongrightarrow> -1/4) at_top"
  by real_asymp

text \<open>\<^url>\<open>https://math.stackexchange.com/questions/1390833\<close>\<close>
context
  fixes a b :: real
  assumes ab: "a + b > 0" "a + b = 1"
begin
real_limit "\<lambda>x. (a * x powr (1 / x) + b) powr (x / ln x)"
  facts: ab
end

subsection \<open>Unsorted examples\<close>

context
  fixes a :: real
  assumes a: "a > 1"
begin

text \<open>
  It seems that Mathematica fails to expand the following example when \<open>a\<close> is a variable.
\<close>
lemma "(\<lambda>x. 1 - (1 - 1 / x powr a) powr x) \<sim> (\<lambda>x. x powr (1 - a))"
  using a by real_asymp

real_limit "\<lambda>x. (1 - (1 - 1 / x powr a) powr x) * x powr (a - 1)"
  facts: a

lemma "(\<lambda>n. log 2 (real ((n + 3) choose 3) / 4) + 1) \<sim> (\<lambda>n. 3 / ln 2 * ln n)"
proof -
  have "(\<lambda>n. log 2 (real ((n + 3) choose 3) / 4) + 1) =
          (\<lambda>n. log 2 ((real n + 1) * (real n + 2) * (real n + 3) / 24) + 1)"
    by (subst binomial_gbinomial)
       (simp add: gbinomial_pochhammer' numeral_3_eq_3 pochhammer_Suc add_ac)
  moreover have "\<dots> \<sim> (\<lambda>n. 3 / ln 2 * ln n)"
    by (real_asymp simp: field_split_simps)
  ultimately show ?thesis by simp
qed

end

lemma "(\<lambda>x::real. exp (sin x) / ln (cos x)) \<sim>[at 0] (\<lambda>x. -2 / x ^ 2)"
  by real_asymp

real_limit "\<lambda>x. ln (1 + 1 / x) * x"
real_limit "\<lambda>x. ln x powr ln x / x"
real_limit "\<lambda>x. (arctan x - pi/2) * x"
real_limit "\<lambda>x. arctan (1/x) * x"

context
  fixes c :: real assumes c: "c \<ge> 2"
begin
lemma c': "c^2 - 3 > 0"
proof -
  from c have "c^2 \<ge> 2^2" by (rule power_mono) auto
  thus ?thesis by simp
qed

real_limit "\<lambda>x. (c^2 - 3) * exp (-x)"
real_limit "\<lambda>x. (c^2 - 3) * exp (-x)" facts: c'
end

lemma "c < 0 \<Longrightarrow> ((\<lambda>x::real. exp (c*x)) \<longlongrightarrow> 0) at_top"
  by real_asymp

lemma "filterlim (\<lambda>x::real. -exp (1/x)) (at_left 0) (at_left 0)"
  by real_asymp

lemma "((\<lambda>t::real. t^2 / (exp t - 1)) \<longlongrightarrow> 0) at_top"
  by real_asymp

lemma "(\<lambda>n. (1 + 1 / real n) ^ n) \<longlonglongrightarrow> exp 1"
  by real_asymp

lemma "((\<lambda>x::real. (1 + y / x) powr x) \<longlongrightarrow> exp y) at_top"
  by real_asymp

lemma "eventually (\<lambda>x::real. x < x^2) at_top"
  by real_asymp

lemma "eventually (\<lambda>x::real. 1 / x^2 \<ge> 1 / x) (at_left 0)"
  by real_asymp

lemma "A > 1 \<Longrightarrow> (\<lambda>n. ((1 + 1 / sqrt A) / 2) powr real_of_int (2 ^ Suc n)) \<longlonglongrightarrow> 0"
  by (real_asymp simp: field_split_simps add_pos_pos)

lemma
  assumes "c > (1 :: real)" "k \<noteq> 0"
  shows   "(\<lambda>n. real n ^ k) \<in> o(\<lambda>n. c ^ n)"
  using assms by (real_asymp (verbose))

lemma "(\<lambda>x::real. exp (-(x^4))) \<in> o(\<lambda>x. exp (-(x^4)) + 1 / x ^ n)"
  by real_asymp

lemma "(\<lambda>x::real. x^2) \<in> o[at_right 0](\<lambda>x. x)"
  by real_asymp

lemma "(\<lambda>x::real. x^2) \<in> o[at_left 0](\<lambda>x. x)"
  by real_asymp

lemma "(\<lambda>x::real. 2 * x + x ^ 2) \<in> \<Theta>[at_left 0](\<lambda>x. x)"
  by real_asymp

lemma "(\<lambda>x::real. inverse (x - 1)^2) \<in> \<omega>[at 1](\<lambda>x. x)"
  by real_asymp

lemma "(\<lambda>x::real. sin (1 / x)) \<sim> (\<lambda>x::real. 1 / x)"
  by real_asymp

lemma
  assumes "q \<in> {0<..<1}"
  shows   "LIM x at_left 1. log q (1 - x) :> at_top"
  using assms by real_asymp

context
  fixes x k :: real
  assumes xk: "x > 1" "k > 0"
begin

lemmas [simp] = add_pos_pos

real_expansion "\<lambda>l. sqrt (1 + l * (l + 1) * 4 * pi^2 * k^2 * (log x (l + 1) - log x l)^2)"
  terms: 2 facts: xk

lemma
  "(\<lambda>l. sqrt (1 + l * (l + 1) * 4 * pi^2 * k^2 * (log x (l + 1) - log x l)^2) -
          sqrt (1 + 4 * pi\<^sup>2 * k\<^sup>2 / (ln x ^ 2))) \<in> O(\<lambda>l. 1 / l ^ 2)"
  using xk by (real_asymp simp: inverse_eq_divide power_divide root_powr_inverse)

end

lemma "(\<lambda>x. (2 * x^3 - 128) / (sqrt x - 2)) \<midarrow>4\<rightarrow> 384"
  by real_asymp

lemma
  "((\<lambda>x::real. (x^2 - 1) / abs (x - 1)) \<longlongrightarrow> 2) (at_right 1)"
  "((\<lambda>x::real. (x^2 - 1) / abs (x - 1)) \<longlongrightarrow> -2) (at_left 1)"
  by real_asymp+

lemma "(\<lambda>x::real. (root 3 x - 1) / (sqrt x - 1)) \<midarrow>1\<rightarrow> 2/3"
  by real_asymp

lemma
  fixes a b :: real
  assumes "a > 1" "b > 1" "a \<noteq> b"
  shows   "((\<lambda>x. ((a powr x - x * ln a) / (b powr x - x * ln b)) powr (1/x^3)) \<longlongrightarrow> 1) at_top"
  using assms by real_asymp

context
  fixes a b :: real
  assumes ab: "a > 0" "b > 0"
begin

lemma
  "((\<lambda>x. ((a powr x - x * ln a) / (b powr x - x * ln b)) powr (1 / x ^ 2)) \<longlongrightarrow>
     exp ((ln a ^ 2 - ln b ^ 2) / 2)) (at 0)"
  using ab by (real_asymp simp: power2_eq_square)

end

real_limit "\<lambda>x. 1 / sin (1/x) ^ 2 + 1 / tan (1/x) ^ 2 - 2 * x ^ 2"

real_limit "\<lambda>x. ((1 / x + 4) powr 1.5 + exp (1 / x) - 9) * x"

lemma "x > (1 :: real) \<Longrightarrow>
         ((\<lambda>n. abs (x powr n / (n * (1 + x powr (2 * n)))) powr (1 / n)) \<longlongrightarrow> 1 / x) at_top"
  by (real_asymp simp add: exp_minus field_simps)

lemma "x = (1 :: real) \<Longrightarrow>
         ((\<lambda>n. abs (x powr n / (n * (1 + x powr (2 * n)))) powr (1 / n)) \<longlongrightarrow> 1 / x) at_top"
  by (real_asymp simp add: exp_minus field_simps)

lemma "x > (0 :: real) \<Longrightarrow> x < 1 \<Longrightarrow>
         ((\<lambda>n. abs (x powr n / (n * (1 + x powr (2 * n)))) powr (1 / n)) \<longlongrightarrow> x) at_top"
  by real_asymp

lemma "(\<lambda>x. (exp (sin b) - exp (sin (b * x))) * tan (pi * x / 2)) \<midarrow>1\<rightarrow>
         (2*b/pi * exp (sin b) * cos b)"
  by real_asymp

(* SLOW *)
lemma "filterlim (\<lambda>x::real. (sin (tan x) - tan (sin x))) (at 0) (at 0)"
  by real_asymp

(* SLOW *)
lemma "(\<lambda>x::real. 1 / sin x powr (tan x ^ 2)) \<midarrow>pi/2\<rightarrow> exp (1 / 2)"
  by (real_asymp simp: exp_minus)

lemma "a > 0 \<Longrightarrow> b > 0 \<Longrightarrow> c > 0 \<Longrightarrow>
  filterlim (\<lambda>x::real. ((a powr x + b powr x + c powr x) / 3) powr (3 / x))
    (nhds (a * b * c)) (at 0)"
  by (real_asymp simp: exp_add add_divide_distrib exp_minus algebra_simps)

real_expansion "\<lambda>x. arctan (sin (1 / x))"

real_expansion "\<lambda>x. ln (1 + 1 / x)"
  terms: 5 (strict)

real_expansion "\<lambda>x. sqrt (x + 1) - sqrt (x - 1)"
  terms: 3 (strict)

text \<open>
  In this example, the first 7 terms of \<open>tan (sin x)\<close> and \<open>sin (tan x)\<close> coincide, which makes
  the calculation a bit slow.
\<close>
real_limit "\<lambda>x. (tan (sin x) - sin (tan x)) / x ^ 7" limit: "at_right 0"

(* SLOW *)
real_expansion "\<lambda>x. sin (tan (1/x)) - tan (sin (1/x))"
  terms: 1 (strict)

(* SLOW *)
real_expansion "\<lambda>x. tan (1 / x)"
  terms: 6

real_expansion "\<lambda>x::real. arctan x"

real_expansion "\<lambda>x. sin (tan (1/x))"

real_expansion "\<lambda>x. (sin (-1 / x) ^ 2) powr sin (-1/x)"

real_limit "\<lambda>x. exp (max (sin x) 1)"

lemma "filterlim (\<lambda>x::real. 1 - 1 / x + ln x) at_top at_top"
  by (force intro: tendsto_diff filterlim_tendsto_add_at_top
        real_tendsto_divide_at_top filterlim_ident ln_at_top)

lemma "filterlim (\<lambda>i::real. i powr (-i/(i-1)) - i powr (-1/(i-1))) (at_left 1) (at_right 0)"
  by real_asymp

lemma "filterlim (\<lambda>i::real. i powr (-i/(i-1)) - i powr (-1/(i-1))) (at_right (-1)) at_top"
  by real_asymp

lemma "eventually (\<lambda>i::real. i powr (-i/(i-1)) - i powr (-1/(i-1)) < 1) (at_right 0)"
  and "eventually (\<lambda>i::real. i powr (-i/(i-1)) - i powr (-1/(i-1)) > -1) at_top"
  by real_asymp+

end

subsection \<open>Interval arithmetic tests\<close>

lemma "filterlim (\<lambda>x::real. x + sin x) at_top at_top"
      "filterlim (\<lambda>x::real. sin x + x) at_top at_top"
      "filterlim (\<lambda>x::real. x + (sin x + sin x)) at_top at_top"
  by real_asymp+

lemma "filterlim (\<lambda>x::real. 2 * x + sin x * x) at_infinity at_top"
      "filterlim (\<lambda>x::real. 2 * x + (sin x + 1) * x) at_infinity at_top"
      "filterlim (\<lambda>x::real. 3 * x + (sin x - 1) * x) at_infinity at_top"
      "filterlim (\<lambda>x::real. 2 * x + x * sin x) at_infinity at_top"
      "filterlim (\<lambda>x::real. 2 * x + x * (sin x + 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. 3 * x + x * (sin x - 1)) at_infinity at_top"

      "filterlim (\<lambda>x::real. x + sin x * sin x) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + sin x * (sin x + 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + sin x * (sin x - 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + sin x * (sin x + 2)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + sin x * (sin x - 2)) at_infinity at_top"

      "filterlim (\<lambda>x::real. x + (sin x - 1) * sin x) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x - 1) * (sin x + 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x - 1) * (sin x - 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x - 1) * (sin x + 2)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x - 1) * (sin x - 2)) at_infinity at_top"

      "filterlim (\<lambda>x::real. x + (sin x - 2) * sin x) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x - 2) * (sin x + 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x - 2) * (sin x - 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x - 2) * (sin x + 2)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x - 2) * (sin x - 2)) at_infinity at_top"

      "filterlim (\<lambda>x::real. x + (sin x + 1) * sin x) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x + 1) * (sin x + 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x + 1) * (sin x - 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x + 1) * (sin x + 2)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x + 1) * (sin x - 2)) at_infinity at_top"

      "filterlim (\<lambda>x::real. x + (sin x + 2) * sin x) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x + 2) * (sin x + 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x + 2) * (sin x - 1)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x + 2) * (sin x + 2)) at_infinity at_top"
      "filterlim (\<lambda>x::real. x + (sin x + 2) * (sin x - 2)) at_infinity at_top"
  by real_asymp+

lemma "filterlim (\<lambda>x::real. x * inverse (sin x + 2)) at_top at_top"
      "filterlim (\<lambda>x::real. x * inverse (sin x - 2)) at_bot at_top"
      "filterlim (\<lambda>x::real. x / inverse (sin x + 2)) at_top at_top"
      "filterlim (\<lambda>x::real. x / inverse (sin x - 2)) at_bot at_top"
  by real_asymp+

lemma "filterlim (\<lambda>x::real. \<lfloor>x\<rfloor>) at_top at_top"
      "filterlim (\<lambda>x::real. \<lceil>x\<rceil>) at_top at_top"
      "filterlim (\<lambda>x::real. nat \<lfloor>x\<rfloor>) at_top at_top"
      "filterlim (\<lambda>x::real. nat \<lceil>x\<rceil>) at_top at_top"
      "filterlim (\<lambda>x::int. nat x) at_top at_top"
      "filterlim (\<lambda>x::int. nat x) at_top at_top"
      "filterlim (\<lambda>n::nat. real (n mod 42) + real n) at_top at_top"
  by real_asymp+

lemma "(\<lambda>n. real_of_int \<lfloor>n\<rfloor>) \<sim>[at_top] (\<lambda>n. real_of_int n)"
      "(\<lambda>n. sqrt \<lfloor>n\<rfloor>) \<sim>[at_top] (\<lambda>n. sqrt n)"
  by real_asymp+

lemma
  "c > 1 \<Longrightarrow> (\<lambda>n::nat. 2 ^ (n div c) :: int) \<in> o(\<lambda>n. 2 ^ n)"
  by (real_asymp simp: field_simps)

lemma
  "c > 1 \<Longrightarrow> (\<lambda>n::nat. 2 ^ (n div c) :: nat) \<in> o(\<lambda>n. 2 ^ n)"
  by (real_asymp simp: field_simps)

end