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

section "Canonical Isomorphisms"

text \<open>
  In this section we develop some technology for working with canonical isomorphisms in a bicategory,
  which permits them to be specified simply by giving syntactic terms that evaluate to the
  domain and codomain, rather than often-cumbersome formulas expressed in terms of unitors and
  associators.
\<close>

theory CanonicalIsos
imports Coherence
begin

  context bicategory
  begin

    interpretation bicategorical_language ..
    interpretation E: self_evaluation_map V H \<a> \<i> src trg ..
    notation E.eval ("\<lbrace>_\<rbrace>")

    text \<open>
      The next definition defines \<open>can u t\<close>, which denotes the unique canonical isomorphism
      from \<open>\<lbrace>t\<rbrace>\<close> to \<open>\<lbrace>u\<rbrace>\<close>.  The ordering of the arguments of \<open>can\<close> has been chosen to be the
      opposite of what was used for \<open>hom\<close>.  Having the arguments to \<open>can\<close> this way makes it easier
      to see at a glance when canonical isomorphisms are composable.  It could probably be argued
      that \<open>hom\<close> should have been defined this way as well, but that choice is somewhat
      well-entrenched by now and the argument for \<open>can\<close> is stronger, as it denotes an arrow and
      therefore appears in expressions composed with other arrows, rather than just as a hypothesis
      or conclusion.
    \<close>

    definition can
    where "can u t \<equiv> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"

    subsection "Basic Properties"

    text \<open>
      The following develop basic properties of \<open>can\<close>.
    \<close>

    lemma can_simps [simp]:
    assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
    shows "arr (can u t)" and "dom (can u t) = \<lbrace>t\<rbrace>" and "cod (can u t) = \<lbrace>u\<rbrace>"
      using assms can_in_hom by auto

    lemma inverse_arrows_can:
    assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
    shows "iso (can u t)" and "inverse_arrows (can u t) (can t u)"
    proof -
      let ?v = "Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>"
      have 1: "Can ?v \<and> Dom ?v = t \<and> Cod ?v = u"
        using assms red_in_Hom Can_red Inv_in_Hom Can_Inv(1) by simp
      show "iso (can u t)"
        unfolding can_def using 1 E.iso_eval_Can by blast
      show "inverse_arrows (can u t) (can t u)"
      proof (unfold can_def)
        show "inverse_arrows \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace>"
        proof
          show "ide (\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace>)"
          proof -
            have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)\<rbrace>"
              by simp
            also have "... = \<lbrace>u\<rbrace>"
            proof (intro E.eval_eqI)
              show 2: "VPar ((Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) u"
                using assms 1 red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_implies_Arr
                      Can_red(1)
                by (simp add: Dom_Ide Cod_Ide)
              show "\<^bold>\<lfloor>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<cdot> Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
              proof -
                have 3: "Can (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
                  using Arr.simps(4) Can.simps(4) Can_Inv(1) Can_red(1) 2 assms(1) assms(2)
                  by presburger
                have "VSeq (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
                  using 2 Arr.simps(4) by blast
                hence "Can (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<and> Can (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<and>
                       Dom (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) = Cod (Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>)"
                  using 3 1 by metis
                thus ?thesis
                  by (metis (no_types) 2 Can.simps(4) Nmlize_Dom Dom_Ide Ide_Nmlize_Can
                      assms(2))
              qed
            qed
            finally have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> = \<lbrace>u\<rbrace>"
              by blast
            moreover have "ide \<lbrace>u\<rbrace>"
              using assms E.ide_eval_Ide by simp
            ultimately show ?thesis by simp
          qed
          show "ide (\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>)"
          proof -
            have "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<rbrace>"
              by simp
            also have "... = \<lbrace>t\<rbrace>"
            proof (intro E.eval_eqI)
              show 2: "VPar ((Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t"
                using assms 1 red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_implies_Arr
                      Can_red(1)
                by (simp add: Dom_Ide Cod_Ide)
              show "\<^bold>\<lfloor>(Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
                using assms 1 2
                by (metis (full_types) Arr.simps(4) Can.simps(4) Can_Inv(1) Can_red(1)
                    Nml_Nmlize(4) Dom_Ide Ide_Nmlize_Can)
            qed
            finally have "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>t\<rbrace>"
              by blast
            moreover have "ide \<lbrace>t\<rbrace>"
              using assms E.ide_eval_Ide by simp
            ultimately show ?thesis by simp
          qed
        qed
      qed
    qed

    lemma inv_can [simp]:
    assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>"
    shows "inv (can u t) = can t u"
      using assms inverse_arrows_can by (simp add: inverse_unique)

    lemma vcomp_can [simp]:
    assumes "Ide t" and "Ide u" and "Ide v" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "\<^bold>\<lfloor>u\<^bold>\<rfloor> = \<^bold>\<lfloor>v\<^bold>\<rfloor>"
    shows "can v u \<cdot> can u t = can v t"
    proof (unfold can_def)
      have "\<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<rbrace>"
        using assms by simp
      also have "... = \<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"
      proof (intro E.eval_eqI)
        show "VPar ((Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)"
          using assms red_in_Hom Inv_in_Hom Ide_implies_Can
          by (simp add: Can_red(1))
        show "\<^bold>\<lfloor>(Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor>"
          using assms Can_red(1) Nml_Nmlize(1) Nmlize_Inv Ide_Nmlize_Can
              Ide_implies_Can \<open>VPar ((Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>) \<^bold>\<cdot> Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) (Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>)\<close>
          apply simp
          by (metis red_simps(4) Nmlize_red Dom_Cod VcompNml_Nml_Dom)
      qed
      finally show "\<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> u\<^bold>\<down>\<rbrace> \<cdot> \<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>Inv (v\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace>"
        by blast
    qed

    lemma hcomp_can [simp]:
    assumes "Ide t" and "Ide u" and "Ide v" and "Ide w" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "\<^bold>\<lfloor>v\<^bold>\<rfloor> = \<^bold>\<lfloor>w\<^bold>\<rfloor>"
    and "Src t = Trg v" and "Src u = Trg w"
    shows "can u t \<star> can w v = can (u \<^bold>\<star> w) (t \<^bold>\<star> v)"
    proof (unfold can_def)
      have "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<rbrace> = \<lbrace>(Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) \<^bold>\<star> (Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>)\<rbrace>"
        using assms by simp
      also have "... = \<lbrace>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<rbrace>"
      proof (intro E.eval_eqI)
        show "VPar (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
        proof -
          have "Arr (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
          proof -
            have "Ide (u \<^bold>\<star> w)"
              using assms by simp
            hence "Can ((u \<^bold>\<star> w)\<^bold>\<down>)"
              using assms Can_red by blast
            thus ?thesis
              using assms Can.simps(4) Can_Inv(1) Dom_Inv Can_implies_Arr Can_red(1)
                    red_simps(4) Nmlize.simps(3) Ide.simps(3)
              by presburger
          qed
          moreover have "Arr (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>)"
            using assms red_in_Hom Inv_in_Hom Ide_implies_Can
            by (simp add: Can_red(1))
          moreover have "Dom (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) =
                         Dom (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
            using assms red_in_Hom Inv_in_Hom Ide_implies_Can
            by (metis (no_types, lifting) Nml_HcompD(3-4) Dom.simps(3-4) red.simps(3)
                red_Nml)
          moreover have "Cod (Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>) =
                         Cod (Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>)"
            using assms red_in_Hom Inv_in_Hom Ide_implies_Can red_Nml
            by (simp add: Can_red(1) Cod_Ide)
          ultimately show ?thesis by simp
        qed
        show "\<^bold>\<lfloor>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down> \<^bold>\<star> Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<^bold>\<rfloor>"
          using assms Inv_in_Hom Ide_implies_Can Nmlize_Inv Ide_Nmlize_Can Can_red
                red2_Nml
          apply auto
          using VcompNml_HcompNml [of u w u w]
             apply (metis red_simps(4) Nml_HcompD(3-4) Nmlize_Nml red_simps(3) red_Nml)
            apply (metis Nml_HcompD(3-4) Nmlize.simps(3) Nmlize_Nml
              red_simps(3) Ide.simps(3) VcompNml_Nml_Dom red_Nml)
           apply (metis Can_red2(1) red_simps(4) Nml_HcompD(3-4) Nmlize.simps(3)
              Nmlize_Nml VcompNml_Cod_Nml red_Nml)
          using red2_Nml Nmlize_red2 Can_red2(1) Nmlize_Hcomp Dom_Ide Ide_implies_Arr
            VcompNml_Nml_Dom Nml_Nmlize(1) Nml_Nmlize(2) Nml_Nmlize(3)
            Nmlize.simps(3)
          by metis
      qed
      finally show "\<lbrace>Inv (u\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> \<star> \<lbrace>Inv (w\<^bold>\<down>) \<^bold>\<cdot> v\<^bold>\<down>\<rbrace> = \<lbrace>Inv ((u \<^bold>\<star> w)\<^bold>\<down>) \<^bold>\<cdot> (t \<^bold>\<star> v)\<^bold>\<down>\<rbrace>"
        by blast
    qed

    subsection "Introduction Rules"

    text \<open>
      To make the \<open>can\<close> notation useful, we need a way to introduce it.
      This is a bit tedious, because in general there can multiple \<open>can\<close>
      notations for the same isomorphism, and we have to use the right ones in the
      right contexts, otherwise we won't be able to compose them properly.
      Thankfully, we don't need the inverse versions of the theorems below,
      as they are easily provable from the non-inverse versions using \<open>inv_can\<close>.
    \<close>

    lemma canI_unitor_0:
    assumes "ide f"
    shows "\<l>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
    and "\<r>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
    proof -
      have "can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) = \<lbrace>\<^bold>\<l>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
        unfolding can_def using assms by (intro E.eval_eqI, simp_all)
      thus 1: "\<l>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
        using assms by (simp add: \<ll>_ide_simp)
      have "can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<r>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
        unfolding can_def using assms by (intro E.eval_eqI, simp_all)
      thus "\<r>[f] = can \<^bold>\<langle>f\<^bold>\<rangle> (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
        using assms by (simp add: \<rr>_ide_simp)
    qed

    lemma canI_unitor_1:
    assumes "obj a"
    shows "\<l>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
    and "\<r>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
    proof -
      have "can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<l>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
        unfolding can_def using assms by (intro E.eval_eqI, simp_all)
      thus 1: "\<l>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
        using assms by (auto simp add: \<ll>_ide_simp)
      have "can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<r>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
        unfolding can_def using assms by (intro E.eval_eqI, simp_all)
      thus "\<r>[a] = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
        using assms by (auto simp add: \<rr>_ide_simp)
    qed

    lemma canI_associator_0:
    assumes "ide f" and "ide g" and "ide h" and "src f = trg g" and "src g = trg h"
    shows "\<a>[f, g, h] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)"
    proof -
      have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>h\<^bold>\<rangle>\<^bold>]\<rbrace>"
        unfolding can_def using assms by (intro E.eval_eqI, simp_all)
      thus "\<a>[f, g, h] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)"
        using assms by (simp add: \<alpha>_def)
    qed

    lemma canI_associator_1:
    assumes "ide f" and "ide g" and "src f = trg g"
    shows "\<a>[trg f, f, g] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
    and "\<a>[f, src f, g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
    and "\<a>[f, g, src g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0)"
    proof -
      show "\<a>[trg f, f, g] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
      proof -
        have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>\<^bold>]\<rbrace>"
          unfolding can_def using assms by (intro E.eval_eqI, simp_all)
        thus ?thesis
          using assms \<alpha>_def by simp
      qed
      show "\<a>[f, src f, g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>)"
      proof -
        have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>g\<^bold>\<rangle>\<^bold>]\<rbrace>"
          unfolding can_def using assms by (intro E.eval_eqI, simp_all)
        thus ?thesis
          using assms \<alpha>_def by simp
      qed
      show "\<a>[f, g, src g] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0)"
      proof -
        have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>g\<^bold>\<rangle>, \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
          unfolding can_def using assms by (intro E.eval_eqI, simp_all)
        thus ?thesis
          using assms \<alpha>_def by simp
      qed
    qed

    lemma canI_associator_2:
    assumes "ide f"
    shows "\<a>[trg f, trg f, f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
    and "\<a>[trg f, f, src f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
    and "\<a>[f, src f, src f] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
    proof -
      show "\<a>[trg f, trg f, f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
      proof -
        have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>\<^bold>]\<rbrace>"
          unfolding can_def using assms by (intro E.eval_eqI, simp_all)
        thus ?thesis
          using assms \<alpha>_def by simp
      qed
      show "\<a>[trg f, f, src f] = can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
      proof -
        have "can (\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
          unfolding can_def using assms by (intro E.eval_eqI, simp_all)
        thus ?thesis
          using assms \<alpha>_def by simp
      qed
      show "\<a>[f, src f, src f] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0)"
      proof -
        have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0) =
              \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>f\<^bold>\<rangle>, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>src f\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
          unfolding can_def using assms by (intro E.eval_eqI, simp_all)
        thus ?thesis
          using assms \<alpha>_def by simp
      qed
    qed

    lemma canI_associator_3:
    assumes "obj a"
    shows "\<a>[a, a, a] = can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
    proof -
      have "can (\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) ((\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) = \<lbrace>\<^bold>\<a>\<^bold>[\<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0, \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0\<^bold>]\<rbrace>"
        unfolding can_def using assms by (intro E.eval_eqI, simp_all)
      thus ?thesis
        using assms \<alpha>_def by auto
    qed

    lemma canI_associator_hcomp:
    assumes "ide f" and "ide g" and "ide h" and "ide k"
    and "src f = trg g" and "src g = trg h" and "src h = trg k"
    shows "\<a>[f \<star> g, h, k] = can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) (((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
    and "\<a>[f, g \<star> h, k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
    and "\<a>[f, g, h \<star> k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
    proof -
      show "\<a>[f \<star> g, h, k] = can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) (((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
      proof -
        have "can ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) (((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) =
              (((f \<star> g) \<star> h \<star> k) \<cdot> (\<a>\<^sup>-\<^sup>1[f, g, h \<star> k] \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot>
                ((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> (g \<star> h \<star> k) \<cdot> (g \<star> h \<star> k) \<cdot> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k]) \<cdot>
                  (((f \<star> g \<star> h) \<cdot> (f \<star> g \<star> h) \<cdot> \<a>[f, g, h]) \<cdot> ((f \<star> g) \<star> h) \<star> k)"
          unfolding can_def using assms \<alpha>_def \<a>'_def \<alpha>'.map_ide_simp by simp
        also have "... = \<a>\<^sup>-\<^sup>1[f, g, h \<star> k] \<cdot> (f \<star> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k] \<cdot> (\<a>[f, g, h] \<star> k)"
          using assms comp_arr_dom comp_cod_arr comp_assoc by simp
        also have "... = \<a>[f \<star> g, h, k]"
          using assms pentagon [of f g h k] invert_side_of_triangle(1) \<alpha>_def \<alpha>'.map_ide_simp
                assoc_simps(1,4-5) ideD(1) iso_assoc preserves_ide seqI
          by simp
        finally show ?thesis by simp
      qed
      show "\<a>[f, g \<star> h, k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
      proof -
        have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle>)) \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) =
              ((f \<star> ((g \<star> h) \<star> k) \<cdot> (\<a>\<^sup>-\<^sup>1[g, h, k] \<cdot> (g \<star> h \<star> k)) \<cdot> (g \<star> h \<star> k)) \<cdot> (f \<star> g \<star> h \<star> k)) \<cdot>
                ((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> (g \<star> h \<star> k) \<cdot> (g \<star> h \<star> k) \<cdot> \<a>[g, h, k]) \<cdot> \<a>[f, g \<star> h, k]) \<cdot>
                  ((f \<star> g \<star> h) \<star> k)"
          unfolding can_def using assms \<alpha>_def \<alpha>'.map_ide_simp \<a>'_def by simp
        also have "... = ((f \<star> \<a>\<^sup>-\<^sup>1[g, h, k]) \<cdot> (f \<star> \<a>[g, h, k])) \<cdot> \<a>[f, g \<star> h, k]"
          using assms comp_arr_dom comp_cod_arr comp_assoc by simp
        also have "... = \<a>[f, g \<star> h, k]"
          using assms comp_cod_arr whisker_left [of f "\<a>\<^sup>-\<^sup>1[g, h, k]" "\<a>[g, h, k]"]
                comp_assoc_assoc'
          by simp
        finally show ?thesis by simp
      qed
      show "\<a>[f, g, h \<star> k] = can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>)"
      proof -
        have "can (\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) ((\<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>g\<^bold>\<rangle>) \<^bold>\<star> \<^bold>\<langle>h\<^bold>\<rangle> \<^bold>\<star> \<^bold>\<langle>k\<^bold>\<rangle>) =
              (f \<star> g \<star> h \<star> k) \<cdot> ((f \<star> g \<star> h \<star> k) \<cdot> (f \<star> g \<star> h \<star> k) \<cdot> \<a>[f, g, h \<star> k]) \<cdot> ((f \<star> g) \<star> h \<star> k)"
          unfolding can_def using assms \<alpha>_def \<alpha>'.map_ide_simp by simp
        also have "... = \<a>[f, g, h \<star> k]"
          using assms comp_arr_dom comp_cod_arr by simp
        finally show ?thesis by simp
      qed
    qed

    subsection "Rules for Eliminating `can'"

    text \<open>
      The following rules are used for replacing \<open>can\<close> in an expression by terms expressed
      using unit and associativity isomorphisms.  They are not really expressed in the form
      of elimination rules, so the names are perhaps a bit misleading.  They are typically
      applied as simplifications.
    \<close>

    lemma canE_unitor:
    assumes "Ide f"
    shows "can f (f \<^bold>\<star> Src f) = \<r>[\<lbrace>f\<rbrace>]"
    and "can f (Trg f \<^bold>\<star> f) = \<l>[\<lbrace>f\<rbrace>]"
    and "can (f \<^bold>\<star> Src f) f = \<r>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
    and "can (Trg f \<^bold>\<star> f) f = \<l>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
    proof -
      show 1: "can f (f \<^bold>\<star> Src f) = \<r>[\<lbrace>f\<rbrace>]"
      proof -
        have f: "\<not>Nml (f \<^bold>\<star> Src f)"
          using assms Nml_HcompD(5) is_Prim0_Src by blast
        have "can f (f \<^bold>\<star> Src f) = \<lbrace>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)\<rbrace>"
          using assms f can_def by simp
        also have "... = \<lbrace>\<^bold>\<r>\<^bold>[f\<^bold>]\<rbrace>"
        proof (intro E.eval_eqI)
          show "VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)) \<^bold>\<r>\<^bold>[f\<^bold>]"
            using assms Nmlize_in_Hom red_in_Hom red2_in_Hom Inv_in_Hom Can_red Can_implies_Arr
                  Nml_Nmlize(1) Ide_implies_Can Nml_Src Nml_implies_Arr
                  HcompNml_Nml_Src Ide_Cod
            apply (simp add: Dom_Ide Cod_Ide)
            apply (intro conjI)
          proof -
            assume f: "Ide f"
            have 1: "Nml (Src f)"
            proof -
              have "Ide (Src f)"
                using f by simp
              thus ?thesis
                using f Obj_Src Nml_Nmlize(1) Nmlize_Src(2) Ide_implies_Arr
                by metis
            qed
            show "Arr (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>)"
              using f 1 Can_red2 Ide_Nmlize_Ide Nml_Nmlize by simp
            show "Dom (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) = \<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>"
              using f 1 Nml_Nmlize red2_in_Hom Ide_Nmlize_Ide by auto
            show "\<^bold>\<lfloor>f\<^bold>\<rfloor> = Cod (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>)"
            proof -
              have "Src \<^bold>\<lfloor>f\<^bold>\<rfloor> = Trg \<^bold>\<lfloor>Src f\<^bold>\<rfloor>"
                using f Nml_Nmlize by simp
              moreover have "\<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<star> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
                using f 1 Nml_Nmlize Nmlize_Src HcompNml_Nml_Src Nml_Src
                by (auto simp add: HcompNml_Nml_Obj)
              thus ?thesis
                using f 1 Obj_Src red2_in_Hom [of "\<^bold>\<lfloor>f\<^bold>\<rfloor>" "\<^bold>\<lfloor>Src f\<^bold>\<rfloor>"] HcompNml_Nml_Src
                      Nml_Nmlize Ide_Nmlize_Ide
                by auto
            qed
          qed
          show "\<^bold>\<lfloor>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<r>\<^bold>[f\<^bold>]\<^bold>\<rfloor>"
            using assms f HcompNml_Nml_Src Nml_Nmlize Can_red Nmlize_Hcomp
                  Nmlize_Inv Nmlize_Src(1) Nmlize_red Nmlize_red2
                  Ide_Nmlize_Can VcompNml_Nml_Ide red_Src
            apply (simp add: HcompNml_Nml_Obj)
          proof -
            assume f: "Ide f"
            have "\<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> Src f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
            proof -
              have "Obj (Src f)"
                using f Obj_Src by simp
              thus ?thesis
                using f apply (cases "Src f")
                by (simp_all add: Nml_Nmlize(1) Nml_Nmlize(2) Ide_Nmlize_Ide)
            qed
            thus "\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> Src f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
              by (metis Cod_Inv Can_red(1) Cod.simps(4) Nmlize.simps(4)
                  Nmlize.simps(7) Nmlize_Vcomp_Cod_Arr red_simps(3)
                  \<open>VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>Src f\<^bold>\<rfloor>) \<^bold>\<cdot> (f\<^bold>\<down> \<^bold>\<star> Src f\<^bold>\<down>)) \<^bold>\<r>\<^bold>[f\<^bold>]\<close> f)
          qed
        qed
        also have "... = \<r>[\<lbrace>f\<rbrace>]"
          using assms E.eval_Runit_Ide by blast
        finally show ?thesis by simp
      qed
      show 2: "can f (Trg f \<^bold>\<star> f) = \<l>[\<lbrace>f\<rbrace>]"
      proof -
        have f: "\<not>Nml (Trg f \<^bold>\<star> f)"
          using assms by (metis Nml.simps(4) Nml_HcompD(6))
        have "can f (Trg f \<^bold>\<star> f) = \<lbrace>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)\<rbrace>"
          using assms f can_def by simp
        also have "... = \<lbrace>\<^bold>\<l>\<^bold>[f\<^bold>]\<rbrace>"
        proof (intro E.eval_eqI)
          show "VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)) \<^bold>\<l>\<^bold>[f\<^bold>]"
            using assms Nmlize_in_Hom red_in_Hom red2_in_Hom Inv_in_Hom Can_red Can_implies_Arr
                  Nml_Nmlize(1) Ide_implies_Can Nml_Trg Nml_implies_Arr
                  HcompNml_Trg_Nml Ide_Cod Nmlize_Trg(1)
            apply (simp add: Dom_Ide Cod_Ide)
            apply (intro conjI)
          proof -
            assume f: "Ide f"
            have 1: "Nml (Trg f)"
            proof -
              have "Ide (Trg f)"
                using f by simp
              thus ?thesis
                using f Obj_Trg Nml_Nmlize(1) Nmlize_Trg(2) Ide_implies_Arr
                by metis
            qed
            show "Arr (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>)"
              using f 1 Can_red2 Ide_Nmlize_Ide Nml_Nmlize(1,3) by simp
            show "Dom (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) = Trg f \<^bold>\<star> \<^bold>\<lfloor>f\<^bold>\<rfloor>"
              using f Obj_Trg 1 Nml_Nmlize(1,3) red2_in_Hom Ide_Nmlize_Ide by auto
            show "\<^bold>\<lfloor>f\<^bold>\<rfloor> = Cod (Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>)"
            proof -
              have "Src (Trg f) = Trg \<^bold>\<lfloor>f\<^bold>\<rfloor>"
                using f Nml_Nmlize(3) by simp
              thus ?thesis
                using f 1 Obj_Trg HcompNml_Trg_Nml Nml_Nmlize(1) Ide_Nmlize_Ide by auto
            qed
          qed
          show "\<^bold>\<lfloor>Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<l>\<^bold>[f\<^bold>]\<^bold>\<rfloor>"
            using assms f HcompNml_Nml_Src Nml_Nmlize Can_red Nmlize_Hcomp
                  Nmlize_Inv Nmlize_Trg(1) Nmlize_red Nmlize_red2
                  Ide_Nmlize_Can VcompNml_Nml_Ide red_Trg
            apply (simp add: HcompNml_Obj_Nml)
          proof -
            assume f: "Ide f"
            have "\<^bold>\<lfloor>Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
            proof -
              have "Obj (Trg f)"
                using f Obj_Trg by simp
              thus ?thesis
                using f apply (cases "Trg f")
                by (simp_all add: Nml_Nmlize(1) Nml_Nmlize(2) Ide_Nmlize_Ide)
            qed
            thus "\<^bold>\<lfloor>f\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>Trg f \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>\<^bold>\<rfloor> \<^bold>\<lfloor>\<^bold>\<cdot>\<^bold>\<rfloor> \<^bold>\<lfloor>f\<^bold>\<rfloor> = \<^bold>\<lfloor>f\<^bold>\<rfloor>"
              by (metis Cod_Inv Can_red(1) Cod.simps(4) Nmlize.simps(4)
                  Nmlize.simps(5) Nmlize_Vcomp_Cod_Arr red_simps(3)
                  \<open>VPar (Inv (f\<^bold>\<down>) \<^bold>\<cdot> (\<^bold>\<lfloor>Trg f\<^bold>\<rfloor> \<^bold>\<Down> \<^bold>\<lfloor>f\<^bold>\<rfloor>) \<^bold>\<cdot> (Trg f\<^bold>\<down> \<^bold>\<star> f\<^bold>\<down>)) \<^bold>\<l>\<^bold>[f\<^bold>]\<close> f)
          qed
        qed
        also have "... = \<l>[\<lbrace>f\<rbrace>]"
          using assms E.eval_Lunit_Ide by blast
        finally show ?thesis by simp
      qed
      show "can (f \<^bold>\<star> Src f) f = \<r>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
        using assms 1 inv_can inv_inv
        by (metis (no_types, lifting) Nml_Nmlize(1) Nmlize.simps(3)
            Nmlize_Src(1) HcompNml_Nml_Src Ide.simps(3) Ide_implies_Arr
            Obj_Src Obj_implies_Ide Trg_Src)
      show "can (Trg f \<^bold>\<star> f) f = \<l>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>]"
        using assms 2 inv_can inv_inv
        by (metis (no_types, lifting) Nml_Nmlize(1) Nmlize.simps(3)
            Nmlize_Trg(1) HcompNml_Trg_Nml Ide.simps(3) Ide_implies_Arr
            Obj_Trg Obj_implies_Ide Src_Trg)
    qed

    lemma canE_associator:
    assumes "Ide f" and "Ide g" and "Ide h" and "Src f = Trg g" and "Src g = Trg h"
    shows "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
    and "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
    proof -
      show "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
      proof -
        have "can (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h) = \<lbrace>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<rbrace>"
          using can_def by simp
        also have "... = \<lbrace>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<rbrace>"
        proof (intro E.eval_eqI)
          have 1: "Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down> \<in> VHom ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h)"
            using assms Inv_in_Hom [of "(f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>"] Can_red [of "f \<^bold>\<star> g \<^bold>\<star> h"]
                  red_in_Hom [of "f \<^bold>\<star> g \<^bold>\<star> h"] red_in_Hom [of "(f \<^bold>\<star> g) \<^bold>\<star> h"]
                  Nmlize_Hcomp_Hcomp Nmlize_Hcomp_Hcomp'
                  Ide_implies_Arr Nml_HcompNml Nmlize_Nml Ide_HcompNml
            by auto
          show par: "VPar (Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<a>\<^bold>[f, g, h\<^bold>]"
            using assms 1 Inv_in_Hom red_in_Hom Ide_in_Hom by simp
          show "\<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
          proof -
            have "\<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
            proof -
              have "Can (Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>)"
                (* Here presburger depends on par being at the end, not after assms. *)
                using assms Nmlize_Inv Can_Inv
                      Arr.simps(10) Arr.simps(4) Can.simps(4) Can_red(1) Ide.simps(3)
                      Src.simps(3) Trg.simps(3) par
                by presburger
              hence "Ide \<^bold>\<lfloor>Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
                using Ide_Nmlize_Can by blast
              thus ?thesis
                using Ide_in_Hom Dom_Ide by presburger
            qed
            also have 6: "... = \<^bold>\<lfloor>(f \<^bold>\<star> g) \<^bold>\<star> h\<^bold>\<rfloor>"
              using 1 Nmlize_Dom [of "Inv ((f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> ((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>"]
              by (metis (mono_tags, lifting) mem_Collect_eq)
            also have 5: "... = Dom \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
              using assms 6 par Nmlize_Dom Nml_Nmlize(4) by metis
            also have "... = \<^bold>\<lfloor>\<^bold>\<a>\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
              using assms 5 Ide_in_Hom by auto
            finally show ?thesis by simp
          qed
        qed
        also have "... = \<a>[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
          using assms E.eval_Assoc_Ide \<alpha>_def by fastforce
        finally show ?thesis by simp
      qed
      show "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
      proof -
        have "can ((f \<^bold>\<star> g) \<^bold>\<star> h) (f \<^bold>\<star> g \<^bold>\<star> h) = \<lbrace>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<rbrace>"
          using can_def by simp
        also have "... = \<lbrace>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<rbrace>"
        proof (intro E.eval_eqI)
          have 1: "Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down> \<in> VHom (f \<^bold>\<star> g \<^bold>\<star> h) ((f \<^bold>\<star> g) \<^bold>\<star> h)"
            using assms Inv_in_Hom [of "((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>"] Can_red [of "(f \<^bold>\<star> g) \<^bold>\<star> h"]
                  red_in_Hom [of "(f \<^bold>\<star> g) \<^bold>\<star> h"] red_in_Hom [of "f \<^bold>\<star> g \<^bold>\<star> h"]
                  Nmlize_Hcomp_Hcomp Nmlize_Hcomp_Hcomp'
                  Ide_implies_Arr Nml_HcompNml Nmlize_Nml Ide_HcompNml
            by auto
          show par: "VPar (Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]"
            using assms 1 Inv_in_Hom red_in_Hom Ide_in_Hom by simp
          show "\<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
          proof -
            have "\<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor> = Dom \<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
            proof -
              have "Can (Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>)"
                using assms Nmlize_Inv Can_Inv
                      Arr.simps(10) Arr.simps(4) Can.simps(4) Can_red(1) Ide.simps(3)
                      Src.simps(3) Trg.simps(3) par
                by presburger
              hence "Ide \<^bold>\<lfloor>Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>\<^bold>\<rfloor>"
                using Ide_Nmlize_Can by blast
              thus ?thesis
                using Ide_in_Hom Dom_Ide by presburger
            qed
            also have 6: "... = \<^bold>\<lfloor>f \<^bold>\<star> g \<^bold>\<star> h\<^bold>\<rfloor>"
              using 1 Nmlize_Dom [of "Inv (((f \<^bold>\<star> g) \<^bold>\<star> h)\<^bold>\<down>) \<^bold>\<cdot> (f \<^bold>\<star> g \<^bold>\<star> h)\<^bold>\<down>"]
              by (metis (mono_tags, lifting) mem_Collect_eq)
            also have 5: "... = Dom \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
              using assms 6 par Nmlize_Dom Nml_Nmlize(4) by metis
            also have "... = \<^bold>\<lfloor>\<^bold>\<a>\<^sup>-\<^sup>1\<^bold>[f, g, h\<^bold>]\<^bold>\<rfloor>"
              using assms 5 Ide_in_Hom by auto
            finally show ?thesis by simp
          qed
        qed
        also have "... = \<a>\<^sup>-\<^sup>1[\<lbrace>f\<rbrace>, \<lbrace>g\<rbrace>, \<lbrace>h\<rbrace>]"
          using assms E.eval_Assoc'_Ide by fastforce
        finally show ?thesis by simp
      qed
    qed

    lemma can_Ide_self:
    assumes "Ide t"
    shows "can t t = \<lbrace>t\<rbrace>"
    proof (unfold can_def)
      show "\<lbrace>Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<rbrace> = \<lbrace>t\<rbrace>"
      proof (intro E.eval_eqI)
        show "VPar (Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t"
          using assms red_in_Hom Inv_in_Hom Ide_implies_Can Can_Inv Can_red(1) Ide_in_Hom(2)
          by auto
        show "\<^bold>\<lfloor>Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>\<^bold>\<rfloor> = \<^bold>\<lfloor>t\<^bold>\<rfloor>"
          using assms red_in_Hom Inv_in_Hom Ide_implies_Can Cod_Inv
          by (metis (mono_tags, lifting) Can_red(1) Nml_Nmlize(1) Nmlize.simps(4)
              Nmlize_Inv Ide_Nmlize_Ide Nmlize_red Inv_Ide VcompNml_Ide_Nml
              \<open>VPar (Inv (t\<^bold>\<down>) \<^bold>\<cdot> t\<^bold>\<down>) t\<close>)
      qed
    qed

    subsection "Rules for Whiskering"

    lemma whisker_can_right_0:
    assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "ide f" and "Src t = \<^bold>\<langle>trg f\<^bold>\<rangle>\<^sub>0"
    shows "can u t \<star> f = can (u \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>) (t \<^bold>\<star> \<^bold>\<langle>f\<^bold>\<rangle>)"
    proof -
      have "f = can \<^bold>\<langle>f\<^bold>\<rangle> \<^bold>\<langle>f\<^bold>\<rangle>"
        using assms can_Ide_self by simp
      thus ?thesis
        using assms Ide_implies_Arr hcomp_can
        by (metis Nml_Nmlize(2) Ide.simps(2) Trg.simps(2))
    qed

    lemma whisker_can_right_1:
    assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "obj a" and "Src t = \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
    shows "can u t \<star> a = can (u \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0) (t \<^bold>\<star> \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0)"
    proof -
      have "a = can \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>a\<^bold>\<rangle>\<^sub>0"
        using assms can_Ide_self by auto
      thus ?thesis
        using assms Ide_implies_Arr hcomp_can
        by (metis Nml_Nmlize(2) Ide.simps(1) Trg.simps(1))
    qed

    lemma whisker_can_left_0:
    assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "ide g" and "Trg t = \<^bold>\<langle>src g\<^bold>\<rangle>\<^sub>0"
    shows "g \<star> can u t = can (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> u) (\<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<star> t)"
    proof -
      have "g = can \<^bold>\<langle>g\<^bold>\<rangle> \<^bold>\<langle>g\<^bold>\<rangle>"
        using assms can_Ide_self by simp
      thus ?thesis
        using assms Ide_implies_Arr hcomp_can
        by (metis Nml_Nmlize(3) Ide.simps(2) Src.simps(2))
    qed

    lemma whisker_can_left_1:
    assumes "Ide t" and "Ide u" and "\<^bold>\<lfloor>t\<^bold>\<rfloor> = \<^bold>\<lfloor>u\<^bold>\<rfloor>" and "obj b" and "Trg t = \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
    shows "b \<star> can u t = can (\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> u) (\<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<star> t)"
    proof -
      have "b = can \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0 \<^bold>\<langle>b\<^bold>\<rangle>\<^sub>0"
        using assms can_Ide_self by auto
      thus ?thesis
        using assms Ide_implies_Arr hcomp_can
        by (metis Nml_Nmlize(3) Ide.simps(1) Src.simps(1))
    qed

  end

