theory Lazy_lists
  imports Main
    Smap_siterate
begin
  codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

primcorec lmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Llist \<Rightarrow> 'b Llist" where
 "lmap f xs = (case xs of LNil \<Rightarrow> LNil | LCons x xs \<Rightarrow> LCons (f x) (lmap f xs))"

primcorec literate :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Llist"
where "literate f x = LCons x (literate f (f x))"

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec eplus :: "ENat \<Rightarrow> ENat \<Rightarrow> ENat" where
"eplus m n = (if is_zero m then n else ESuc (eplus (epred m) n))"

primcorec llength :: "'a Llist \<Rightarrow> ENat" where
"llength xs = (if lnull xs then EZ else ESuc (llength (ltl xs)))"

primcorec ltake :: "ENat \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "is_zero n \<or> lnull xs \<Longrightarrow> lnull (ltake n xs)"
| "lhd (ltake n xs) = lhd xs"
| "ltl (ltake n xs) = ltake (epred n) (ltl xs)"

fun to_llist :: "'a list \<Rightarrow> 'a Llist" where
  "to_llist [] = LNil"
| "to_llist (Cons x xs) = LCons x (to_llist xs)"

primcorec llist_of_stream :: "'a Stream \<Rightarrow> 'a Llist"
  where "llist_of_stream s = LCons (shd s) (llist_of_stream (stl s))"

(*cohipster lappend *)
(*ca 25 seconds*)
(* lappend_LNil2 *)
lemma lemma_ac [thy_expl]: "lappend y LNil = y"
  by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    simp

lemma lemma_ad [thy_expl]: "lappend LNil y = y"
 by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    simp

lemma lemma_ae [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
 by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    (metis lappend.simps(4) lemma_ac lnull_def)

lemma lemma_af [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"

 by (simp add: lappend.code)
(* lappend_assoc *)
text_raw \<open>\DefineSnippet{lappendassoc}{\<close>
lemma lemma_ag [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
text_raw \<open>}%EndSnippet\<close>
  by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    auto

lemma lemma_ah [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
 by(coinduction arbitrary: y rule: Llist.coinduct_strong)
    (metis Llist.sel(2) lappend.ctr(1) lappend.simps(4) lnull_def)
(*cohipster lmap *)
(* ca 5 seconds *)
lemma lemma_ai [thy_expl]: "lmap y (LCons z LNil) = LCons (y z) LNil"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    simp
text_raw \<open>\DefineSnippet{lemmaaj}{\<close>
lemma lemma_aj [thy_expl]: "LCons (y z) (lmap y x2) = lmap y (LCons z x2)"
text_raw \<open>}%EndSnippet\<close>
  by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    simp
(*cohipster lmap lappend *)
(*ca 80 seconds*)
text_raw \<open>\DefineSnippet{lemmaak}{\<close>
lemma lemma_ak [thy_expl]: "ltl (lmap y z) = lmap y (ltl z)"
text_raw \<open>}%EndSnippet\<close>
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.case_eq_if Llist.collapse(2) Llist.inject lemma_aj lmap.disc_iff(2) lnull_def ltl_def)

lemma lemma_al [thy_expl]: "ltl (lappend z (lmap y z)) = lappend (ltl z) (lmap y z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis lappend.simps(4) lemma_ac lmap.ctr(1))

lemma lemma_am [thy_expl]: "ltl (lappend (lmap y z) z) = lappend (lmap y (ltl z)) z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.sel(2) lappend.disc_iff(1) lappend.simps(4) lemma_ak lmap.disc_iff(2) lnull_def)

lemma lemma_an [thy_expl]: "ltl (lappend (lmap y z) (ltl z)) = lappend (lmap y (ltl z)) (ltl z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.sel(2) lappend.ctr(1) lappend.simps(4) lemma_ak lmap.ctr(1) lmap.disc_iff(2))

(*lmap_lappend_distrib*)
text_raw \<open>\DefineSnippet{lappendlmap}{\<close>
lemma lemma_ao [thy_expl]: "lappend (lmap y z) (lmap y x2) = lmap y (lappend z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt Llist.collapse(2) Llist.sel(1) lappend.disc_iff(1) lappend.simps(3) lappend.simps(4) lemma_aj lemma_ak lmap.disc_iff(2))
text_raw \<open>}%EndSnippet\<close>
(*cohipster literate *)
(*Discovers nothing interesting - 3 seconds ish*)
(*cohipster llength *)
(* ca 4 seconds *)
(*llength_LCons*)
lemma lemma_ap [thy_expl]: "llength (LCons y z) = ESuc (llength z)"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    simp
(*cohipster lappend literate*)
(* 23 seconds *)
(* lappend_iterates *)
lemma lemma_aq [thy_expl]: "lappend (literate z x2) y = literate z x2"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    auto
(*cohipster llength lappend *)
(* 65 seconds *)
lemma lemma_ar [thy_expl]: "llength (lappend z (LCons y x2)) = ESuc (llength (lappend z x2))"
 by(coinduction arbitrary: x2 y z rule: ENat.coinduct_strong)
    (smt ENat.distinct(1) ENat.sel Llist.discI(2) Llist.sel(3) is_zero_def lappend.disc_iff(1) lappend.simps(4) llength.ctr(1) llength.ctr(2))

lemma lemma_as [thy_expl]: "llength (lappend z y) = llength (lappend y z)"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    (metis ENat.sel Lazy_lists.lemma_ar Llist.collapse(2) lappend.disc_iff(1) lappend.simps(4) llength.disc_iff(2) llength.sel)

lemma lemma_at [thy_expl]: "llength (ltl (lappend z y)) = llength (ltl (lappend y z))"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    (metis lemma_as llength.disc_iff(2) llength.sel lnull_def)
(*cohipster eplus *)
(* 85 seconds *)
lemma lemma_au [thy_expl]: "eplus x EZ = x"
 by(coinduction arbitrary: x rule: ENat.coinduct_strong)
    simp
(*178*)
lemma lemma_av [thy_expl]: "eplus EZ x = x"
 by(coinduction arbitrary: x rule: ENat.coinduct_strong)
    simp
(*iadd_Suc_right*)
lemma lemma_aw [thy_expl]: "ESuc (eplus x y) = eplus x (ESuc y)"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis ENat.distinct(1) ENat.sel eplus.code is_zero_def)
(*  eSuc_plus_1 *)
lemma lemma_ax [thy_expl]: "eplus x (ESuc EZ) = ESuc x"
 by(coinduction arbitrary: x rule: ENat.coinduct_strong)
    (metis lemma_au lemma_aw)

lemma lemma_ay [thy_expl]: "eplus y (ESuc x) = eplus x (ESuc y)"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis ENat.collapse(2) ENat.disc(2) eplus.sel lemma_au lemma_aw)
(*174*)
lemma lemma_az [thy_expl]: "eplus (eplus x y) z = eplus x (eplus y z)"
 by(coinduction arbitrary: x y z rule: ENat.coinduct_strong)
    auto

lemma lemma_ba [thy_expl]: "eplus y (ESuc (ESuc x)) = eplus x (ESuc (ESuc y))"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis lemma_aw lemma_ay)

lemma lemma_bb [thy_expl]: "epred (eplus x (ESuc y)) = eplus x y"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    auto
(*176*)
lemma lemma_bc [thy_expl]: "eplus y x = eplus x y"
 by(coinduction arbitrary: x y rule: ENat.coinduct_strong)
    (metis lemma_ay lemma_bb)

lemma lemma_bd [thy_expl]: "eplus y (eplus x z) = eplus x (eplus y z)"
proof(coinduction arbitrary: x y z rule: ENat.coinduct_strong)
  case Eq_ENat thus ?case
    using lemma_az lemma_bc
    by (force simp add: lemma_az lemma_bc)
