(*  Title:      HOL/Library/Finite_Lattice.thy
    Author:     Alessandro Coglio
*)

theory Finite_Lattice
imports Product_Order
begin

text \<open>A non-empty finite lattice is a complete lattice.
Since types are never empty in Isabelle/HOL,
a type of classes \<^class>\<open>finite\<close> and \<^class>\<open>lattice\<close>
should also have class \<^class>\<open>complete_lattice\<close>.
A type class is defined
that extends classes \<^class>\<open>finite\<close> and \<^class>\<open>lattice\<close>
with the operators \<^const>\<open>bot\<close>, \<^const>\<open>top\<close>, \<^const>\<open>Inf\<close>, and \<^const>\<open>Sup\<close>,
along with assumptions that define these operators
in terms of the ones of classes \<^class>\<open>finite\<close> and \<^class>\<open>lattice\<close>.
The resulting class is a subclass of \<^class>\<open>complete_lattice\<close>.\<close>

class finite_lattice_complete = finite + lattice + bot + top + Inf + Sup +
  assumes bot_def: "bot = Inf_fin UNIV"
  assumes top_def: "top = Sup_fin UNIV"
  assumes Inf_def: "Inf A = Finite_Set.fold inf top A"
  assumes Sup_def: "Sup A = Finite_Set.fold sup bot A"

text \<open>The definitional assumptions
on the operators \<^const>\<open>bot\<close> and \<^const>\<open>top\<close>
of class \<^class>\<open>finite_lattice_complete\<close>
ensure that they yield bottom and top.\<close>

lemma finite_lattice_complete_bot_least: "(bot::'a::finite_lattice_complete) \<le> x"
  by (auto simp: bot_def intro: Inf_fin.coboundedI)

instance finite_lattice_complete \<subseteq> order_bot
  by standard (auto simp: finite_lattice_complete_bot_least)

lemma finite_lattice_complete_top_greatest: "(top::'a::finite_lattice_complete) \<ge> x"
  by (auto simp: top_def Sup_fin.coboundedI)

instance finite_lattice_complete \<subseteq> order_top
  by standard (auto simp: finite_lattice_complete_top_greatest)

instance finite_lattice_complete \<subseteq> bounded_lattice ..

text \<open>The definitional assumptions
on the operators \<^const>\<open>Inf\<close> and \<^const>\<open>Sup\<close>
of class \<^class>\<open>finite_lattice_complete\<close>
ensure that they yield infimum and supremum.\<close>

lemma finite_lattice_complete_Inf_empty: "Inf {} = (top :: 'a::finite_lattice_complete)"
  by (simp add: Inf_def)

lemma finite_lattice_complete_Sup_empty: "Sup {} = (bot :: 'a::finite_lattice_complete)"
  by (simp add: Sup_def)

lemma finite_lattice_complete_Inf_insert:
  fixes A :: "'a::finite_lattice_complete set"
  shows "Inf (insert x A) = inf x (Inf A)"
proof -
  interpret comp_fun_idem "inf :: 'a \<Rightarrow> _"
    by (fact comp_fun_idem_inf)
  show ?thesis by (simp add: Inf_def)
qed

lemma finite_lattice_complete_Sup_insert:
  fixes A :: "'a::finite_lattice_complete set"
  shows "Sup (insert x A) = sup x (Sup A)"
proof -
  interpret comp_fun_idem "sup :: 'a \<Rightarrow> _"
    by (fact comp_fun_idem_sup)
  show ?thesis by (simp add: Sup_def)
qed

lemma finite_lattice_complete_Inf_lower:
  "(x::'a::finite_lattice_complete) \<in> A \<Longrightarrow> Inf A \<le> x"
  using finite [of A]
  by (induct A) (auto simp add: finite_lattice_complete_Inf_insert intro: le_infI2)

lemma finite_lattice_complete_Inf_greatest:
  "\<forall>x::'a::finite_lattice_complete \<in> A. z \<le> x \<Longrightarrow> z \<le> Inf A"
  using finite [of A]
  by (induct A) (auto simp add: finite_lattice_complete_Inf_empty finite_lattice_complete_Inf_insert)

lemma finite_lattice_complete_Sup_upper:
  "(x::'a::finite_lattice_complete) \<in> A \<Longrightarrow> Sup A \<ge> x"
  using finite [of A]
  by (induct A) (auto simp add: finite_lattice_complete_Sup_insert intro: le_supI2)

lemma finite_lattice_complete_Sup_least:
  "\<forall>x::'a::finite_lattice_complete \<in> A. z \<ge> x \<Longrightarrow> z \<ge> Sup A"
  using finite [of A]
  by (induct A) (auto simp add: finite_lattice_complete_Sup_empty finite_lattice_complete_Sup_insert)

instance finite_lattice_complete \<subseteq> complete_lattice
proof
qed (auto simp:
  finite_lattice_complete_Inf_lower
  finite_lattice_complete_Inf_greatest
  finite_lattice_complete_Sup_upper
  finite_lattice_complete_Sup_least
  finite_lattice_complete_Inf_empty
  finite_lattice_complete_Sup_empty)

text \<open>The product of two finite lattices is already a finite lattice.\<close>

lemma finite_bot_prod:
  "(bot :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete)) =
    Inf_fin UNIV"
  by (metis Inf_fin.coboundedI UNIV_I bot.extremum_uniqueI finite_UNIV)

lemma finite_top_prod:
  "(top :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete)) =
    Sup_fin UNIV"
  by (metis Sup_fin.coboundedI UNIV_I top.extremum_uniqueI finite_UNIV)

lemma finite_Inf_prod:
  "Inf(A :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete) set) =
    Finite_Set.fold inf top A"
  by (metis Inf_fold_inf finite)

lemma finite_Sup_prod:
  "Sup (A :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete) set) =
    Finite_Set.fold sup bot A"
  by (metis Sup_fold_sup finite)

instance prod :: (finite_lattice_complete, finite_lattice_complete) finite_lattice_complete
  by standard (auto simp: finite_bot_prod finite_top_prod finite_Inf_prod finite_Sup_prod)

text \<open>Functions with a finite domain and with a finite lattice as codomain
already form a finite lattice.\<close>

lemma finite_bot_fun: "(bot :: ('a::finite \<Rightarrow> 'b::finite_lattice_complete)) = Inf_fin UNIV"
  by (metis Inf_UNIV Inf_fin_Inf empty_not_UNIV finite)

lemma finite_top_fun: "(top :: ('a::finite \<Rightarrow> 'b::finite_lattice_complete)) = Sup_fin UNIV"
  by (metis Sup_UNIV Sup_fin_Sup empty_not_UNIV finite)

lemma finite_Inf_fun:
  "Inf (A::('a::finite \<Rightarrow> 'b::finite_lattice_complete) set) =
    Finite_Set.fold inf top A"
  by (metis Inf_fold_inf finite)

lemma finite_Sup_fun:
  "Sup (A::('a::finite \<Rightarrow> 'b::finite_lattice_complete) set) =
    Finite_Set.fold sup bot A"
  by (metis Sup_fold_sup finite)

instance "fun" :: (finite, finite_lattice_complete) finite_lattice_complete
  by standard (auto simp: finite_bot_fun finite_top_fun finite_Inf_fun finite_Sup_fun)

subsection \<open>Finite Distributive Lattices\<close>

text \<open>A finite distributive lattice is a complete lattice
whose \<^const>\<open>inf\<close> and \<^const>\<open>sup\<close> operators
distribute over \<^const>\<open>Sup\<close> and \<^const>\<open>Inf\<close>.\<close>

class finite_distrib_lattice_complete =
  distrib_lattice + finite_lattice_complete

lemma finite_distrib_lattice_complete_sup_Inf:
  "sup (x::'a::finite_distrib_lattice_complete) (Inf A) = (INF y\<in>A. sup x y)"
  using finite
  by (induct A rule: finite_induct) (simp_all add: sup_inf_distrib1)

lemma finite_distrib_lattice_complete_inf_Sup:
  "inf (x::'a::finite_distrib_lattice_complete) (Sup A) = (SUP y\<in>A. inf x y)"
  using finite [of A] by induct (simp_all add: inf_sup_distrib1)

context finite_distrib_lattice_complete
begin
subclass finite_distrib_lattice
proof -
  show "class.finite_distrib_lattice Inf Sup inf (\<le>) (<) sup bot top"
  proof
    show "bot = Inf UNIV"
      unfolding bot_def top_def Inf_def
      using Inf_fin.eq_fold Inf_fin.insert inf.absorb2 by force
  next
    show "top = Sup UNIV"
      unfolding bot_def top_def Sup_def
      using Sup_fin.eq_fold Sup_fin.insert by force
  next
    show "Inf {} = Sup UNIV"
      unfolding Inf_def Sup_def bot_def top_def
      using Sup_fin.eq_fold Sup_fin.insert by force
  next
    show "Sup {} = Inf UNIV"
      unfolding Inf_def Sup_def bot_def top_def
      using Inf_fin.eq_fold Inf_fin.insert inf.absorb2 by force
  next
    interpret comp_fun_idem_inf: comp_fun_idem inf
      by (fact comp_fun_idem_inf)
    show "Inf (insert a A) = inf a (Inf A)" for a A
      using comp_fun_idem_inf.fold_insert_idem Inf_def finite by simp
  next
    interpret comp_fun_idem_sup: comp_fun_idem sup
      by (fact comp_fun_idem_sup)
    show "Sup (insert a A) = sup a (Sup A)" for a A
      using comp_fun_idem_sup.fold_insert_idem Sup_def finite by simp
  qed
qed
end

instance finite_distrib_lattice_complete \<subseteq> complete_distrib_lattice ..

text \<open>The product of two finite distributive lattices
is already a finite distributive lattice.\<close>

instance prod ::
  (finite_distrib_lattice_complete, finite_distrib_lattice_complete)
  finite_distrib_lattice_complete
  ..

text \<open>Functions with a finite domain
and with a finite distributive lattice as codomain
already form a finite distributive lattice.\<close>

instance "fun" ::
  (finite, finite_distrib_lattice_complete) finite_distrib_lattice_complete
  ..

subsection \<open>Linear Orders\<close>

text \<open>A linear order is a distributive lattice.
A type class is defined
that extends class \<^class>\<open>linorder\<close>
with the operators \<^const>\<open>inf\<close> and \<^const>\<open>sup\<close>,
along with assumptions that define these operators
in terms of the ones of class \<^class>\<open>linorder\<close>.
The resulting class is a subclass of \<^class>\<open>distrib_lattice\<close>.\<close>

class linorder_lattice = linorder + inf + sup +
  assumes inf_def: "inf x y = (if x \<le> y then x else y)"
  assumes sup_def: "sup x y = (if x \<ge> y then x else y)"

text \<open>The definitional assumptions
on the operators \<^const>\<open>inf\<close> and \<^const>\<open>sup\<close>
of class \<^class>\<open>linorder_lattice\<close>
ensure that they yield infimum and supremum
and that they distribute over each other.\<close>

lemma linorder_lattice_inf_le1: "inf (x::'a::linorder_lattice) y \<le> x"
  unfolding inf_def by (metis (full_types) linorder_linear)

lemma linorder_lattice_inf_le2: "inf (x::'a::linorder_lattice) y \<le> y"
  unfolding inf_def by (metis (full_types) linorder_linear)

lemma linorder_lattice_inf_greatest:
  "(x::'a::linorder_lattice) \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> inf y z"
  unfolding inf_def by (metis (full_types))

lemma linorder_lattice_sup_ge1: "sup (x::'a::linorder_lattice) y \<ge> x"
  unfolding sup_def by (metis (full_types) linorder_linear)

lemma linorder_lattice_sup_ge2: "sup (x::'a::linorder_lattice) y \<ge> y"
  unfolding sup_def by (metis (full_types) linorder_linear)

lemma linorder_lattice_sup_least:
  "(x::'a::linorder_lattice) \<ge> y \<Longrightarrow> x \<ge> z \<Longrightarrow> x \<ge> sup y z"
  by (auto simp: sup_def)

lemma linorder_lattice_sup_inf_distrib1:
  "sup (x::'a::linorder_lattice) (inf y z) = inf (sup x y) (sup x z)"
  by (auto simp: inf_def sup_def)

instance linorder_lattice \<subseteq> distrib_lattice
proof
qed (auto simp:
  linorder_lattice_inf_le1
  linorder_lattice_inf_le2
  linorder_lattice_inf_greatest
  linorder_lattice_sup_ge1
  linorder_lattice_sup_ge2
  linorder_lattice_sup_least
  linorder_lattice_sup_inf_distrib1)

subsection \<open>Finite Linear Orders\<close>

text \<open>A (non-empty) finite linear order is a complete linear order.\<close>

class finite_linorder_complete = linorder_lattice + finite_lattice_complete

instance finite_linorder_complete \<subseteq> complete_linorder ..

text \<open>A (non-empty) finite linear order is a complete lattice
whose \<^const>\<open>inf\<close> and \<^const>\<open>sup\<close> operators
distribute over \<^const>\<open>Sup\<close> and \<^const>\<open>Inf\<close>.\<close>