end


theory Basic_Lens
imports Main "Separation_Algebra.Separation_Algebra" "../lib/Sep_Algebra_Add"
begin

datatype ('a, 's) basic_lens = BLENS (get\<^sub>b: "'s \<Rightarrow> 'a") (put\<^sub>b: "'a \<Rightarrow> 's \<Rightarrow> 's")
type_notation basic_lens (infixr "\<lhd>" 0)

section \<open>Definite Sep Algebra Values\<close>
(*
  this specifies that a sep. algebra value is 'fully defined', i.e. doesn't contain ambiguities,
  so only 0 can be disjoint with it
*)
inductive sep_definite :: "'a::sep_algebra \<Rightarrow> bool" where
  "(\<And>a'. a ## a' \<Longrightarrow> a' = 0) \<Longrightarrow> sep_definite a"

(* a sep_algebra type that is either 0 or 'definite' in the above sense *)
class definite_sep_algebra = stronger_sep_algebra +
  assumes definite: "a \<noteq> 0 \<Longrightarrow> a ## a' \<Longrightarrow> a' = 0"
begin

subclass unique_zero_sep_algebra
  apply standard
  using local.definite by auto
end

lemma definite_algebra_is_definite[iff]:
  "(a::_::definite_sep_algebra) \<noteq> 0 \<Longrightarrow> sep_definite a"
  by (simp add: definite sep_definite.intros)