qed

(*cohipster llength lappend eplus *)
(* 30 seconds *)
(*llength_lappend*)
lemma lemma_be [thy_expl]: "eplus (llength y) (llength z) = llength (lappend y z)"
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    auto

lemma lemma_bf [thy_expl]: "eplus (ESuc (llength y)) (llength z) = ESuc (llength (lappend y z))"
proof(coinduction arbitrary: y z rule: ENat.coinduct_strong)
  case Eq_ENat thus ?case
    using lemma_be
    by (force simp add: lemma_be)
qed

(*cohipster llength lmap*)
(* 18 seconds *)
(* llength_lmap *)
text_raw \<open>\DefineSnippet{llengthlmap}{\<close>
lemma lemma_bg [thy_expl]: "llength (lmap y z) = llength z"
text_raw \<open>}%EndSnippet\<close>
 by(coinduction arbitrary: y z rule: ENat.coinduct_strong)
    (metis lemma_ak llength.disc_iff(2) llength.sel lmap.disc_iff(2))

(*cohipster ltake *)
(* ca 80 seconds *)
lemma lemma_bh [thy_expl]: "ltake y (ltake y z) = ltake y z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    auto
(*ltake_ltl*)
lemma lemma_bi [thy_expl]: "ltl (ltake (ESuc y) z) = ltake y (ltl z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis ENat.disc(2) ENat.sel Llist.sel(2) lnull_def ltake.disc(1) ltake.simps(4))

lemma lemma_bj [thy_expl]: "ltake z (ltake y x2) = ltake y (ltake z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    auto

lemma lemma_bk [thy_expl]: "ltake y (ltake (ESuc y) z) = ltake y z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt ENat.collapse(2) ENat.disc(2) lemma_bi ltake.disc_iff(2) ltake.simps(3))

lemma lemma_bl [thy_expl]: "ltake y (ltl (ltake y z)) = ltl (ltake y z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.sel(2) ltake.ctr(1) ltake.disc_iff(2) ltake.simps(3) ltake.simps(4))
(*ltake_eSuc_LCons*)
lemma lemma_bm [thy_expl]: "ltake (ESuc z) (LCons y x2) = LCons y (ltake z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    simp

lemma lemma_bn [thy_expl]: "ltake y (LCons z (ltake y x2)) = ltake y (LCons z x2)"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt Llist.disc(2) Llist.sel(1) Llist.sel(3) lemma_bj lemma_bl ltake.disc_iff(2) ltake.simps(3) ltake.simps(4))

lemma lemma_bo [thy_expl]: "ltake (ESuc y) (ltl (ltake y z)) = ltl (ltake y z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis lemma_bi lemma_bl)

lemma lemma_bp [thy_expl]: "ltake (ESuc (ESuc y)) (ltake y z) = ltake y z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis ENat.disc(2) lemma_bi lemma_bo ltake.disc_iff(2) ltake.simps(3))

lemma lemma_bq [thy_expl]: "ltake (ESuc EZ) (ltake (ESuc y) z) = ltake (ESuc EZ) z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (simp add: ltake.ctr(1))
(*cohipster ltake lmap*)
(* 32 seconds *)
(* ltake_lmap *)
text_raw \<open>\DefineSnippet{ltakelmap}{\<close>
lemma lemma_br [thy_expl]: "ltake z (lmap y x2) = lmap y (ltake z x2)"
text_raw \<open>}%EndSnippet\<close>
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt ENat.collapse(2) Llist.case_eq_if Llist.sel(1) lemma_ak lemma_bi lmap.disc_iff(2) lmap.sel(1) ltake.ctr(2) ltake.disc_iff(2))

(*cohipster llist_of_stream *)
(* 5 seconds *)
lemma lemma_bw [thy_expl]: "llist_of_stream (SCons y z) = LCons y (llist_of_stream z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    simp
(*cohipster llist_of_stream smap lmap *)
(* 41 seconds *)
lemma lemma_bx [thy_expl]: "llist_of_stream (smap y z) = lmap y (llist_of_stream z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (smt Llist.case_eq_if lemma_ak llist_of_stream.disc_iff llist_of_stream.simps(2) llist_of_stream.simps(3) lmap.disc_iff(2) lmap.sel(1) smap.simps(1) smap.simps(2))
(*cohipster llist_of_stream literate siterate *)
(* 23 seconds *)
lemma lemma_by [thy_expl]: "llist_of_stream (siterate y z) = literate y z"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    auto
(*cohipster lmap literate *)
(* 45 seconds *)
lemma lemma_bz [thy_expl]: "lmap z (LCons y (literate z x2)) = LCons (z y) (literate z (z x2))"
 by(coinduction arbitrary: x2 y z rule: Llist.coinduct_strong)
    (smt Llist.distinct(1) Llist.sel(1) Llist.sel(3) lemma_aj literate.code lnull_def)
(* lmap_iterates *)
lemma lemma_ca [thy_expl]: "lmap y (literate y z) = literate y (y z)"
 by(coinduction arbitrary: y z rule: Llist.coinduct_strong)
    (metis lemma_bz literate.code)

(*cohipster to_llist lappend append *)
(* 80 seconds *)
(* lappend_llist_of_llist_of *)
lemma lemma_cb [thy_expl]: "lappend (to_llist y) (to_llist z) = to_llist (y @ z)"
apply (induct y arbitrary: z)
apply (simp add: lemma_ad)
apply (simp add: lappend.code)
  done
(*cohipster to_llist lmap map *)
(* 65 seconds *)
(*lmap_llist_of*)
text_raw \<open>\DefineSnippet{tollistmap}{\<close>
lemma lemma_cc [thy_expl]: "to_llist (map y z) = lmap y (to_llist z)"
apply (induct z)
apply (simp add: lmap.ctr(1))
apply (simp add: lemma_aj)
  done
text_raw \<open>}%EndSnippet\<close>
end


theory Fold imports Sem_Equiv Vars begin

subsection "Simple folding of arithmetic expressions"

type_synonym
  tab = "vname \<Rightarrow> val option"

fun afold :: "aexp \<Rightarrow> tab \<Rightarrow> aexp" where
"afold (N n) _ = N n" |
"afold (V x) t = (case t x of None \<Rightarrow> V x | Some k \<Rightarrow> N k)" |
"afold (Plus e1 e2) t = (case (afold e1 t, afold e2 t) of
  (N n1, N n2) \<Rightarrow> N(n1+n2) | (e1',e2') \<Rightarrow> Plus e1' e2')"

definition "approx t s \<longleftrightarrow> (ALL x k. t x = Some k \<longrightarrow> s x = k)"

theorem aval_afold[simp]:
assumes "approx t s"
shows "aval (afold a t) s = aval a s"
  using assms
  by (induct a) (auto simp: approx_def split: aexp.split option.split)

theorem aval_afold_N:
assumes "approx t s"
shows "afold a t = N n \<Longrightarrow> aval a s = n"
  by (metis assms aval.simps(1) aval_afold)

definition
  "merge t1 t2 = (\<lambda>m. if t1 m = t2 m then t1 m else None)"

primrec "defs" :: "com \<Rightarrow> tab \<Rightarrow> tab" where
"defs SKIP t = t" |
"defs (x ::= a) t =
  (case afold a t of N k \<Rightarrow> t(x \<mapsto> k) | _ \<Rightarrow> t(x:=None))" |
"defs (c1;;c2) t = (defs c2 o defs c1) t" |
"defs (IF b THEN c1 ELSE c2) t = merge (defs c1 t) (defs c2 t)" |
"defs (WHILE b DO c) t = t |` (-lvars c)"