instance finite_linorder_complete \<subseteq> finite_distrib_lattice_complete ..

end


section "The definition of the While language"

theory WhileLang imports MiscLemmas Coinductive.Coinductive_List begin

(* -- AST and other types -- *)

type_synonym name = "char list"
type_synonym val = nat
type_synonym store = "name \<Rightarrow> val"
type_synonym exp = "store \<Rightarrow> val"

datatype prog =
  Skip
  | Assign name exp
  | Print exp
  | Seq prog prog
  | If exp prog prog
  | While exp prog

(* -- small-step semantics -- *)

type_synonym out = "val list"
type_synonym state = "store \<times> out"

definition output_of :: "state \<Rightarrow> out" where
  "output_of \<equiv> \<lambda>(_, out). out"

definition subst :: "name \<Rightarrow> exp \<Rightarrow> state \<Rightarrow> state" where
  "subst n e \<equiv> \<lambda>(s, out). (s(n:= e s), out)"

definition print :: "exp \<Rightarrow> state \<Rightarrow> state" where
  "print e \<equiv> \<lambda>(s, out). (s,  out @ [e s])"

definition guard :: "exp \<Rightarrow> state \<Rightarrow> bool" where
  "guard x \<equiv> \<lambda>(s, _). x s \<noteq> 0"

inductive step :: "prog \<times> state \<Rightarrow> prog \<times> state \<Rightarrow> bool" where
  step_skip: "step (Skip,s) (Skip,s)"
| step_assign: "step (Assign n x,s) (Skip, subst n x s)"
| step_print: "step (Print x,s) (Skip, print x s)"
| step_seq1: "step (Seq Skip q,s) (q,s)"
| step_seq2: "step (p0,s0) (p1,s1) \<Longrightarrow> p0 \<noteq> Skip \<Longrightarrow> step (Seq p0 q,s0) (Seq p1 q,s1)"
| step_if: "step (If x p q, s) ((if guard x s then p else q), s)"
| step_while: "step (While x p, s) (If x (Seq p (While x p)) Skip, s)"

declare step.intros[simp,intro]

inductive_cases skipE[elim!]: "step (Skip, s) ct"
inductive_cases assignE[elim!]: "step (Assign n x, s) ct"
inductive_cases printE[elim!]: "step (Print x, s) ct"
inductive_cases seqE[elim]: "step (Seq c1 c2, s) ct"
inductive_cases ifE[elim!]: "step (If x c1 c2, s) ct"
inductive_cases whileE[elim]: "step (While x p, s) ct"

lemmas step_induct = step.induct[split_format(complete)]

inductive terminates where
  "star step (p, s) (Skip, t) \<Longrightarrow> terminates s p t"

inductive diverges where
  "\<forall>t. \<not> terminates s p t
       \<and> out = lSup { llist_of out | out. \<exists>q t. star step (p, s) (q, t, out) }
   \<Longrightarrow>
   diverges s p out"

(* -- sanity theorems -- *)

lemma step_exists':
  "\<exists>t. step (prog, (s, out)) t"
proof (induct prog)
  case Skip
  then show ?case by fastforce
next
  case (Assign x1 x2)
  then show ?case
    apply clarsimp
    apply (rule_tac x=Skip in exI)
    apply (rule_tac x="fst (subst x1 x2 (s, out))" in exI)
    apply (rule_tac x="snd (subst x1 x2 (s, out))" in exI)
    by fastforce
next
  case (Print x)
  then show ?case
    apply clarsimp
    apply (rule_tac x=Skip in exI)
    apply (rule_tac x="fst (print x (s, out))" in exI)
    apply (rule_tac x="snd (print x (s, out))" in exI)
    by fastforce
next
  case (Seq prog1 prog2)
  then show ?case
    apply (case_tac "prog1 = Skip")
    by fastforce+
next
  case (If x1 prog1 prog2)
  then show ?case by fastforce
next
  case (While x1 prog)
  then show ?case by fastforce
qed

theorem step_exists: (* one can always take a step *)
  "\<forall>s. \<exists>t. step s t"
  using step_exists' by simp

theorem terminates_or_diverges: (* every program either terminates or diverges *)
  "(\<exists>t. terminates s p t) \<or> (\<exists>output. diverges s p output)"
  by (clarsimp simp: diverges.simps)

lemma step_deterministic':
  "step (prog, st, out) t1 \<Longrightarrow> step (prog, st, out) t2 \<Longrightarrow> t1 = t2"
proof (induct prog arbitrary: t1 t2)
  case Skip
  then show ?case by clarsimp
next
  case (Assign x1 x2)
  then show ?case by clarsimp
next
  case (Print x)
  then show ?case by clarsimp
next
  case (Seq prog1 prog2)
  then show ?case by (elim seqE; clarsimp)
next
  case (If x1 prog1 prog2)
  then show ?case by clarsimp
next
  case (While x1 prog)
  then show ?case by (elim whileE; clarsimp)
qed

theorem step_deterministic:
  "step s t1 \<Longrightarrow> step s t2 \<Longrightarrow> t1 = t2"
  apply (cases s)
  using step_deterministic' by clarsimp

lemma star_step_refl:
  "star step (Skip, t1) (Skip, t2) \<Longrightarrow> t1 = t2"
  by (induct "(Skip, t1)" "(Skip, t2)" arbitrary: t1 t2 rule: star.induct; clarsimp)

theorem terminates_deterministic:
  "terminates s p t1 \<Longrightarrow> terminates s p t2 \<Longrightarrow> t1 = t2"
proof (simp add: terminates.simps, induct "(p, s)" "(Skip, t1)" arbitrary: p s t1 rule: star.induct)
  case refl
  then show ?case
    by (clarsimp intro!: star_step_refl)
next
  case (step y)
  then show ?case
    apply (rotate_tac 3)
    apply (erule star.cases)
     apply clarsimp
    apply simp
    apply (drule (1) step_deterministic)
    apply simp
    apply (drule_tac x="fst ya" and y="snd ya" in meta_spec2)
    by simp
qed

theorem diverges_deterministic:
  "diverges s p t1 \<Longrightarrow> diverges s p t2 \<Longrightarrow> t1 = t2"
  by (simp add: diverges.simps)

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Derivation Bounds\<close>

text \<open>Starting from this point onwards we apply the results on matrices to derive
  complexity bounds in \isafor. So, here begins the connection to the definitions
  and prerequisites that have originally been defined within \isafor.

This theory contains the notion of a derivation bound.\<close>

theory Derivation_Bound
imports
  "Abstract-Rewriting.Abstract_Rewriting"
begin

definition deriv_bound :: "'a rel \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> bool"
where
  "deriv_bound r a n \<longleftrightarrow> \<not> (\<exists> b. (a, b) \<in> r ^^ Suc n)"

lemma deriv_boundI [intro?]:
  "(\<And>b m. n < m \<Longrightarrow> (a, b) \<in> r ^^ m \<Longrightarrow> False) \<Longrightarrow> deriv_bound r a n"
  by (auto simp: deriv_bound_def) (metis lessI relpow_Suc_I)

lemma deriv_boundE:
  assumes "deriv_bound r a n"
    and "(\<And>b m. n < m \<Longrightarrow> (a, b) \<in> r ^^ m \<Longrightarrow> False) \<Longrightarrow> P"
  shows "P"
  using assms(1)
  by (intro assms)
     (auto simp: deriv_bound_def relpow_add relcomp.simps dest!: less_imp_Suc_add, metis relpow_E2)

lemma deriv_bound_iff:
  "deriv_bound r a n \<longleftrightarrow> (\<forall>b m. n < m \<longrightarrow> (a, b) \<notin> r ^^ m)"
  by (auto elim: deriv_boundE intro: deriv_boundI)

lemma deriv_bound_empty [simp]:
  "deriv_bound {} a n"
  by (simp add: deriv_bound_def)

lemma deriv_bound_mono:
  assumes "m \<le> n" and "deriv_bound r a m"
  shows "deriv_bound r a n"
  using assms by (auto simp: deriv_bound_iff)

lemma deriv_bound_image:
  assumes b: "deriv_bound r' (f a) n"
    and step: "\<And> a b. (a, b) \<in> r \<Longrightarrow> (f a, f b) \<in> r'\<^sup>+"
  shows "deriv_bound r a n"
proof
  fix b m
  assume "(a, b) \<in> r ^^ m"
  from relpow_image [OF step this] have "(f a, f b) \<in> r'\<^sup>+ ^^ m" .
  from trancl_steps_relpow [OF subset_refl this]
    obtain k where "k \<ge> m" and "(f a, f b) \<in> r' ^^ k" by auto
  moreover assume "n < m"
  moreover with deriv_bound_mono [OF _ b, of "m - 1"]
    have "deriv_bound r' (f a) (m - 1)" by simp
  ultimately show False using b by (simp add: deriv_bound_iff)
qed

lemma deriv_bound_subset:
  assumes "r \<subseteq> r'\<^sup>+"
    and b: "deriv_bound r' a n"
  shows "deriv_bound r a n"
  using assms by (intro deriv_bound_image [of _ "\<lambda>x. x", OF b]) auto


theory Bool_Fold imports "~~/src/HOL/IMP/Fold" begin

text {*
\exercise
Strengthen and re-prove the congruence rules for conditional semantic equivalence
to take the value of boolean expressions into account in the \texttt{IF} and
\texttt{WHILE} cases. As a reminder, the weaker rules are:

@{thm [display] equiv_up_to_if_weak}

@{thm [display] equiv_up_to_while_weak}

Find a formulation that takes @{text b} into account for equivalences about @{term c} or @{term d}.
*}

lemma equiv_up_to_if:
(* your definition/proof here *)

lemma equiv_up_to_while:
  assumes b: "P \<Turnstile> b <\<sim>> b'"
  assumes c: "(\<lambda>s. P s \<and> bval b s) \<Turnstile> c \<sim> c'"
  assumes I: "\<And>s s'. (c, s) \<Rightarrow> s' \<Longrightarrow> P s \<Longrightarrow> bval b s \<Longrightarrow> P s'"
  shows "P \<Turnstile> WHILE b DO c \<sim> WHILE b' DO c'"
(* your definition/proof here *)

text {*
\endexercise

\exercise
Extend constant folding with analysing boolean expressions
and eliminate dead \texttt{IF} branches as well as loops whose body is
never executed. Use the contents of theory @{theory Fold} as a blueprint.
*}

fun bfold :: "bexp \<Rightarrow> tab \<Rightarrow> bexp"  where
(* your definition/proof here *)

primrec bdefs :: "com \<Rightarrow> tab \<Rightarrow> tab"  where
(* your definition/proof here *)

primrec fold' :: "com \<Rightarrow> tab \<Rightarrow> com"  where
(* your definition/proof here *)

text {*
  Hint: you will need to make use of stronger congruence rules
        for conditional semantic equivalence.
*}

lemma fold'_equiv: "approx t \<Turnstile> c \<sim> fold' c t"
(* your definition/proof here *)

theorem constant_folding_equiv': "fold' c empty \<sim> c"
(* your definition/proof here *)

text {* \endexercise *}

end


(*  Title:      HOL/Analysis/Bounded_Linear_Function.thy
    Author:     Fabian Immler, TU München
*)

section \<open>Bounded Linear Function\<close>

theory Bounded_Linear_Function
imports
  Topology_Euclidean_Space
  Operator_Norm
  Uniform_Limit
  Function_Topology

begin

lemma onorm_componentwise:
  assumes "bounded_linear f"
  shows "onorm f \<le> (\<Sum>i\<in>Basis. norm (f i))"
proof -
  {
    fix i::'a
    assume "i \<in> Basis"
    hence "onorm (\<lambda>x. (x \<bullet> i) *\<^sub>R f i) \<le> onorm (\<lambda>x. (x \<bullet> i)) * norm (f i)"
      by (auto intro!: onorm_scaleR_left_lemma bounded_linear_inner_left)
    also have "\<dots> \<le>  norm i * norm (f i)"
      by (rule mult_right_mono)
        (auto simp: ac_simps Cauchy_Schwarz_ineq2 intro!: onorm_le)
    finally have "onorm (\<lambda>x. (x \<bullet> i) *\<^sub>R f i) \<le> norm (f i)" using \<open>i \<in> Basis\<close>
      by simp
  } hence "onorm (\<lambda>x. \<Sum>i\<in>Basis. (x \<bullet> i) *\<^sub>R f i) \<le> (\<Sum>i\<in>Basis. norm (f i))"
    by (auto intro!: order_trans[OF onorm_sum_le] bounded_linear_scaleR_const
      sum_mono bounded_linear_inner_left)
  also have "(\<lambda>x. \<Sum>i\<in>Basis. (x \<bullet> i) *\<^sub>R f i) = (\<lambda>x. f (\<Sum>i\<in>Basis. (x \<bullet> i) *\<^sub>R i))"
    by (simp add: linear_sum bounded_linear.linear assms linear_simps)
  also have "\<dots> = f"
    by (simp add: euclidean_representation)
  finally show ?thesis .