instantiation tsa_opt :: (_) definite_sep_algebra
begin
instance
  apply standard
  by (simp add: sep_disj_tsa_opt_def zero_tsa_opt_def)
end

section \<open>Basic Lens\<close>

locale basic_lens =
  fixes L :: "'a \<lhd> 's"
  assumes get_put': "get\<^sub>b L (put\<^sub>b L x s) = x"
  assumes put_get': "put\<^sub>b L (get\<^sub>b L s) s = s"
  assumes put_put': "put\<^sub>b L x (put\<^sub>b L y s) = put\<^sub>b L x s"
begin

definition "get \<equiv> get\<^sub>b L"
definition "put \<equiv> put\<^sub>b L"

definition "is x s \<equiv> get s = x"

definition "update f s \<equiv> put (f (get s)) s"

definition "update_maybe f s \<equiv> case f (get s) of Some a' \<Rightarrow> Some (put a' s) | None \<Rightarrow> None"

lemmas base_defs = get_def put_def
lemmas defs = base_defs is_def[unfolded base_defs] update_def[unfolded base_defs] update_maybe_def[unfolded base_defs]
lemmas ground_defs = defs

lemma unfold:
  assumes "L \<equiv> BLENS get_f put_f"
  shows
    "get s \<equiv> get_f s" "put x s \<equiv> put_f x s" "is x s \<equiv> get_f s = x"
    "update f s \<equiv> put_f (f (get_f s)) s"
    "update_maybe f' s \<equiv> case f' (get_f s) of Some a' \<Rightarrow> Some (put_f a' s) | None \<Rightarrow> None"
  unfolding defs
  unfolding assms
  by (auto simp only: basic_lens.sel)