primrec fold where
"fold SKIP _ = SKIP" |
"fold (x ::= a) t = (x ::= (afold a t))" |
"fold (c1;;c2) t = (fold c1 t;; fold c2 (defs c1 t))" |
"fold (IF b THEN c1 ELSE c2) t = IF b THEN fold c1 t ELSE fold c2 t" |
"fold (WHILE b DO c) t = WHILE b DO fold c (t |` (-lvars c))"

lemma approx_merge:
  "approx t1 s \<or> approx t2 s \<Longrightarrow> approx (merge t1 t2) s"
  by (fastforce simp: merge_def approx_def)

lemma approx_map_le:
  "approx t2 s \<Longrightarrow> t1 \<subseteq>\<^sub>m t2 \<Longrightarrow> approx t1 s"
  by (clarsimp simp: approx_def map_le_def dom_def)

lemma restrict_map_le [intro!, simp]: "t |` S \<subseteq>\<^sub>m t"
  by (clarsimp simp: restrict_map_def map_le_def)

lemma merge_restrict:
  assumes "t1 |` S = t |` S"
  assumes "t2 |` S = t |` S"
  shows "merge t1 t2 |` S = t |` S"
proof -
  from assms
  have "\<forall>x. (t1 |` S) x = (t |` S) x"
   and "\<forall>x. (t2 |` S) x = (t |` S) x" by auto
  thus ?thesis
    by (auto simp: merge_def restrict_map_def
             split: if_splits)
qed

lemma defs_restrict:
  "defs c t |` (- lvars c) = t |` (- lvars c)"
proof (induction c arbitrary: t)
  case (Seq c1 c2)
  hence "defs c1 t |` (- lvars c1) = t |` (- lvars c1)"
    by simp
  hence "defs c1 t |` (- lvars c1) |` (-lvars c2) =
         t |` (- lvars c1) |` (-lvars c2)" by simp
  moreover
  from Seq
  have "defs c2 (defs c1 t) |` (- lvars c2) =
        defs c1 t |` (- lvars c2)"
    by simp
  hence "defs c2 (defs c1 t) |` (- lvars c2) |` (- lvars c1) =
         defs c1 t |` (- lvars c2) |` (- lvars c1)"
    by simp
  ultimately
  show ?case by (clarsimp simp: Int_commute)
next
  case (If b c1 c2)
  hence "defs c1 t |` (- lvars c1) = t |` (- lvars c1)" by simp
  hence "defs c1 t |` (- lvars c1) |` (-lvars c2) =
         t |` (- lvars c1) |` (-lvars c2)" by simp
  moreover
  from If
  have "defs c2 t |` (- lvars c2) = t |` (- lvars c2)" by simp
  hence "defs c2 t |` (- lvars c2) |` (-lvars c1) =
         t |` (- lvars c2) |` (-lvars c1)" by simp
  ultimately
  show ?case by (auto simp: Int_commute intro: merge_restrict)
qed (auto split: aexp.split)

lemma big_step_pres_approx:
  "(c,s) \<Rightarrow> s' \<Longrightarrow> approx t s \<Longrightarrow> approx (defs c t) s'"
proof (induction arbitrary: t rule: big_step_induct)
  case Skip thus ?case by simp
next
  case Assign
  thus ?case
    by (clarsimp simp: aval_afold_N approx_def split: aexp.split)
next
  case (Seq c1 s1 s2 c2 s3)
  have "approx (defs c1 t) s2" by (rule Seq.IH(1)[OF Seq.prems])
  hence "approx (defs c2 (defs c1 t)) s3" by (rule Seq.IH(2))
  thus ?case by simp
next
  case (IfTrue b s c1 s')
  hence "approx (defs c1 t) s'" by simp
  thus ?case by (simp add: approx_merge)
next
  case (IfFalse b s c2 s')
  hence "approx (defs c2 t) s'" by simp
  thus ?case by (simp add: approx_merge)
next
  case WhileFalse
  thus ?case by (simp add: approx_def restrict_map_def)
next
  case (WhileTrue b s1 c s2 s3)
  hence "approx (defs c t) s2" by simp
  with WhileTrue
  have "approx (defs c t |` (-lvars c)) s3" by simp
  thus ?case by (simp add: defs_restrict)
qed

lemma big_step_pres_approx_restrict:
  "(c,s) \<Rightarrow> s' \<Longrightarrow> approx (t |` (-lvars c)) s \<Longrightarrow> approx (t |` (-lvars c)) s'"
proof (induction arbitrary: t rule: big_step_induct)
  case Assign
  thus ?case by (clarsimp simp: approx_def)
next
  case (Seq c1 s1 s2 c2 s3)
  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s1"
    by (simp add: Int_commute)
  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s2"
    by (rule Seq)
  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s2"
    by (simp add: Int_commute)
  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s3"
    by (rule Seq)
  thus ?case by simp