qed

lemmas onorm_componentwise_le = order_trans[OF onorm_componentwise]

subsection\<^marker>\<open>tag unimportant\<close> \<open>Intro rules for \<^term>\<open>bounded_linear\<close>\<close>

named_theorems bounded_linear_intros

lemma onorm_inner_left:
  assumes "bounded_linear r"
  shows "onorm (\<lambda>x. r x \<bullet> f) \<le> onorm r * norm f"
proof (rule onorm_bound)
  fix x
  have "norm (r x \<bullet> f) \<le> norm (r x) * norm f"
    by (simp add: Cauchy_Schwarz_ineq2)
  also have "\<dots> \<le> onorm r * norm x * norm f"
    by (intro mult_right_mono onorm assms norm_ge_zero)
  finally show "norm (r x \<bullet> f) \<le> onorm r * norm f * norm x"
    by (simp add: ac_simps)
qed (intro mult_nonneg_nonneg norm_ge_zero onorm_pos_le assms)

lemma onorm_inner_right:
  assumes "bounded_linear r"
  shows "onorm (\<lambda>x. f \<bullet> r x) \<le> norm f * onorm r"
  apply (subst inner_commute)
  apply (rule onorm_inner_left[OF assms, THEN order_trans])
  apply simp
  done

lemmas [bounded_linear_intros] =
  bounded_linear_zero
  bounded_linear_add
  bounded_linear_const_mult
  bounded_linear_mult_const
  bounded_linear_scaleR_const
  bounded_linear_const_scaleR
  bounded_linear_ident
  bounded_linear_sum
  bounded_linear_Pair
  bounded_linear_sub
  bounded_linear_fst_comp
  bounded_linear_snd_comp
  bounded_linear_inner_left_comp
  bounded_linear_inner_right_comp

subsection\<^marker>\<open>tag unimportant\<close> \<open>declaration of derivative/continuous/tendsto introduction rules for bounded linear functions\<close>

attribute_setup bounded_linear =
  \<open>Scan.succeed (Thm.declaration_attribute (fn thm =>
    fold (fn (r, s) => Named_Theorems.add_thm s (thm RS r))
      [
        (@{thm bounded_linear.has_derivative}, \<^named_theorems>\<open>derivative_intros\<close>),
        (@{thm bounded_linear.tendsto}, \<^named_theorems>\<open>tendsto_intros\<close>),
        (@{thm bounded_linear.continuous}, \<^named_theorems>\<open>continuous_intros\<close>),
        (@{thm bounded_linear.continuous_on}, \<^named_theorems>\<open>continuous_intros\<close>),
        (@{thm bounded_linear.uniformly_continuous_on}, \<^named_theorems>\<open>continuous_intros\<close>),
        (@{thm bounded_linear_compose}, \<^named_theorems>\<open>bounded_linear_intros\<close>)
      ]))\<close>

attribute_setup bounded_bilinear =
  \<open>Scan.succeed (Thm.declaration_attribute (fn thm =>
    fold (fn (r, s) => Named_Theorems.add_thm s (thm RS r))
      [
        (@{thm bounded_bilinear.FDERIV}, \<^named_theorems>\<open>derivative_intros\<close>),
        (@{thm bounded_bilinear.tendsto}, \<^named_theorems>\<open>tendsto_intros\<close>),
        (@{thm bounded_bilinear.continuous}, \<^named_theorems>\<open>continuous_intros\<close>),
        (@{thm bounded_bilinear.continuous_on}, \<^named_theorems>\<open>continuous_intros\<close>),
        (@{thm bounded_linear_compose[OF bounded_bilinear.bounded_linear_left]},
          \<^named_theorems>\<open>bounded_linear_intros\<close>),
        (@{thm bounded_linear_compose[OF bounded_bilinear.bounded_linear_right]},
          \<^named_theorems>\<open>bounded_linear_intros\<close>),
        (@{thm bounded_linear.uniformly_continuous_on[OF bounded_bilinear.bounded_linear_left]},
          \<^named_theorems>\<open>continuous_intros\<close>),
        (@{thm bounded_linear.uniformly_continuous_on[OF bounded_bilinear.bounded_linear_right]},
          \<^named_theorems>\<open>continuous_intros\<close>)
      ]))\<close>

subsection \<open>Type of bounded linear functions\<close>

typedef\<^marker>\<open>tag important\<close> (overloaded) ('a, 'b) blinfun ("(_ \<Rightarrow>\<^sub>L /_)" [22, 21] 21) =
  "{f::'a::real_normed_vector\<Rightarrow>'b::real_normed_vector. bounded_linear f}"
  morphisms blinfun_apply Blinfun
  by (blast intro: bounded_linear_intros)

declare [[coercion
    "blinfun_apply :: ('a::real_normed_vector \<Rightarrow>\<^sub>L'b::real_normed_vector) \<Rightarrow> 'a \<Rightarrow> 'b"]]

lemma bounded_linear_blinfun_apply[bounded_linear_intros]:
  "bounded_linear g \<Longrightarrow> bounded_linear (\<lambda>x. blinfun_apply f (g x))"
  by (metis blinfun_apply mem_Collect_eq bounded_linear_compose)

setup_lifting type_definition_blinfun

lemma blinfun_eqI: "(\<And>i. blinfun_apply x i = blinfun_apply y i) \<Longrightarrow> x = y"
  by transfer auto

lemma bounded_linear_Blinfun_apply: "bounded_linear f \<Longrightarrow> blinfun_apply (Blinfun f) = f"
  by (auto simp: Blinfun_inverse)

subsection \<open>Type class instantiations\<close>

instantiation blinfun :: (real_normed_vector, real_normed_vector) real_normed_vector
begin

lift_definition\<^marker>\<open>tag important\<close> norm_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> real" is onorm .

lift_definition minus_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  is "\<lambda>f g x. f x - g x"
  by (rule bounded_linear_sub)

definition dist_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> real"
  where "dist_blinfun a b = norm (a - b)"

definition [code del]:
  "(uniformity :: (('a \<Rightarrow>\<^sub>L 'b) \<times> ('a \<Rightarrow>\<^sub>L 'b)) filter) = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

definition open_blinfun :: "('a \<Rightarrow>\<^sub>L 'b) set \<Rightarrow> bool"
  where [code del]: "open_blinfun S = (\<forall>x\<in>S. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> S)"

lift_definition uminus_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b" is "\<lambda>f x. - f x"
  by (rule bounded_linear_minus)

lift_definition\<^marker>\<open>tag important\<close> zero_blinfun :: "'a \<Rightarrow>\<^sub>L 'b" is "\<lambda>x. 0"
  by (rule bounded_linear_zero)

lift_definition\<^marker>\<open>tag important\<close> plus_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  is "\<lambda>f g x. f x + g x"
  by (metis bounded_linear_add)

lift_definition\<^marker>\<open>tag important\<close> scaleR_blinfun::"real \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b" is "\<lambda>r f x. r *\<^sub>R f x"
  by (metis bounded_linear_compose bounded_linear_scaleR_right)

definition sgn_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  where "sgn_blinfun x = scaleR (inverse (norm x)) x"

instance
  apply standard
  unfolding dist_blinfun_def open_blinfun_def sgn_blinfun_def uniformity_blinfun_def
  apply (rule refl | (transfer, force simp: onorm_triangle onorm_scaleR onorm_eq_0 algebra_simps))+
  done

end

