Section CategoryTheory.
Context
{obj : Type} {C : obj -> obj -> Type}
{bif : obj -> obj -> obj}
{Eq2_C : Eq2 C}
`{forall a b, Equivalence (eq2 (a := a) (b := b))}
`{Category obj C (Eq2C := _)}
`{Coproduct obj C (Eq2_C := _) (Cat_C := _) bif}.
Local Lemma aux_app_asm_correct1 (I J A B : obj) :
(assoc_r >>>
bimap (id_ I) (assoc_l >>> bimap swap (id_ B) >>> assoc_r) >>>
assoc_l)
⩯ bimap swap (id_ (bif A B)) >>>
(assoc_r >>>
(bimap (id_ J) assoc_l >>>
(assoc_l >>> (bimap swap (id_ B) >>> assoc_r)))).
(** Denotes a list of instruction by binding the resulting trees. *)
Definition denote_list: list instr -> itree E unit :=
traverse_ denote_instr.
(** *** [asm] combinators *)
Proof with try typeclasses eauto.
unfold denote_asm.
(* On the left-hand-side, we have a [loop] of two [asm] mashed together. On the right-hand-side however we have two [loop]s combined together. The game is to massage them through successive rewriting until they line up. *)
(* We first work on the rhs to reduce it to a single loop. The textual explanations are fairly cryptic. The key intuition comes by drawing the state of the circuit and using the rewiring laws the categorical structure provides, as represented for instance here: https://en.wikipedia.org/wiki/Traced_monoidal_category [bimap_ktree_loop] and [loop_bimap_ktree] are the _superposing_ laws. [compose_loop] and [loop_compose] are the _naturality_ in _X_ and _Y_. [loop_loop] is the second _vanishing_ law. *)
match goal with | |- ?x ⩯ _ => set (lhs := x) end.
rewrite loop_superposing.   (* a loop superposed atop another diagram can englob the latter *)
rewrite loop_superposing_2. (* as well as if the loop is under... But it takes a bit more rewiring! *)
rewrite loop_natural_left.  (* a loop append to diagrams can swallow them... *)
rewrite loop_natural_right. (* ... from either side. *)
rewrite loop_vanishing_2.   (* Finally, two nested loop can be combined. *)
(* Remain now to relate the bodies of the loops on each side. *)
(* First by some more equational reasoning. *)
rewrite <- (loop_dinatural' swap swap) by apply swap_involutive.
subst lhs.
apply Proper_loop.
rewrite !cat_assoc.
repeat rewrite <- (cat_assoc _ _ (bimap (denote_bks _) (denote_bks _) >>> _)).
cbn. rewrite relabel_bks_correct, app_bks_correct.
rewrite cat_assoc.
rewrite <- aux_app_asm_correct1, <- aux_app_asm_correct2.
rewrite 2 subpure_swap4; reflexivity.
Qed.

Theorem relabel_asm_correct {A B C D}
(f : sub Fun fin A B) (g : sub Fun fin C D)
(bc : asm B C)
: denote_asm (relabel_asm f g bc)
⩯ subpure f >>> denote_asm bc >>> subpure g.