lemma get_put: "get (put x s) = x"
  unfolding get_def put_def using get_put' by simp

lemma put_get: "put (get s) s = s"
  unfolding get_def put_def using put_get' by simp

lemma put_put: "put x (put y s) = put x s"
  unfolding get_def put_def using put_put' by simp

lemma put_put_comp:
  "put x o put y = put x"
  by (auto simp add: put_put)

lemma is_get: "is x s \<longleftrightarrow> get s = x"
  unfolding is_def by simp

lemma is_put: "is x (put x s)"
  unfolding is_def using get_put by simp

lemma update_id:
  "update id = id" "update (\<lambda>a. a) = id"
  unfolding update_def
  using put_get by auto

lemma update_ignore:
  "update (\<lambda>_. x) = put x"
  unfolding update_def by simp

lemma get_update:
  "get (update f s) = f (get s)"
  unfolding update_def using get_put by simp

lemma update_equality:
  "update f = update f' \<longleftrightarrow> f = f'"
  unfolding update_def
  apply standard+
   apply (metis get_put)
  by simp

lemma update_maybeE[elim!]:
  assumes "update_maybe f s = Some s'"
  obtains a' where "f (get s) = Some a'" "s' = put a' s"
  using get_put assms
  unfolding update_maybe_def
  by (auto split: option.splits)

