section \<open>Stochastic Matrices\<close>

text \<open>We define a type for stochastic vectors and right-stochastic matrices,
 i.e., non-negative real vectors and matrices where the sum of each column is 1.
 For this type we define a matrix-vector multplication, i.e., we show that
 $A * v$ is a stochastic vector, if $A$ is a right-stochastic matrix and $v$
 a stochastic vector.
\<close>
theory Stochastic_Matrix
  imports Perron_Frobenius.Perron_Frobenius_Aux (* for non_neg_mat *)
begin

definition non_neg_vec :: "'a :: linordered_idom ^ 'n \<Rightarrow> bool" where
  "non_neg_vec A \<equiv> (\<forall> i. A $ i \<ge> 0)"

definition stoch_vec :: "'a :: comm_ring_1 ^ 'n \<Rightarrow> bool" where
  "stoch_vec v = (sum (\<lambda> i. v $ i) UNIV = 1)"

definition right_stoch_mat :: "'a :: comm_ring_1 ^ 'n ^ 'm \<Rightarrow> bool" where
  "right_stoch_mat a = (\<forall> j. stoch_vec (column j a))"

typedef 'i st_mat = "{ a :: real ^ 'i ^ 'i. non_neg_mat a \<and> right_stoch_mat a}"
  morphisms st_mat Abs_st_mat
  by (rule exI[of _ "\<chi> i j. if i = undefined then 1 else 0"],
      auto simp: non_neg_mat_def elements_mat_h_def right_stoch_mat_def stoch_vec_def column_def)

setup_lifting type_definition_st_mat

typedef 'i st_vec = "{ v :: real ^ 'i. non_neg_vec v \<and> stoch_vec v}"
  morphisms st_vec Abs_st_vec
  by (rule exI[of _ "\<chi> i. if i = undefined then 1 else 0"],
      auto simp: non_neg_vec_def stoch_vec_def)

setup_lifting type_definition_st_vec

lift_definition transition_vec_of_st_mat :: "'i :: finite st_mat \<Rightarrow> 'i \<Rightarrow> 'i st_vec"
  is "\<lambda> a i. column i a"
  by (auto simp: right_stoch_mat_def non_neg_mat_def stoch_vec_def
      elements_mat_h_def non_neg_vec_def column_def)

lemma non_neg_vec_st_vec: "non_neg_vec (st_vec v)"
  by (transfer, auto)

lemma non_neg_mat_mult_non_neg_vec: "non_neg_mat a \<Longrightarrow> non_neg_vec v \<Longrightarrow>
  non_neg_vec (a *v v)"
  unfolding non_neg_mat_def non_neg_vec_def  elements_mat_h_def
  by (auto simp: matrix_vector_mult_def intro!: sum_nonneg)

lemma right_stoch_mat_mult_stoch_vec: assumes "right_stoch_mat a" and "stoch_vec v"
shows "stoch_vec (a *v v)"
proof -
  note * = assms[unfolded right_stoch_mat_def column_def stoch_vec_def, simplified]
  have "stoch_vec (a *v v) = ((\<Sum>i\<in>UNIV. \<Sum>j\<in>UNIV. a $ i $ j * v $ j) = 1)"
    (is "_ = (?sum = 1)")
    unfolding stoch_vec_def matrix_vector_mult_def by auto
  also have "?sum = (\<Sum>j\<in>UNIV. \<Sum>i\<in>UNIV. a $ i $ j * v $ j)"
    by (rule sum.swap)
  also have "\<dots> = (\<Sum>j\<in>UNIV. v $ j)"
    by (rule sum.cong[OF refl], insert *, auto simp: sum_distrib_right[symmetric])
  also have "\<dots> = 1" using * by auto
  finally show ?thesis by simp
qed

lift_definition st_mat_times_st_vec :: "'i :: finite st_mat \<Rightarrow> 'i st_vec \<Rightarrow> 'i st_vec"
  (infixl "*st" 70) is "(*v)"
  using right_stoch_mat_mult_stoch_vec non_neg_mat_mult_non_neg_vec by auto

lift_definition to_st_vec :: "real ^ 'i \<Rightarrow> 'i st_vec" is
  "\<lambda> x. if stoch_vec x \<and> non_neg_vec x then x else (\<chi> i. if i = undefined then 1 else 0)"
  by (auto simp: non_neg_vec_def stoch_vec_def)

lemma right_stoch_mat_st_mat: "right_stoch_mat (st_mat A)"
  by transfer auto

lemma non_neg_mat_st_mat: "non_neg_mat (st_mat A)"
  by (transfer, auto simp: non_neg_mat_def elements_mat_h_def)

lemma st_mat_mult_st_vec: "st_mat A *v st_vec X = st_vec (A *st X)" by (transfer, auto)

lemma st_vec_nonneg[simp]: "st_vec x $ i \<ge> 0"
  using non_neg_vec_st_vec[of x] by (auto simp: non_neg_vec_def)

lemma st_mat_nonneg[simp]: "st_mat x $ i $h j \<ge> 0"
  using non_neg_mat_st_mat[of x] by (auto simp: non_neg_mat_def elements_mat_h_def)

end