declare uniformity_Abort[where 'a="('a :: real_normed_vector) \<Rightarrow>\<^sub>L ('b :: real_normed_vector)", code]

lemma norm_blinfun_eqI:
  assumes "n \<le> norm (blinfun_apply f x) / norm x"
  assumes "\<And>x. norm (blinfun_apply f x) \<le> n * norm x"
  assumes "0 \<le> n"
  shows "norm f = n"
  by (auto simp: norm_blinfun_def
    intro!: antisym onorm_bound assms order_trans[OF _ le_onorm]
    bounded_linear_intros)

lemma norm_blinfun: "norm (blinfun_apply f x) \<le> norm f * norm x"
  by transfer (rule onorm)

lemma norm_blinfun_bound: "0 \<le> b \<Longrightarrow> (\<And>x. norm (blinfun_apply f x) \<le> b * norm x) \<Longrightarrow> norm f \<le> b"
  by transfer (rule onorm_bound)

lemma bounded_bilinear_blinfun_apply[bounded_bilinear]: "bounded_bilinear blinfun_apply"
proof
  fix f g::"'a \<Rightarrow>\<^sub>L 'b" and a b::'a and r::real
  show "(f + g) a = f a + g a" "(r *\<^sub>R f) a = r *\<^sub>R f a"
    by (transfer, simp)+
  interpret bounded_linear f for f::"'a \<Rightarrow>\<^sub>L 'b"
    by (auto intro!: bounded_linear_intros)
  show "f (a + b) = f a + f b" "f (r *\<^sub>R a) = r *\<^sub>R f a"
    by (simp_all add: add scaleR)
  show "\<exists>K. \<forall>a b. norm (blinfun_apply a b) \<le> norm a * norm b * K"
    by (auto intro!: exI[where x=1] norm_blinfun)
qed

interpretation blinfun: bounded_bilinear blinfun_apply
  by (rule bounded_bilinear_blinfun_apply)

lemmas bounded_linear_apply_blinfun[intro, simp] = blinfun.bounded_linear_left

declare blinfun.zero_left [simp] blinfun.zero_right [simp]

context bounded_bilinear
begin

named_theorems bilinear_simps

lemmas [bilinear_simps] =
  add_left
  add_right
  diff_left
  diff_right
  minus_left
  minus_right
  scaleR_left
  scaleR_right
  zero_left
  zero_right
  sum_left
  sum_right

end

instance blinfun :: (real_normed_vector, banach) banach
proof
  fix X::"nat \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  assume "Cauchy X"
  {
    fix x::'a
    {
      fix x::'a
      assume "norm x \<le> 1"
      have "Cauchy (\<lambda>n. X n x)"
      proof (rule CauchyI)
        fix e::real
        assume "0 < e"
        from CauchyD[OF \<open>Cauchy X\<close> \<open>0 < e\<close>] obtain M
          where M: "\<And>m n. m \<ge> M \<Longrightarrow> n \<ge> M \<Longrightarrow> norm (X m - X n) < e"
          by auto
        show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (X m x - X n x) < e"
        proof (safe intro!: exI[where x=M])
          fix m n
          assume le: "M \<le> m" "M \<le> n"
          have "norm (X m x - X n x) = norm ((X m - X n) x)"
            by (simp add: blinfun.bilinear_simps)
          also have "\<dots> \<le> norm (X m - X n) * norm x"
             by (rule norm_blinfun)
          also have "\<dots> \<le> norm (X m - X n) * 1"
            using \<open>norm x \<le> 1\<close> norm_ge_zero by (rule mult_left_mono)
          also have "\<dots> = norm (X m - X n)" by simp
          also have "\<dots> < e" using le by fact
          finally show "norm (X m x - X n x) < e" .
        qed
      qed
      hence "convergent (\<lambda>n. X n x)"
        by (metis Cauchy_convergent_iff)
    } note convergent_norm1 = this
    define y where "y = x /\<^sub>R norm x"
    have y: "norm y \<le> 1" and xy: "x = norm x *\<^sub>R y"
      by (simp_all add: y_def inverse_eq_divide)
    have "convergent (\<lambda>n. norm x *\<^sub>R X n y)"
      by (intro bounded_bilinear.convergent[OF bounded_bilinear_scaleR] convergent_const
        convergent_norm1 y)
    also have "(\<lambda>n. norm x *\<^sub>R X n y) = (\<lambda>n. X n x)"
      by (subst xy) (simp add: blinfun.bilinear_simps)
    finally have "convergent (\<lambda>n. X n x)" .
  }
  then obtain v where v: "\<And>x. (\<lambda>n. X n x) \<longlonglongrightarrow> v x"
    unfolding convergent_def
    by metis

  have "Cauchy (\<lambda>n. norm (X n))"
  proof (rule CauchyI)
    fix e::real
    assume "e > 0"
    from CauchyD[OF \<open>Cauchy X\<close> \<open>0 < e\<close>] obtain M
      where M: "\<And>m n. m \<ge> M \<Longrightarrow> n \<ge> M \<Longrightarrow> norm (X m - X n) < e"
      by auto
    show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (norm (X m) - norm (X n)) < e"
    proof (safe intro!: exI[where x=M])
      fix m n assume mn: "m \<ge> M" "n \<ge> M"
      have "norm (norm (X m) - norm (X n)) \<le> norm (X m - X n)"
        by (metis norm_triangle_ineq3 real_norm_def)
      also have "\<dots> < e" using mn by fact
      finally show "norm (norm (X m) - norm (X n)) < e" .
    qed
  qed
  then obtain K where K: "(\<lambda>n. norm (X n)) \<longlonglongrightarrow> K"
    unfolding Cauchy_convergent_iff convergent_def
    by metis

  have "bounded_linear v"
  proof
    fix x y and r::real
    from tendsto_add[OF v[of x] v [of y]] v[of "x + y", unfolded blinfun.bilinear_simps]
      tendsto_scaleR[OF tendsto_const[of r] v[of x]] v[of "r *\<^sub>R x", unfolded blinfun.bilinear_simps]
    show "v (x + y) = v x + v y" "v (r *\<^sub>R x) = r *\<^sub>R v x"
      by (metis (poly_guards_query) LIMSEQ_unique)+
    show "\<exists>K. \<forall>x. norm (v x) \<le> norm x * K"
    proof (safe intro!: exI[where x=K])
      fix x
      have "norm (v x) \<le> K * norm x"
        by (rule tendsto_le[OF _ tendsto_mult[OF K tendsto_const] tendsto_norm[OF v]])
          (auto simp: norm_blinfun)
      thus "norm (v x) \<le> norm x * K"
        by (simp add: ac_simps)
    qed
  qed
  hence Bv: "\<And>x. (\<lambda>n. X n x) \<longlonglongrightarrow> Blinfun v x"
    by (auto simp: bounded_linear_Blinfun_apply v)

  have "X \<longlonglongrightarrow> Blinfun v"
  proof (rule LIMSEQ_I)
    fix r::real assume "r > 0"
    define r' where "r' = r / 2"
    have "0 < r'" "r' < r" using \<open>r > 0\<close> by (simp_all add: r'_def)
    from CauchyD[OF \<open>Cauchy X\<close> \<open>r' > 0\<close>]
    obtain M where M: "\<And>m n. m \<ge> M \<Longrightarrow> n \<ge> M \<Longrightarrow> norm (X m - X n) < r'"
      by metis
    show "\<exists>no. \<forall>n\<ge>no. norm (X n - Blinfun v) < r"
    proof (safe intro!: exI[where x=M])
      fix n assume n: "M \<le> n"
      have "norm (X n - Blinfun v) \<le> r'"
      proof (rule norm_blinfun_bound)
        fix x
        have "eventually (\<lambda>m. m \<ge> M) sequentially"
          by (metis eventually_ge_at_top)
        hence ev_le: "eventually (\<lambda>m. norm (X n x - X m x) \<le> r' * norm x) sequentially"
        proof eventually_elim
          case (elim m)
          have "norm (X n x - X m x) = norm ((X n - X m) x)"
            by (simp add: blinfun.bilinear_simps)
          also have "\<dots> \<le> norm ((X n - X m)) * norm x"
            by (rule norm_blinfun)
          also have "\<dots> \<le> r' * norm x"
            using M[OF n elim] by (simp add: mult_right_mono)
          finally show ?case .
        qed
        have tendsto_v: "(\<lambda>m. norm (X n x - X m x)) \<longlonglongrightarrow> norm (X n x - Blinfun v x)"
          by (auto intro!: tendsto_intros Bv)
        show "norm ((X n - Blinfun v) x) \<le> r' * norm x"
          by (auto intro!: tendsto_upperbound tendsto_v ev_le simp: blinfun.bilinear_simps)
      qed (simp add: \<open>0 < r'\<close> less_imp_le)
      thus "norm (X n - Blinfun v) < r"
        by (metis \<open>r' < r\<close> le_less_trans)
    qed
  qed
  thus "convergent X"
    by (rule convergentI)
qed

subsection\<^marker>\<open>tag unimportant\<close> \<open>On Euclidean Space\<close>

lemma Zfun_sum:
  assumes "finite s"
  assumes f: "\<And>i. i \<in> s \<Longrightarrow> Zfun (f i) F"
  shows "Zfun (\<lambda>x. sum (\<lambda>i. f i x) s) F"
  using assms by induct (auto intro!: Zfun_zero Zfun_add)

lemma norm_blinfun_euclidean_le:
  fixes a::"'a::euclidean_space \<Rightarrow>\<^sub>L 'b::real_normed_vector"
  shows "norm a \<le> sum (\<lambda>x. norm (a x)) Basis"
  apply (rule norm_blinfun_bound)
   apply (simp add: sum_nonneg)
  apply (subst euclidean_representation[symmetric, where 'a='a])
  apply (simp only: blinfun.bilinear_simps sum_distrib_right)
  apply (rule order.trans[OF norm_sum sum_mono])
  apply (simp add: abs_mult mult_right_mono ac_simps Basis_le_norm)
  done

lemma tendsto_componentwise1:
  fixes a::"'a::euclidean_space \<Rightarrow>\<^sub>L 'b::real_normed_vector"
    and b::"'c \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  assumes "(\<And>j. j \<in> Basis \<Longrightarrow> ((\<lambda>n. b n j) \<longlongrightarrow> a j) F)"
  shows "(b \<longlongrightarrow> a) F"
proof -
  have "\<And>j. j \<in> Basis \<Longrightarrow> Zfun (\<lambda>x. norm (b x j - a j)) F"
    using assms unfolding tendsto_Zfun_iff Zfun_norm_iff .
  hence "Zfun (\<lambda>x. \<Sum>j\<in>Basis. norm (b x j - a j)) F"
    by (auto intro!: Zfun_sum)
  thus ?thesis
    unfolding tendsto_Zfun_iff
    by (rule Zfun_le)
      (auto intro!: order_trans[OF norm_blinfun_euclidean_le] simp: blinfun.bilinear_simps)
qed

lift_definition
  blinfun_of_matrix::"('b::euclidean_space \<Rightarrow> 'a::euclidean_space \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  is "\<lambda>a x. \<Sum>i\<in>Basis. \<Sum>j\<in>Basis. ((x \<bullet> j) * a i j) *\<^sub>R i"
  by (intro bounded_linear_intros)

lemma blinfun_of_matrix_works:
  fixes f::"'a::euclidean_space \<Rightarrow>\<^sub>L 'b::euclidean_space"
  shows "blinfun_of_matrix (\<lambda>i j. (f j) \<bullet> i) = f"
proof (transfer, rule,  rule euclidean_eqI)
  fix f::"'a \<Rightarrow> 'b" and x::'a and b::'b assume "bounded_linear f" and b: "b \<in> Basis"
  then interpret bounded_linear f by simp
  have "(\<Sum>j\<in>Basis. \<Sum>i\<in>Basis. (x \<bullet> i * (f i \<bullet> j)) *\<^sub>R j) \<bullet> b
    = (\<Sum>j\<in>Basis. if j = b then (\<Sum>i\<in>Basis. (x \<bullet> i * (f i \<bullet> j))) else 0)"
    using b
    by (simp add: inner_sum_left inner_Basis if_distrib cong: if_cong) (simp add: sum.swap)
  also have "\<dots> = (\<Sum>i\<in>Basis. (x \<bullet> i * (f i \<bullet> b)))"
    using b by (simp)
  also have "\<dots> = f x \<bullet> b"
    by (metis (mono_tags, lifting) Linear_Algebra.linear_componentwise linear_axioms)
  finally show "(\<Sum>j\<in>Basis. \<Sum>i\<in>Basis. (x \<bullet> i * (f i \<bullet> j)) *\<^sub>R j) \<bullet> b = f x \<bullet> b" .
qed

lemma blinfun_of_matrix_apply:
  "blinfun_of_matrix a x = (\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. ((x \<bullet> j) * a i j) *\<^sub>R i)"
  by transfer simp

lemma blinfun_of_matrix_minus: "blinfun_of_matrix x - blinfun_of_matrix y = blinfun_of_matrix (x - y)"
  by transfer (auto simp: algebra_simps sum_subtractf)

lemma norm_blinfun_of_matrix:
  "norm (blinfun_of_matrix a) \<le> (\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. \<bar>a i j\<bar>)"
  apply (rule norm_blinfun_bound)
   apply (simp add: sum_nonneg)
  apply (simp only: blinfun_of_matrix_apply sum_distrib_right)
  apply (rule order_trans[OF norm_sum sum_mono])
  apply (rule order_trans[OF norm_sum sum_mono])
  apply (simp add: abs_mult mult_right_mono ac_simps Basis_le_norm)
  done

lemma tendsto_blinfun_of_matrix:
  assumes "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> ((\<lambda>n. b n i j) \<longlongrightarrow> a i j) F"
  shows "((\<lambda>n. blinfun_of_matrix (b n)) \<longlongrightarrow> blinfun_of_matrix a) F"
proof -
  have "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> Zfun (\<lambda>x. norm (b x i j - a i j)) F"
    using assms unfolding tendsto_Zfun_iff Zfun_norm_iff .
  hence "Zfun (\<lambda>x. (\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. \<bar>b x i j - a i j\<bar>)) F"
    by (auto intro!: Zfun_sum)
  thus ?thesis
    unfolding tendsto_Zfun_iff blinfun_of_matrix_minus
    by (rule Zfun_le) (auto intro!: order_trans[OF norm_blinfun_of_matrix])
qed

lemma tendsto_componentwise:
  fixes a::"'a::euclidean_space \<Rightarrow>\<^sub>L 'b::euclidean_space"
    and b::"'c \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  shows "(\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> ((\<lambda>n. b n j \<bullet> i) \<longlongrightarrow> a j \<bullet> i) F) \<Longrightarrow> (b \<longlongrightarrow> a) F"
  apply (subst blinfun_of_matrix_works[of a, symmetric])
  apply (subst blinfun_of_matrix_works[of "b x" for x, symmetric, abs_def])
  by (rule tendsto_blinfun_of_matrix)

lemma
  continuous_blinfun_componentwiseI:
  fixes f:: "'b::t2_space \<Rightarrow> 'a::euclidean_space \<Rightarrow>\<^sub>L 'c::euclidean_space"
  assumes "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> continuous F (\<lambda>x. (f x) j \<bullet> i)"
  shows "continuous F f"
  using assms by (auto simp: continuous_def intro!: tendsto_componentwise)

lemma
  continuous_blinfun_componentwiseI1:
  fixes f:: "'b::t2_space \<Rightarrow> 'a::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> continuous F (\<lambda>x. f x i)"
  shows "continuous F f"
  using assms by (auto simp: continuous_def intro!: tendsto_componentwise1)

lemma
  continuous_on_blinfun_componentwise:
  fixes f:: "'d::t2_space \<Rightarrow> 'e::euclidean_space \<Rightarrow>\<^sub>L 'f::real_normed_vector"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> continuous_on s (\<lambda>x. f x i)"
  shows "continuous_on s f"
  using assms
  by (auto intro!: continuous_at_imp_continuous_on intro!: tendsto_componentwise1
    simp: continuous_on_eq_continuous_within continuous_def)

lemma bounded_linear_blinfun_matrix: "bounded_linear (\<lambda>x. (x::_\<Rightarrow>\<^sub>L _) j \<bullet> i)"
  by (auto intro!: bounded_linearI' bounded_linear_intros)

lemma continuous_blinfun_matrix:
  fixes f:: "'b::t2_space \<Rightarrow> 'a::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_inner"
  assumes "continuous F f"
  shows "continuous F (\<lambda>x. (f x) j \<bullet> i)"
  by (rule bounded_linear.continuous[OF bounded_linear_blinfun_matrix assms])

lemma continuous_on_blinfun_matrix:
  fixes f::"'a::t2_space \<Rightarrow> 'b::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_inner"
  assumes "continuous_on S f"
  shows "continuous_on S (\<lambda>x. (f x) j \<bullet> i)"
  using assms
  by (auto simp: continuous_on_eq_continuous_within continuous_blinfun_matrix)

lemma continuous_on_blinfun_of_matrix[continuous_intros]:
  assumes "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> continuous_on S (\<lambda>s. g s i j)"
  shows "continuous_on S (\<lambda>s. blinfun_of_matrix (g s))"
  using assms
  by (auto simp: continuous_on intro!: tendsto_blinfun_of_matrix)

lemma mult_if_delta:
  "(if P then (1::'a::comm_semiring_1) else 0) * q = (if P then q else 0)"
  by auto

lemma compact_blinfun_lemma:
  fixes f :: "nat \<Rightarrow> 'a::euclidean_space \<Rightarrow>\<^sub>L 'b::euclidean_space"
  assumes "bounded (range f)"
  shows "\<forall>d\<subseteq>Basis. \<exists>l::'a \<Rightarrow>\<^sub>L 'b. \<exists> r::nat\<Rightarrow>nat.
    strict_mono r \<and> (\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r n) i) (l i) < e) sequentially)"
  by (rule compact_lemma_general[where unproj = "\<lambda>e. blinfun_of_matrix (\<lambda>i j. e j \<bullet> i)"])
   (auto intro!: euclidean_eqI[where 'a='b] bounded_linear_image assms
    simp: blinfun_of_matrix_works blinfun_of_matrix_apply inner_Basis mult_if_delta sum.delta'
      scaleR_sum_left[symmetric])

lemma blinfun_euclidean_eqI: "(\<And>i. i \<in> Basis \<Longrightarrow> blinfun_apply x i = blinfun_apply y i) \<Longrightarrow> x = y"
  apply (auto intro!: blinfun_eqI)
  apply (subst (2) euclidean_representation[symmetric, where 'a='a])
  apply (subst (1) euclidean_representation[symmetric, where 'a='a])
  apply (simp add: blinfun.bilinear_simps)
  done

lemma Blinfun_eq_matrix: "bounded_linear f \<Longrightarrow> Blinfun f = blinfun_of_matrix (\<lambda>i j. f j \<bullet> i)"
  by (intro blinfun_euclidean_eqI)
     (auto simp: blinfun_of_matrix_apply bounded_linear_Blinfun_apply inner_Basis if_distrib
      if_distribR sum.delta' euclidean_representation
      cong: if_cong)

text \<open>TODO: generalize (via \<open>compact_cball\<close>)?\<close>
instance blinfun :: (euclidean_space, euclidean_space) heine_borel
proof
  fix f :: "nat \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  assume f: "bounded (range f)"
  then obtain l::"'a \<Rightarrow>\<^sub>L 'b" and r where r: "strict_mono r"
    and l: "\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>Basis. dist (f (r n) i) (l i) < e) sequentially"
    using compact_blinfun_lemma [OF f] by blast
  {
    fix e::real
    let ?d = "real_of_nat DIM('a) * real_of_nat DIM('b)"
    assume "e > 0"
    hence "e / ?d > 0" by (simp)
    with l have "eventually (\<lambda>n. \<forall>i\<in>Basis. dist (f (r n) i) (l i) < e / ?d) sequentially"
      by simp
    moreover
    {
      fix n
      assume n: "\<forall>i\<in>Basis. dist (f (r n) i) (l i) < e / ?d"
      have "norm (f (r n) - l) = norm (blinfun_of_matrix (\<lambda>i j. (f (r n) - l) j \<bullet> i))"
        unfolding blinfun_of_matrix_works ..
      also note norm_blinfun_of_matrix
      also have "(\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. \<bar>(f (r n) - l) j \<bullet> i\<bar>) <
        (\<Sum>i\<in>(Basis::'b set). e / real_of_nat DIM('b))"
      proof (rule sum_strict_mono)
        fix i::'b assume i: "i \<in> Basis"
        have "(\<Sum>j::'a\<in>Basis. \<bar>(f (r n) - l) j \<bullet> i\<bar>) < (\<Sum>j::'a\<in>Basis. e / ?d)"
        proof (rule sum_strict_mono)
          fix j::'a assume j: "j \<in> Basis"
          have "\<bar>(f (r n) - l) j \<bullet> i\<bar> \<le> norm ((f (r n) - l) j)"
            by (simp add: Basis_le_norm i)
          also have "\<dots> < e / ?d"
            using n i j by (auto simp: dist_norm blinfun.bilinear_simps)
          finally show "\<bar>(f (r n) - l) j \<bullet> i\<bar> < e / ?d" by simp
        qed simp_all
        also have "\<dots> \<le> e / real_of_nat DIM('b)"
          by simp
        finally show "(\<Sum>j\<in>Basis. \<bar>(f (r n) - l) j \<bullet> i\<bar>) < e / real_of_nat DIM('b)"
          by simp
      qed simp_all
      also have "\<dots> \<le> e" by simp
      finally have "dist (f (r n)) l < e"
        by (auto simp: dist_norm)
    }
    ultimately have "eventually (\<lambda>n. dist (f (r n)) l < e) sequentially"
      using eventually_elim2 by force
  }
  then have *: "((f \<circ> r) \<longlongrightarrow> l) sequentially"
    unfolding o_def tendsto_iff by simp
  with r show "\<exists>l r. strict_mono r \<and> ((f \<circ> r) \<longlongrightarrow> l) sequentially"
    by auto
qed

subsection\<^marker>\<open>tag unimportant\<close> \<open>concrete bounded linear functions\<close>

lemma transfer_bounded_bilinear_bounded_linearI:
  assumes "g = (\<lambda>i x. (blinfun_apply (f i) x))"
  shows "bounded_bilinear g = bounded_linear f"
proof
  assume "bounded_bilinear g"
  then interpret bounded_bilinear f by (simp add: assms)
  show "bounded_linear f"
  proof (unfold_locales, safe intro!: blinfun_eqI)
    fix i
    show "f (x + y) i = (f x + f y) i" "f (r *\<^sub>R x) i = (r *\<^sub>R f x) i" for r x y
      by (auto intro!: blinfun_eqI simp: blinfun.bilinear_simps)
    from _ nonneg_bounded show "\<exists>K. \<forall>x. norm (f x) \<le> norm x * K"
      by (rule ex_reg) (auto intro!: onorm_bound simp: norm_blinfun.rep_eq ac_simps)
  qed
qed (auto simp: assms intro!: blinfun.comp)

lemma transfer_bounded_bilinear_bounded_linear[transfer_rule]:
  "(rel_fun (rel_fun (=) (pcr_blinfun (=) (=))) (=)) bounded_bilinear bounded_linear"
  by (auto simp: pcr_blinfun_def cr_blinfun_def rel_fun_def OO_def
    intro!: transfer_bounded_bilinear_bounded_linearI)

context bounded_bilinear
begin

lift_definition prod_left::"'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'c" is "(\<lambda>b a. prod a b)"
  by (rule bounded_linear_left)
declare prod_left.rep_eq[simp]

lemma bounded_linear_prod_left[bounded_linear]: "bounded_linear prod_left"
  by transfer (rule flip)

lift_definition prod_right::"'a \<Rightarrow> 'b \<Rightarrow>\<^sub>L 'c" is "(\<lambda>a b. prod a b)"
  by (rule bounded_linear_right)
declare prod_right.rep_eq[simp]

lemma bounded_linear_prod_right[bounded_linear]: "bounded_linear prod_right"
  by transfer (rule bounded_bilinear_axioms)

end

lift_definition id_blinfun::"'a::real_normed_vector \<Rightarrow>\<^sub>L 'a" is "\<lambda>x. x"
  by (rule bounded_linear_ident)

lemmas blinfun_apply_id_blinfun[simp] = id_blinfun.rep_eq

lemma norm_blinfun_id[simp]:
  "norm (id_blinfun::'a::{real_normed_vector, perfect_space} \<Rightarrow>\<^sub>L 'a) = 1"
  by transfer (auto simp: onorm_id)

lemma norm_blinfun_id_le:
  "norm (id_blinfun::'a::real_normed_vector \<Rightarrow>\<^sub>L 'a) \<le> 1"
  by transfer (auto simp: onorm_id_le)

lift_definition fst_blinfun::"('a::real_normed_vector \<times> 'b::real_normed_vector) \<Rightarrow>\<^sub>L 'a" is fst
  by (rule bounded_linear_fst)

lemma blinfun_apply_fst_blinfun[simp]: "blinfun_apply fst_blinfun = fst"
  by transfer (rule refl)

lift_definition snd_blinfun::"('a::real_normed_vector \<times> 'b::real_normed_vector) \<Rightarrow>\<^sub>L 'b" is snd
  by (rule bounded_linear_snd)

lemma blinfun_apply_snd_blinfun[simp]: "blinfun_apply snd_blinfun = snd"
  by transfer (rule refl)

lift_definition blinfun_compose::
  "'a::real_normed_vector \<Rightarrow>\<^sub>L 'b::real_normed_vector \<Rightarrow>
    'c::real_normed_vector \<Rightarrow>\<^sub>L 'a \<Rightarrow>
    'c \<Rightarrow>\<^sub>L 'b" (infixl "o\<^sub>L" 55) is "(o)"
  parametric comp_transfer
  unfolding o_def
  by (rule bounded_linear_compose)

lemma blinfun_apply_blinfun_compose[simp]: "(a o\<^sub>L b) c = a (b c)"
  by (simp add: blinfun_compose.rep_eq)

lemma norm_blinfun_compose:
  "norm (f o\<^sub>L g) \<le> norm f * norm g"
  by transfer (rule onorm_compose)

lemma bounded_bilinear_blinfun_compose[bounded_bilinear]: "bounded_bilinear (o\<^sub>L)"
  by unfold_locales
    (auto intro!: blinfun_eqI exI[where x=1] simp: blinfun.bilinear_simps norm_blinfun_compose)

lemma blinfun_compose_zero[simp]:
  "blinfun_compose 0 = (\<lambda>_. 0)"
  "blinfun_compose x 0 = 0"
  by (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI)

lemma blinfun_bij2:
  fixes f::"'a \<Rightarrow>\<^sub>L 'a::euclidean_space"
  assumes "f o\<^sub>L g = id_blinfun"
  shows "bij (blinfun_apply g)"
proof (rule bijI)
  show "inj g"
    using assms
    by (metis blinfun_apply_id_blinfun blinfun_compose.rep_eq injI inj_on_imageI2)
  then show "surj g"
    using blinfun.bounded_linear_right bounded_linear_def linear_inj_imp_surj by blast
qed

lemma blinfun_bij1:
  fixes f::"'a \<Rightarrow>\<^sub>L 'a::euclidean_space"
  assumes "f o\<^sub>L g = id_blinfun"
  shows "bij (blinfun_apply f)"
proof (rule bijI)
  show "surj (blinfun_apply f)"
    by (metis assms blinfun_apply_blinfun_compose blinfun_apply_id_blinfun surjI)
  then show "inj (blinfun_apply f)"
    using blinfun.bounded_linear_right bounded_linear_def linear_surj_imp_inj by blast
qed

lift_definition blinfun_inner_right::"'a::real_inner \<Rightarrow> 'a \<Rightarrow>\<^sub>L real" is "(\<bullet>)"
  by (rule bounded_linear_inner_right)
declare blinfun_inner_right.rep_eq[simp]

lemma bounded_linear_blinfun_inner_right[bounded_linear]: "bounded_linear blinfun_inner_right"
  by transfer (rule bounded_bilinear_inner)

lift_definition blinfun_inner_left::"'a::real_inner \<Rightarrow> 'a \<Rightarrow>\<^sub>L real" is "\<lambda>x y. y \<bullet> x"
  by (rule bounded_linear_inner_left)
declare blinfun_inner_left.rep_eq[simp]

lemma bounded_linear_blinfun_inner_left[bounded_linear]: "bounded_linear blinfun_inner_left"
  by transfer (rule bounded_bilinear.flip[OF bounded_bilinear_inner])

lift_definition blinfun_scaleR_right::"real \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'a::real_normed_vector" is "(*\<^sub>R)"
  by (rule bounded_linear_scaleR_right)
declare blinfun_scaleR_right.rep_eq[simp]

lemma bounded_linear_blinfun_scaleR_right[bounded_linear]: "bounded_linear blinfun_scaleR_right"
  by transfer (rule bounded_bilinear_scaleR)

lift_definition blinfun_scaleR_left::"'a::real_normed_vector \<Rightarrow> real \<Rightarrow>\<^sub>L 'a" is "\<lambda>x y. y *\<^sub>R x"
  by (rule bounded_linear_scaleR_left)
lemmas [simp] = blinfun_scaleR_left.rep_eq

lemma bounded_linear_blinfun_scaleR_left[bounded_linear]: "bounded_linear blinfun_scaleR_left"
  by transfer (rule bounded_bilinear.flip[OF bounded_bilinear_scaleR])

lift_definition blinfun_mult_right::"'a \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'a::real_normed_algebra" is "(*)"
  by (rule bounded_linear_mult_right)
declare blinfun_mult_right.rep_eq[simp]

lemma bounded_linear_blinfun_mult_right[bounded_linear]: "bounded_linear blinfun_mult_right"
  by transfer (rule bounded_bilinear_mult)

lift_definition blinfun_mult_left::"'a::real_normed_algebra \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'a" is "\<lambda>x y. y * x"
  by (rule bounded_linear_mult_left)
lemmas [simp] = blinfun_mult_left.rep_eq

lemma bounded_linear_blinfun_mult_left[bounded_linear]: "bounded_linear blinfun_mult_left"
  by transfer (rule bounded_bilinear.flip[OF bounded_bilinear_mult])

lemmas bounded_linear_function_uniform_limit_intros[uniform_limit_intros] =
  bounded_linear.uniform_limit[OF bounded_linear_apply_blinfun]
  bounded_linear.uniform_limit[OF bounded_linear_blinfun_apply]
  bounded_linear.uniform_limit[OF bounded_linear_blinfun_matrix]

subsection \<open>The strong operator topology on continuous linear operators\<close>

text \<open>Let \<open>'a\<close> and \<open>'b\<close> be two normed real vector spaces. Then the space of linear continuous
operators from \<open>'a\<close> to \<open>'b\<close> has a canonical norm, and therefore a canonical corresponding topology
(the type classes instantiation are given in \<^file>\<open>Bounded_Linear_Function.thy\<close>).

However, there is another topology on this space, the strong operator topology, where \<open>T\<^sub>n\<close> tends to
\<open>T\<close> iff, for all \<open>x\<close> in \<open>'a\<close>, then \<open>T\<^sub>n x\<close> tends to \<open>T x\<close>. This is precisely the product topology
where the target space is endowed with the norm topology. It is especially useful when \<open>'b\<close> is the set
of real numbers, since then this topology is compact.

We can not implement it using type classes as there is already a topology, but at least we
can define it as a topology.

Note that there is yet another (common and useful) topology on operator spaces, the weak operator
topology, defined analogously using the product topology, but where the target space is given the
weak-* topology, i.e., the pullback of the weak topology on the bidual of the space under the
canonical embedding of a space into its bidual. We do not define it there, although it could also be
defined analogously.
\<close>

definition\<^marker>\<open>tag important\<close> strong_operator_topology::"('a::real_normed_vector \<Rightarrow>\<^sub>L'b::real_normed_vector) topology"
where "strong_operator_topology = pullback_topology UNIV blinfun_apply euclidean"

lemma strong_operator_topology_topspace:
  "topspace strong_operator_topology = UNIV"
unfolding strong_operator_topology_def topspace_pullback_topology topspace_euclidean by auto

lemma strong_operator_topology_basis:
  fixes f::"('a::real_normed_vector \<Rightarrow>\<^sub>L'b::real_normed_vector)" and U::"'i \<Rightarrow> 'b set" and x::"'i \<Rightarrow> 'a"
  assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> open (U i)"
  shows "openin strong_operator_topology {f. \<forall>i\<in>I. blinfun_apply f (x i) \<in> U i}"
proof -
  have "open {g::('a\<Rightarrow>'b). \<forall>i\<in>I. g (x i) \<in> U i}"
    by (rule product_topology_basis'[OF assms])
  moreover have "{f. \<forall>i\<in>I. blinfun_apply f (x i) \<in> U i}
                = blinfun_apply-`{g::('a\<Rightarrow>'b). \<forall>i\<in>I. g (x i) \<in> U i} \<inter> UNIV"
    by auto
  ultimately show ?thesis
    unfolding strong_operator_topology_def by (subst openin_pullback_topology) auto
qed

lemma strong_operator_topology_continuous_evaluation:
  "continuous_map strong_operator_topology euclidean (\<lambda>f. blinfun_apply f x)"
proof -
  have "continuous_map strong_operator_topology euclidean ((\<lambda>f. f x) o blinfun_apply)"
    unfolding strong_operator_topology_def apply (rule continuous_map_pullback)
    using continuous_on_product_coordinates by fastforce
  then show ?thesis unfolding comp_def by simp
qed

lemma continuous_on_strong_operator_topo_iff_coordinatewise:
  "continuous_map T strong_operator_topology f
    \<longleftrightarrow> (\<forall>x. continuous_map T euclidean (\<lambda>y. blinfun_apply (f y) x))"
proof (auto)
  fix x::"'b"
  assume "continuous_map T strong_operator_topology f"
  with continuous_map_compose[OF this strong_operator_topology_continuous_evaluation]
  have "continuous_map T euclidean ((\<lambda>z. blinfun_apply z x) o f)"
    by simp
  then show "continuous_map T euclidean (\<lambda>y. blinfun_apply (f y) x)"
    unfolding comp_def by auto
next
  assume *: "\<forall>x. continuous_map T euclidean (\<lambda>y. blinfun_apply (f y) x)"
  have "\<And>i. continuous_map T euclidean (\<lambda>x. blinfun_apply (f x) i)"
    using * unfolding comp_def by auto
  then have "continuous_map T euclidean (blinfun_apply o f)"
    unfolding o_def
    by (metis (no_types) continuous_map_componentwise_UNIV euclidean_product_topology)
  show "continuous_map T strong_operator_topology f"
    unfolding strong_operator_topology_def
    apply (rule continuous_map_pullback')
    by (auto simp add: \<open>continuous_map T euclidean (blinfun_apply o f)\<close>)
qed

lemma strong_operator_topology_weaker_than_euclidean:
  "continuous_map euclidean strong_operator_topology (\<lambda>f. f)"
  by (subst continuous_on_strong_operator_topo_iff_coordinatewise,
    auto simp add: linear_continuous_on)

end


theory Executable_Relation
imports Main
begin

subsection {* A dedicated type for relations *}

subsubsection {* Definition of the dedicated type for relations *}

typedef 'a rel = "UNIV :: (('a * 'a) set) set"
morphisms set_of_rel rel_of_set by simp

setup_lifting type_definition_rel

lift_definition Rel :: "'a set => ('a * 'a) set => 'a rel" is "\<lambda> X R. Id_on X Un R" .

subsubsection {* Constant definitions on relations *}

hide_const (open) converse relcomp rtrancl Image

lift_definition member :: "'a * 'a => 'a rel => bool" is "Set.member" .

lift_definition converse :: "'a rel => 'a rel" is "Relation.converse" .

lift_definition union :: "'a rel => 'a rel => 'a rel" is "Set.union" .

lift_definition relcomp :: "'a rel => 'a rel => 'a rel" is "Relation.relcomp" .

lift_definition rtrancl :: "'a rel => 'a rel" is "Transitive_Closure.rtrancl" .

lift_definition Image :: "'a rel => 'a set => 'a set" is "Relation.Image" .

subsubsection {* Code generation *}

code_datatype Rel

lemma [code]:
  "converse (Rel X R) = Rel X (R^-1)"
by transfer auto

lemma [code]:
  "union (Rel X R) (Rel Y S) = Rel (X Un Y) (R Un S)"
by transfer auto

lemma [code]:
   "relcomp (Rel X R) (Rel Y S) = Rel (X Int Y) (Set.filter (%(x, y). y : Y) R Un (Set.filter (%(x, y). x : X) S Un R O S))"
by transfer (auto simp add: Id_on_eqI relcomp.simps)

lemma [code]:
  "rtrancl (Rel X R) = Rel UNIV (R^+)"
apply transfer
apply auto
apply (metis Id_on_iff Un_commute UNIV_I rtrancl_Un_separatorE rtrancl_eq_or_trancl)
by (metis in_rtrancl_UnI trancl_into_rtrancl)

lemma [code]:
  "Image (Rel X R) S = (X Int S) Un (R `` S)"
by transfer auto

quickcheck_generator rel constructors: Rel

lemma
  "member (x, (y :: nat)) (rtrancl (union R S)) \<Longrightarrow> member (x, y) (union (rtrancl R) (rtrancl S))"
quickcheck[exhaustive, expect = counterexample]
oops

end


(* Title:      Applications of Modal Kleene Algebras
   Author:     Victor B. F. Gomes, Walter Guttmann, Peter Höfner, Georg Struth, Tjark Weber
   Maintainer: Walter Guttmann <walter.guttman at canterbury.ac.nz>
               Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Applications of Modal Kleene Algebras\<close>

theory Modal_Kleene_Algebra_Applications
imports Antidomain_Semiring
begin

text \<open>This file collects some applications of the theories developed so far. These are described
 in~\cite{guttmannstruthweber11algmeth}.\<close>

context antidomain_kleene_algebra
begin

subsection \<open>A Reachability Result\<close>

text \<open>This example is taken from~\cite{desharnaismoellerstruth06kad}.\<close>

lemma opti_iterate_var [simp]: "|(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof (rule order.antisym)
  show "|(ad y \<cdot> x)\<^sup>\<star>\<rangle> y \<le> |x\<^sup>\<star>\<rangle> y"
    by (simp add: a_subid_aux1' ds.fd_iso2 star_iso)
  have "d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = d y + ad y \<cdot> |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    using local.ads_d_def local.d_6 local.fdia_def by auto
  also have "... = d y + |ad y \<cdot> x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by (simp add: fdia_export_2)
  finally have "d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by simp
  thus "|x\<^sup>\<star>\<rangle> y \<le> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    using local.dka.fd_def local.dka.fdia_star_induct_eq by auto
qed

lemma opti_iterate [simp]: "d y + |(x \<cdot> ad y)\<^sup>\<star>\<rangle> |x\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof -
  have "d y + |(x \<cdot> ad y)\<^sup>\<star>\<rangle> |x\<rangle> y = d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by (metis local.conway.dagger_slide local.ds.fdia_mult)
  also have "... = d y + |x\<rangle> |x\<^sup>\<star>\<rangle> y"
    by simp
  finally show ?thesis
    by force
qed

lemma opti_iterate_var_2 [simp]: "d y + |ad y \<cdot> x\<rangle> |x\<^sup>\<star>\<rangle> y = |x\<^sup>\<star>\<rangle> y"
  by (metis local.dka.fdia_star_unfold_var opti_iterate_var)

subsection \<open>Derivation of Segerberg's Formula\<close>

text \<open>This example is taken from~\cite{DesharnaisMoellerStruthLMCS}.\<close>

definition Alpha :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("A")
  where "A x y = d (x \<cdot> y) \<cdot> ad y"

lemma A_dom [simp]: "d (A x y) = A x y"
  using Alpha_def local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma A_fdia: "A x y = |x\<rangle> y \<cdot> ad y"
  by (simp add: Alpha_def local.dka.fd_def)

lemma A_fdia_var: "A x y = |x\<rangle> d y \<cdot> ad y"
  by (simp add: A_fdia)

lemma a_A: "ad (A x (ad y)) = |x] y + ad y"
  using Alpha_def local.a_6 local.a_d_closed local.apd_d_def local.fbox_def by force

lemma fsegerberg [simp]: "d y + |x\<^sup>\<star>\<rangle> A x y = |x\<^sup>\<star>\<rangle> y"
proof (rule order.antisym)
  have "d y + |x\<rangle> (d y + |x\<^sup>\<star>\<rangle> A x y) = d y + |x\<rangle> y + |x\<rangle> |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (simp add: A_fdia add_assoc local.ds.fdia_add1)
  also have "... = d y + |x\<rangle> y \<cdot> ad y + |x\<rangle> |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (metis local.am2 local.d_6 local.dka.fd_def local.fdia_def)
  finally have "d y + |x\<rangle> (d y + |x\<^sup>\<star>\<rangle> A x y) = d y + |x\<^sup>\<star>\<rangle> A x y"
    by (metis A_dom A_fdia add_assoc local.dka.fdia_star_unfold_var)
  thus "|x\<^sup>\<star>\<rangle> y \<le> d y + |x\<^sup>\<star>\<rangle> A x y"
    by (metis local.a_d_add_closure local.ads_d_def local.dka.fdia_star_induct_eq local.fdia_def)
  have "d y + |x\<^sup>\<star>\<rangle> A x y = d y + |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (simp add: A_fdia)
  also have "... \<le> d y + |x\<^sup>\<star>\<rangle> |x\<rangle> y"
    using local.dpdz.domain_1'' local.ds.fd_iso1 local.join.sup_mono by blast
  finally show "d y + |x\<^sup>\<star>\<rangle> A x y \<le> |x\<^sup>\<star>\<rangle> y"
    by simp
qed

lemma fbox_segerberg [simp]: "d y \<cdot> |x\<^sup>\<star>] ( |x] y + ad y ) = |x\<^sup>\<star>] y"
proof -
  have "|x\<^sup>\<star>] ( |x] y + ad y ) = d ( |x\<^sup>\<star>] ( |x] y + ad y ) )"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def by auto
  hence f1: "|x\<^sup>\<star>] ( |x] y + ad y ) = ad ( |x\<^sup>\<star>\<rangle> (A x (ad y)) )"
    by (simp add: a_A local.fdia_fbox_de_morgan_2)
  have "ad y + |x\<^sup>\<star>\<rangle> (A x (ad y)) = |x\<^sup>\<star>\<rangle> ad y"
    by (metis fsegerberg local.a_d_closed local.ads_d_def local.apd_d_def)
  thus ?thesis
    by (metis f1 local.ads_d_def local.ans4 local.fbox_simp local.fdia_fbox_de_morgan_2)
qed

subsection \<open>Wellfoundedness and Loeb's Formula\<close>

text \<open>This example is taken from~\cite{DesharnaisStruthSCP}.\<close>

definition Omega :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<Omega>")
  where "\<Omega> x y = d y \<cdot> ad (x \<cdot> y)"

text \<open>If $y$ is a set, then $\Omega(x,y)$ describes those elements in $y$ from which no further $x$ transitions are possible.\<close>

lemma omega_fdia: "\<Omega> x y = d y \<cdot> ad ( |x\<rangle> y )"
  using Omega_def local.a_d_closed local.ads_d_def local.apd_d_def local.dka.fd_def by auto

lemma omega_fbox: "\<Omega> x y = d y \<cdot> |x] (ad y)"
  by (simp add: fdia_fbox_de_morgan_2 omega_fdia)

lemma omega_absorb1 [simp]: "\<Omega> x y \<cdot> ad ( |x\<rangle> y ) = \<Omega> x y"
  by (simp add: mult_assoc omega_fdia)

lemma omega_absorb2 [simp]: "\<Omega> x y \<cdot> ad (x \<cdot> y) = \<Omega> x y"
  by (simp add: Omega_def mult_assoc)

lemma omega_le_1: "\<Omega> x y \<le> d y"
  by (simp add: Omega_def d_a_galois1)

lemma omega_subid: "\<Omega> x (d y) \<le> d y"
  by (simp add: Omega_def local.a_subid_aux2)

lemma omega_le_2: "\<Omega> x y \<le> ad ( |x\<rangle> y )"
  by (simp add: local.dka.dom_subid_aux2 omega_fdia)

lemma omega_dom [simp]: "d (\<Omega> x y) = \<Omega> x y"
  using Omega_def local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma a_omega: "ad (\<Omega> x y) = ad y + |x\<rangle> y"
  by (simp add: Omega_def local.a_6 local.ds.fd_def)

lemma omega_fdia_3 [simp]: "d y \<cdot> ad (\<Omega> x y) = d y \<cdot> |x\<rangle> y"
  using Omega_def local.ads_d_def local.fdia_def local.s4 by presburger

lemma omega_zero_equiv_1: "\<Omega> x y = 0 \<longleftrightarrow> d y \<le> |x\<rangle> y"
  by (simp add: Omega_def local.a_gla local.ads_d_def local.fdia_def)

definition Loebian :: "'a \<Rightarrow> bool"
  where "Loebian x = (\<forall>y. |x\<rangle> y \<le> |x\<rangle> \<Omega> x y)"

definition PreLoebian :: "'a \<Rightarrow> bool"
  where "PreLoebian x = (\<forall>y. d y \<le> |x\<^sup>\<star>\<rangle> \<Omega> x y)"

definition Noetherian :: "'a \<Rightarrow> bool"
  where "Noetherian x = (\<forall>y. \<Omega> x y = 0 \<longrightarrow> d y = 0)"

lemma noetherian_alt: "Noetherian x \<longleftrightarrow> (\<forall>y. d y \<le> |x\<rangle> y \<longrightarrow> d y = 0)"
  by (simp add: Noetherian_def omega_zero_equiv_1)

lemma Noetherian_iff_PreLoebian: "Noetherian x \<longleftrightarrow> PreLoebian x"
proof
  assume hyp: "Noetherian x"
  {
    fix y
    have "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) = d y \<cdot> ad (\<Omega> x y + |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y)"
      by (metis local.dka.fdia_star_unfold_var omega_dom)
    also have "... = d y \<cdot> ad (\<Omega> x y) \<cdot> ad ( |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y )"
      using ans4 mult_assoc by presburger
    also have "... \<le> |x\<rangle> d y \<cdot> ad ( |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y )"
      by (simp add: local.dka.dom_subid_aux2 local.mult_isor)
    also have "... \<le> |x\<rangle> (d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ))"
      by (simp add: local.dia_diff)
    finally have "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) \<le> |x\<rangle> (d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ))"
      by blast
    hence "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) = 0"
      by (metis hyp local.ads_d_def local.dpdz.dom_mult_closed local.fdia_def noetherian_alt)
    hence "d y \<le> |x\<^sup>\<star>\<rangle> \<Omega> x y"
      by (simp add: local.a_gla local.ads_d_def local.dka.fd_def)
  }
  thus "PreLoebian x"
    using PreLoebian_def by blast
next
  assume a: "PreLoebian x"
  {
    fix y
    assume b: "\<Omega> x y = 0"
    hence "d y \<le> |x\<rangle> d y"
      using omega_zero_equiv_1 by auto
    hence "d y = 0"
      by (metis (no_types) PreLoebian_def a b a_one a_zero add_zeror annir fdia_def less_eq_def)
  }
  thus "Noetherian x"
    by (simp add: Noetherian_def)
qed

lemma Loebian_imp_Noetherian: "Loebian x \<Longrightarrow> Noetherian x"
proof -
  assume a: "Loebian x"
  {
    fix y
    assume b: "\<Omega> x y = 0"
    hence "d y \<le> |x\<rangle> d y"
      using omega_zero_equiv_1 by auto
    also have "... \<le> |x\<rangle> (\<Omega> x y)"
      using Loebian_def a by auto
    finally have "d y = 0"
      by (simp add: b order.antisym fdia_def)
  }
  thus "Noetherian x"
    by (simp add: Noetherian_def)
qed

lemma d_transitive: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> (\<forall>y. |x\<rangle> y = |x\<^sup>\<star>\<rangle> |x\<rangle> y)"
proof -
  assume a: "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
  {
    fix y
    have "|x\<rangle> y + |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
      by (simp add: a)
    hence "|x\<^sup>\<star>\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
      using local.dka.fd_def local.dka.fdia_star_induct_var by auto
    have "|x\<rangle> y \<le> |x\<^sup>\<star>\<rangle> |x\<rangle> y"
      using local.dka.fd_def local.order_prop opti_iterate by force
  }
  thus ?thesis
    using a order.antisym dka.fd_def dka.fdia_star_induct_var by auto
qed

lemma d_transitive_var: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> (\<forall>y. |x\<rangle> y = |x\<rangle> |x\<^sup>\<star>\<rangle> y)"
proof -
  assume "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
  then have "\<forall>a. |x\<rangle> |x\<^sup>\<star>\<rangle> a = |x\<rangle> a"
    by (metis (full_types) d_transitive local.dka.fd_def local.dka.fdia_d_simp local.star_slide_var mult_assoc)
  then show ?thesis
    by presburger
qed

lemma d_transitive_PreLoebian_imp_Loebian: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> PreLoebian x \<Longrightarrow> Loebian x"
proof -
  assume wt: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y)"
  and "PreLoebian x"
  hence "\<forall>y. |x\<rangle> y \<le> |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y"
    using PreLoebian_def local.ads_d_def local.dka.fd_def local.ds.fd_iso1 by auto
  hence "\<forall>y. |x\<rangle> y \<le> |x\<rangle> \<Omega> x y"
    by (metis wt d_transitive_var)
  then show "Loebian x"
    using Loebian_def fdia_def by auto
qed

lemma d_transitive_Noetherian_iff_Loebian: "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y \<Longrightarrow> Noetherian x \<longleftrightarrow> Loebian x"
  using Loebian_imp_Noetherian Noetherian_iff_PreLoebian d_transitive_PreLoebian_imp_Loebian by blast

lemma Loeb_iff_box_Loeb: "Loebian x \<longleftrightarrow> (\<forall>y. |x] (ad ( |x] y ) + d y) \<le> |x] y)"
proof -
  have "Loebian x \<longleftrightarrow> (\<forall>y. |x\<rangle> y \<le> |x\<rangle> (d y \<cdot> |x] (ad y)))"
    using Loebian_def omega_fbox by auto
  also have "... \<longleftrightarrow> (\<forall>y. ad ( |x\<rangle> (d y \<cdot> |x] (ad y)) ) \<le> ad ( |x\<rangle> y ))"
    using a_antitone' fdia_def by fastforce
  also have "... \<longleftrightarrow> (\<forall>y. |x] ad (d y \<cdot> |x] (ad y)) \<le> |x] (ad y))"
    by (simp add: fdia_fbox_de_morgan_2)
  also have "... \<longleftrightarrow> (\<forall>y. |x] (d (ad y) + ad ( |x] (ad y) )) \<le> |x] (ad y))"
    by (simp add: local.ads_d_def local.fbox_def)
  finally show ?thesis
    by (metis add_commute local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def)
qed

end

subsection \<open>Divergence Kleene Algebras and Separation of Termination\<close>

text \<open>The notion of divergence has been added to modal Kleene algebras in~\cite{DesharnaisMoellerStruthLMCS}.
More facts about divergence could be added in the future. Some could be adapted from omega algebras.\<close>

class nabla_op =
  fixes nabla :: "'a \<Rightarrow> 'a" ("\<nabla>_" [999] 1000)

class fdivergence_kleene_algebra = antidomain_kleene_algebra + nabla_op +
  assumes nabla_closure [simp]: "d \<nabla> x = \<nabla> x"
  and nabla_unfold: "\<nabla> x \<le> |x\<rangle> \<nabla> x"
  and nabla_coinduction: "d y \<le> |x\<rangle> y + d z \<Longrightarrow> d y \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> z"

begin

lemma nabla_coinduction_var: "d y \<le> |x\<rangle> y \<Longrightarrow> d y \<le> \<nabla> x"
proof -
  assume "d y \<le> |x\<rangle> y"
  hence "d y \<le> |x\<rangle> y + d 0"
    by simp
  hence "d y \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> 0"
    using nabla_coinduction by blast
  thus "d y \<le> \<nabla> x"
    by (simp add: fdia_def)
qed

lemma nabla_unfold_eq [simp]: "|x\<rangle> \<nabla> x = \<nabla> x"
proof -
  have f1: "ad (ad (x \<cdot> \<nabla>x)) = ad (ad (x \<cdot> \<nabla>x)) + \<nabla>x"
    using local.ds.fd_def local.join.sup.order_iff local.nabla_unfold by presburger
  then have "ad (ad (x \<cdot> \<nabla>x)) \<cdot> ad (ad \<nabla>x) = \<nabla>x"
    by (metis local.ads_d_def local.dpdz.dns5 local.dpdz.dsg4 local.join.sup_commute local.nabla_closure)
  then show ?thesis
    using f1 by (metis local.ads_d_def local.ds.fd_def local.ds.fd_subdist_2 local.join.sup.order_iff local.join.sup_commute nabla_coinduction_var)
qed

lemma nabla_subdist: "\<nabla> x \<le> \<nabla> (x + y)"
proof -
  have "d \<nabla> x \<le> \<nabla> (x + y)"
    by (metis local.ds.fd_iso2 local.join.sup.cobounded1 local.nabla_closure nabla_coinduction_var nabla_unfold_eq)
  thus ?thesis
    by simp
qed

lemma nabla_iso: "x \<le> y \<Longrightarrow> \<nabla> x \<le> \<nabla> y"
  by (metis less_eq_def nabla_subdist)

lemma nabla_omega: "\<Omega> x (d y) = 0 \<Longrightarrow> d y \<le> \<nabla> x"
  using omega_zero_equiv_1 nabla_coinduction_var by fastforce

lemma nabla_noether: "\<nabla> x = 0 \<Longrightarrow> Noetherian x"
  using local.join.le_bot local.noetherian_alt nabla_coinduction_var by blast

lemma nabla_preloeb: "\<nabla> x = 0 \<Longrightarrow> PreLoebian x"
  using Noetherian_iff_PreLoebian nabla_noether by auto

lemma star_nabla_1 [simp]: "|x\<^sup>\<star>\<rangle> \<nabla> x = \<nabla> x"
proof (rule order.antisym)
  show "|x\<^sup>\<star>\<rangle> \<nabla> x \<le> \<nabla> x"
    by (metis dka.fdia_star_induct_var order.eq_iff nabla_closure nabla_unfold_eq)
  show "\<nabla> x \<le> |x\<^sup>\<star>\<rangle> \<nabla> x"
    by (metis ds.fd_iso2 star_ext nabla_unfold_eq)
qed

lemma nabla_sum_expand [simp]: "|x\<rangle> \<nabla> (x + y) + |y\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
proof -
  have "d ((x + y) \<cdot> \<nabla>(x + y)) = \<nabla>(x + y)"
    using local.dka.fd_def nabla_unfold_eq by presburger
  thus ?thesis
    by (simp add: local.dka.fd_def)
qed

lemma wagner_3:
  assumes "d z + |x\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
  shows "\<nabla> (x + y) = \<nabla> x + |x\<^sup>\<star>\<rangle> z"
proof (rule order.antisym)
  have "d \<nabla>(x + y) \<le> d z + |x\<rangle> \<nabla>(x + y)"
    by (simp add: assms)
  thus "\<nabla> (x + y) \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> z"
    by (metis add_commute nabla_closure nabla_coinduction)
  have "d z + |x\<rangle> \<nabla> (x + y) \<le> \<nabla> (x + y)"
    using assms by auto
  hence "|x\<^sup>\<star>\<rangle> z \<le> \<nabla> (x + y)"
    by (metis local.dka.fdia_star_induct local.nabla_closure)
  thus "\<nabla> x + |x\<^sup>\<star>\<rangle> z \<le> \<nabla> (x + y)"
    by (simp add: sup_least nabla_subdist)
qed

lemma nabla_sum_unfold [simp]: "\<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
proof -
  have "\<nabla> (x + y) = |x\<rangle> \<nabla> (x + y) + |y\<rangle> \<nabla> (x + y)"
    by simp
  thus ?thesis
    by (metis add_commute local.dka.fd_def local.ds.fd_def local.ds.fdia_d_simp wagner_3)
qed

lemma nabla_separation: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> \<Longrightarrow> (\<nabla> (x + y) = \<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y)"
proof (rule order.antisym)
  assume quasi_comm: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  hence a: "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    using quasicomm_var by blast
  have "\<nabla> (x + y) = \<nabla> y + |y\<^sup>\<star>\<cdot> x\<rangle> \<nabla> (x + y)"
    by (metis local.ds.fdia_mult local.join.sup_commute nabla_sum_unfold)
  also have "... \<le> \<nabla> y + |x \<cdot> (x + y)\<^sup>\<star>\<rangle> \<nabla> (x + y)"
    using a local.ds.fd_iso2 local.join.sup.mono by blast
  also have "... = \<nabla> y + |x\<rangle> |(x + y)\<^sup>\<star>\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def mult_assoc)
  finally have "\<nabla> (x + y) \<le> \<nabla> y + |x\<rangle> \<nabla> (x + y)"
    by (metis star_nabla_1)
  thus "\<nabla> (x + y) \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y"
    by (metis add_commute nabla_closure nabla_coinduction)
next
  have "\<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y = \<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> y"
    by simp
  also have "... = \<nabla> x + |x\<^sup>\<star> \<cdot> y\<rangle> \<nabla> y"
    by (simp add: fdia_def mult_assoc)
  also have "... \<le> \<nabla> x + |x\<^sup>\<star> \<cdot> y\<rangle> \<nabla> (x + y)"
    using dpdz.dom_iso eq_refl fdia_def join.sup_ge2 join.sup_mono mult_isol nabla_iso by presburger
  also have "... = \<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def mult_assoc)
  finally show "\<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y \<le> \<nabla> (x + y)"
    by (metis nabla_sum_unfold)
qed

text \<open>The next lemma is a separation of termination theorem by Bachmair and Dershowitz~\cite{bachmair86commutation}.\<close>

lemma bachmair_dershowitz: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> \<Longrightarrow> \<nabla> x + \<nabla> y = 0 \<longleftrightarrow> \<nabla> (x + y) = 0"
proof -
  assume quasi_comm: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  have "\<forall>x. |x\<rangle> 0 = 0"
    by (simp add: fdia_def)
  hence "\<nabla>y = 0 \<Longrightarrow> \<nabla>x + \<nabla>y = 0 \<longleftrightarrow> \<nabla>(x + y) = 0"
    using quasi_comm nabla_separation by presburger
  thus ?thesis
    using add_commute local.join.le_bot nabla_subdist by fastforce
qed

text \<open>The next lemma is a more complex separation of termination theorem by Doornbos,
Backhouse and van der Woude~\cite{doornbos97calculational}.\<close>

lemma separation_of_termination:
assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> + y"
shows "\<nabla> x + \<nabla> y = 0 \<longleftrightarrow> \<nabla> (x + y) = 0"
proof
  assume xy_wf: "\<nabla> x + \<nabla> y = 0"
  hence x_preloeb: "\<nabla> (x + y) \<le> |x\<^sup>\<star>\<rangle> \<Omega> x (\<nabla> (x + y))"
    by (metis PreLoebian_def no_trivial_inverse nabla_closure nabla_preloeb)
  hence y_div: "\<nabla> y = 0"
    using add_commute no_trivial_inverse xy_wf by blast
  have "\<nabla> (x + y) \<le> |y\<rangle> \<nabla> (x + y) + |x\<rangle> \<nabla> (x + y)"
    by (simp add: local.join.sup_commute)
  hence "\<nabla> (x + y) \<cdot> ad ( |x\<rangle> \<nabla> (x + y) ) \<le> |y\<rangle> \<nabla>(x + y)"
    by (simp add: local.da_shunt1 local.dka.fd_def local.join.sup_commute)
  hence "\<Omega> x \<nabla>(x + y) \<le> |y\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def omega_fdia)
  also have "... \<le> |y\<rangle> |x\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y))"
    using local.dpdz.dom_iso local.ds.fd_iso1 x_preloeb by blast
  also have "... = |y \<cdot> x\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: fdia_def mult_assoc)
  also have "... \<le> |x \<cdot> (x + y)\<^sup>\<star> + y\<rangle> (\<Omega> x \<nabla>(x + y))"
    using assms local.ds.fd_iso2 local.lazycomm_var by blast
  also have "... = |x \<cdot> (x + y)\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y)) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: local.dka.fd_def)
  also have "... \<le> |(x \<cdot> (x + y)\<^sup>\<star>)\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    using local.add_iso local.dpdz.domain_1'' local.ds.fd_iso1 local.omega_fdia by auto
  also have "... \<le> |x\<rangle> |(x + y)\<^sup>\<star>\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: fdia_def mult_assoc)
  finally have "\<Omega> x \<nabla>(x + y) \<le> |x\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (metis star_nabla_1)
  hence "\<Omega> x \<nabla>(x + y) \<cdot> ad ( |x\<rangle> \<nabla>(x + y) ) \<le> |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: local.da_shunt1 local.dka.fd_def)
  hence "\<Omega> x \<nabla>(x + y) \<le> |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: omega_fdia mult_assoc)
  hence "(\<Omega> x \<nabla>(x + y)) = 0"
    by (metis noetherian_alt omega_dom nabla_noether y_div)
  thus "\<nabla> (x + y) = 0"
    using local.dka.fd_def local.join.le_bot x_preloeb by auto
next
  assume "\<nabla> (x + y) = 0"
  thus "(\<nabla> x) + (\<nabla> y) = 0"
    by (metis local.join.le_bot local.join.sup.order_iff local.join.sup_commute nabla_subdist)
qed

text \<open>The final examples can be found in~\cite{guttmannstruthweber11algmeth}.\<close>

definition T :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_ \<leadsto> _ \<leadsto> _" [61,61,61] 60)
  where "p\<leadsto>x\<leadsto>q \<equiv> ad p + |x] d q"

lemma T_d [simp]: "d (p\<leadsto>x\<leadsto>q) = p\<leadsto>x\<leadsto>q"
  using T_def local.a_d_add_closure local.fbox_def by auto

lemma T_p: "d p \<cdot> (p\<leadsto>x\<leadsto>q) = d p \<cdot> |x] d q"
proof -
  have "d p \<cdot> (p\<leadsto>x\<leadsto>q) = ad (ad p + ad (p\<leadsto>x\<leadsto>q))"
    using T_d local.ads_d_def by auto
  thus ?thesis
    using T_def add_commute local.a_mult_add local.ads_d_def by auto
qed

lemma T_a [simp]: "ad p \<cdot> (p\<leadsto>x\<leadsto>q) = ad p"
  by (metis T_d T_def local.a_d_closed local.ads_d_def local.apd_d_def local.dpdz.dns5 local.join.sup.left_idem)

lemma T_seq: "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>y\<leadsto>s) \<le> p\<leadsto>x \<cdot> y\<leadsto>s"
proof -
  have f1: "|x] q = |x] d q"
    using local.fbox_simp by auto
  have "ad p \<cdot> ad (x \<cdot> ad (q\<leadsto>y\<leadsto>s)) + |x] d q \<cdot> |x] (ad q + |y] d s) \<le> ad p + |x] d q \<cdot> |x] (ad q + |y] d s)"
    using local.a_subid_aux2 local.add_iso by blast
  hence "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>y\<leadsto>s) \<le> ad p + |x](d q \<cdot> (q\<leadsto>y\<leadsto>s))"
    by (metis T_d T_def f1 local.distrib_right' local.fbox_add1 local.fbox_def)
  also have "... = ad p + |x](d q \<cdot> (ad q + |y] d s))"
    by (simp add: T_def)
  also have "... = ad p + |x](d q \<cdot> |y] d s)"
    using T_def T_p by auto
  also have "... \<le> ad p + |x] |y] d s"
    by (metis (no_types, lifting) dka.dom_subid_aux2 dka.dsg3 order.eq_iff fbox_iso join.sup.mono)
  finally show ?thesis
    by (simp add: T_def fbox_mult)
qed

lemma T_square: "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<le> p\<leadsto>x\<cdot>x\<leadsto>p"
  by (simp add: T_seq)

lemma T_segerberg [simp]: "d p \<cdot> |x\<^sup>\<star>](p\<leadsto>x\<leadsto>p) = |x\<^sup>\<star>] d p"
  using T_def add_commute local.fbox_segerberg local.fbox_simp by force

lemma lookahead [simp]: "|x\<^sup>\<star>](d p \<cdot> |x] d p) = |x\<^sup>\<star>] d p"
  by (metis (full_types) local.dka.dsg3 local.fbox_add1 local.fbox_mult local.fbox_simp local.fbox_star_unfold_var local.star_slide_var local.star_trans_eq)

lemma alternation: "d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>](d q \<cdot> (p\<leadsto>x\<leadsto>q))"
proof -
  have fbox_simp_2: "\<And>x p. |x]p = d( |x] p )"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def by fastforce
  have "|(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q)) \<le> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p))"
    using local.dka.domain_1'' local.fbox_iso local.order_trans by blast
  also have "... \<le> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p)"
    using T_seq local.dka.dom_iso local.fbox_iso by blast
  finally have 1: "|(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q)) \<le> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p)".
  have "d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) = d p \<cdot> |1+x] |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (metis (full_types) fbox_mult meyer_1)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    using fbox_simp_2 fbox_mult fbox_add2 mult_assoc by auto
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>\<cdot>x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (simp add: star_slide)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (simp add: fbox_mult)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)))"
    by (metis T_d fbox_simp_2 local.dka.dom_mult_closed local.fbox_add1 mult_assoc)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
  proof -
    have f1: "d ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) = (q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)"
      by (metis (full_types) T_d fbox_simp_2 local.dka.dsg3)
    then have "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = |(x \<cdot> x)\<^sup>\<star>] d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> |(x \<cdot> x)\<^sup>\<star>] ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))"
      by (metis (full_types) fbox_simp_2 local.fbox_add1)
    then have f2: "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = ad ((x \<cdot> x)\<^sup>\<star> \<cdot> ad ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) + (x \<cdot> x)\<^sup>\<star> \<cdot> ad (d ( |x] (q \<leadsto> x \<leadsto> p))))"
      by (simp add: add_commute local.fbox_def)
    have "d ( |x] (p \<leadsto> x \<leadsto> q)) \<cdot> d ( |x] (q \<leadsto> x \<leadsto> p)) = |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p))"
      by (metis (no_types) T_d fbox_simp_2 local.fbox_add1)
    then have "d ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) \<cdot> d (d ( |x] (q \<leadsto> x \<leadsto> p))) = (q \<leadsto> x \<leadsto> p) \<cdot> |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p))"
      using f1 fbox_simp_2 mult_assoc by force
    then have "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = |(x \<cdot> x)\<^sup>\<star>] ((q \<leadsto> x \<leadsto> p) \<cdot> |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p)))"
      using f2 by (metis (no_types) local.ans4 local.fbox_add1 local.fbox_def)
    then show ?thesis
      by (metis (no_types) T_d fbox_simp_2 local.dka.dsg3 local.fbox_add1 mult_assoc)
  qed
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p) \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))" using "1"
    by (metis fbox_simp_2 dka.dns5 dka.dsg4 join.sup.absorb2 mult_assoc)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    using T_segerberg local.a_d_closed local.ads_d_def local.apd_d_def local.distrib_left local.fbox_def mult_assoc by auto
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x] d q \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    by (simp add: T_p)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x] d q \<cdot> |x] |x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    by (metis T_d T_p fbox_simp_2 fbox_add1 fbox_simp mult_assoc)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x] d q \<cdot> |x](p\<leadsto>x\<leadsto>q))"
  proof -
    have f1: "ad (x \<cdot> ad ( |x] d p)) = |x \<cdot> x] d p"
      using local.fbox_def local.fbox_mult by presburger
    have f2: "ad (d q \<cdot> d (x \<cdot> ad (d p))) = q \<leadsto> x \<leadsto> p"
      by (simp add: T_def local.a_de_morgan_var_4 local.fbox_def)
    have "ad q + |x] d p = ad (d q \<cdot> d (x \<cdot> ad (d p)))"
      by (simp add: local.a_de_morgan_var_4 local.fbox_def)
    then have "ad (x \<cdot> ad ( |x] d p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] d q) = ad (x \<cdot> ad ( |x] d p)) \<cdot> ad (x \<cdot> ad (d q)) \<cdot> (ad q + |x] d p)"
      using f2 by (metis (no_types) local.am2 local.fbox_def mult_assoc)
    then show ?thesis
      using f1 by (simp add: T_def local.am2 local.fbox_def mult_assoc)
  qed
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](d q \<cdot> (p\<leadsto>x\<leadsto>q)))"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.distrib_left local.fbox_def mult_assoc by auto
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p) \<cdot> |(x\<cdot>x)\<^sup>\<star>](q\<leadsto>x\<leadsto>p) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x](d q \<cdot> (p\<leadsto>x\<leadsto>q))"
    by (metis T_d fbox_simp_2 local.dka.dom_mult_closed local.fbox_add1)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x] (d q \<cdot> (p\<leadsto>x\<leadsto>q))"
    by (metis T_d local.fbox_add1 local.fbox_simp lookahead)
  finally show ?thesis
    by (metis fbox_mult star_slide)
qed

lemma "|(x\<cdot>x)\<^sup>\<star>] d p \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>] ad p = d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>ad p) \<cdot> (ad p\<leadsto>x\<leadsto>p))"
  using alternation local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma "|x\<^sup>\<star>] d p = d p \<cdot> |x\<^sup>\<star>](p\<leadsto>x\<leadsto>p)"
  by (simp add: alternation)

end

end