lemma update_comp':
  "update f o update g = update (f o g)"
  using update_comp
  unfolding comp_def
  by simp

lemma put_equality:
  "put a s = put a' s \<longleftrightarrow> a = a'"
  by (metis get_put)

lemmas laws = get_put put_get put_put put_put_comp is_get is_put update_id update_ignore get_update
  update_comp update_equality update_maybeE update_comp' put_equality

end

section \<open>Basic Pointer Lens\<close>

locale basic_ptr_lens =
  fixes F :: "'p \<Rightarrow> 'a \<lhd> 's" (* F for 'factory', since it produces lenses *)
  assumes is_lens: "basic_lens (F p)"
  assumes put_focused': "p \<noteq> p' \<Longrightarrow> get\<^sub>b (F p) (put\<^sub>b (F p') a s) = get\<^sub>b (F p) s"
begin
definition "get p \<equiv> basic_lens.get (F p)"
definition "put p \<equiv> basic_lens.put (F p)"

definition "is p \<equiv> \<lambda>x s. basic_lens.is (F p) x s"
definition "update p \<equiv> \<lambda>f s. basic_lens.update (F p) f s"

definition "update_maybe p \<equiv> \<lambda>f s. case f (basic_lens.get (F p) s) of Some a' \<Rightarrow> Some (basic_lens.put (F p) a' s) | None \<Rightarrow> None"

lemmas defs = get_def put_def is_def update_def update_maybe_def

lemma put_focused: "p \<noteq> p' \<Longrightarrow> get p (put p' a s) = get p s"
  by (simp add: basic_lens.get_def basic_lens.put_def get_def is_lens put_def put_focused')

lemmas laws = basic_lens.laws[OF is_lens, folded defs] put_focused

lemmas parent_defs = basic_lens.defs[OF is_lens]
lemmas ground_defs = defs[unfolded parent_defs]

lemma unfold:
  assumes "F \<equiv> \<lambda>p. (BLENS (get_f p) (put_f p))"
  shows "get p s \<equiv> get_f p s" "put p x s \<equiv> put_f p x s"
    "is p x s \<equiv> (get_f p s = x)"
    "update p f s \<equiv> put_f p (f (get_f p s)) s"
    "update_maybe p f' s \<equiv> case f' (get_f p s) of Some a' \<Rightarrow> Some (put_f p a' s) | None \<Rightarrow> None"
  unfolding ground_defs
  unfolding assms
  by (auto simp only: basic_lens.sel)

end

section \<open>Basic Lens Equivalence\<close>

locale basic_lens_equiv =
  L: basic_lens L + L': basic_lens L'
  for L  :: "'a \<lhd> 's"
  and L' :: "'b \<lhd> 't" +
  fixes embed_a :: "'v \<Rightarrow> 'a"
  fixes embed_b :: "'v \<Rightarrow> 'b"
  fixes transl_s :: "'s \<Rightarrow> 't"
  assumes get_transl: "L'.get (transl_s s) = embed_b x \<longleftrightarrow> L.get s = embed_a x"
  assumes put_transl: "L'.put (embed_b x) (transl_s s) = transl_s (L.put (embed_a x) s)"
begin

lemma is_transl: "L'.is (embed_b x) (transl_s s) = L.is (embed_a x) s"
  by (simp add: L'.is_def L.is_def get_transl)

lemmas laws = get_transl put_transl is_transl

end

section \<open>Basic Pointer Lens Equivalence\<close>

locale basic_ptr_lens_equiv =
  F: basic_ptr_lens F + F': basic_ptr_lens F'
  for F  :: "'p \<Rightarrow> 'a \<lhd> 's"
  and F' :: "'p \<Rightarrow> 'b \<lhd> 't" +
  fixes embed_a :: "'v \<Rightarrow> 'a"
  fixes embed_b :: "'v \<Rightarrow> 'b"
  fixes transl_s :: "'s \<Rightarrow> 't"
  assumes is_lens_equiv: "basic_lens_equiv (F p) (F' p) embed_a embed_b transl_s"
begin

lemmas laws = basic_lens_equiv.laws[OF is_lens_equiv, folded F.defs, folded F'.defs]

end

section \<open>Composition\<close>

locale compose_basic_lenses =
  L_inner: basic_lens L_inner +
  L_outer: basic_lens L_outer
  for L_inner :: "'a \<lhd> 's"
  and L_outer :: "'s \<lhd> 't"
begin
definition "L \<equiv> BLENS (L_inner.get o L_outer.get) (\<lambda>a. L_outer.update (L_inner.put a))"

lemma update_put_get:
  "L_outer.update (L_inner.put (L_inner.get (L_outer.get s))) s = s"
  using L_inner.put_get L_outer.put_get L_outer.update_def by auto

sublocale basic_lens L
  unfolding L_def
  apply standard
  by (auto simp: L_inner.laws L_outer.laws update_put_get)

lemmas compose_defs = defs[unfolded L_def, simplified, folded L_def]
lemmas compose_ground_defs = compose_defs[unfolded L_inner.ground_defs, unfolded L_outer.ground_defs]

schematic_goal inner_unfold:
  assumes "L_inner \<equiv> BLENS get_f_inner put_f_inner"
  shows
    "get s \<equiv> ?get" "put a s \<equiv> ?put" "is a s \<equiv> ?is"
    "update f s \<equiv> ?update" "update_maybe f' s \<equiv> ?update_maybe"
  unfolding unfold[OF L_def[abs_def]]
  unfolding L_inner.unfold[OF assms]
  by auto

schematic_goal outer_unfold:
  assumes "L_outer \<equiv> BLENS get_f_outer put_f_outer"
  shows
    "get s \<equiv> ?get" "put a s \<equiv> ?put" "is a s \<equiv> ?is"
    "update f s \<equiv> ?update" "update_maybe f' s \<equiv> ?update_maybe"
  unfolding unfold[OF L_def[abs_def]]
  unfolding L_outer.unfold[OF assms]
  by auto

schematic_goal compose_unfold:
  assumes "L_inner \<equiv> BLENS get_f_inner put_f_inner"
  assumes "L_outer \<equiv> BLENS get_f_outer put_f_outer"
  shows
    "get s \<equiv> ?get" "put a s \<equiv> ?put" "is a s \<equiv> ?is"
    "update f s \<equiv> ?update" "update_maybe f' s \<equiv> ?update_maybe"
  unfolding unfold[OF L_def[abs_def]]
  unfolding L_inner.unfold[OF assms(1)] L_outer.unfold[OF assms(2)]
  by auto

end

subsection \<open>Pointer Lens Composition\<close>

locale compose_basic_ptr_lens =
  F_inner: basic_ptr_lens F_inner +
  L_outer: basic_lens L_outer
  for F_inner :: "'p \<Rightarrow> 'a \<lhd> 's"
  and L_outer :: "'s \<lhd> 't"
begin
definition "F p \<equiv> BLENS (F_inner.get p o L_outer.get) (\<lambda>a. L_outer.update (F_inner.put p a))"

lemma update_put_get:
  "L_outer.update (F_inner.put p (F_inner.get p (L_outer.get s))) s = s"
  by (simp add: F_inner.laws(2) L_outer.put_get L_outer.update_def)

sublocale basic_ptr_lens F
  unfolding F_def
  apply standard
  by (auto simp: F_inner.laws L_outer.laws update_put_get)

lemmas compose_defs = ground_defs[unfolded F_def, simplified, folded F_def]
lemmas compose_ground_defs = compose_defs[unfolded F_inner.ground_defs, unfolded L_outer.ground_defs]

schematic_goal compose_unfold:
  assumes "F_inner \<equiv> \<lambda>p. BLENS (get_f_inner p) (put_f_inner p)"
  assumes "L_outer \<equiv> BLENS get_f_outer put_f_outer"
  shows
    "get p s \<equiv> ?get" "put p a s \<equiv> ?put" "is p a s \<equiv> ?is"
    "update p f s \<equiv> ?update" "update_maybe p f' s \<equiv> ?update_maybe"
  unfolding unfold[OF F_def[abs_def]]
  unfolding F_inner.unfold[OF assms(1)] L_outer.unfold[OF assms(2)]
  by auto

schematic_goal compose_inner_unfold:
  assumes "F_inner \<equiv> \<lambda>p. BLENS (get_f_inner p) (put_f_inner p)"
  shows
    "get p s \<equiv> ?get" "put p a s \<equiv> ?put" "is p a s \<equiv> ?is"
    "update p f s \<equiv> ?update" "update_maybe p f' s \<equiv> ?update_maybe"
  unfolding unfold[OF F_def[abs_def]]
  unfolding F_inner.unfold[OF assms(1)]
  by auto

end

section \<open>Combination\<close>

locale combine_basic_lenses = left: basic_lens Ll + right: basic_lens Lr
  for Ll :: "'al \<lhd> 's"
  and Lr :: "'ar \<lhd> 's"  +
assumes separate:
  "right.get (left.put al s) = right.get s"
  "left.get (right.put ar s) = left.get s"
  "left.put al (right.put ar s) = right.put ar (left.put al s)"
begin

definition "L \<equiv> BLENS (\<lambda>s. (left.get s, right.get s)) (\<lambda>(vl', vr'). left.put vl' o right.put vr')"

sublocale basic_lens L
  unfolding L_def
  apply standard
  by (auto simp: left.laws right.laws separate)

lemmas combine_defs = ground_defs[unfolded L_def, simplified basic_lens.sel, folded L_def]
lemmas combine_ground_defs = combine_defs[unfolded left.ground_defs, unfolded right.ground_defs]
end

section \<open>Sep Algebra Lens\<close>

locale sep_algebra_lens = basic_lens L
  for L :: "'a::stronger_sep_algebra \<lhd> 's::stronger_sep_algebra" +
  assumes get_zero: "get 0 = 0"
  assumes put_zero: "put 0 0 = 0"
  assumes get_split: "x ## y \<Longrightarrow> get (x + y) = get x + get y"
  assumes put_split: "x ## y \<Longrightarrow> ax ## ay \<Longrightarrow> put (ax + ay) (x + y) = put ax x + put ay y"
  assumes disj_consistent:
    "x ## y \<Longrightarrow> get x ## get y"
    "x ## y \<Longrightarrow> ax ## ay \<Longrightarrow> put ax x ## put ay y"
    "put 0 x ## put 0 y \<Longrightarrow> ax ## ay \<Longrightarrow> put ax x ## put ay y"
  assumes zero_split: "x ## y \<Longrightarrow> x + y = put (get x + get y) 0 \<Longrightarrow> x = put (get x) 0"
begin
definition lift :: "'a \<Rightarrow> 's" where
  "lift a \<equiv> put a 0"

definition del :: "'s \<Rightarrow> 's" where
  "del \<equiv> put 0"

definition discard_rest :: "'s \<Rightarrow> 's" where
  "discard_rest s \<equiv> lift (get s)"

definition zero_otherwise :: "'s \<Rightarrow> bool" where
  "zero_otherwise s \<equiv> s = discard_rest s"

lemmas sep_defs = lift_def discard_rest_def[unfolded lift_def]
  zero_otherwise_def[unfolded discard_rest_def, unfolded lift_def]
lemmas sep_ground_defs = sep_defs[unfolded defs]

lemma zero_zero: "zero_otherwise 0"
  unfolding zero_otherwise_def discard_rest_def lift_def
  by (simp add: get_zero put_zero)

lemma lift_zero: "lift 0 = 0"
  unfolding lift_def
  by (simp add: put_zero)

lemma get_lift: "get (lift a) = a"
  unfolding lift_def
  by (simp add: get_put)

lemma zero_lift: "zero_otherwise (lift a)"
  unfolding zero_otherwise_def discard_rest_def lift_def
  by (simp add: get_put)

lemma zero_if_zero_otherwise: "get fa = 0 \<Longrightarrow> zero_otherwise fa \<Longrightarrow> fa = 0"
  unfolding zero_otherwise_def discard_rest_def lift_def
  by (simp add: put_zero)

lemma zero_otherwiseE:
  "zero_otherwise s \<Longrightarrow> s = lift (get s)"
  unfolding zero_otherwise_def discard_rest_def lift_def by simp

lemma zero_split': "x ## y \<Longrightarrow> zero_otherwise (x + y) \<Longrightarrow> zero_otherwise x"
  by (simp add: discard_rest_def get_split lift_def zero_otherwise_def zero_split)

lemma lift_disj: "ax ## ay \<Longrightarrow> lift ax ## lift ay"
  unfolding lift_def
  by (simp add: disj_consistent(2) put_zero)

lemma lift_split: "ax ## ay \<Longrightarrow> lift (ax + ay) = lift ax + lift ay"
  unfolding lift_def
  by (metis disjoint_zero_sym put_split sep_add_zero_sym)

lemma split_zero: "ax ## ay \<Longrightarrow> get s = ax + ay \<Longrightarrow> zero_otherwise s \<Longrightarrow> s = lift ax + lift ay"
  unfolding zero_otherwise_def discard_rest_def lift_def
  using lift_def lift_split by auto

lemma lift_del_disj:
  "lift a ## del s"
  by (simp add: del_def lift_def put_zero sep_algebra_lens.disj_consistent(3) sep_algebra_lens_axioms)

lemma del_put: "del (put v s) = del (put v' s)"
  by (simp add: del_def put_put)

lemma del_zero: "zero_otherwise s \<Longrightarrow> del s = 0"
  by (metis del_def del_put sep_ground_defs(3) put_def put_zero)

lemma lift_get_disj: "lift a ## s \<longleftrightarrow> a ## get s"
  unfolding lift_def
  by (metis disj_consistent(1) disj_consistent(2) disjoint_zero_sym get_put put_get)

lemma del_lift_definite:
  assumes "sep_definite a" (* meaning: a is completely defined, only 0 can be disj with it *)
  shows "lift a ## s \<Longrightarrow> del (lift a + s) = s"
  apply (rule sep_definite.cases[OF assms])
  by (metis del_def lift_def lift_get_disj put_get put_put put_split sep_add_zero_sym sep_disj_commuteI sep_disj_zero)

lemma is_split: "is a s \<Longrightarrow> s = lift a + del s"
  by (metis basic_lens.put_get basic_lens_axioms del_def disjoint_zero_sym is_def lift_def put_split sep_add_zero sep_add_zero_sym sep_disj_zero)

lemmas sep_laws = get_zero put_zero get_split put_split disj_consistent zero_split
  zero_zero lift_zero get_lift zero_lift zero_if_zero_otherwise zero_split' lift_disj lift_split split_zero
  lift_del_disj del_put del_zero del_lift_definite is_split

lemma lift_alt_def: "s = lift a \<longleftrightarrow> get s = a \<and> zero_otherwise s"
  using discard_rest_def get_lift zero_otherwise_def by auto

end

section \<open>Sep Algebra Pointer Lens\<close>

locale sep_algebra_ptr_lens = basic_ptr_lens F
  for F :: "'p \<Rightarrow> 'a::stronger_sep_algebra \<lhd> 's::stronger_sep_algebra" +
  assumes is_sep_lens: "sep_algebra_lens (F p)"
begin

definition lift :: "'p \<Rightarrow> 'a \<Rightarrow> 's" where
  "lift p = sep_algebra_lens.lift (F p)"

definition zero_otherwise :: "'p \<Rightarrow> 's \<Rightarrow> bool" where
  "zero_otherwise p \<equiv> sep_algebra_lens.zero_otherwise (F p)"

definition del :: "'p \<Rightarrow> 's \<Rightarrow> 's" where
  "del p = sep_algebra_lens.del (F p)"

lemmas underlying_ground_defs = sep_algebra_lens.sep_ground_defs[OF is_sep_lens]

lemmas sep_defs = lift_def del_def zero_otherwise_def
lemmas sep_ground_defs = sep_defs[unfolded underlying_ground_defs]

lemmas sep_laws = sep_algebra_lens.sep_laws[OF is_sep_lens, folded defs, folded sep_defs]
end

section \<open>Compose Sep Algebra Pointer Lens\<close>

locale compose_sep_algebra_ptr_lens =
  F_inner: sep_algebra_ptr_lens F_inner +
  L_outer: sep_algebra_lens L_outer
  for F_inner :: "'p \<Rightarrow> 'a::stronger_sep_algebra \<lhd> 's::stronger_sep_algebra"
  and L_outer :: "'s::stronger_sep_algebra \<lhd> 't::stronger_sep_algebra"
begin

sublocale compose_basic_ptr_lens F_inner L_outer
  by standard

lemma have_lens_axioms: "\<And>p. sep_algebra_lens_axioms (F p)"
  unfolding sep_algebra_lens_axioms_def parent_defs
  apply (simp add: F_def L_outer.update_def F_inner.laws L_outer.laws)
  by (smt (z3) F_inner.sep_laws(1) F_inner.sep_laws(2) F_inner.sep_laws(3) F_inner.sep_laws(4) F_inner.sep_laws(5) F_inner.sep_laws(6) F_inner.sep_laws(7) F_inner.sep_laws(8) L_outer.get_def L_outer.get_put' L_outer.get_split L_outer.get_zero L_outer.put_def L_outer.put_put' L_outer.put_split L_outer.put_zero L_outer.sep_laws(5) L_outer.sep_laws(6) L_outer.zero_split)

sublocale sep_algebra_ptr_lens F
  unfolding sep_algebra_ptr_lens_def
  apply standard
   apply (simp add: basic_ptr_lens_axioms)
  unfolding sep_algebra_ptr_lens_axioms_def sep_algebra_lens_def
  apply standard
  apply standard
  by (auto simp add: is_lens have_lens_axioms)
end

section \<open>Lens-Assertion Connection\<close>

locale lens_assertion =
  concrete: basic_ptr_lens Fc + abstract: sep_algebra_ptr_lens F\<alpha> +
  basic_ptr_lens_equiv Fc F\<alpha> embed_c embed_\<alpha> \<alpha>
  for Fc :: "'p \<Rightarrow> 'vc \<lhd> 'c" (* access to elements in concrete realm *)
  and F\<alpha> :: "'p \<Rightarrow> 'va::stronger_sep_algebra \<lhd> 'a::stronger_sep_algebra" (* access to elements in abstract realm *)
  and embed_c :: "'v \<Rightarrow> 'vc"
  and embed_\<alpha> :: "'v \<Rightarrow> 'va"
  and \<alpha> :: "'c \<Rightarrow> 'a" +
assumes embed_\<alpha>_notnull:
  "\<not>(\<exists>v. embed_\<alpha> v = va) \<Longrightarrow> va = 0"
assumes valid_embed: "sep_definite (embed_\<alpha> v)"
fixes is_null_value :: "'vc \<Rightarrow> bool"
assumes null_value: "is_null_value vc \<longleftrightarrow> \<not>(\<exists>v. embed_c v = vc)"
begin

lemma abstract_is_null: "is_null_value (concrete.get p s) \<Longrightarrow> abstract.get p (\<alpha> s) = 0"
  apply (simp add: null_value)
  using laws(1) embed_\<alpha>_notnull
  by metis

(* the abstract state that models exactly the p\<rightarrow>v relationship *)
definition exact_is :: "'p \<Rightarrow> 'v \<Rightarrow> 'a" where
  "exact_is p v \<equiv> abstract.lift p (embed_\<alpha> v)"

(* the 'rest' of an abstract state without any information about p *)
definition rest_is :: "'p \<Rightarrow> 'a \<Rightarrow> 'a" where
  "rest_is p \<equiv> abstract.del p"

lemma exact_rest_disj: "exact_is p v ## rest_is p m"
  unfolding exact_is_def rest_is_def
  by (simp add: abstract.sep_laws)

lemma rest_filter: "exact_is p v ## y \<Longrightarrow> rest_is p (exact_is p v + y) = y"
  unfolding exact_is_def rest_is_def
  by (simp add: abstract.sep_laws(21) valid_embed)

lemma rest_set_determ: "rest_is p (abstract.put p v m) = rest_is p (abstract.put p v' m)"
  unfolding rest_is_def
  by (simp add: abstract.sep_laws)

lemma rest_is_0:
  assumes "is_null_value (concrete.get p c)"
  shows "rest_is p (\<alpha> c) = \<alpha> c"
  unfolding rest_is_def
  by (metis abstract.laws(2) abstract.laws(6) abstract.sep_laws(10) abstract.sep_laws(22) abstract_is_null assms sep_add_zero_sym)

definition assn_is :: "'p \<Rightarrow> 'v \<Rightarrow> 'a \<Rightarrow> bool" where
  "assn_is p v \<equiv> EXACT (exact_is p v)"

lemma assn_is_split:
  "(assn_is p v ** F) a \<longleftrightarrow> a = exact_is p v + rest_is p a \<and> F (rest_is p a)"
  unfolding assn_is_def
  apply standard
   apply (erule sep_conjE)
   apply (simp add: pred_lift_extract_simps(2) rest_filter)
  by (metis EXACT_def exact_rest_disj sep_conjI)

lemma assn_is_concrete:
  "(assn_is p v ** F) (\<alpha> c) \<longleftrightarrow> concrete.is p (embed_c v) c \<and> F (rest_is p (\<alpha> c))"
  unfolding assn_is_split
  by (metis abstract.del_def abstract.ground_defs(1) abstract.is_lens abstract.is_sep_lens abstract.laws(5) abstract.parent_defs(1) abstract.sep_laws(11) abstract.sep_laws(22) abstract.sep_laws(3) basic_lens.get_put exact_is_def laws(3) lens_assertion.exact_rest_disj lens_assertion_axioms rest_is_def sep_algebra_lens.del_def)

lemma assn_is_update:
  assumes "(assn_is p v \<and>* F) (\<alpha> c)"
  shows "(assn_is p v' \<and>* F) (\<alpha> (concrete.put p (embed_c v') c))"
  by (metis abstract.del_def abstract.is_sep_lens abstract.laws(3) abstract.put_def assms(1) assn_is_concrete concrete.laws(6) laws(2) rest_is_def sep_algebra_lens.del_def)

lemma assn_is_create:
  assumes "is_null_value (concrete.get p c)"
  assumes "F (\<alpha> c)"
  shows "(assn_is p v' \<and>* F) (\<alpha> (concrete.put p (embed_c v') c))"
  unfolding assn_is_concrete
  by (metis abstract.laws(2) assms(1) assms(2) concrete.laws(6) laws(2) rest_is_0 rest_set_determ)

lemma assn_is_destroy:
  assumes "is_null_value v'"
  assumes "(assn_is p v \<and>* F) (\<alpha> c)"
  shows "F (\<alpha> (concrete.put p v' c))"
  unfolding assn_is_concrete
  by (metis abstract.laws(2) assms(1) assms(2) assn_is_split concrete.laws(1) concrete.laws(3) laws(2) rest_is_0 rest_set_determ)

end

locale compose_lens_assertion =
  base: lens_assertion Fc F\<alpha> + Lc: basic_lens Lc + L\<alpha>: sep_algebra_lens L\<alpha>
  for Fc :: "'p \<Rightarrow> 'vc \<lhd> 'c"
  and F\<alpha> :: "'p \<Rightarrow> 'va::stronger_sep_algebra \<lhd> 'a::stronger_sep_algebra"
  and Lc :: "'c \<lhd> 'fc"
  and L\<alpha> :: "'a \<lhd> 'fa::stronger_sep_algebra" +
  fixes \<alpha>_full :: "'fc \<Rightarrow> 'fa"
  assumes \<alpha>s: "L\<alpha>.get (\<alpha>_full s) = \<alpha> (Lc.get s)" "L\<alpha>.put (\<alpha> a) (\<alpha>_full s) = \<alpha>_full (Lc.put a s)"
begin

sublocale concrete: compose_basic_ptr_lens Fc Lc
  by standard

sublocale abstract: compose_sep_algebra_ptr_lens F\<alpha> L\<alpha>
  by standard

sublocale lens_assertion concrete.F abstract.F embed_c embed_\<alpha> \<alpha>_full
  unfolding lens_assertion_def basic_ptr_lens_equiv_def basic_ptr_lens_equiv_axioms_def basic_lens_equiv_def
  apply (auto simp add: concrete.basic_ptr_lens_axioms abstract.sep_algebra_ptr_lens_axioms abstract.basic_ptr_lens_axioms
      concrete.is_lens abstract.is_lens)
  unfolding basic_lens_equiv_axioms_def
  apply (auto simp: concrete.parent_defs abstract.parent_defs)
     apply (auto simp: concrete.F_def abstract.F_def L\<alpha>.update_def Lc.update_def \<alpha>s base.laws)
  using base.lens_assertion_axioms lens_assertion.axioms(4) by blast

end

section \<open>Common Interpretations\<close>

definition func_lens :: "'p \<Rightarrow> ('v \<lhd> 'p \<Rightarrow> 'v)" where
  "func_lens \<equiv> \<lambda>p. BLENS (\<lambda>f. f p) (\<lambda>v' f. f(p := v'))"

interpretation func_lens: basic_ptr_lens func_lens
  unfolding func_lens_def
  apply standard
  by auto

lemmas func_lens_unfold = func_lens.unfold[OF func_lens_def]

abbreviation sep_algebra_func_lens :: "'p \<Rightarrow> ('v::unique_zero_sep_algebra \<lhd> 'p \<Rightarrow> 'v)" where
  "sep_algebra_func_lens \<equiv> func_lens"

interpretation sep_algebra_func_lens: sep_algebra_ptr_lens sep_algebra_func_lens
  unfolding sep_algebra_ptr_lens_def
  apply standard
proof -
  show "basic_ptr_lens sep_algebra_func_lens"
    by (simp add: func_lens.basic_ptr_lens_axioms)

  note unfold = basic_ptr_lens.parent_defs[OF this]

  show "sep_algebra_ptr_lens_axioms sep_algebra_func_lens"
    apply standard
    unfolding unfold
              apply (auto simp: func_lens_def)
      apply (simp add: sep_disj_funD)
     apply (metis fun_upd_upd sep_disj_fun_updI)
    unfolding plus_fun_def zero_fun_def sep_disj_fun_def
    apply standard
    by (metis fun_upd_other fun_upd_same unique_zero_simps(4))
qed

lemmas sep_algebra_func_lens_unfold = func_lens_unfold

end