(*
  File:    Data_Structures/Time_Functions.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Time functions for various standard library operations\<close>
theory Time_Funs
  imports MainRLT
begin

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

lemma T_length_eq: "T_length xs = length xs + 1"
  by (induction xs) auto

lemmas [simp del] = T_length.simps

fun T_map  :: "('a \<Rightarrow> nat) \<Rightarrow> 'a list \<Rightarrow> nat" where
  "T_map T_f [] = 1"
| "T_map T_f (x # xs) = T_f x + T_map T_f xs + 1"

lemma T_map_eq: "T_map T_f xs = (\<Sum>x\<leftarrow>xs. T_f x) + length xs + 1"
  by (induction xs) auto

lemmas [simp del] = T_map.simps

fun T_filter  :: "('a \<Rightarrow> nat) \<Rightarrow> 'a list \<Rightarrow> nat" where
  "T_filter T_p [] = 1"
| "T_filter T_p (x # xs) = T_p x + T_filter T_p xs + 1"

lemma T_filter_eq: "T_filter T_p xs = (\<Sum>x\<leftarrow>xs. T_p x) + length xs + 1"
  by (induction xs) auto

lemmas [simp del] = T_filter.simps

fun T_nth :: "'a list \<Rightarrow> nat \<Rightarrow> nat" where
  "T_nth [] n = 1"
| "T_nth (x # xs) n = (case n of 0 \<Rightarrow> 1 | Suc n' \<Rightarrow> T_nth xs n' + 1)"

lemma T_nth_eq: "T_nth xs n = min n (length xs) + 1"
  by (induction xs n rule: T_nth.induct) (auto split: nat.splits)

lemmas [simp del] = T_nth.simps

fun T_take :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
  "T_take n [] = 1"
| "T_take n (x # xs) = (case n of 0 \<Rightarrow> 1 | Suc n' \<Rightarrow> T_take n' xs + 1)"

lemma T_take_eq: "T_take n xs = min n (length xs) + 1"
  by (induction xs arbitrary: n) (auto split: nat.splits)

fun T_drop :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
  "T_drop n [] = 1"
| "T_drop n (x # xs) = (case n of 0 \<Rightarrow> 1 | Suc n' \<Rightarrow> T_drop n' xs + 1)"

lemma T_drop_eq: "T_drop n xs = min n (length xs) + 1"
  by (induction xs arbitrary: n) (auto split: nat.splits)

end


section \<open> Simple UTP real-time theory \<close>

theory utp_simple_time imports "UTP.utp" begin

text \<open> In this section we give a small example UTP theory, and show how Isabelle/UTP can be
  used to automate production of programming laws. \<close>

subsection \<open> Observation Space and Signature \<close>

text \<open> We first declare the observation space for our theory of timed relations. It consists
  of two variables, to denote time and the program state, respectively. \<close>

alphabet 's rt =
  clock :: nat  st :: 's

text \<open> A timed relation is a homogeneous relation over the declared observation space. \<close>

type_synonym 's time_rel = "'s rt hrel"

text \<open> We introduce the following operator for adding an $n$-unit delay to a timed relation. \<close>

utp_def Wait :: "nat \<Rightarrow> 's time_rel" where
"Wait(n) = ($clock\<acute> = $clock + \<guillemotleft>n\<guillemotright> \<and> $st\<acute> = $st)"

subsection \<open> UTP Theory \<close>

text \<open> We define a single healthiness condition which ensures that the clock monotonically
  advances, and so forbids reverse time travel. \<close>

utp_def HT :: "'s time_rel \<Rightarrow> 's time_rel" where
"HT(P) = (P \<and> $clock \<le> $clock\<acute>)"

text \<open> This healthiness condition is idempotent, monotonic, and also continuous, meaning it
  distributes through arbitary non-empty infima. \<close>

theorem HT_idem: "HT(HT(P)) = HT(P)" by rel_auto

theorem HT_mono: "P \<sqsubseteq> Q \<Longrightarrow> HT(P) \<sqsubseteq> HT(Q)" by rel_auto

theorem HT_continuous: "Continuous HT" by rel_auto

text \<open> We now create the UTP theory object for timed relations. This is done using a local
  interpretation @{term "utp_theory_continuous HT"}. This raises the proof obligations
  that @{term HT} is both idempotent and continuous, which we have proved already.
  The result of this command is a collection of theorems that can be derived from these
  facts. Notably, we obtain a complete lattice of timed relations via the Knaster-Tarski theorem.
  We also apply some locale rewrites so that the theorems that are exports have a more intuitive
  form. \<close>

interpretation time_theory: utp_theory_continuous HT
  rewrites "P \<in> carrier time_theory.thy_order \<longleftrightarrow> P is HT"
  and "carrier time_theory.thy_order \<rightarrow> carrier time_theory.thy_order \<equiv> \<lbrakk>HT\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>HT\<rbrakk>\<^sub>H"
  and "le time_theory.thy_order = (\<sqsubseteq>)"
  and "eq time_theory.thy_order = (=)"
proof -
  show "utp_theory_continuous HT"
  proof
    show "\<And>P. HT (HT P) = HT P"
      by (simp add: HT_idem)
    show "Continuous HT"
      by (simp add: HT_continuous)
  qed
qed (simp_all)

text \<open> The object \textit{time-theory} is a new namespace that contains both definitions and theorems.
  Since the theory forms a complete lattice, we obtain a top element, bottom element, and a
  least fixed-point constructor. We give all of these some intuitive syntax. \<close>

notation time_theory.utp_top ("\<top>\<^sub>t")
notation time_theory.utp_bottom ("\<bottom>\<^sub>t")
notation time_theory.utp_lfp ("\<mu>\<^sub>t")

text \<open> Below is a selection of theorems that have been exported by the locale interpretation. \<close>

thm time_theory.bottom_healthy
thm time_theory.top_higher
thm time_theory.meet_bottom
thm time_theory.LFP_unfold

subsection \<open> Closure Laws \<close>

text \<open> @{term HT} applied to @{term Wait} has no affect, since the latter always advances time. \<close>

lemma HT_Wait: "HT(Wait(n)) = Wait(n)" by (rel_auto)

lemma HT_Wait_closed [closure]: "Wait(n) is HT"
  by (simp add: HT_Wait Healthy_def)

text \<open> Relational identity, @{term II}, is likewise @{term HT}-healthy. \<close>

lemma HT_skip_closed [closure]: "II is HT"
  by (rel_auto)

text \<open> @{term HT} is closed under sequential composition, which can be shown
  by transitivity of @{term "(\<le>)"}. \<close>

lemma HT_seqr_closed [closure]:
  "\<lbrakk> P is HT; Q is HT \<rbrakk> \<Longrightarrow> P ;; Q is HT"
  by (rel_auto, meson dual_order.trans) \<comment> \<open> Sledgehammer required \<close>

text \<open> Assignment is also healthy, provided that the clock variable is not assigned. \<close>

lemma HT_assign_closed [closure]: "\<lbrakk> vwb_lens x; clock \<bowtie> x \<rbrakk> \<Longrightarrow> x := v is HT"
  by (rel_auto, metis (mono_tags, lifting) eq_iff lens.select_convs(1) lens_indep_get rt.select_convs(1))

text \<open> An alternative characterisation of the above is that @{term x} is within the state space lens. \<close>

lemma HT_assign_closed' [closure]: "\<lbrakk> vwb_lens x; x \<subseteq>\<^sub>L st \<rbrakk> \<Longrightarrow> x := v is HT"
  by (rel_auto)

subsection \<open> Algebraic Laws \<close>

text \<open> Finally, we prove some useful algebraic laws. \<close>

theorem Wait_skip: "Wait(0) = II" by (rel_auto)

theorem Wait_Wait: "Wait(m) ;; Wait(n) = Wait (m + n)" by (rel_auto)

theorem Wait_cond: "Wait(m) ;; (P \<triangleleft> b \<triangleright>\<^sub>r Q) = (Wait m ;; P) \<triangleleft> b\<lbrakk>&clock+\<guillemotleft>m\<guillemotright>/&clock\<rbrakk> \<triangleright>\<^sub>r (Wait m ;; Q)"
  by (rel_auto)

lemma Wait_eq_assign: "Wait(m) = clock := clock + \<guillemotleft>m\<guillemotright>"
  by (rel_auto)

theorem Wait_assign:
  assumes "clock \<sharp> v" "x \<bowtie> clock"
  shows "Wait(m) ;; x := v = x := v ;; Wait(m)"
  by (simp add: Wait_eq_assign assigns_comp usubst unrest assms lens_indep_sym)

end


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

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

datatype Tree = TNode "Tree" "int" "Tree" | TNil

fun insert :: "int => int list => int list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

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

fun add :: "int => Tree => Tree" where
"add x (TNode p z q) =
   (if x <= z then TNode (add x p) z q else TNode p z (add x q))"
| "add x (TNil) = TNode TNil x TNil"

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

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

theorem property0 :
  "((tsort xs) = (isort xs))"
  oops

end


section \<open>Set Cover\<close>

theory Approx_SC_Hoare
imports
  "HOL-Hoare.Hoare_Logic"
  Complex_Main (* "HOL-Analysis.Harmonic_Numbers" *)
begin

text \<open>This is a formalization of the set cover algorithm and proof
in the book by Kleinberg and Tardos \<^cite>\<open>"KleinbergT06"\<close>.\<close>

definition harm :: "nat \<Rightarrow> 'a :: real_normed_field" where
  "harm n = (\<Sum>k=1..n. inverse (of_nat k))"
(* For simplicity defined locally instead of importing HOL-Analysis.Harmonic_Numbers.
   Only the definition, no theorems are needed.
*)

locale Set_Cover = (* Set Cover *)
  fixes w :: "nat \<Rightarrow> real"
    and m :: nat
    and S :: "nat \<Rightarrow> 'a set"
  assumes S_finite: "\<forall>i \<in> {1..m}. finite (S i)"
      and w_nonneg: "\<forall>i. 0 \<le> w i"
begin

definition U :: "'a set" where
  "U = (\<Union>i \<in> {1..m}. S i)"

lemma S_subset: "\<forall>i \<in> {1..m}. S i \<subseteq> U"
  using U_def by blast

lemma U_finite: "finite U"
  unfolding U_def using S_finite by blast

lemma empty_cover: "m = 0 \<Longrightarrow> U = {}"
  using U_def by simp

definition sc :: "nat set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "sc C X \<longleftrightarrow> C \<subseteq> {1..m} \<and> (\<Union>i \<in> C. S i) = X"

definition cost :: "'a set \<Rightarrow> nat \<Rightarrow> real" where
  "cost R i = w i / card (S i \<inter> R)"

lemma cost_nonneg: "0 \<le> cost R i"
  using w_nonneg by (simp add: cost_def)

text \<open>\<open>cost R i = 0\<close> if \<open>card (S i \<inter> R) = 0\<close>! Needs to be accounted for separately in \<open>min_arg\<close>.\<close>
fun min_arg :: "'a set \<Rightarrow> nat \<Rightarrow> nat" where
  "min_arg R 0 = 1"
| "min_arg R (Suc x) =
   (let j = min_arg R x
    in if S j \<inter> R = {} \<or> (S (Suc x) \<inter> R \<noteq> {} \<and> cost R (Suc x) < cost R j) then (Suc x) else j)"

lemma min_in_range: "k > 0 \<Longrightarrow> min_arg R k \<in> {1..k}"
  by (induction k) (force simp: Let_def)+

lemma min_empty: "S (min_arg R k) \<inter> R = {} \<Longrightarrow> \<forall>i \<in> {1..k}. S i \<inter> R = {}"
proof (induction k)
  case (Suc k)
  from Suc.prems have prem: "S (min_arg R k) \<inter> R = {}" by (auto simp: Let_def split: if_splits)
  with Suc.IH have IH: "\<forall>i \<in> {1..k}. S i \<inter> R = {}" .
  show ?case proof fix i assume "i \<in> {1..Suc k}" show "S i \<inter> R = {}"
    proof (cases \<open>i = Suc k\<close>)
      case True with Suc.prems prem show ?thesis by simp
    next
      case False with IH \<open>i \<in> {1..Suc k}\<close> show ?thesis by simp
    qed
  qed
qed simp

lemma min_correct: "\<lbrakk> i \<in> {1..k}; S i \<inter> R \<noteq> {} \<rbrakk> \<Longrightarrow> cost R (min_arg R k) \<le> cost R i"
proof (induction k)
  case (Suc k)
  show ?case proof (cases \<open>i = Suc k\<close>)
    case True with Suc.prems show ?thesis by (auto simp: Let_def)
  next
    case False with Suc.prems Suc.IH have IH: "cost R (min_arg R k) \<le> cost R i" by simp
    from Suc.prems False min_empty[of R k] have "S (min_arg R k) \<inter> R \<noteq> {}" by force
    with IH show ?thesis by (auto simp: Let_def)
  qed
qed simp

text \<open>Correctness holds quite trivially for both m = 0 and m > 0
      (assuming a set cover can be found at all, otherwise algorithm would not terminate).\<close>
lemma set_cover_correct:
"VARS (R :: 'a set) (C :: nat set) (i :: nat)
  {True}
  R := U; C := {};
  WHILE R \<noteq> {} INV {R \<subseteq> U \<and> sc C (U - R)} DO
  i := min_arg R m;
  R := R - S i;
  C := C \<union> {i}
  OD
  {sc C U}"
proof (vcg, goal_cases)
  case 2 show ?case proof (cases m)
    case 0
    from empty_cover[OF this] 2 show ?thesis by (auto simp: sc_def)
  next
    case Suc then have "m > 0" by simp
    from min_in_range[OF this] 2 show ?thesis using S_subset by (auto simp: sc_def)
  qed
qed (auto simp: sc_def)

definition c_exists :: "nat set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "c_exists C R = (\<exists>c. sum w C = sum c (U - R) \<and> (\<forall>i. 0 \<le> c i)
                \<and> (\<forall>k \<in> {1..m}. sum c (S k \<inter> (U - R))
                   \<le> (\<Sum>j = card (S k \<inter> R) + 1..card (S k). inverse j) * w k))"

definition inv :: "nat set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "inv C R \<longleftrightarrow> sc C (U - R) \<and> R \<subseteq> U \<and> c_exists C R"

lemma invI:
  assumes "sc C (U - R)" "R \<subseteq> U"
          "\<exists>c. sum w C = sum c (U - R) \<and> (\<forall>i. 0 \<le> c i)
        \<and> (\<forall>k \<in> {1..m}. sum c (S k \<inter> (U - R))
                      \<le> (\<Sum>j = card (S k \<inter> R) + 1..card (S k). inverse j) * w k)"
    shows "inv C R" using assms by (auto simp: inv_def c_exists_def)

lemma invD:
  assumes "inv C R"
  shows "sc C (U - R)" "R \<subseteq> U"
        "\<exists>c. sum w C = sum c (U - R) \<and> (\<forall>i. 0 \<le> c i)
      \<and> (\<forall>k \<in> {1..m}. sum c (S k \<inter> (U - R))
                    \<le> (\<Sum>j = card (S k \<inter> R) + 1..card (S k). inverse j) * w k)"
  using assms by (auto simp: inv_def c_exists_def)

lemma inv_init: "inv {} U"
proof (rule invI, goal_cases)
  case 3
  let ?c = "(\<lambda>_. 0) :: 'a \<Rightarrow> real"
  have "sum w {} = sum ?c (U - U)" by simp
  moreover {
    have "\<forall>k \<in> {1..m}. 0 \<le> (\<Sum>j = card (S k \<inter> U) + 1..card (S k). inverse j) * w k"
      by (simp add: sum_nonneg w_nonneg)
    then have "(\<forall>k\<in>{1..m}. sum ?c (S k \<inter> (U - U))
             \<le> (\<Sum>j = card (S k \<inter> U) + 1..card (S k). inverse j) * w k)" by simp
  }
  ultimately show ?case by blast
qed (simp_all add: sc_def)

lemma inv_step:
  assumes "inv C R" "R \<noteq> {}"
  defines [simp]: "i \<equiv> min_arg R m"
  shows "inv (C \<union> {i}) (R - (S i))"
proof (cases m)
  case 0
  from empty_cover[OF this] invD(2)[OF assms(1)] have "R = {}" by blast
  then show ?thesis using assms(2) by simp