next
  case (IfTrue b s c1 s' c2)
  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s"
    by (simp add: Int_commute)
  hence "approx (t |` (-lvars c2) |` (-lvars c1)) s'"
    by (rule IfTrue)
  thus ?case by (simp add: Int_commute)
next
  case (IfFalse b s c2 s' c1)
  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s"
    by simp
  hence "approx (t |` (-lvars c1) |` (-lvars c2)) s'"
    by (rule IfFalse)
  thus ?case by simp
qed auto

declare assign_simp [simp]

lemma approx_eq:
  "approx t \<Turnstile> c \<sim> fold c t"
proof (induction c arbitrary: t)
  case SKIP show ?case by simp
next
  case Assign
  show ?case by (simp add: equiv_up_to_def)
next
  case Seq
  thus ?case by (auto intro!: equiv_up_to_seq big_step_pres_approx)
next
  case If
  thus ?case by (auto intro!: equiv_up_to_if_weak)
next
  case (While b c)
  hence "approx (t |` (- lvars c)) \<Turnstile>
         WHILE b DO c \<sim> WHILE b DO fold c (t |` (- lvars c))"
    by (auto intro: equiv_up_to_while_weak big_step_pres_approx_restrict)
  thus ?case
    by (auto intro: equiv_up_to_weaken approx_map_le)
qed

lemma approx_empty [simp]:
  "approx empty = (\<lambda>_. True)"
  by (auto simp: approx_def)

theorem constant_folding_equiv:
  "fold c empty \<sim> c"
  using approx_eq [of empty c]
  by (simp add: equiv_up_to_True sim_sym)

end


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

chapter "Cartesian Monoidal Category"

theory CartesianMonoidalCategory
imports MonoidalCategory Category3.CartesianCategory
begin

  locale symmetric_monoidal_category =
    monoidal_category C T \<alpha> \<iota> +
    S: symmetry_functor C C +
    ToS: composite_functor CC.comp CC.comp C S.map T +
    \<sigma>: natural_isomorphism CC.comp C T ToS.map \<sigma>
  for C :: "'a comp"                            (infixr "\<cdot>" 55)
  and T :: "'a * 'a \<Rightarrow> 'a"
  and \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a"
  and \<iota> :: 'a
  and \<sigma> :: "'a * 'a \<Rightarrow> 'a" +
  assumes sym_inverse: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> inverse_arrows (\<sigma> (a, b)) (\<sigma> (b, a))"
  and unitor_coherence: "ide a \<Longrightarrow> \<l>[a] \<cdot> \<sigma> (a, \<I>) = \<r>[a]"
  and assoc_coherence: "\<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow>
                          \<alpha> (b, c, a) \<cdot> \<sigma> (a, b \<otimes> c) \<cdot> \<alpha> (a, b, c)
                             = (b \<otimes> \<sigma> (a, c)) \<cdot> \<alpha> (b, a, c) \<cdot> (\<sigma> (a, b) \<otimes> c)"
  begin

    abbreviation sym                  ("\<s>[_, _]")
    where "sym a b \<equiv> \<sigma> (a, b)"

  end

  locale elementary_symmetric_monoidal_category =
    elementary_monoidal_category C tensor unity lunit runit assoc
  for C :: "'a comp"                  (infixr "\<cdot>" 55)
  and tensor :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"       (infixr "\<otimes>" 53)
  and unity :: 'a                      ("\<I>")
  and lunit :: "'a \<Rightarrow> 'a"              ("\<l>[_]")
  and runit :: "'a \<Rightarrow> 'a"              ("\<r>[_]")
  and assoc :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("\<a>[_, _, _]")
  and sym :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"          ("\<s>[_, _]") +
  assumes sym_in_hom: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> \<guillemotleft>\<s>[a, b] : a \<otimes> b \<rightarrow> b \<otimes> a\<guillemotright>"
  and sym_naturality: "\<lbrakk> arr f; arr g \<rbrakk> \<Longrightarrow> \<s>[cod f, cod g] \<cdot> (f \<otimes> g) = (g \<otimes> f) \<cdot> \<s>[dom f, dom g]"
  and sym_inverse: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> inverse_arrows \<s>[a, b] \<s>[b, a]"
  and unitor_coherence: "ide a \<Longrightarrow> \<l>[a] \<cdot> \<s>[a, \<I>] = \<r>[a]"
  and assoc_coherence: "\<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow>
                          \<a>[b, c, a] \<cdot> \<s>[a, b \<otimes> c] \<cdot> \<a>[a, b, c]
                             = (b \<otimes> \<s>[a, c]) \<cdot> \<a>[b, a, c] \<cdot> (\<s>[a, b] \<otimes> c)"
  begin

    lemma sym_simps [simp]:
    assumes "ide a" and "ide b"
    shows "arr \<s>[a, b]"
    and "dom \<s>[a, b] = a \<otimes> b"
    and "cod \<s>[a, b] = b \<otimes> a"
      using assms sym_in_hom by auto

    interpretation monoidal_category C T \<alpha> \<iota>
      using induces_monoidal_category by simp
    interpretation CC: product_category C C ..

    interpretation S: symmetry_functor C C ..
    interpretation ToS: composite_functor CC.comp CC.comp C S.map T ..

    definition \<sigma> :: "'a * 'a \<Rightarrow> 'a"
    where "\<sigma> f \<equiv> if CC.arr f then \<s>[cod (fst f), cod (snd f)] \<cdot> (fst f \<otimes> snd f) else null"

    interpretation \<sigma>: natural_isomorphism CC.comp C T ToS.map \<sigma>
    proof -
      interpret \<sigma>: transformation_by_components CC.comp C T ToS.map "\<lambda>a. \<s>[fst a, snd a]"
        apply unfold_locales
        using sym_in_hom sym_naturality by auto
      interpret \<sigma>: natural_isomorphism CC.comp C T ToS.map \<sigma>.map
        apply unfold_locales
        using sym_inverse \<sigma>.map_simp_ide by auto
      have "\<sigma> = \<sigma>.map"
        using \<sigma>_def \<sigma>.map_def sym_naturality by fastforce
      thus "natural_isomorphism CC.comp C T ToS.map \<sigma>"
        using \<sigma>.natural_isomorphism_axioms by presburger
    qed

    interpretation symmetric_monoidal_category C T \<alpha> \<iota> \<sigma>
    proof
      show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> inverse_arrows (\<sigma> (a, b)) (\<sigma> (b, a))"
      proof -
        fix a b
        assume a: "ide a" and b: "ide b"
        show "inverse_arrows (\<sigma> (a, b)) (\<sigma> (b, a))"
          using a b sym_inverse comp_arr_dom \<sigma>_def by auto
      qed
      (*
       * TODO: Here just using "lunit" refers to the locale parameter, rather than
       * the constant introduced by the interpretation above of monoidal_category.
       * This is slightly mysterious.
       *)
      show "\<And>a. ide a \<Longrightarrow> local.lunit a \<cdot> \<sigma> (a, local.unity) = local.runit a"
      proof -
        fix a
        assume a: "ide a"
        show "local.lunit a \<cdot> \<sigma> (a, local.unity) = local.runit a"
          using a lunit_agreement \<I>_agreement sym_in_hom comp_arr_dom [of "\<s>[a, \<I>]"]
                unitor_coherence runit_agreement \<sigma>_def
          by simp
      qed
      show "\<And>a b c. \<lbrakk> ide a; ide b; ide c \<rbrakk> \<Longrightarrow>
                      local.assoc b c a \<cdot> \<sigma> (a, local.tensor b c) \<cdot> local.assoc a b c
                        = local.tensor b (\<sigma> (a, c)) \<cdot> local.assoc b a c \<cdot> local.tensor (\<sigma> (a, b)) c"
      proof -
        fix a b c
        assume a: "ide a" and b: "ide b" and c: "ide c"
        show "local.assoc b c a \<cdot> \<sigma> (a, local.tensor b c) \<cdot> local.assoc a b c
                = local.tensor b (\<sigma> (a, c)) \<cdot> local.assoc b a c \<cdot> local.tensor (\<sigma> (a, b)) c"
          using a b c sym_in_hom tensor_preserves_ide \<sigma>_def assoc_coherence
                comp_arr_dom comp_cod_arr
          by simp
      qed
    qed

    lemma induces_symmetric_monoidal_category:
    shows "symmetric_monoidal_category C T \<alpha> \<iota> \<sigma>"
      ..

  end

  context symmetric_monoidal_category
  begin

    interpretation elementary_monoidal_category C tensor unity lunit runit assoc
      using induces_elementary_monoidal_category by auto

    lemma induces_elementary_symmetric_monoidal_category:
    shows "elementary_symmetric_monoidal_category
             C tensor unity lunit runit assoc (\<lambda>a b. \<sigma> (a, b))"
      using \<sigma>.naturality unitor_coherence assoc_coherence sym_inverse
      by unfold_locales auto

  end

  (* TODO: This definition of "diagonal_functor" conflicts with the one in Category3.Limit. *)
  locale diagonal_functor =
    C: category C +
    CC: product_category C C
  for C :: "'a comp"
  begin

    abbreviation map
    where "map f \<equiv> if C.arr f then (f, f) else CC.null"

    lemma is_functor:
    shows "functor C CC.comp map"
      using map_def by unfold_locales auto

    sublocale "functor" C CC.comp map
      using is_functor by simp

  end

  locale cartesian_monoidal_category =
    monoidal_category C T \<alpha> \<iota> +
    \<Omega>: constant_functor C C \<I> +
    \<Delta>: diagonal_functor C +
    \<tau>: natural_transformation C C map \<Omega>.map \<tau> +
    \<delta>: natural_transformation C C map \<open>T o \<Delta>.map\<close> \<delta>
  for C :: "'a comp"                            (infixr "\<cdot>" 55)
  and T :: "'a * 'a \<Rightarrow> 'a"
  and \<alpha> :: "'a * 'a * 'a \<Rightarrow> 'a"
  and \<iota> :: 'a
  and \<delta> :: "'a \<Rightarrow> 'a"                           ("\<d>[_]")
  and \<tau> :: "'a \<Rightarrow> 'a"                           ("\<t>[_]") +
  assumes trm_unity: "\<t>[\<I>] = \<I>"
  and pr0_dup: "ide a \<Longrightarrow> \<r>[a] \<cdot> (a \<otimes> \<t>[a]) \<cdot> \<delta> a = a"
  and pr1_dup: "ide a \<Longrightarrow> \<l>[a] \<cdot> (\<t>[a] \<otimes> a) \<cdot> \<delta> a = a"
  and tuple_pr: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> (\<r>[a] \<cdot> (a \<otimes> \<t>[b]) \<otimes> \<l>[b] \<cdot> (\<t>[a] \<otimes> b)) \<cdot> \<d>[a \<otimes> b] = a \<otimes> b"

  locale elementary_cartesian_monoidal_category =
    elementary_monoidal_category C tensor unity lunit runit assoc
  for C :: "'a comp"                   (infixr "\<cdot>" 55)
  and tensor :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"       (infixr "\<otimes>" 53)
  and unity :: 'a                      ("\<I>")
  and lunit :: "'a \<Rightarrow> 'a"              ("\<l>[_]")
  and runit :: "'a \<Rightarrow> 'a"              ("\<r>[_]")
  and assoc :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("\<a>[_, _, _]")
  and trm :: "'a \<Rightarrow> 'a"                ("\<t>[_]")
  and dup :: "'a \<Rightarrow> 'a"                ("\<d>[_]") +
  assumes trm_in_hom [intro]: "ide a \<Longrightarrow> \<guillemotleft>\<t>[a] : a \<rightarrow> \<I>\<guillemotright>"
  and trm_unity: "\<t>[\<I>] = \<I>"
  and trm_naturality: "arr f \<Longrightarrow> \<t>[cod f] \<cdot> f = \<t>[dom f]"
  and dup_in_hom [intro]: "ide a \<Longrightarrow> \<guillemotleft>\<d>[a] : a \<rightarrow> a \<otimes> a\<guillemotright>"
  and dup_naturality: "arr f \<Longrightarrow> \<d>[cod f] \<cdot> f = (f \<otimes> f) \<cdot> \<d>[dom f]"
  and prj0_dup: "ide a \<Longrightarrow> \<r>[a] \<cdot> (a \<otimes> \<t>[a]) \<cdot> \<d>[a] = a"
  and prj1_dup: "ide a \<Longrightarrow> \<l>[a] \<cdot> (\<t>[a] \<otimes> a) \<cdot> \<d>[a] = a"
  and tuple_prj: "\<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow> (\<r>[a] \<cdot> (a \<otimes> \<t>[b]) \<otimes> \<l>[b] \<cdot> (\<t>[a] \<otimes> b)) \<cdot> \<d>[a \<otimes> b] = a \<otimes> b"

  context cartesian_monoidal_category
  begin

    lemma terminal_unity:
    shows "terminal \<I>"
    proof
      show "ide \<I>" by simp
      show "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> \<I>\<guillemotright>"
      proof
        fix a
        assume a: "ide a"
        show "\<guillemotleft>\<tau> a : a \<rightarrow> \<I>\<guillemotright>" using a by auto
        show "\<And>f. \<guillemotleft>f : a \<rightarrow> \<I>\<guillemotright> \<Longrightarrow> f = \<tau> a"
          using trm_unity \<tau>.naturality comp_cod_arr by fastforce
      qed
    qed

    lemma trm_is_terminal_arr:
    assumes "ide a"
    shows "terminal_arr \<t>[a]"
      using assms terminal_unity by simp

    interpretation elementary_monoidal_category C tensor unity lunit runit assoc
      using induces_elementary_monoidal_category by simp

    interpretation elementary_cartesian_monoidal_category C tensor unity lunit runit assoc \<tau> \<delta>
    proof
      show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<t>[a] : a \<rightarrow> \<I>\<guillemotright>"
        using \<iota>_in_hom by force
      show "\<t>[\<I>] = \<I>"
        using \<tau>.preserves_hom \<iota>_in_hom ide_unity trm_is_terminal_arr terminal_unity
        by (intro terminal_arr_unique) auto
      show "\<And>f. arr f \<Longrightarrow> \<t>[cod f] \<cdot> f = \<t>[dom f]"
        using \<tau>.naturality comp_cod_arr by simp
      show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<d>[a] : a \<rightarrow> a \<otimes> a\<guillemotright>"
        by auto
      show "\<And>f. arr f \<Longrightarrow> \<d>[cod f] \<cdot> f = (f \<otimes> f) \<cdot> \<d>[dom f]"
        using \<delta>.naturality by simp
      show "\<And>a. ide a \<Longrightarrow> \<l>[a] \<cdot> (\<t>[a] \<otimes> a) \<cdot> \<d>[a] = a"
        using pr1_dup lunit_in_hom by simp
      show "\<And>a. ide a \<Longrightarrow> \<r>[a] \<cdot> (a \<otimes> \<t>[a]) \<cdot> \<d>[a] = a"
        using pr0_dup runit_in_hom by simp
      show "\<And>a0 a1. \<lbrakk> ide a0; ide a1 \<rbrakk> \<Longrightarrow>
                     (\<r>[a0] \<cdot> (a0 \<otimes> \<t>[a1]) \<otimes> \<l>[a1] \<cdot> (\<t>[a0] \<otimes> a1)) \<cdot> \<d>[a0 \<otimes> a1]
                       = a0 \<otimes> a1"
        using tuple_pr by simp
    qed

    lemma induces_elementary_cartesian_monoidal_category:
    shows "elementary_cartesian_monoidal_category C tensor \<I> lunit runit assoc \<tau> \<delta>"
      ..

  end

  context elementary_cartesian_monoidal_category
  begin

    lemma trm_simps [simp]:
    assumes "ide a"
    shows "arr \<t>[a]" and "dom \<t>[a] = a" and "cod \<t>[a] = \<I>"
      using assms trm_in_hom by auto

    lemma dup_simps [simp]:
    assumes "ide a"
    shows "arr \<d>[a]" and "dom \<d>[a] = a" and "cod \<d>[a] = a \<otimes> a"
      using assms dup_in_hom by auto

    definition \<tau> :: "'a \<Rightarrow> 'a"
    where "\<tau> f \<equiv> if arr f then \<t>[dom f] else null"

    definition \<delta> :: "'a \<Rightarrow> 'a"
    where "\<delta> f \<equiv> if arr f then \<d>[cod f] \<cdot> f else null"

    interpretation CC: product_category C C ..

    interpretation MC: monoidal_category C T \<alpha> \<iota>
      using induces_monoidal_category by auto

    interpretation I: constant_functor C C MC.unity
      by unfold_locales auto
    interpretation \<Delta>: diagonal_functor C ..
    interpretation D: composite_functor C CC.comp C \<Delta>.map T ..
    interpretation \<tau>: natural_transformation C C map I.map \<tau>
      using trm_naturality I.map_def \<tau>_def \<I>_agreement comp_cod_arr
      by unfold_locales auto
    interpretation \<delta>: natural_transformation C C map D.map \<delta>
      using dup_naturality \<delta>_def comp_arr_dom
      by unfold_locales auto

    interpretation MC: cartesian_monoidal_category C T \<alpha> \<iota> \<delta> \<tau>
    proof
      show "\<tau> MC.unity = MC.unity"
        using \<I>_agreement trm_unity \<tau>_def by simp
      show "\<And>a. ide a \<Longrightarrow> MC.runit a \<cdot> MC.tensor a (\<tau> a) \<cdot> \<delta> a = a"
        using runit_agreement \<tau>_def \<delta>_def prj0_dup comp_arr_dom by auto
      show "\<And>a. ide a \<Longrightarrow> MC.lunit a \<cdot> MC.tensor (\<tau> a) a \<cdot> \<delta> a = a"
        using lunit_agreement \<tau>_def \<delta>_def prj1_dup comp_arr_dom by auto
      show "\<And>a b. \<lbrakk> ide a; ide b \<rbrakk> \<Longrightarrow>
                  MC.tensor (MC.runit a \<cdot> MC.tensor a (\<tau> b)) (MC.lunit b \<cdot> MC.tensor (\<tau> a) b) \<cdot>
                  \<delta> (MC.tensor a b) = MC.tensor a b"
      proof -
        fix a b
        assume a: "ide a" and b: "ide b"
        have "seq \<r>[a] (a \<otimes> \<t>[b])"
          by (metis a b arr_tensor cod_tensor ide_char in_homE runit_in_hom seqI trm_simps(1,3))
        moreover have "seq \<l>[b] (\<t>[a] \<otimes> b)"
          by (metis a b arr_tensor cod_tensor ide_char in_homE lunit_in_hom seqI trm_simps(1,3))
        ultimately show "MC.tensor (MC.runit a \<cdot> MC.tensor a (\<tau> b))
                                   (MC.lunit b \<cdot> MC.tensor (\<tau> a) b) \<cdot> \<delta> (MC.tensor a b) =
                         MC.tensor a b"
          using a b lunit_agreement runit_agreement unitor_coincidence \<tau>_def \<delta>_def comp_arr_dom
                tensor_preserves_ide tuple_prj T_def
          by auto
      qed
    qed

    lemma induces_cartesian_monoidal_category:
    shows "cartesian_monoidal_category C T \<alpha> \<iota> \<delta> \<tau>"
      ..

  end

  text \<open>
    A cartesian category extends to a a cartesian monoidal category by using the product
    structure to obtain the various canonical maps.
  \<close>

  context cartesian_category
  begin

    interpretation C: elementary_cartesian_category C pr0 pr1 \<one> trm
      using extends_to_elementary_cartesian_category by simp
    interpretation CC: product_category C C ..
    interpretation CCC: product_category C CC.comp ..
    interpretation T: binary_functor C C C Prod
      using binary_functor_Prod by simp
    interpretation T: binary_endofunctor C Prod ..
    interpretation ToTC: "functor" CCC.comp C T.ToTC
      using T.functor_ToTC by auto
    interpretation ToCT: "functor" CCC.comp C T.ToCT
      using T.functor_ToCT by auto

    interpretation \<alpha>: transformation_by_components CCC.comp C T.ToTC T.ToCT
                        \<open>\<lambda>abc. assoc (fst abc) (fst (snd abc)) (snd (snd abc))\<close>
    proof
      show "\<And>abc. CCC.ide abc \<Longrightarrow>
                     \<guillemotleft>assoc (fst abc) (fst (snd abc)) (snd (snd abc)) : T.ToTC abc \<rightarrow> T.ToCT abc\<guillemotright>"
        using CCC.ide_char CC.ide_char CCC.arr_char CC.arr_char T.ToTC_def T.ToCT_def
        by auto
      show "\<And>f. CCC.arr f \<Longrightarrow>
                  assoc (fst (CCC.cod f)) (fst (snd (CCC.cod f))) (snd (snd (CCC.cod f)))
                          \<cdot> T.ToTC f =
                  T.ToCT f
                    \<cdot> assoc (fst (CCC.dom f)) (fst (snd (CCC.dom f))) (snd (snd (CCC.dom f)))"
        using CCC.arr_char CC.arr_char CCC.dom_char CCC.cod_char T.ToTC_def T.ToCT_def
              assoc_naturality
        by simp blast
    qed

    abbreviation \<alpha>
    where "\<alpha> \<equiv> \<alpha>.map"

    interpretation \<alpha>: natural_isomorphism CCC.comp C T.ToTC T.ToCT \<alpha>.map
    proof
      show "\<And>a. CCC.ide a \<Longrightarrow> iso (\<alpha>.map a)"
        using CCC.ide_char CC.ide_char \<alpha>.map_simp_ide inverse_arrows_assoc by auto
    qed

    interpretation L: "functor" C C \<open>\<lambda>f. Prod (cod \<iota>, f)\<close>
      using \<iota>_is_terminal_arr T.fixing_ide_gives_functor_1 by simp
    interpretation L: endofunctor C \<open>\<lambda>f. Prod (cod \<iota>, f)\<close> ..
    interpretation \<l>: transformation_by_components C C
                        \<open>\<lambda>f. Prod (cod \<iota>, f)\<close> map \<open>\<lambda>a. pr0 (cod \<iota>) a\<close>
      using \<iota>_is_terminal_arr
      by unfold_locales auto
    interpretation \<l>: natural_isomorphism C C \<open>\<lambda>f. Prod (cod \<iota>, f)\<close> map \<l>.map
      using \<l>.map_simp_ide inverse_arrows_lunit ide_some_terminal
      by unfold_locales auto
    interpretation L: equivalence_functor C C \<open>\<lambda>f. Prod (cod \<iota>, f)\<close>
      using \<l>.natural_isomorphism_axioms naturally_isomorphic_def
            L.isomorphic_to_identity_is_equivalence
      by blast

    interpretation R: "functor" C C \<open>\<lambda>f. Prod (f, cod \<iota>)\<close>
      using \<iota>_is_terminal_arr T.fixing_ide_gives_functor_2 by simp
    interpretation R: endofunctor C\<open>\<lambda>f. Prod (f, cod \<iota>)\<close> ..
    interpretation \<rho>: transformation_by_components C C
                        \<open>\<lambda>f. Prod (f, cod \<iota>)\<close> map \<open>\<lambda>a. pr1 a (cod \<iota>)\<close>
      using \<iota>_is_terminal_arr
      by unfold_locales auto
    interpretation \<rho>: natural_isomorphism C C \<open>\<lambda>f. Prod (f, cod \<iota>)\<close> map \<rho>.map
      using \<rho>.map_simp_ide inverse_arrows_runit ide_some_terminal
      by unfold_locales auto
    interpretation R: equivalence_functor C C \<open>\<lambda>f. Prod (f, cod \<iota>)\<close>
      using \<rho>.natural_isomorphism_axioms naturally_isomorphic_def
            R.isomorphic_to_identity_is_equivalence
      by blast

    interpretation C: monoidal_category C Prod \<alpha>.map \<iota>
      using ide_some_terminal \<iota>_is_iso pentagon comp_assoc
      by unfold_locales auto

    interpretation \<Omega>: constant_functor C C C.unity
      using C.ide_unity
      by unfold_locales auto

    interpretation \<tau>: natural_transformation C C map \<Omega>.map trm
      using C.unity_def \<Omega>.map_def ide_some_terminal trm_naturality comp_cod_arr trm_in_hom
      apply unfold_locales
      using trm_def
          apply auto[1]
         apply fastforce
        apply fastforce
       apply (metis in_homE trm_eqI trm_in_hom cod_pr0 dom_dom)
      by (metis trm_eqI trm_in_hom dom_dom map_simp)

    interpretation \<Delta>: "functor" C CC.comp Diag
      using functor_Diag by simp
    interpretation \<Pi>o\<Delta>: composite_functor C CC.comp C Diag Prod ..

    interpretation natural_transformation C C map \<open>Prod o Diag\<close> dup
      using dup_is_natural_transformation by simp

    lemma unity_agreement:
    shows "C.unity = \<one>"
      using C.unity_def ide_some_terminal by simp

    lemma assoc_agreement:
    assumes "ide a" and "ide b" and "ide c"
    shows "C.assoc a b c = assoc a b c"
      using assms assoc_def \<alpha>.map_simp_ide by simp

    lemma assoc'_agreement:
    assumes "ide a" and "ide b" and "ide c"
    shows "C.assoc' a b c = assoc' a b c"
      using assms inverse_arrows_assoc inverse_unique by auto

    lemma runit_char_eqn:
    assumes "ide a"
    shows "prod (runit a) \<one> = prod a \<iota> \<cdot> assoc a \<one> \<one>"
      using assms ide_one assoc_def comp_assoc prod_tuple comp_cod_arr
      by (intro pr_joint_monic [of a \<one> "prod (runit a) \<one>" "prod a \<iota> \<cdot> assoc a \<one> \<one>"]) auto

    lemma runit_agreement:
    assumes "ide a"
    shows "runit a = C.runit a"
      using assms unity_agreement assoc_agreement C.runit_char(2) runit_char_eqn
            ide_some_terminal
      by (intro C.runit_eqI) auto

    lemma lunit_char_eqn:
    assumes "ide a"
    shows "prod \<one> (lunit a) = prod \<iota> a \<cdot> assoc' \<one> \<one> a"
    proof (intro pr_joint_monic [of \<one> a "prod \<one> (lunit a)" "prod \<iota> a \<cdot> assoc' \<one> \<one> a"])
      show "seq (lunit a) (local.prod \<one> (lunit a))"
        using assms ide_one by simp
      show "lunit a \<cdot> prod \<one> (lunit a) = lunit a \<cdot> prod \<iota> a \<cdot> assoc' \<one> \<one> a"
        using assms ide_one assoc'_def comp_assoc prod_tuple comp_cod_arr by simp
      show "pr1 \<one> a \<cdot> prod \<one> (lunit a) = pr1 \<one> a \<cdot> prod \<iota> a \<cdot> assoc' \<one> \<one> a"
        using assms ide_one assoc'_def comp_cod_arr prod_tuple pr_naturality
        apply simp
        by (metis trm_eqI cod_pr0 cod_pr1 comp_in_homI' ide_prod pr_simps(1,3-6) pr1_in_hom')
    qed

    lemma lunit_agreement:
    assumes "ide a"
    shows "lunit a = C.lunit a"
      using assms unity_agreement assoc'_agreement C.lunit_char(2) lunit_char_eqn
            ide_some_terminal
      by (intro C.lunit_eqI) auto

    interpretation C: cartesian_monoidal_category C Prod \<alpha>.map \<iota> dup trm
    proof
      show "trm C.unity = C.unity"
        by (simp add: C.unity_def ide_some_terminal trm_one)
      show "\<And>a. ide a \<Longrightarrow> C.runit a \<cdot> C.tensor a \<t>[a] \<cdot> dup a = a"
        using comp_runit_term_dup runit_agreement by simp
      show "\<And>a. ide a \<Longrightarrow> C.lunit a \<cdot> C.tensor \<t>[a] a \<cdot> dup a = a"
        using comp_lunit_term_dup lunit_agreement by auto
      show "\<And>a b. \<lbrakk>ide a; ide b\<rbrakk>
                     \<Longrightarrow> C.tensor (C.runit a \<cdot> C.tensor a \<t>[b])
                                  (C.lunit b \<cdot> C.tensor \<t>[a] b) \<cdot> dup (C.tensor a b) =
                         C.tensor a b"
      proof -
        fix a b
        assume a: "ide a" and b: "ide b"
        have "C.tensor (C.runit a \<cdot> C.tensor a \<t>[b])
                       (C.lunit b \<cdot> C.tensor \<t>[a] b) \<cdot> dup (C.tensor a b) =
              prod (C.runit a \<cdot> prod a \<t>[b]) (C.lunit b \<cdot> prod \<t>[a] b) \<cdot> dup (prod a b)"
          using a b by simp
        also have "... = tuple ((C.runit a \<cdot> prod a \<t>[b]) \<cdot> prod a b)
                               ((C.lunit b \<cdot> prod \<t>[a] b) \<cdot> prod a b)"
          using a b ide_one trm_in_hom [of a] trm_in_hom [of b] unity_agreement prod_tuple
          by fastforce
        also have "... = tuple (C.runit a \<cdot> prod a \<t>[b] \<cdot> prod a b)
                               (C.lunit b \<cdot> prod \<t>[a] b \<cdot> prod a b)"
          using comp_assoc by simp
        also have "... = tuple (C.runit a \<cdot> prod a \<t>[b]) (C.lunit b \<cdot> prod \<t>[a] b)"
          using a b comp_arr_dom by simp
        also have "... = tuple (runit a \<cdot> prod a \<t>[b]) (lunit b \<cdot> prod \<t>[a] b)"
          using a b lunit_agreement runit_agreement by simp
        also have "... = tuple (pr1 a b) (pr0 a b)"
        proof -
          have "runit a \<cdot> prod a \<t>[b] = pr1 a b"
            using a b pr_naturality(2) trm_in_hom [of b]
            by (metis cod_pr1 comp_ide_arr ide_char in_homE pr_simps(4,6) seqI)
          moreover have "lunit b \<cdot> prod \<t>[a] b = pr0 a b"
            using a b pr_naturality(1) [of b b b "\<t>[a]" a \<one>] trm_in_hom [of a] comp_cod_arr
            by (metis cod_pr0 ide_char in_homE pr_simps(1))
          ultimately show ?thesis by simp
        qed
        also have "... = prod a b"
          using a b by simp
        finally show "C.tensor (C.runit a \<cdot> C.tensor a \<t>[b])
                               (C.lunit b \<cdot> C.tensor \<t>[a] b) \<cdot> dup (C.tensor a b) =
                      C.tensor a b"
          by auto
      qed
    qed

    lemma extends_to_cartesian_monoidal_category:
    shows "cartesian_monoidal_category C Prod \<alpha>.map \<iota> dup trm"
      ..

  end

  text \<open>
    In a \<open>cartesian_monoidal_category\<close>, the monoidal structure is given by a categorical product
    and terminal object, so that the underlying category is cartesian.
  \<close>

  context cartesian_monoidal_category
  begin

    definition pr0                        ("\<p>\<^sub>0[_, _]")
    where "\<p>\<^sub>0[a, b] \<equiv> if ide a \<and> ide b then \<r>[a] \<cdot> (a \<otimes> \<t>[b]) else null"

    definition pr1                        ("\<p>\<^sub>1[_, _]")
    where "\<p>\<^sub>1[a, b] \<equiv> if ide a \<and> ide b then \<l>[b] \<cdot> (\<t>[a] \<otimes> b) else null"

    lemma pr_in_hom [intro]:
    assumes "ide a0" and "ide a1"
    shows "\<guillemotleft>\<p>\<^sub>0[a0, a1] : a0 \<otimes> a1 \<rightarrow> a0\<guillemotright>"
    and "\<guillemotleft>\<p>\<^sub>1[a0, a1] : a0 \<otimes> a1 \<rightarrow> a1\<guillemotright>"
    proof -
      show "\<guillemotleft>\<p>\<^sub>0[a0, a1] : a0 \<otimes> a1 \<rightarrow> a0\<guillemotright>"
        unfolding pr0_def
        using assms runit_in_hom by fastforce
      show "\<guillemotleft>\<p>\<^sub>1[a0, a1] : a0 \<otimes> a1 \<rightarrow> a1\<guillemotright>"
        unfolding pr1_def
        using assms lunit_in_hom by fastforce
    qed

    lemma pr_simps [simp]:
    assumes "ide a0" and "ide a1"
    shows "arr \<p>\<^sub>0[a0, a1]" and "dom \<p>\<^sub>0[a0, a1] = a0 \<otimes> a1" and "cod \<p>\<^sub>0[a0, a1] = a0"
    and "arr \<p>\<^sub>1[a0, a1]" and "dom \<p>\<^sub>1[a0, a1] = a0 \<otimes> a1" and "cod \<p>\<^sub>1[a0, a1] = a1"
      using assms pr_in_hom(1-2) by blast+

    interpretation P: composite_functor CC.comp C CC.comp T \<Delta>.map ..

    interpretation ECC: elementary_cartesian_category C pr1 pr0 \<I> \<tau>
    proof
      show "\<And>a b. \<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> span \<p>\<^sub>0[a, b] \<p>\<^sub>1[a, b]"
        by simp
      show "\<And>a b. \<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> cod \<p>\<^sub>1[a, b] = b"
        by simp
      show "\<And>a b. \<lbrakk>ide a; ide b\<rbrakk> \<Longrightarrow> cod \<p>\<^sub>0[a, b] = a"
        by simp
      show "ide \<I>"
        by simp
      show "\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<tau> a : a \<rightarrow> \<I>\<guillemotright>"
        by auto
      show "\<And>a f. \<lbrakk>ide a; \<guillemotleft>f : a \<rightarrow> \<I>\<guillemotright>\<rbrakk> \<Longrightarrow> f = \<t>[a]"
        using \<open>\<And>a. ide a \<Longrightarrow> \<guillemotleft>\<t>[a] : a \<rightarrow> \<I>\<guillemotright>\<close> terminalE terminal_unity by blast
      show "\<And>a b. \<not> (ide a \<and> ide b) \<Longrightarrow> \<p>\<^sub>1[a, b] = null"
        using pr1_def by auto
      show "\<And>a b. \<not> (ide a \<and> ide b) \<Longrightarrow> \<p>\<^sub>0[a, b] = null"
        using pr0_def by auto
      show "\<And>f g. span f g \<Longrightarrow> \<exists>!l. \<p>\<^sub>0[cod f, cod g] \<cdot> l = f \<and> \<p>\<^sub>1[cod f, cod g] \<cdot> l = g"
      proof -
        fix f g
        assume fg: "span f g"
        let ?l = "(f \<otimes> g) \<cdot> \<d>[dom f]"
        have "\<p>\<^sub>0[cod f, cod g] \<cdot> ?l = f"
        proof -
          have "\<p>\<^sub>0[cod f, cod g] \<cdot> ?l = (\<r>[cod f] \<cdot> (cod f \<otimes> \<t>[cod g])) \<cdot> (f \<otimes> g) \<cdot> \<d>[dom f]"
            using fg pr0_def by simp
          also have "... = \<r>[cod f] \<cdot> ((cod f \<otimes> \<t>[cod g]) \<cdot> (f \<otimes> g)) \<cdot> \<d>[dom f]"
            using comp_assoc by simp
          also have "... = \<r>[cod f] \<cdot> (f \<otimes> \<t>[dom f]) \<cdot> \<d>[dom f]"
            using fg interchange comp_cod_arr \<tau>.naturality by simp
          also have "... = \<r>[cod f] \<cdot> ((cod f \<otimes> \<t>[cod f]) \<cdot> (f \<otimes> f)) \<cdot> \<d>[dom f]"
            using fg interchange comp_cod_arr \<tau>.naturality by simp
          also have "... = \<r>[cod f] \<cdot> (cod f \<otimes> \<t>[cod f]) \<cdot> (f \<otimes> f) \<cdot> \<d>[dom f]"
            using comp_assoc by simp
          also have "... = (\<r>[cod f] \<cdot> (cod f \<otimes> \<t>[cod f]) \<cdot> \<d>[cod f]) \<cdot> f"
            using fg \<delta>.naturality comp_assoc by simp
          also have "... = f"
            using fg pr0_dup comp_cod_arr by simp
          finally show ?thesis by blast
        qed
        moreover have "\<p>\<^sub>1[cod f, cod g] \<cdot> ?l = g"
        proof -
          have "\<p>\<^sub>1[cod f, cod g] \<cdot> ?l = \<l>[cod g] \<cdot> ((\<t>[cod f] \<otimes> cod g) \<cdot> (f \<otimes> g)) \<cdot> \<d>[dom g]"
            using fg pr1_def comp_assoc by simp
          also have "... = \<l>[cod g] \<cdot> (\<t>[dom f] \<otimes> g) \<cdot> \<d>[dom g]"
            using fg interchange comp_cod_arr \<tau>.naturality
            by simp
          also have "... = \<l>[cod g] \<cdot> ((\<t>[cod g] \<otimes> cod g) \<cdot> (g \<otimes> g)) \<cdot> \<d>[dom g]"
            using fg interchange comp_cod_arr \<tau>.naturality by simp
          also have "... = \<l>[cod g] \<cdot> (\<t>[cod g] \<otimes> cod g) \<cdot> (g \<otimes> g) \<cdot> \<d>[dom g]"
            using comp_assoc by simp
          also have "... = (\<l>[cod g] \<cdot> (\<t>[cod g] \<otimes> cod g) \<cdot> \<d>[cod g]) \<cdot> g"
            using fg \<delta>.naturality comp_assoc by simp
          also have "... = g"
            using fg pr1_dup comp_cod_arr by simp
          finally show ?thesis by blast
        qed
        moreover have "\<And>l. \<lbrakk> \<p>\<^sub>0[cod f, cod g] \<cdot> l = f; \<p>\<^sub>1[cod f, cod g] \<cdot> l = g \<rbrakk> \<Longrightarrow> l = ?l"
        proof -
          fix l
          assume f: "\<p>\<^sub>0[cod f, cod g] \<cdot> l = f" and g: "\<p>\<^sub>1[cod f, cod g] \<cdot> l = g"
          have l: "\<guillemotleft>l : dom f \<rightarrow> cod f \<otimes> cod g\<guillemotright>"
            using f g fg
            by (metis arr_iff_in_hom dom_comp ide_cod pr_simps(5) seqE)
          have "?l = (\<p>\<^sub>0[cod f, cod g] \<cdot> l \<otimes> \<p>\<^sub>1[cod f, cod g] \<cdot> l) \<cdot> \<d>[dom f]"
            using f g by simp
          also have "... = ((\<p>\<^sub>0[cod f, cod g] \<otimes> \<p>\<^sub>1[cod f, cod g]) \<cdot> (l \<otimes> l)) \<cdot> \<d>[dom f]"
            using fg f g interchange by simp
          also have "... = (\<p>\<^sub>0[cod f, cod g] \<otimes> \<p>\<^sub>1[cod f, cod g]) \<cdot> (l \<otimes> l) \<cdot> \<d>[dom f]"
            using comp_assoc by simp
          also have "... = ((\<p>\<^sub>0[cod f, cod g] \<otimes> \<p>\<^sub>1[cod f, cod g]) \<cdot> \<d>[cod f \<otimes> cod g]) \<cdot> l"
            using l \<delta>.naturality [of l] comp_assoc by auto
          also have "... = (cod f \<otimes> cod g) \<cdot> l"
            using f g fg tuple_pr pr0_def pr1_def by auto
          also have "... = l"
            using l comp_cod_arr by auto
          finally show "l = ?l" by simp
        qed
        ultimately show "\<exists>!l. \<p>\<^sub>0[cod f, cod g] \<cdot> l = f \<and> \<p>\<^sub>1[cod f, cod g] \<cdot> l = g"
          by auto
      qed
    qed

    lemma extends_to_elementary_cartesian_category:
    shows "elementary_cartesian_category C pr1 pr0 \<I> \<tau>"
      ..

    lemma is_cartesian_category:
    shows "cartesian_category C"
      using ECC.is_cartesian_category by simp

  end

  (*
   * TODO: I would like to have coherence theorems for symmetric monoidal and cartesian
   * monoidal categories here, but I haven't yet figured out a suitably economical way
   * to extend the existing result.
   *)

end