next
  case Suc then have "0 < m" by simp
  note hyp = invD[OF assms(1)]
  show ?thesis proof (rule invI, goal_cases)
      \<comment> \<open>Correctness\<close>
    case 1 have "i \<in> {1..m}" using min_in_range[OF \<open>0 < m\<close>] by simp
    with hyp(1) S_subset show ?case by (auto simp: sc_def)
  next
    case 2 from hyp(2) show ?case by auto
  next
    case 3
      \<comment> \<open>Set Cover grows\<close>
    have "\<exists>i \<in> {1..m}. S i \<inter> R \<noteq> {}"
      using assms(2) U_def hyp(2) by blast
    then have "S i \<inter> R \<noteq> {}" using min_empty by auto
    then have "0 < card (S i \<inter> R)"
      using S_finite min_in_range[OF \<open>0 < m\<close>] by auto

      \<comment> \<open>Proving properties of cost function\<close>
    from hyp(3) obtain c where "sum w C = sum c (U - R)" "\<forall>i. 0 \<le> c i" and
      SUM: "\<forall>k\<in>{1..m}. sum c (S k \<inter> (U - R))
        \<le> (\<Sum>j = card (S k \<inter> R) + 1..card (S k). inverse j) * w k" by blast
    let ?c = "(\<lambda>x. if x \<in> S i \<inter> R then cost R i else c x)"

      \<comment> \<open>Proof of Lemma 11.9\<close>
    have "finite (U - R)" "finite (S i \<inter> R)" "(U - R) \<inter> (S i \<inter> R) = {}"
      using U_finite S_finite min_in_range[OF \<open>0 < m\<close>] by auto
    then have "sum ?c (U - R \<union> (S i \<inter> R)) = sum ?c (U - R) + sum ?c (S i \<inter> R)"
      by (rule sum.union_disjoint)
    moreover have U_split: "U - (R - S i) = U - R \<union> (S i \<inter> R)" using hyp(2) by blast
    moreover {
      have "sum ?c (S i \<inter> R) = card (S i \<inter> R) * cost R i" by simp
      also have "... = w i" unfolding cost_def using \<open>0 < card (S i \<inter> R)\<close> by simp
      finally have "sum ?c (S i \<inter> R) = w i" .
    }
    ultimately have "sum ?c (U - (R - S i)) = sum ?c (U - R) + w i" by simp
    moreover {
      have "C \<inter> {i} = {}" using hyp(1) \<open>S i \<inter> R \<noteq> {}\<close> by (auto simp: sc_def)
      from sum.union_disjoint[OF _ _ this] have "sum w (C \<union> {i}) = sum w C + w i"
        using hyp(1) by (auto simp: sc_def intro: finite_subset)
    }
    ultimately have 1: "sum w (C \<union> {i}) = sum ?c (U - (R - S i))" \<comment> \<open>Lemma 11.9\<close>
      using \<open>sum w C = sum c (U - R)\<close> by simp

    have 2: "\<forall>i. 0 \<le> ?c i" using \<open>\<forall>i. 0 \<le> c i\<close> cost_nonneg by simp

      \<comment> \<open>Proof of Lemma 11.10\<close>
    have 3: "\<forall>k\<in>{1..m}. sum ?c (S k \<inter> (U - (R - S i)))
          \<le> (\<Sum>j = card (S k \<inter> (R - S i)) + 1..card (S k). inverse j) * w k"
    proof
      fix k assume "k \<in> {1..m}"
      let ?rem = "S k \<inter> R" \<comment> \<open>Remaining elements to be covered\<close>
      let ?add = "S k \<inter> S i \<inter> R" \<comment> \<open>Elements that will be covered in this step\<close>
      let ?cov = "S k \<inter> (U - R)" \<comment> \<open>Covered elements\<close>

      \<comment> \<open>Transforming left and right sides\<close>
      have "sum ?c (S k \<inter> (U - (R - S i))) = sum ?c (S k \<inter> (U - R \<union> (S i \<inter> R)))"
        unfolding U_split ..
      also have "... = sum ?c (?cov \<union> ?add)"
        by (simp add: Int_Un_distrib Int_assoc)
      also have "... = sum ?c ?cov + sum ?c ?add"
        by (rule sum.union_disjoint) (insert S_finite \<open>k \<in> _\<close>, auto)
      finally have lhs:
        "sum ?c (S k \<inter> (U - (R - S i))) = sum ?c ?cov + sum ?c ?add" .
      have "S k \<inter> (R - S i) = ?rem - ?add" by blast
      then have "card (S k \<inter> (R - S i)) = card (?rem - ?add)" by simp
      also have "... = card ?rem - card ?add"
        using S_finite \<open>k \<in> _\<close> by (auto intro: card_Diff_subset)
      finally have rhs:
        "card (S k \<inter> (R - S i)) + 1 = card ?rem - card ?add + 1" by simp

      \<comment> \<open>The apparent complexity of the remaining proof is deceiving. Much of this is just about
          convincing Isabelle that these sum transformations are allowed.\<close>
      have "sum ?c ?add = card ?add * cost R i" by simp
      also have "... \<le> card ?add * cost R k"
        proof (cases "?rem = {}")
          case True
          then have "card ?add = 0" by (auto simp: card_eq_0_iff)
          then show ?thesis by simp
        next
          case False
          from min_correct[OF \<open>k \<in> _\<close> this] have "cost R i \<le> cost R k" by simp
          then show ?thesis by (simp add: mult_left_mono)
        qed
      also have "... = card ?add * inverse (card ?rem) * w k"
        by (simp add: cost_def divide_inverse_commute)
      also have "... = (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse (card ?rem)) * w k"
        proof -
          have "card ?add \<le> card ?rem"
            using S_finite \<open>k \<in> _\<close> by (blast intro: card_mono)
          then show ?thesis by (simp add: sum_distrib_left)
        qed
      also have "... \<le> (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j) * w k"
        proof -
          have "\<forall>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse (card ?rem) \<le> inverse j"
            by force
          then have "(\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse (card ?rem))
                   \<le> (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j)"
            by (blast intro: sum_mono)
          with w_nonneg show ?thesis by (blast intro: mult_right_mono)
        qed
      finally have "sum ?c ?add
                 \<le> (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j) * w k" .
      moreover from SUM have "sum ?c ?cov
                           \<le> (\<Sum>j \<in> {card ?rem + 1 .. card (S k)}. inverse j) * w k"
        using \<open>k \<in> {1..m}\<close> by simp
      ultimately have "sum ?c (S k \<inter> (U - (R - S i)))
                    \<le> ((\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j) +
                        (\<Sum>j \<in> {card ?rem + 1 .. card (S k)}. inverse j)) * w k"
        unfolding lhs by argo
      also have "... = (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card (S k)}. inverse j) * w k"
        proof -
          have sum_split: "b \<in> {a .. c} \<Longrightarrow> sum f {a .. c} = sum f {a .. b} + sum f {Suc b .. c}"
            for f :: "nat \<Rightarrow> real" and a b c :: nat
          proof -
            assume "b \<in> {a .. c}"
            then have "{a .. b} \<union> {Suc b .. c} = {a .. c}" by force
            moreover have "{a .. b} \<inter> {Suc b .. c} = {}"
              using \<open>b \<in> {a .. c}\<close> by auto
            ultimately show ?thesis by (metis finite_atLeastAtMost sum.union_disjoint)
          qed

          have "(\<Sum>j \<in> {card ?rem - card ?add + 1 .. card (S k)}. inverse j)
              = (\<Sum>j \<in> {card ?rem - card ?add + 1 .. card ?rem}. inverse j)
              + (\<Sum>j \<in> {card ?rem + 1 .. card (S k)}. inverse j)"
            proof (cases \<open>?add = {}\<close>)
              case False
              then have "0 < card ?add" "0 < card ?rem"
                using S_finite \<open>k \<in> _\<close> by fastforce+
              then have "Suc (card ?rem - card ?add) \<le> card ?rem" by simp
              moreover have "card ?rem \<le> card (S k)"
                using S_finite \<open>k \<in> _\<close> by (simp add: card_mono)
              ultimately show ?thesis by (auto intro: sum_split)
            qed simp
          then show ?thesis by algebra
        qed
      finally show "sum ?c (S k \<inter> (U - (R - S i)))
                 \<le> (\<Sum>j \<in> {card (S k \<inter> (R - S i)) + 1 .. card (S k)}. inverse j) * w k"
        unfolding rhs .
    qed

    from 1 2 3 show ?case by blast
  qed
qed

lemma cover_sum:
  fixes c :: "'a \<Rightarrow> real"
  assumes "sc C V" "\<forall>i. 0 \<le> c i"
  shows "sum c V \<le> (\<Sum>i \<in> C. sum c (S i))"
proof -
  from assms(1) have "finite C" by (auto simp: sc_def finite_subset)
  then show ?thesis using assms(1)
  proof (induction C arbitrary: V rule: finite_induct)
    case (insert i C)
    have V_split: "(\<Union> (S ` insert i C)) = (\<Union> (S ` C)) \<union> S i" by auto
    have finite: "finite (\<Union> (S ` C))" "finite (S i)"
      using insert S_finite by (auto simp: sc_def)

    have "sum c (S i) - sum c (\<Union> (S ` C) \<inter> S i) \<le> sum c (S i)"
      using assms(2) by (simp add: sum_nonneg)
    then have "sum c (\<Union> (S ` insert i C)) \<le> sum c (\<Union> (S ` C)) + sum c (S i)"
      unfolding V_split using sum_Un[OF finite, of c] by linarith
    moreover have "(\<Sum>i\<in>insert i C. sum c (S i)) = (\<Sum>i \<in> C. sum c (S i)) + sum c (S i)"
      by (simp add: insert.hyps)
    ultimately show ?case using insert by (fastforce simp: sc_def)
  qed (simp add: sc_def)
qed

abbreviation H :: "nat \<Rightarrow> real" where "H \<equiv> harm"

definition d_star :: nat ("d\<^sup>*") where "d\<^sup>* \<equiv> Max (card ` (S ` {1..m}))"

lemma set_cover_bound:
  assumes "inv C {}" "sc C' U"
  shows "sum w C \<le> H d\<^sup>* * sum w C'"
proof -
  from invD(3)[OF assms(1)] obtain c where
    "sum w C = sum c U" "\<forall>i. 0 \<le> c i" and H_bound:
    "\<forall>k \<in> {1..m}. sum c (S k) \<le> H (card (S k)) * w k" \<comment> \<open>Lemma 11.10\<close>
    by (auto simp: harm_def Int_absorb2 S_subset)

  have "\<forall>k \<in> {1..m}. card (S k) \<le> d\<^sup>*" by (auto simp: d_star_def)
  then have "\<forall>k \<in> {1..m}. H (card (S k)) \<le> H d\<^sup>*" by (auto simp: harm_def intro!: sum_mono2)
  with H_bound have "\<forall>k \<in> {1..m}. sum c (S k) \<le> H d\<^sup>* * w k"
    by (metis atLeastAtMost_iff atLeastatMost_empty_iff empty_iff mult_right_mono w_nonneg)
  moreover have "C' \<subseteq> {1..m}" using assms(2) by (simp add: sc_def)
  ultimately have "\<forall>i \<in> C'. sum c (S i) \<le> H d\<^sup>* * w i" by blast
  then have "(\<Sum>i \<in> C'. sum c (S i)) \<le> H d\<^sup>* * sum w C'"
    by (auto simp: sum_distrib_left intro: sum_mono)

  have "sum w C = sum c U" by fact \<comment> \<open>Lemma 11.9\<close>
  also have "... \<le> (\<Sum>i \<in> C'. sum c (S i))" by (rule cover_sum[OF assms(2)]) fact
  also have "... \<le> H d\<^sup>* * sum w C'" by fact
  finally show ?thesis .
qed

theorem set_cover_approx:
"VARS (R :: 'a set) (C :: nat set) (i :: nat)
  {True}
  R := U; C := {};
  WHILE R \<noteq> {} INV {inv C R} DO
  i := min_arg R m;
  R := R - S i;
  C := C \<union> {i}
  OD
  {sc C U \<and> (\<forall>C'. sc C' U \<longrightarrow> sum w C \<le> H d\<^sup>* * sum w C')}"
proof (vcg, goal_cases)
  case 1 show ?case by (rule inv_init)
next
  case 2 thus ?case using inv_step ..
next
  case (3 R C i)
  then have "sc C U" unfolding inv_def by auto
  with 3 show ?case by (auto intro: set_cover_bound)
qed

end (* Set Cover *)

end (* Theory *)


(*  Title:      HOL/Probability/Convolution.thy
    Author:     Sudeep Kanav, TU München
    Author:     Johannes Hölzl, TU München *)

section {* Convolution Measure *}

theory Convolution
  imports Independent_Family
begin

lemma (in finite_measure) sigma_finite_measure: "sigma_finite_measure M"
  ..

definition convolution :: "('a :: ordered_euclidean_space) measure \<Rightarrow> 'a measure \<Rightarrow> 'a measure" (infix "\<star>" 50) where
  "convolution M N = distr (M \<Otimes>\<^sub>M N) borel (\<lambda>(x, y). x + y)"

lemma
  shows space_convolution[simp]: "space (convolution M N) = space borel"
    and sets_convolution[simp]: "sets (convolution M N) = sets borel"
    and measurable_convolution1[simp]: "measurable A (convolution M N) = measurable A borel"
    and measurable_convolution2[simp]: "measurable (convolution M N) B = measurable borel B"
  by (simp_all add: convolution_def)

lemma nn_integral_convolution:
  assumes "finite_measure M" "finite_measure N"
  assumes [measurable_cong]: "sets N = sets borel" "sets M = sets borel"
  assumes [measurable]: "f \<in> borel_measurable borel"
  shows "(\<integral>\<^sup>+x. f x \<partial>convolution M N) = (\<integral>\<^sup>+x. \<integral>\<^sup>+y. f (x + y) \<partial>N \<partial>M)"
proof -
  interpret M: finite_measure M by fact
  interpret N: finite_measure N by fact
  interpret pair_sigma_finite M N ..
  show ?thesis
    unfolding convolution_def
    by (simp add: nn_integral_distr N.nn_integral_fst[symmetric])
qed

lemma convolution_emeasure:
  assumes "A \<in> sets borel" "finite_measure M" "finite_measure N"
  assumes [simp]: "sets N = sets borel" "sets M = sets borel"
  assumes [simp]: "space M = space N" "space N = space borel"
  shows "emeasure (M \<star> N) A = \<integral>\<^sup>+x. (emeasure N {a. a + x \<in> A}) \<partial>M "
  using assms by (auto intro!: nn_integral_cong simp del: nn_integral_indicator simp: nn_integral_convolution
    nn_integral_indicator [symmetric] ac_simps split:split_indicator)

lemma convolution_emeasure':
  assumes [simp]:"A \<in> sets borel"
  assumes [simp]: "finite_measure M" "finite_measure N"
  assumes [simp]: "sets N = sets borel" "sets M = sets borel"
  shows  "emeasure (M \<star> N) A = \<integral>\<^sup>+x. \<integral>\<^sup>+y.  (indicator  A (x + y)) \<partial>N  \<partial>M"
  by (auto simp del: nn_integral_indicator simp: nn_integral_convolution
    nn_integral_indicator[symmetric] borel_measurable_indicator)

lemma convolution_finite:
  assumes [simp]: "finite_measure M" "finite_measure N"
  assumes [measurable_cong]: "sets N = sets borel" "sets M = sets borel"
  shows "finite_measure (M \<star> N)"
  unfolding convolution_def
  by (intro finite_measure_pair_measure finite_measure.finite_measure_distr) auto

lemma convolution_emeasure_3:
  assumes [simp, measurable]: "A \<in> sets borel"
  assumes [simp]: "finite_measure M" "finite_measure N" "finite_measure L"
  assumes [simp]: "sets N = sets borel" "sets M = sets borel" "sets L = sets borel"
  shows "emeasure (L \<star> (M \<star> N )) A = \<integral>\<^sup>+x. \<integral>\<^sup>+y. \<integral>\<^sup>+z. indicator A (x + y + z) \<partial>N \<partial>M \<partial>L"
  apply (subst nn_integral_indicator[symmetric], simp)
  apply (subst nn_integral_convolution,
        auto intro!: borel_measurable_indicator borel_measurable_indicator' convolution_finite)+
  by (rule nn_integral_cong)+ (auto simp: semigroup_add_class.add.assoc)

lemma convolution_emeasure_3':
  assumes [simp, measurable]:"A \<in> sets borel"
  assumes [simp]: "finite_measure M" "finite_measure N"  "finite_measure L"
  assumes [measurable_cong, simp]: "sets N = sets borel" "sets M = sets borel" "sets L = sets borel"
  shows "emeasure ((L \<star> M) \<star> N ) A = \<integral>\<^sup>+x. \<integral>\<^sup>+y. \<integral>\<^sup>+z. indicator A (x + y + z) \<partial>N \<partial>M \<partial>L"
  apply (subst nn_integral_indicator[symmetric], simp)+
  apply (subst nn_integral_convolution)
  apply (simp_all add: convolution_finite)
  apply (subst nn_integral_convolution)
  apply (simp_all add: finite_measure.sigma_finite_measure sigma_finite_measure.borel_measurable_nn_integral)
  done

lemma convolution_commutative:
  assumes [simp]: "finite_measure M" "finite_measure N"
  assumes [measurable_cong, simp]: "sets N = sets borel" "sets M = sets borel"
  shows "(M \<star> N) = (N \<star> M)"
proof (rule measure_eqI)
  interpret M: finite_measure M by fact
  interpret N: finite_measure N by fact
  interpret pair_sigma_finite M N ..

  show "sets (M \<star> N) = sets (N \<star> M)" by simp

  fix A assume "A \<in> sets (M \<star> N)"
  then have 1[measurable]:"A \<in> sets borel" by simp
  have "emeasure (M \<star> N) A = \<integral>\<^sup>+x. \<integral>\<^sup>+y. indicator A (x + y) \<partial>N \<partial>M" by (auto intro!: convolution_emeasure')
  also have "... = \<integral>\<^sup>+x. \<integral>\<^sup>+y. (\<lambda>(x,y). indicator A (x + y)) (x, y) \<partial>N \<partial>M" by (auto intro!: nn_integral_cong)
  also have "... = \<integral>\<^sup>+y. \<integral>\<^sup>+x. (\<lambda>(x,y). indicator A (x + y)) (x, y) \<partial>M \<partial>N" by (rule Fubini[symmetric]) simp
  also have "... = emeasure (N \<star> M) A" by (auto intro!: nn_integral_cong simp: add.commute convolution_emeasure')
  finally show "emeasure (M \<star> N) A = emeasure (N \<star> M) A" by simp
qed

lemma convolution_associative:
  assumes [simp]: "finite_measure M" "finite_measure N"  "finite_measure L"
  assumes [simp]: "sets N = sets borel" "sets M = sets borel" "sets L = sets borel"
  shows "(L \<star> (M \<star> N)) = ((L \<star> M) \<star> N)"
  by (auto intro!: measure_eqI simp: convolution_emeasure_3 convolution_emeasure_3')

lemma (in prob_space) sum_indep_random_variable:
  assumes ind: "indep_var borel X borel Y"
  assumes [simp, measurable]: "random_variable borel X"
  assumes [simp, measurable]: "random_variable borel Y"
  shows "distr M borel (\<lambda>x. X x + Y x) = convolution (distr M borel X)  (distr M borel Y)"
  using ind unfolding indep_var_distribution_eq convolution_def
  by (auto simp: distr_distr intro!:arg_cong[where f = "distr M borel"])

lemma (in prob_space) sum_indep_random_variable_lborel:
  assumes ind: "indep_var borel X borel Y"
  assumes [simp, measurable]: "random_variable lborel X"
  assumes [simp, measurable]:"random_variable lborel Y"
  shows "distr M lborel (\<lambda>x. X x + Y x) = convolution (distr M lborel X)  (distr M lborel Y)"
  using ind unfolding indep_var_distribution_eq convolution_def
  by (auto simp: distr_distr o_def intro!: arg_cong[where f = "distr M borel"] cong: distr_cong)

lemma convolution_density:
  fixes f g :: "real \<Rightarrow> ereal"
  assumes [measurable]: "f \<in> borel_measurable borel" "g \<in> borel_measurable borel"
  assumes [simp]:"finite_measure (density lborel f)" "finite_measure (density lborel g)"
  assumes gt_0[simp]: "AE x in lborel. 0 \<le> f x" "AE x in lborel. 0 \<le> g x"
  shows "density lborel f \<star> density lborel g = density lborel (\<lambda>x. \<integral>\<^sup>+y. f (x - y) * g y \<partial>lborel)"
    (is "?l = ?r")
proof (intro measure_eqI)
  fix A assume "A \<in> sets ?l"
  then have [measurable]: "A \<in> sets borel"
    by simp

  have "(\<integral>\<^sup>+x. f x * (\<integral>\<^sup>+y. g y * indicator A (x + y) \<partial>lborel) \<partial>lborel) =
    (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. g y * (f x * indicator A (x + y)) \<partial>lborel) \<partial>lborel)"
    using gt_0
  proof (intro nn_integral_cong_AE, eventually_elim)
    fix x assume "0 \<le> f x"
    then have "f x * (\<integral>\<^sup>+ y. g y * indicator A (x + y) \<partial>lborel) =
      (\<integral>\<^sup>+ y. f x * (g y * indicator A (x + y)) \<partial>lborel)"
      by (intro nn_integral_cmult[symmetric]) auto
    then show "f x * (\<integral>\<^sup>+ y. g y * indicator A (x + y) \<partial>lborel) =
      (\<integral>\<^sup>+ y. g y * (f x * indicator A (x + y)) \<partial>lborel)"
      by (simp add: ac_simps)
  qed
  also have "\<dots> = (\<integral>\<^sup>+y. (\<integral>\<^sup>+x. g y * (f x * indicator A (x + y)) \<partial>lborel) \<partial>lborel)"
    by (intro lborel_pair.Fubini') simp
  also have "\<dots> = (\<integral>\<^sup>+y. (\<integral>\<^sup>+x. f (x - y) * g y * indicator A x \<partial>lborel) \<partial>lborel)"
    using gt_0
  proof (intro nn_integral_cong_AE, eventually_elim)
    fix y assume "0 \<le> g y"
    then have "(\<integral>\<^sup>+x. g y * (f x * indicator A (x + y)) \<partial>lborel) =
      g y * (\<integral>\<^sup>+x. f x * indicator A (x + y) \<partial>lborel)"
      by (intro nn_integral_cmult) auto
    also have "\<dots> = g y * (\<integral>\<^sup>+x. f (x - y) * indicator A x \<partial>lborel)"
      using gt_0
      by (subst nn_integral_real_affine[where c=1 and t="-y"])
         (auto simp del: gt_0 simp add: one_ereal_def[symmetric])
    also have "\<dots> = (\<integral>\<^sup>+x. g y * (f (x - y) * indicator A x) \<partial>lborel)"
      using `0 \<le> g y` by (intro nn_integral_cmult[symmetric]) auto
    finally show "(\<integral>\<^sup>+ x. g y * (f x * indicator A (x + y)) \<partial>lborel) =
      (\<integral>\<^sup>+ x. f (x - y) * g y * indicator A x \<partial>lborel)"
      by (simp add: ac_simps)
  qed
  also have "\<dots> = (\<integral>\<^sup>+x. (\<integral>\<^sup>+y. f (x - y) * g y * indicator A x \<partial>lborel) \<partial>lborel)"
    by (intro lborel_pair.Fubini') simp
  finally show "emeasure ?l A = emeasure ?r A"
    by (auto simp: convolution_emeasure' nn_integral_density emeasure_density
      nn_integral_multc)
qed simp

lemma (in prob_space) distributed_finite_measure_density:
  "distributed M N X f \<Longrightarrow> finite_measure (density N f)"
  using finite_measure_distr[of X N] distributed_distr_eq_density[of M N X f] by simp

lemma (in prob_space) distributed_convolution:
  fixes f :: "real \<Rightarrow> _"
  fixes g :: "real \<Rightarrow> _"
  assumes indep: "indep_var borel X borel Y"
  assumes X: "distributed M lborel X f"
  assumes Y: "distributed M lborel Y g"
  shows "distributed M lborel (\<lambda>x. X x + Y x) (\<lambda>x. \<integral>\<^sup>+y. f (x - y) * g y \<partial>lborel)"
  unfolding distributed_def
proof safe
  show "AE x in lborel. 0 \<le> \<integral>\<^sup>+ xa. f (x - xa) * g xa \<partial>lborel"
    by (auto simp: nn_integral_nonneg)

  have fg[measurable]: "f \<in> borel_measurable borel" "g \<in> borel_measurable borel"
    using distributed_borel_measurable[OF X] distributed_borel_measurable[OF Y] by simp_all

  show "(\<lambda>x. \<integral>\<^sup>+ xa. f (x - xa) * g xa \<partial>lborel) \<in> borel_measurable lborel"
    by measurable

  have "distr M borel (\<lambda>x. X x + Y x) = (distr M borel X \<star> distr M borel Y)"
    using distributed_measurable[OF X] distributed_measurable[OF Y]
    by (intro sum_indep_random_variable) (auto simp: indep)
  also have "\<dots> = (density lborel f \<star> density lborel g)"
    using distributed_distr_eq_density[OF X] distributed_distr_eq_density[OF Y]
    by (simp cong: distr_cong)
  also have "\<dots> = density lborel (\<lambda>x. \<integral>\<^sup>+ y. f (x - y) * g y \<partial>lborel)"
  proof (rule convolution_density)
    show "finite_measure (density lborel f)"
      using X by (rule distributed_finite_measure_density)
    show "finite_measure (density lborel g)"
      using Y by (rule distributed_finite_measure_density)
    show "AE x in lborel. 0 \<le> f x"
      using X by (rule distributed_AE)
    show "AE x in lborel. 0 \<le> g x"
      using Y by (rule distributed_AE)
  qed fact+
  finally show "distr M lborel (\<lambda>x. X x + Y x) = density lborel (\<lambda>x. \<integral>\<^sup>+ y. f (x - y) * g y \<partial>lborel)"
    by (simp cong: distr_cong)
  show "random_variable lborel (\<lambda>x. X x + Y x)"
    using distributed_measurable[OF X] distributed_measurable[OF Y] by simp
qed

lemma prob_space_convolution_density:
  fixes f:: "real \<Rightarrow> _"
  fixes g:: "real \<Rightarrow> _"
  assumes [measurable]: "f\<in> borel_measurable borel"
  assumes [measurable]: "g\<in> borel_measurable borel"
  assumes gt_0[simp]: "\<And>x. 0 \<le> f x" "\<And>x. 0 \<le> g x"
  assumes "prob_space (density lborel f)" (is "prob_space ?F")
  assumes "prob_space (density lborel g)" (is "prob_space ?G")
  shows "prob_space (density lborel (\<lambda>x.\<integral>\<^sup>+y. f (x - y) * g y \<partial>lborel))" (is "prob_space ?D")
proof (subst convolution_density[symmetric])
  interpret F: prob_space ?F by fact
  show "finite_measure ?F" by unfold_locales
  interpret G: prob_space ?G by fact
  show "finite_measure ?G" by unfold_locales
  interpret FG: pair_prob_space ?F ?G ..

  show "prob_space (density lborel f \<star> density lborel g)"
    unfolding convolution_def by (rule FG.prob_space_distr) simp
qed simp_all

end


(*  Title:       MonoidalFunctor
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2017
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter "Monoidal Functor"

text_raw\<open>
\label{monoidal-functor-chap}
\<close>

theory MonoidalFunctor
imports MonoidalCategory
begin

    text \<open>
      A monoidal functor is a functor @{term F} between monoidal categories @{term C}
      and @{term D} that preserves the monoidal structure up to isomorphism.
      The traditional definition assumes a monoidal functor to be equipped with
      two natural isomorphisms, a natural isomorphism @{term \<phi>} that expresses the preservation
      of tensor product and a natural isomorphism @{term \<psi>} that expresses the preservation
      of the unit object.  These natural isomorphisms are subject to coherence conditions;
      the condition for @{term \<phi>} involving the associator and the conditions for @{term \<psi>}
      involving the unitors.  However, as pointed out in \<^cite>\<open>"Etingof15"\<close> (Section 2.4),
      it is not necessary to take the natural isomorphism @{term \<psi>} as given,
      since the mere assumption that @{term "F \<I>\<^sub>C"} is isomorphic to @{term "\<I>\<^sub>D"}
      is sufficient for there to be a canonical definition of @{term \<psi>} from which the
      coherence conditions can be derived.  This leads to a more economical definition
      of monoidal functor, which is the one we adopt here.
\<close>

  locale monoidal_functor =
    C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
    D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
    "functor" C D F +
    CC: product_category C C +
    DD: product_category D D +
    FF: product_functor C C D D F F +
    FoT\<^sub>C: composite_functor C.CC.comp C D T\<^sub>C F +
    T\<^sub>DoFF: composite_functor C.CC.comp D.CC.comp D FF.map T\<^sub>D +
    \<phi>: natural_isomorphism C.CC.comp D T\<^sub>DoFF.map FoT\<^sub>C.map \<phi>
  for C :: "'c comp"                    (infixr "\<cdot>\<^sub>C" 55)
  and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
  and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
  and \<iota>\<^sub>C :: "'c"
  and D :: "'d comp"                    (infixr "\<cdot>\<^sub>D" 55)
  and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
  and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
  and \<iota>\<^sub>D :: "'d"
  and F :: "'c \<Rightarrow> 'd"
  and \<phi> :: "'c * 'c \<Rightarrow> 'd" +
  assumes preserves_unity: "D.isomorphic D.unity (F C.unity)"
  and assoc_coherence:
      "\<lbrakk> C.ide a; C.ide b; C.ide c \<rbrakk> \<Longrightarrow>
         F (\<alpha>\<^sub>C (a, b, c)) \<cdot>\<^sub>D \<phi> (T\<^sub>C (a, b), c) \<cdot>\<^sub>D T\<^sub>D (\<phi> (a, b), F c)
           = \<phi> (a, T\<^sub>C (b, c)) \<cdot>\<^sub>D T\<^sub>D (F a, \<phi> (b, c)) \<cdot>\<^sub>D \<alpha>\<^sub>D (F a, F b, F c)"
  begin

    notation C.tensor                     (infixr "\<otimes>\<^sub>C" 53)
    and C.unity                           ("\<I>\<^sub>C")
    and C.lunit                           ("\<l>\<^sub>C[_]")
    and C.runit                           ("\<r>\<^sub>C[_]")
    and C.assoc                           ("\<a>\<^sub>C[_, _, _]")
    and D.tensor                          (infixr "\<otimes>\<^sub>D" 53)
    and D.unity                           ("\<I>\<^sub>D")
    and D.lunit                           ("\<l>\<^sub>D[_]")
    and D.runit                           ("\<r>\<^sub>D[_]")
    and D.assoc                           ("\<a>\<^sub>D[_, _, _]")

    lemma \<phi>_in_hom:
    assumes "C.ide a" and "C.ide b"
    shows "\<guillemotleft>\<phi> (a, b) : F a \<otimes>\<^sub>D F b \<rightarrow>\<^sub>D F (a \<otimes>\<^sub>C b)\<guillemotright>"
      using assms by auto

    text \<open>
      We wish to exhibit a canonical definition of an isomorphism
      @{term "\<psi> \<in> D.hom \<I>\<^sub>D (F \<I>\<^sub>C)"} that satisfies certain coherence conditions that
      involve the left and right unitors.  In \<^cite>\<open>"Etingof15"\<close>, the isomorphism @{term \<psi>}
      is defined by the equation @{term "\<l>\<^sub>D[F \<I>\<^sub>C] = F \<l>\<^sub>C[\<I>\<^sub>C] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F \<I>\<^sub>C)"},
      which suffices for the definition because the functor \<open>- \<otimes>\<^sub>D F \<I>\<^sub>C\<close> is fully faithful.
      It is then asserted (Proposition 2.4.3) that the coherence condition
      @{term "\<l>\<^sub>D[F a] = F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)"} is satisfied for any object @{term a}
      of \<open>C\<close>, as well as the corresponding condition for the right unitor.
      However, the proof is left as an exercise (Exercise 2.4.4).
      The organization of the presentation suggests that that one should derive the
      general coherence condition from the special case
      @{term "\<l>\<^sub>D[F \<I>\<^sub>C] = F \<l>\<^sub>C[\<I>\<^sub>C] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F \<I>\<^sub>C)"} used as the definition of @{term \<psi>}.
      However, I did not see how to do it that way, so I used a different approach.
      The isomorphism @{term "\<iota>\<^sub>D' \<equiv> F \<iota>\<^sub>C \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C)"} serves as an alternative unit for the
      monoidal category \<open>D\<close>.  There is consequently a unique isomorphism that maps
      @{term "\<iota>\<^sub>D"} to @{term "\<iota>\<^sub>D'"}.  We define @{term \<psi>} to be this isomorphism and then use
      the definition to establish the desired coherence conditions.
\<close>

    abbreviation \<iota>\<^sub>1
    where "\<iota>\<^sub>1 \<equiv> F \<iota>\<^sub>C \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C)"

    lemma \<iota>\<^sub>1_in_hom:
    shows "\<guillemotleft>\<iota>\<^sub>1 : F \<I>\<^sub>C \<otimes>\<^sub>D F \<I>\<^sub>C \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright>"
      using C.\<iota>_in_hom by (intro D.in_homI, auto)

    lemma \<iota>\<^sub>1_is_iso:
    shows "D.iso \<iota>\<^sub>1"
      using C.\<iota>_is_iso C.\<iota>_in_hom \<phi>_in_hom D.isos_compose by auto

    interpretation D: monoidal_category_with_alternate_unit D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D \<iota>\<^sub>1
    proof -
      have 1: "\<exists>\<psi>. \<guillemotleft>\<psi> : F \<I>\<^sub>C \<rightarrow>\<^sub>D \<I>\<^sub>D\<guillemotright> \<and> D.iso \<psi>"
      proof -
        obtain \<psi>' where \<psi>': "\<guillemotleft>\<psi>' : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi>'"
          using preserves_unity by auto
        have "\<guillemotleft>D.inv \<psi>' : F \<I>\<^sub>C \<rightarrow>\<^sub>D \<I>\<^sub>D\<guillemotright> \<and> D.iso (D.inv \<psi>')"
          using \<psi>' by simp
        thus ?thesis by auto
      qed
      obtain \<psi> where \<psi>: "\<guillemotleft>\<psi> : F \<I>\<^sub>C \<rightarrow>\<^sub>D \<I>\<^sub>D\<guillemotright> \<and> D.iso \<psi>"
        using 1 by blast
      interpret L: equivalence_functor D D \<open>\<lambda>f. (D.cod \<iota>\<^sub>1) \<otimes>\<^sub>D f\<close>
      proof -
        interpret L: "functor" D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close>
          using D.T.fixing_ide_gives_functor_1 by simp
        interpret L: endofunctor D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> ..
        interpret \<psi>x: natural_transformation D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f\<close>
                        \<open>\<lambda>f. \<psi> \<otimes>\<^sub>D f\<close>
          using \<psi> D.T.fixing_arr_gives_natural_transformation_1 [of \<psi>] by auto
        interpret \<psi>x: natural_isomorphism D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<psi> \<otimes>\<^sub>D f\<close>
          apply unfold_locales using \<psi> D.tensor_preserves_iso by simp
        interpret \<ll>\<^sub>Do\<psi>x: vertical_composite D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> \<open>\<lambda>f. \<I>\<^sub>D \<otimes>\<^sub>D f\<close> D.map
                                           \<open>\<lambda>f. \<psi> \<otimes>\<^sub>D f\<close> D.\<ll> ..
        interpret \<ll>\<^sub>Do\<psi>x: natural_isomorphism D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close> D.map \<ll>\<^sub>Do\<psi>x.map
          using \<psi>x.natural_isomorphism_axioms D.\<ll>.natural_isomorphism_axioms
                natural_isomorphisms_compose by blast
        interpret L: equivalence_functor D D \<open>\<lambda>f. (F \<I>\<^sub>C) \<otimes>\<^sub>D f\<close>
          using L.isomorphic_to_identity_is_equivalence \<ll>\<^sub>Do\<psi>x.natural_isomorphism_axioms
          by simp
        show "equivalence_functor D D (\<lambda>f. (D.cod \<iota>\<^sub>1) \<otimes>\<^sub>D f)"
          using L.equivalence_functor_axioms C.\<iota>_in_hom by auto
      qed
      interpret R: equivalence_functor D D \<open>\<lambda>f. T\<^sub>D (f, D.cod \<iota>\<^sub>1)\<close>
      proof -
        interpret R: "functor" D D \<open>\<lambda>f. T\<^sub>D (f, F \<I>\<^sub>C)\<close>
          using D.T.fixing_ide_gives_functor_2 by simp
        interpret R: endofunctor D \<open>\<lambda>f. T\<^sub>D (f, F \<I>\<^sub>C)\<close> ..
        interpret x\<psi>: natural_transformation D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D\<close>
                        \<open>\<lambda>f. f \<otimes>\<^sub>D \<psi>\<close>
          using \<psi> D.T.fixing_arr_gives_natural_transformation_2 [of \<psi>] by auto
        interpret x\<psi>: natural_isomorphism D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<psi>\<close>
          using \<psi> D.tensor_preserves_iso by (unfold_locales, simp)
        interpret \<rho>\<^sub>Dox\<psi>: vertical_composite D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close> \<open>\<lambda>f. f \<otimes>\<^sub>D \<I>\<^sub>D\<close> D.map
                                                \<open>\<lambda>f. f \<otimes>\<^sub>D \<psi>\<close> D.\<rho> ..
        interpret \<rho>\<^sub>Dox\<psi>: natural_isomorphism D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close> D.map \<rho>\<^sub>Dox\<psi>.map
          using x\<psi>.natural_isomorphism_axioms D.\<rho>.natural_isomorphism_axioms
                natural_isomorphisms_compose by blast
        interpret R: equivalence_functor D D \<open>\<lambda>f. f \<otimes>\<^sub>D (F \<I>\<^sub>C)\<close>
          using R.isomorphic_to_identity_is_equivalence \<rho>\<^sub>Dox\<psi>.natural_isomorphism_axioms
          by simp
        show "equivalence_functor D D (\<lambda>f. f \<otimes>\<^sub>D (D.cod \<iota>\<^sub>1))"
          using R.equivalence_functor_axioms C.\<iota>_in_hom by auto
      qed
      show "monoidal_category_with_alternate_unit D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D \<iota>\<^sub>1"
        using D.pentagon C.\<iota>_is_iso C.\<iota>_in_hom preserves_hom \<iota>\<^sub>1_is_iso \<iota>\<^sub>1_in_hom
        by (unfold_locales, auto)
    qed

    no_notation D.tensor   (infixr "\<otimes>\<^sub>D" 53)
    notation D.C\<^sub>1.tensor   (infixr "\<otimes>\<^sub>D" 53)   (* equal to D.tensor *)
    no_notation D.assoc    ("\<a>\<^sub>D[_, _, _]")
    notation D.C\<^sub>1.assoc    ("\<a>\<^sub>D[_, _, _]")      (* equal to D.assoc *)
    no_notation D.assoc'   ("\<a>\<^sub>D\<^sup>-\<^sup>1[_, _, _]")
    notation D.C\<^sub>1.assoc'   ("\<a>\<^sub>D\<^sup>-\<^sup>1[_, _, _]")   (* equal to D.assoc' *)
    notation D.C\<^sub>1.unity    ("\<I>\<^sub>1")
    notation D.C\<^sub>1.lunit    ("\<l>\<^sub>1[_]")
    notation D.C\<^sub>1.runit    ("\<r>\<^sub>1[_]")

    lemma \<I>\<^sub>1_char [simp]:
    shows "\<I>\<^sub>1 = F \<I>\<^sub>C"
      using D.C\<^sub>1.unity_def \<iota>\<^sub>1_in_hom by auto

    definition \<psi>
    where "\<psi> \<equiv> THE \<psi>. \<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"

    lemma \<psi>_char:
    shows "\<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright>" and "D.iso \<psi>" and "\<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
    and "\<exists>!\<psi>. \<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
    proof -
      show "\<exists>!\<psi>. \<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
        using D.unit_unique_upto_unique_iso \<iota>\<^sub>1_in_hom D.C\<^sub>1.\<iota>_in_hom
        by (elim D.in_homE, auto)
      hence 1: "\<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"
        unfolding \<psi>_def
        using theI' [of "\<lambda>\<psi>. \<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<psi> \<and> \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)"]
          by fast
      show "\<guillemotleft>\<psi> : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright>" using 1 by simp
      show "D.iso \<psi>" using 1 by simp
      show "\<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi>)" using 1 by simp
    qed

    lemma \<psi>_eqI:
    assumes "\<guillemotleft>f: \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright>" and "D.iso f" and "f \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (f \<otimes>\<^sub>D f)"
    shows "f = \<psi>"
      using assms \<psi>_def \<psi>_char
            the1_equality [of "\<lambda>f. \<guillemotleft>f: \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso f \<and> f \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (f \<otimes>\<^sub>D f)" f]
      by simp

    lemma lunit_coherence1:
    assumes "C.ide a"
    shows "\<l>\<^sub>1[F a] \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a) = \<l>\<^sub>D[F a]"
    proof -
      have "D.par (\<l>\<^sub>1[F a] \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)) \<l>\<^sub>D[F a]"
        using assms D.C\<^sub>1.lunit_in_hom D.tensor_in_hom D.lunit_in_hom \<psi>_char(1) C.\<iota>_in_hom
        by auto
      text \<open>
        The upper left triangle in the following diagram commutes.
\<close>
      text \<open>
\newcommand\xIc{{\cal I}}
\newcommand\xId{{\cal I}}
\newcommand\xac[3]{{\scriptsize \<open>\<a>\<close>}[{#1},{#2},{#3}]}
\newcommand\xad[3]{{\scriptsize \<open>\<a>\<close>}[{#1},{#2},{#3}]}
\newcommand\xlc[1]{{\scriptsize \<open>\<l>\<close>}[{#1}]}
\newcommand\xld[1]{{\scriptsize \<open>\<l>\<close>}[{#1}]}
\newcommand\xldp[1]{{\scriptsize \<open>\<l>\<close>}_1[{#1}]}
$$\xymatrix{
  {\xId\otimes F a}
     \ar[rrr]^{\psi\otimes F a}
  & & &
  {F\xIc\otimes F a}
  \\
  &
  {\xId\otimes(F\xIc \otimes F a)}
     \ar[ul]_{\xId\otimes\xldp{F a}}
     \ar[ddr]^{\psi\otimes(F\xIc\otimes F a)}
  \\ \\
  &
  {\xId\otimes(\xId \otimes F a)}
     \ar[r]_{\psi\otimes(\psi\otimes F a)}
     \ar[uuul]^{\xId\otimes\xld{F a}}
     \ar[uu]_{\xId\otimes(\psi\otimes F a)}
  &
  {F\xIc\otimes (F\xIc\otimes F a)}
     \ar[uuur]^{F\xIc\otimes\xldp{F a}}
  \\ \\
  {(\xId\otimes\xId)\otimes F a}
     \ar[uuuuu]^{\iota\otimes F a}
     \ar[uur]_{\xad{\xId}{\xId}{F a}}
     \ar[rrr]^{(\psi\otimes\psi)\otimes F a}
  & & &
  {(F\xIc\otimes F\xIc)\otimes F a}
     \ar[uuuuu]_{\iota_1\otimes F a}
     \ar[uul]^{\xad{F\xIc}{F\xIc}{F a}}
}$$
\<close>
      moreover have "(\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (\<I>\<^sub>D \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a) = \<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>D[F a]"
      proof -
        have "(\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (\<I>\<^sub>D \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a)
                = (\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (D.inv \<psi> \<otimes>\<^sub>D F \<I>\<^sub>C \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a)"
          using assms \<psi>_char(1-2) D.interchange [of "D.inv \<psi>"] D.comp_cod_arr
                D.inv_is_inverse D.comp_inv_arr
          by (elim D.in_homE, simp)
        also have "... = (D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a)"
        proof -
          have "(\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D (D.inv \<psi> \<otimes>\<^sub>D F \<I>\<^sub>C \<otimes>\<^sub>D F a) =
                (D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a])"
            using assms \<psi>_char(1-2) D.interchange [of "\<I>\<^sub>D"] D.interchange [of "D.inv \<psi>"]
                  D.comp_arr_dom D.comp_cod_arr
            by (elim D.in_homE, auto)
          thus ?thesis
            using assms \<psi>_char(1-2) D.inv_in_hom
                  D.comp_permute [of "\<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>1[F a]" "D.inv \<psi> \<otimes>\<^sub>D F \<I>\<^sub>C \<otimes>\<^sub>D F a"
                                     "D.inv \<psi> \<otimes>\<^sub>D F a" "F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"]
            by (elim D.in_homE, auto)
        qed
        also have "... = (D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a] \<cdot>\<^sub>D
                         (\<psi> \<otimes>\<^sub>D \<psi> \<otimes>\<^sub>D F a)"
          using assms \<psi>_char(1-2) D.C\<^sub>1.lunit_char(2) D.comp_assoc by auto
        also have "... = ((D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D ((\<psi> \<otimes>\<^sub>D \<psi>) \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D
                         D.inv \<a>\<^sub>D[\<I>\<^sub>D, \<I>\<^sub>D, F a]"
          using assms \<psi>_char(1-2) D.assoc'_naturality [of \<psi> \<psi> "F a"] D.comp_assoc by auto
        also have "... = (\<iota>\<^sub>D \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[\<I>\<^sub>D, \<I>\<^sub>D, F a]"
        proof -
          have "(D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D ((\<psi> \<otimes>\<^sub>D \<psi>) \<otimes>\<^sub>D F a) = \<iota>\<^sub>D \<otimes>\<^sub>D F a"
          proof -
            have "(D.inv \<psi> \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D ((\<psi> \<otimes>\<^sub>D \<psi>) \<otimes>\<^sub>D F a) =
                  D.inv \<psi> \<cdot>\<^sub>D \<psi> \<cdot>\<^sub>D \<iota>\<^sub>D \<otimes>\<^sub>D F a"
              using assms \<psi>_char(1-3) D.\<iota>_in_hom \<iota>\<^sub>1_in_hom D.interchange
              by (elim D.in_homE, auto)
            also have "... = \<iota>\<^sub>D \<otimes>\<^sub>D F a"
              using assms \<psi>_char(1-2) D.inv_is_inverse D.comp_inv_arr D.comp_cod_arr
                    D.comp_reduce D.\<iota>_in_hom
              by (elim D.in_homE, auto)
            finally show ?thesis by blast
          qed
          thus ?thesis by simp
        qed
        also have "... = \<I>\<^sub>D \<otimes>\<^sub>D \<l>\<^sub>D[F a]"
          using assms D.lunit_char by simp
        finally show ?thesis by blast
      qed
      ultimately show ?thesis
        using D.L.is_faithful [of "\<l>\<^sub>1[F a] \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)" "\<l>\<^sub>D[F a]"] D.\<iota>_in_hom by force
    qed

    lemma lunit_coherence2:
    assumes "C.ide a"
    shows "F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) = \<l>\<^sub>1[F a]"
    proof -
      text \<open>
        We show that the lower left triangle in the following diagram commutes.
\<close>
      text \<open>
\newcommand\xIc{{\cal I}}
\newcommand\xId{{\cal I}}
\newcommand\xac[3]{{\scriptsize \<open>\<a>\<close>}[{#1},{#2},{#3}]}
\newcommand\xad[3]{{\scriptsize \<open>\<a>\<close>}[{#1},{#2},{#3}]}
\newcommand\xlc[1]{{\scriptsize \<open>\<l>\<close>}[{#1}]}
\newcommand\xld[1]{{\scriptsize \<open>\<l>\<close>}[{#1}]}
\newcommand\xldp[1]{{\scriptsize \<open>\<l>\<close>}_1[{#1}]}
$$\xymatrix{
  {(F\xIc\otimes F\xIc)\otimes F a}
      \ar[rrrrr]^{\phi(\xIc,\xIc)\otimes F a}
      \ar[ddd]_{\xad{F\xIc}{F\xIc}{Fa}}
      \ar[dddrr]^{\iota_1\otimes F a}
  &&&&&{F(\xIc\otimes\xIc)\otimes F a}
      \ar[ddd]^{\phi(\xIc\otimes\xIc, a)}
      \ar[dddlll]_{F\iota\otimes F a}
  \\ \\ \\
  {F\xIc\otimes(F\xIc\otimes F a)}
      \ar[ddd]_{F\xIc\otimes\phi(\xIc, a)}
      \ar[rr]_{F\xIc\otimes\xldp{Fa}}
  &&{F\xIc\otimes F a}
      \ar[r]_{\phi(\xIc, a)}
  &{F(\xIc\otimes a)}
  &&{F((\xIc\otimes\xIc)\otimes a)}
      \ar[ddd]^{F\xac{\xIc}{\xIc}{a}}
      \ar[ll]^{F(\iota\otimes a)}
  \\ \\ \\
  {F\xIc\otimes F (\xIc\otimes a)}
      \ar[rrrrr]_{\phi(\xIc, \xIc\otimes a)}
      \ar[uuurr]_{F\xIc\otimes F\xlc{a}}
  &&&&&{F(\xIc\otimes (\xIc \otimes a))}
      \ar[uuull]^{F(\xIc\otimes\xlc{a})}
}$$
\<close>
      have "(F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<phi> (\<I>\<^sub>C, a)) = F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"
      proof -
        have "(F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<phi> (\<I>\<^sub>C, a))
                = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] \<cdot>\<^sub>D
                  \<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a) \<cdot>\<^sub>D (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
        proof -
          have "D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a) \<cdot>\<^sub>D
                       (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a)
                   = (F \<I>\<^sub>C \<otimes>\<^sub>D \<phi> (\<I>\<^sub>C, a)) \<cdot>\<^sub>D \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
            using assms \<phi>_in_hom assoc_coherence D.invert_side_of_triangle(1) by simp
          hence "F \<I>\<^sub>C \<otimes>\<^sub>D \<phi> (\<I>\<^sub>C, a)
                    = (D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a) \<cdot>\<^sub>D
                      (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
            using assms \<phi>_in_hom D.invert_side_of_triangle(2) by simp
          thus ?thesis
            using D.comp_assoc by simp
        qed
        also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
                         (D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D F (\<iota>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
                         \<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a) \<cdot>\<^sub>D (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D
                         D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
        proof -
          have 1: "F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a]) = F (\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a])"
            using assms C.lunit_char(1-2) C.\<iota>_in_hom preserves_inv by auto
          hence "F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] = D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D F (\<iota>\<^sub>C \<otimes>\<^sub>C a)"
          proof -
            have "F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C, a] \<cdot>\<^sub>D D.inv (F (\<iota>\<^sub>C \<otimes>\<^sub>C a))
                    = D.inv (F (\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>D D.inv (F \<a>\<^sub>C[\<I>\<^sub>C, \<I>\<^sub>C ,a]))"
              using assms 1 preserves_iso C.ide_is_iso C.\<iota>_is_iso C.ide_unity C.iso_assoc
                    C.iso_lunit C.tensor_preserves_iso D.inv_comp D.inv_inv
                    D.iso_inv_iso D.iso_is_arr
              by metis
            thus ?thesis
              using assms 1 preserves_iso C.ide_is_iso C.\<iota>_is_iso C.ide_unity C.iso_assoc
                    C.iso_lunit C.tensor_preserves_iso D.inv_comp D.inv_inv
                    D.iso_inv_iso D.iso_is_arr D.invert_side_of_triangle(2)
              by metis
          qed
         thus ?thesis by argo
        qed
        also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
                         D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D (F (\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C \<otimes>\<^sub>C \<I>\<^sub>C, a)) \<cdot>\<^sub>D
                         (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
          using D.comp_assoc by auto
        also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
                         D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D (\<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D (F \<iota>\<^sub>C \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D
                         (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
          using assms \<phi>.naturality [of "(\<iota>\<^sub>C, a)"] C.\<iota>_in_hom by auto
        also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
                         D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D
                         ((F \<iota>\<^sub>C \<otimes>\<^sub>D F a) \<cdot>\<^sub>D (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C) \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D
                         D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
          using D.comp_assoc by auto
        also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
                         D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D (\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D
                         D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
          using assms D.interchange C.\<iota>_in_hom by auto
        also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D
                         D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D
                         ((F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]) \<cdot>\<^sub>D \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]) \<cdot>\<^sub>D
                         D.inv \<a>\<^sub>D[F \<I>\<^sub>C, F \<I>\<^sub>C, F a]"
        proof -
          have "(\<iota>\<^sub>1 \<otimes>\<^sub>D F a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F \<I>\<^sub>C, F \<I>\<^sub>C, F a] = F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"
            using assms D.C\<^sub>1.lunit_char [of "F a"] by auto
          thus ?thesis
            using assms D.inv_is_inverse \<iota>\<^sub>1_in_hom \<phi>_in_hom D.invert_side_of_triangle(2)
            by simp
        qed
        also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D
                         (D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)) \<cdot>\<^sub>D
                         (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a])"
          using assms D.comp_arr_dom [of "F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"] D.comp_assoc by auto
        also have "... = (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a])"
        proof -
          have "D.inv (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a])
                   = D.inv (D.inv (\<phi> (\<I>\<^sub>C, a)) \<cdot>\<^sub>D F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a]) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a))"
            using assms \<phi>.naturality [of "(\<I>\<^sub>C, \<l>\<^sub>C[a])"] D.invert_side_of_triangle(1) by simp
          also have "... = D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)"
            using assms D.inv_comp D.inv_is_inverse D.isos_compose D.comp_assoc
            by simp
          finally have "D.inv (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a])
                          = D.inv (\<phi> (\<I>\<^sub>C, \<I>\<^sub>C \<otimes>\<^sub>C a)) \<cdot>\<^sub>D D.inv (F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])) \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)"
            by blast
          thus ?thesis by argo
        qed
        also have "... = ((F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a]) \<cdot>\<^sub>D D.inv (F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a])) \<cdot>\<^sub>D (F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a])"
          using assms D.tensor_preserves_iso D.comp_assoc by simp
        also have "... = F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"
          using assms D.tensor_preserves_iso D.comp_arr_inv D.inv_is_inverse D.comp_cod_arr
                D.interchange
          by simp
        finally show ?thesis by blast
      qed
      hence "F \<I>\<^sub>C \<otimes>\<^sub>D F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) = F \<I>\<^sub>C \<otimes>\<^sub>D \<l>\<^sub>1[F a]"
        using assms \<phi>_in_hom D.interchange by simp
      moreover have "D.par (F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)) \<l>\<^sub>1[F a]"
        using assms \<phi>_in_hom by simp
      ultimately show ?thesis
        using D.C\<^sub>1.L.is_faithful [of "F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)" "\<l>\<^sub>1[F a]"] D.C\<^sub>1.unity_def by simp
    qed

    text \<open>
      Combining the two previous lemmas yields the coherence result we seek.
      This is the condition that is traditionally taken as part of the definition
      of monoidal functor.
\<close>

    lemma lunit_coherence:
    assumes "C.ide a"
    shows "\<l>\<^sub>D[F a] = F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)"
    proof -
      have "\<l>\<^sub>D[F a] \<cdot>\<^sub>D D.inv (\<psi> \<otimes>\<^sub>D F a) = \<l>\<^sub>1[F a]"
        using assms lunit_coherence1 \<psi>_char(2)
              D.invert_side_of_triangle(2) [of "\<l>\<^sub>D[F a]" "\<l>\<^sub>1[F a]" "\<psi> \<otimes>\<^sub>D F a"]
        by auto
      also have "... = F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)"
        using assms lunit_coherence2 by simp
      finally have "\<l>\<^sub>D[F a] \<cdot>\<^sub>D D.inv (\<psi> \<otimes>\<^sub>D F a) = F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)"
        by blast
      hence "\<l>\<^sub>D[F a] = (F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)) \<cdot>\<^sub>D (\<psi> \<otimes>\<^sub>D F a)"
        using assms \<psi>_char(2) \<phi>_in_hom
              D.invert_side_of_triangle(2) [of "F \<l>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (\<I>\<^sub>C, a)" "\<l>\<^sub>D[F a]" "D.inv (\<psi> \<otimes>\<^sub>D F a)"]
        by simp
      thus ?thesis
        using assms \<psi>_char(1) D.comp_assoc by auto
    qed

    text \<open>
      We now want to obtain the corresponding result for the right unitor.
      To avoid a repetition of what would amount to essentially the same tedious diagram chases
      that were carried out above, we instead show here that @{term F} becomes a monoidal functor
      from the opposite of \<open>C\<close> to the opposite of \<open>D\<close>,
      with @{term "\<lambda>f. \<phi> (snd f, fst f)"} as the structure map.
      The fact that in the opposite monoidal categories the left and right unitors are exchanged
      then permits us to obtain the result for the right unitor from the result already proved
      for the left unitor.
\<close>

    interpretation C': opposite_monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C ..
    interpretation D': opposite_monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D ..
    interpretation T\<^sub>D'oFF: composite_functor C.CC.comp D.CC.comp D FF.map D'.T ..
    interpretation FoT\<^sub>C': composite_functor C.CC.comp C D C'.T F ..
    interpretation \<phi>': natural_transformation C.CC.comp D T\<^sub>D'oFF.map FoT\<^sub>C'.map
                                              \<open>\<lambda>f. \<phi> (snd f, fst f)\<close>
      using \<phi>.is_natural_1 \<phi>.is_natural_2 \<phi>.is_extensional by (unfold_locales, auto)
    interpretation \<phi>': natural_isomorphism C.CC.comp D T\<^sub>D'oFF.map FoT\<^sub>C'.map
                                           \<open>\<lambda>f. \<phi> (snd f, fst f)\<close>
      by (unfold_locales, simp)
    interpretation F': monoidal_functor C C'.T C'.\<alpha> \<iota>\<^sub>C D D'.T D'.\<alpha> \<iota>\<^sub>D F \<open>\<lambda>f. \<phi> (snd f, fst f)\<close>
      using preserves_unity apply (unfold_locales; simp)
    proof -
      fix a b c
      assume a: "C.ide a" and b: "C.ide b" and c: "C.ide c"
      have "(\<phi> (c \<otimes>\<^sub>C b, a) \<cdot>\<^sub>D (\<phi> (c, b) \<otimes>\<^sub>D F a)) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F c, F b, F a] =
            F (C.assoc' c b a) \<cdot>\<^sub>D \<phi> (c, b \<otimes>\<^sub>C a) \<cdot>\<^sub>D (F c \<otimes>\<^sub>D \<phi> (b, a))"
      proof -
        have "D.seq (F \<a>\<^sub>C[c, b, a]) (\<phi> (c \<otimes>\<^sub>C b, a) \<cdot>\<^sub>D (\<phi> (c, b) \<otimes>\<^sub>D F a))"
          using a b c \<phi>_in_hom by simp
        moreover have "D.seq (\<phi> (c, b \<otimes>\<^sub>C a) \<cdot>\<^sub>D (F c \<otimes>\<^sub>D \<phi> (b, a))) \<a>\<^sub>D[F c, F b, F a]"
          using a b c \<phi>_in_hom by simp
        moreover have
             "F \<a>\<^sub>C[c, b, a] \<cdot>\<^sub>D \<phi> (c \<otimes>\<^sub>C b, a) \<cdot>\<^sub>D (\<phi> (c, b) \<otimes>\<^sub>D F a) =
              (\<phi> (c, b \<otimes>\<^sub>C a) \<cdot>\<^sub>D (F c \<otimes>\<^sub>D \<phi> (b, a))) \<cdot>\<^sub>D \<a>\<^sub>D[F c, F b, F a]"
          using a b c assoc_coherence D.comp_assoc by simp
        moreover have "D.iso (F \<a>\<^sub>C[c,b,a])"
          using a b c by simp
        moreover have "D.iso \<a>\<^sub>D[F c, F b, F a]"
          using a b c by simp
        moreover have "D.inv (F \<a>\<^sub>C[c,b,a]) = F (C.assoc' c b a)"
          using a b c preserves_inv by simp
        ultimately show ?thesis
          using D.invert_opposite_sides_of_square by simp
      qed
      thus "F (C.assoc' c b a) \<cdot>\<^sub>D \<phi> (c, b \<otimes>\<^sub>C a) \<cdot>\<^sub>D (F c \<otimes>\<^sub>D \<phi> (b, a)) =
            \<phi> (c \<otimes>\<^sub>C b, a) \<cdot>\<^sub>D (\<phi> (c, b) \<otimes>\<^sub>D F a) \<cdot>\<^sub>D \<a>\<^sub>D\<^sup>-\<^sup>1[F c, F b, F a]"
        using D.comp_assoc by simp
    qed

    lemma induces_monoidal_functor_between_opposites:
    shows "monoidal_functor C C'.T C'.\<alpha> \<iota>\<^sub>C D D'.T D'.\<alpha> \<iota>\<^sub>D F (\<lambda>f. \<phi> (snd f, fst f))"
      ..

    lemma runit_coherence:
    assumes "C.ide a"
    shows "\<r>\<^sub>D[F a] = F \<r>\<^sub>C[a] \<cdot>\<^sub>D \<phi> (a, \<I>\<^sub>C) \<cdot>\<^sub>D (F a \<otimes>\<^sub>D \<psi>)"
    proof -
      have "C'.lunit a = \<r>\<^sub>C[a]"
        using assms C'.lunit_simp by simp
      moreover have "D'.lunit (F a) = \<r>\<^sub>D[F a]"
        using assms D'.lunit_simp by simp
      moreover have "F'.\<psi> = \<psi>"
      proof (intro \<psi>_eqI)
        show "\<guillemotleft>F'.\<psi> : D'.unity \<rightarrow>\<^sub>D F C'.unity\<guillemotright>" using F'.\<psi>_char(1) by simp
        show "D.iso F'.\<psi>" using F'.\<psi>_char(2) by simp
        show "F'.\<psi> \<cdot>\<^sub>D \<iota>\<^sub>D = \<iota>\<^sub>1 \<cdot>\<^sub>D (F'.\<psi> \<otimes>\<^sub>D F'.\<psi>)" using F'.\<psi>_char(3) by simp
      qed
      moreover have "D'.lunit (F a) = F (C'.lunit a) \<cdot>\<^sub>D \<phi> (a, C'.unity) \<cdot>\<^sub>D (F a \<otimes>\<^sub>D F'.\<psi>)"
        using assms F'.lunit_coherence by simp
      ultimately show ?thesis by simp
    qed

  end

  section "Strict Monoidal Functor"

  text \<open>
    A strict monoidal functor preserves the monoidal structure ``on the nose''.
\<close>

  locale strict_monoidal_functor =
    C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
    D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
    "functor" C D F
  for C :: "'c comp"                    (infixr "\<cdot>\<^sub>C" 55)
  and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
  and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
  and \<iota>\<^sub>C :: "'c"
  and D :: "'d comp"                    (infixr "\<cdot>\<^sub>D" 55)
  and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
  and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
  and \<iota>\<^sub>D :: "'d"
  and F :: "'c \<Rightarrow> 'd" +
  assumes strictly_preserves_\<iota>: "F \<iota>\<^sub>C = \<iota>\<^sub>D"
  and strictly_preserves_T: "\<lbrakk> C.arr f; C.arr g \<rbrakk> \<Longrightarrow> F (T\<^sub>C (f, g)) = T\<^sub>D (F f, F g)"
  and strictly_preserves_\<alpha>_ide: "\<lbrakk> C.ide a; C.ide b; C.ide c \<rbrakk> \<Longrightarrow>
                                   F (\<alpha>\<^sub>C (a, b, c)) = \<alpha>\<^sub>D (F a, F b, F c)"
  begin

    notation C.tensor                  (infixr "\<otimes>\<^sub>C" 53)
    and C.unity                        ("\<I>\<^sub>C")
    and C.lunit                        ("\<l>\<^sub>C[_]")
    and C.runit                        ("\<r>\<^sub>C[_]")
    and C.assoc                        ("\<a>\<^sub>C[_, _, _]")
    and D.tensor                       (infixr "\<otimes>\<^sub>D" 53)
    and D.unity                        ("\<I>\<^sub>D")
    and D.lunit                        ("\<l>\<^sub>D[_]")
    and D.runit                        ("\<r>\<^sub>D[_]")
    and D.assoc                        ("\<a>\<^sub>D[_, _, _]")

    lemma strictly_preserves_tensor:
    assumes "C.arr f" and "C.arr g"
    shows "F (f \<otimes>\<^sub>C g) = F f \<otimes>\<^sub>D F g"
      using assms strictly_preserves_T by blast

    lemma strictly_preserves_\<alpha>:
    assumes "C.arr f" and "C.arr g" and "C.arr h"
    shows "F (\<alpha>\<^sub>C (f, g, h)) = \<alpha>\<^sub>D (F f, F g, F h)"
    proof -
      have "F (\<alpha>\<^sub>C (f, g, h)) = F ((f \<otimes>\<^sub>C g \<otimes>\<^sub>C h) \<cdot>\<^sub>C \<alpha>\<^sub>C (C.dom f, C.dom g, C.dom h))"
        using assms C.\<alpha>.is_natural_1 [of "(f, g, h)"] C.T.ToCT_simp by force
      also have "... = (F f \<otimes>\<^sub>D F g \<otimes>\<^sub>D F h) \<cdot>\<^sub>D \<alpha>\<^sub>D (D.dom (F f), D.dom (F g), D.dom (F h))"
        using assms strictly_preserves_\<alpha>_ide strictly_preserves_tensor by simp
      also have "... = \<alpha>\<^sub>D (F f, F g, F h)"
        using assms D.\<alpha>.is_natural_1 [of "(F f, F g, F h)"] by simp
      finally show ?thesis by blast
    qed

    lemma strictly_preserves_unity:
    shows "F \<I>\<^sub>C = \<I>\<^sub>D"
      using C.\<iota>_in_hom strictly_preserves_\<iota> C.unity_def D.unity_def by auto

    lemma strictly_preserves_assoc:
    assumes "C.arr a" and "C.arr b" and "C.arr c"
    shows "F \<a>\<^sub>C[a, b, c] = \<a>\<^sub>D[F a, F b, F c] "
      using assms strictly_preserves_\<alpha> by simp

    lemma strictly_preserves_lunit:
    assumes "C.ide a"
    shows "F \<l>\<^sub>C[a] = \<l>\<^sub>D[F a]"
    proof -
      let ?P = "\<lambda>f. f \<in> C.hom (\<I>\<^sub>C \<otimes>\<^sub>C a) a \<and> \<I>\<^sub>C \<otimes>\<^sub>C f = (\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>C C.assoc' \<I>\<^sub>C \<I>\<^sub>C a"
      let ?Q = "\<lambda>f. f \<in> D.hom (\<I>\<^sub>D \<otimes>\<^sub>D F a) (F a) \<and>
                    \<I>\<^sub>D \<otimes>\<^sub>D f = (\<iota>\<^sub>D \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.assoc' \<I>\<^sub>D \<I>\<^sub>D (F a)"
      have 1: "?P \<l>\<^sub>C[a]" using assms C.lunit_char by simp
      hence "?Q (F \<l>\<^sub>C[a])"
      proof -
        have "F \<l>\<^sub>C[a] \<in> D.hom (\<I>\<^sub>D \<otimes>\<^sub>D F a) (F a)"
          using assms 1 strictly_preserves_unity strictly_preserves_tensor by auto
        moreover have
            "F ((\<iota>\<^sub>C \<otimes>\<^sub>C a) \<cdot>\<^sub>C C.assoc' \<I>\<^sub>C \<I>\<^sub>C a) = (\<iota>\<^sub>D \<otimes>\<^sub>D F a) \<cdot>\<^sub>D D.assoc' \<I>\<^sub>D \<I>\<^sub>D (F a)"
          using assms 1 strictly_preserves_\<iota> strictly_preserves_assoc strictly_preserves_unity
                strictly_preserves_tensor preserves_inv C.\<iota>_in_hom
          by auto
        moreover have "\<I>\<^sub>D \<otimes>\<^sub>D F \<l>\<^sub>C[a] = F (\<I>\<^sub>C \<otimes>\<^sub>C \<l>\<^sub>C[a])"
          using assms strictly_preserves_unity strictly_preserves_tensor by simp
        ultimately show ?thesis
          using assms C.lunit_char(2) by simp
      qed
      thus ?thesis using assms D.lunit_eqI by simp
    qed

    lemma strictly_preserves_runit:
    assumes "C.ide a"
    shows "F \<r>\<^sub>C[a] = \<r>\<^sub>D[F a]"
    proof -
      let ?P = "\<lambda>f. f \<in> C.hom (a \<otimes>\<^sub>C \<I>\<^sub>C) a \<and> f \<otimes>\<^sub>C \<I>\<^sub>C = (a \<otimes>\<^sub>C \<iota>\<^sub>C) \<cdot>\<^sub>C C.assoc a \<I>\<^sub>C \<I>\<^sub>C"
      let ?Q = "\<lambda>f. f \<in> D.hom (F a \<otimes>\<^sub>D \<I>\<^sub>D) (F a) \<and>
                    f \<otimes>\<^sub>D \<I>\<^sub>D = (F a \<otimes>\<^sub>D \<iota>\<^sub>D) \<cdot>\<^sub>D D.assoc (F a) \<I>\<^sub>D \<I>\<^sub>D"
      have 1: "?P \<r>\<^sub>C[a]" using assms C.runit_char by simp
      hence "?Q (F \<r>\<^sub>C[a])"
      proof -
        have "F \<r>\<^sub>C[a] \<in> D.hom (F a \<otimes>\<^sub>D \<I>\<^sub>D) (F a)"
          using assms 1 strictly_preserves_unity strictly_preserves_tensor by auto
        moreover have "F ((a \<otimes>\<^sub>C \<iota>\<^sub>C) \<cdot>\<^sub>C C.assoc a \<I>\<^sub>C \<I>\<^sub>C)
                         = (F a \<otimes>\<^sub>D \<iota>\<^sub>D) \<cdot>\<^sub>D D.assoc (F a) \<I>\<^sub>D \<I>\<^sub>D"
          using assms 1 strictly_preserves_\<iota> strictly_preserves_assoc strictly_preserves_unity
                strictly_preserves_tensor preserves_inv C.\<iota>_in_hom
          by auto
        moreover have "F \<r>\<^sub>C[a] \<otimes>\<^sub>D \<I>\<^sub>D = F (\<r>\<^sub>C[a] \<otimes>\<^sub>C \<I>\<^sub>C)"
          using assms strictly_preserves_unity strictly_preserves_tensor by simp
        ultimately show ?thesis
          using assms C.runit_char(2) by simp
      qed
      thus ?thesis using assms D.runit_eqI by simp
    qed

    text \<open>
      The following are used to simplify the expression of the sublocale relationship between
      @{locale strict_monoidal_functor} and @{locale monoidal_functor}, as the definition of
      the latter mentions the structure map @{term \<phi>}.  For a strict monoidal functor,
      this is an identity transformation.
\<close>

    interpretation FF: product_functor C C D D F F ..
    interpretation FoT\<^sub>C: composite_functor C.CC.comp C D T\<^sub>C F ..
    interpretation T\<^sub>DoFF: composite_functor C.CC.comp D.CC.comp D FF.map T\<^sub>D ..

    lemma structure_is_trivial:
    shows "T\<^sub>DoFF.map = FoT\<^sub>C.map"
    proof
      fix x
      have "C.CC.arr x \<Longrightarrow> T\<^sub>DoFF.map x = FoT\<^sub>C.map x"
      proof -
        assume x: "C.CC.arr x"
        have "T\<^sub>DoFF.map x = F (fst x) \<otimes>\<^sub>D F (snd x)"
          using x by simp
        also have "... = FoT\<^sub>C.map x"
          using x strictly_preserves_tensor [of "fst x" "snd x"] by simp
        finally show "T\<^sub>DoFF.map x = FoT\<^sub>C.map x" by simp
      qed
      moreover have "\<not> C.CC.arr x \<Longrightarrow> T\<^sub>DoFF.map x = FoT\<^sub>C.map x"
        using T\<^sub>DoFF.is_extensional FoT\<^sub>C.is_extensional by simp
      ultimately show "T\<^sub>DoFF.map x = FoT\<^sub>C.map x" by blast
    qed

    abbreviation \<phi> where "\<phi> \<equiv> T\<^sub>DoFF.map"

    lemma structure_is_natural_isomorphism:
    shows "natural_isomorphism C.CC.comp D T\<^sub>DoFF.map FoT\<^sub>C.map \<phi>"
      using T\<^sub>DoFF.as_nat_iso.natural_isomorphism_axioms structure_is_trivial by force

  end

  text \<open>
    A strict monoidal functor is a monoidal functor.
\<close>

  sublocale strict_monoidal_functor \<subseteq> monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D F \<phi>
  proof -
    interpret FF: product_functor C C D D F F ..
    interpret FoT\<^sub>C: composite_functor C.CC.comp C D T\<^sub>C F ..
    interpret T\<^sub>DoFF: composite_functor C.CC.comp D.CC.comp D FF.map T\<^sub>D ..
    interpret \<phi>: natural_isomorphism C.CC.comp D T\<^sub>DoFF.map FoT\<^sub>C.map \<phi>
      using structure_is_natural_isomorphism by simp
    show "monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D F \<phi>"
    proof
      show "D.isomorphic \<I>\<^sub>D (F \<I>\<^sub>C)"
      proof (unfold D.isomorphic_def)
        have "\<guillemotleft>\<I>\<^sub>D : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso \<I>\<^sub>D"
          using strictly_preserves_unity by auto
        thus "\<exists>f. \<guillemotleft>f : \<I>\<^sub>D \<rightarrow>\<^sub>D F \<I>\<^sub>C\<guillemotright> \<and> D.iso f" by blast
      qed
      fix a b c
      assume a: "C.ide a"
      assume b: "C.ide b"
      assume c: "C.ide c"
      show "F \<a>\<^sub>C[a, b, c] \<cdot>\<^sub>D \<phi> (a \<otimes>\<^sub>C b, c) \<cdot>\<^sub>D (\<phi> (a, b) \<otimes>\<^sub>D F c) =
            \<phi> (a, b \<otimes>\<^sub>C c) \<cdot>\<^sub>D (F a \<otimes>\<^sub>D \<phi> (b, c)) \<cdot>\<^sub>D \<a>\<^sub>D[F a, F b, F c]"
        using a b c strictly_preserves_tensor strictly_preserves_assoc
              D.comp_arr_dom D.comp_cod_arr
        by simp
    qed
  qed

  lemma strict_monoidal_functors_compose:
  assumes "strict_monoidal_functor B T\<^sub>B \<alpha>\<^sub>B \<iota>\<^sub>B C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C F"
  and "strict_monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D G"
  shows "strict_monoidal_functor B T\<^sub>B \<alpha>\<^sub>B \<iota>\<^sub>B D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D (G o F)"
  proof -
    interpret F: strict_monoidal_functor B T\<^sub>B \<alpha>\<^sub>B \<iota>\<^sub>B C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C F
      using assms(1) by auto
    interpret G: strict_monoidal_functor C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D G
      using assms(2) by auto
    interpret GoF: composite_functor B C D F G ..
    show ?thesis
      using F.strictly_preserves_T F.strictly_preserves_\<iota> F.strictly_preserves_\<alpha>
            G.strictly_preserves_T G.strictly_preserves_\<iota> G.strictly_preserves_\<alpha>
      by (unfold_locales, simp_all)
  qed

  text \<open>
    An equivalence of monoidal categories is a monoidal functor whose underlying
    ordinary functor is also part of an ordinary equivalence of categories.
\<close>

  locale equivalence_of_monoidal_categories =
    C: monoidal_category C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C +
    D: monoidal_category D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D +
    equivalence_of_categories C D F G \<eta> \<epsilon> +
    monoidal_functor D T\<^sub>D \<alpha>\<^sub>D \<iota>\<^sub>D C T\<^sub>C \<alpha>\<^sub>C \<iota>\<^sub>C F \<phi>
  for C :: "'c comp"                    (infixr "\<cdot>\<^sub>C" 55)
  and T\<^sub>C :: "'c * 'c \<Rightarrow> 'c"
  and \<alpha>\<^sub>C :: "'c * 'c * 'c \<Rightarrow> 'c"
  and \<iota>\<^sub>C :: "'c"
  and D :: "'d comp"                    (infixr "\<cdot>\<^sub>D" 55)
  and T\<^sub>D :: "'d * 'd \<Rightarrow> 'd"
  and \<alpha>\<^sub>D :: "'d * 'd * 'd \<Rightarrow> 'd"
  and \<iota>\<^sub>D :: "'d"
  and F :: "'d \<Rightarrow> 'c"
  and \<phi> :: "'d * 'd \<Rightarrow> 'c"
  and \<iota> :: 'c
  and G :: "'c \<Rightarrow> 'd"
  and \<eta> :: "'d \<Rightarrow> 'd"
  and \<epsilon> :: "'c \<Rightarrow> 'c"

end