Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.functors MathClasses.theory.categories.

Section natural_transformations_id_comp.
  Context
    `{Category A} `{Category B} `{!Functor (f: A → B) f'}
    `{!Functor (f: A → B) f'} `{!Functor (g: A → B) g'} `{!Functor (h: A → B) h'}
    `{!NaturalTransformation (m:f⇛g)} `{!NaturalTransformation (n:g⇛h)}.

  Global Instance id_transformation: NaturalTransformation (λ a, cat_id: f a ⟶ f a).
  Proof. intros ???. rewrite left_identity, right_identity; reflexivity. Qed.

  Global Instance compose_transformation: NaturalTransformation (λ a, n a ◎ m a).
  Proof.
    intros ???.
    rewrite <- associativity, natural, associativity, natural, associativity; reflexivity.
  Qed.
End natural_transformations_id_comp.

Record Object A `{Arrows A} `{∀ x y : A, Equiv (x ⟶ y)} `{!CatId A} `{!CatComp A}
     B `{Arrows B} `{∀ x y : B, Equiv (x ⟶ y)} `{!CatId B} `{!CatComp B} : Type := object
  { map_obj:> A → B
  ; Fmap_inst:> Fmap map_obj
  ; Functor_inst: Functor map_obj _ }.
#[global]
Existing Instance Fmap_inst.
#[global]
Existing Instance Functor_inst.

Arguments Object _ {Aarrows Aeq Aid Acomp} _ {Barrows Beq Bid Bcomp} : rename.
Arguments object {A Aarrows Aeq Aid Acomp B Barrows Beq Bid Bcomp} {Fmap Functor} _ : rename.
Arguments map_obj {A Aarrows Aeq Aid Acomp B Barrows Beq Bid Bcomp} _ _ : rename.

Record Arrow `{Arrows A} `{∀ x y : A, Equiv (x ⟶ y)} `{!CatId A} `{!CatComp A}
     `{Arrows B} `{∀ x y : B, Equiv (x ⟶ y)} `{!CatId B} `{!CatComp B} (F G : Object A B) : Type := arrow
  { eta:> map_obj F ⇛ map_obj G
  ; NaturalTransformation_inst: NaturalTransformation eta }.
#[global]
Existing Instance NaturalTransformation_inst.

Arguments arrow {A Aarrows Aeq Aid Acomp B Barrows Beq Bid Bcomp F G} _ _ : rename.
Arguments eta {A Aarrows Aeq Aid Acomp B Barrows Beq Bid Bcomp F G} _ _ : rename.

Section contents.
  Context `{Category A} `{Category B}.

  Global Instance: Arrows (Object A B) := Arrow.

  Section arrow_setoid.
    Context (F G : Object A B).

    Global Program Instance e: Equiv (F ⟶ G) :=
      λ m n, ∀ x: A, m x = n x.

    Instance e_refl: Reflexive e.
    Proof. intro a; red; reflexivity. Qed.

    Instance e_sym: Symmetric e.
    Proof. intros m n Hmn a. red in Hmn. rewrite Hmn. reflexivity. Qed.

    Instance e_trans: Transitive e.
    Proof. intros m n o Hmn Hno a. red in Hmn, Hno. rewrite Hmn, Hno. reflexivity. Qed.

    Instance: Equivalence e := {}.
    Global Instance: Setoid (F ⟶ G) := {}.
  End arrow_setoid.

  Global Instance: CatId (Object A B) := λ _, arrow (λ _, cat_id) _.
  Global Instance: CatComp (Object A B) := λ _ _ _ m n, arrow (λ a, m a ◎ n a) _.

  Global Instance: ∀ x y z: Object A B,
    Proper ((=) ==> (=) ==> (=)) ((◎): (y ⟶ z) → (x ⟶ y) → (x ⟶ z)).
  Proof.
    intros ????? Hx ?? Hy a.
    simpl. rewrite (Hx a), (Hy a). reflexivity.
  Qed.

  Instance: ∀ x y: Object A B, LeftIdentity (comp x y y) cat_id.
  Proof. repeat intro. simpl. apply left_identity. Qed.

  Instance: ∀ x y: Object A B, RightIdentity (comp x x y) cat_id.
  Proof. repeat intro. simpl. apply right_identity. Qed.

  Instance: ArrowsAssociative (Object A B).
  Proof. repeat intro. simpl. apply associativity. Qed.

  Global Instance: Category (Object A B) := {}.
End contents.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ABCequalsCBA.
Require Export lemma__NCorder.
Require Export lemma__angledistinct.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__diagonalsmeet.
Require Export lemma__equalanglesNC.
Require Export lemma__equalanglesflip.
Require Export lemma__equalanglestransitive.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelflip.
Require Export lemma__ray4.
Require Export logic.
Require Export proposition__26A.
Require Export proposition__29B.
Definition proposition__34 : forall A B C D, (euclidean__defs.PG A C D B) -> ((euclidean__axioms.Cong A B C D) /\ ((euclidean__axioms.Cong A C B D) /\ ((euclidean__defs.CongA C A B B D C) /\ ((euclidean__defs.CongA A B D D C A) /\ (euclidean__axioms.Cong__3 C A B B D C))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (* Cut *) ((euclidean__defs.Par A C D B) /\ (euclidean__defs.Par A B C D)) as H0.
- assert ((euclidean__defs.Par A C D B) /\ (euclidean__defs.Par A B C D)) as H0 by exact H.
assert ((euclidean__defs.Par A C D B) /\ (euclidean__defs.Par A B C D)) as __TmpHyp by exact H0.
destruct __TmpHyp as [H1 H2].
split.
-- exact H1.
-- exact H2.
- assert (* Cut *) (euclidean__defs.Par A C B D) as H1.
-- destruct H0 as [H1 H2].
assert (* Cut *) ((euclidean__defs.Par C A D B) /\ ((euclidean__defs.Par A C B D) /\ (euclidean__defs.Par C A B D))) as H3.
--- apply (@lemma__parallelflip.lemma__parallelflip A C D B H1).
--- destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
exact H6.
-- assert (* Cut *) (exists M, (euclidean__axioms.BetS A M D) /\ (euclidean__axioms.BetS C M B)) as H2.
--- destruct H0 as [H2 H3].
apply (@lemma__diagonalsmeet.lemma__diagonalsmeet A C D B H).
--- destruct H2 as [M H3].
destruct H3 as [H4 H5].
destruct H0 as [H6 H7].
assert (* Cut *) (euclidean__axioms.BetS B M C) as H8.
---- apply (@euclidean__axioms.axiom__betweennesssymmetry C M B H5).
---- assert (* Cut *) (euclidean__axioms.Col B M C) as H9.
----- right.
right.
right.
right.
left.
exact H8.
----- assert (* Cut *) (euclidean__axioms.Col B C M) as H10.
------ assert (* Cut *) ((euclidean__axioms.Col M B C) /\ ((euclidean__axioms.Col M C B) /\ ((euclidean__axioms.Col C B M) /\ ((euclidean__axioms.Col B C M) /\ (euclidean__axioms.Col C M B))))) as H10.
------- apply (@lemma__collinearorder.lemma__collinearorder B M C H9).
------- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H17.
------ assert (* Cut *) (~(euclidean__defs.Meet A B C D)) as H11.
------- assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B D u) /\ ((euclidean__axioms.Col B D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C B D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H11 by exact H1.
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B D u) /\ ((euclidean__axioms.Col B D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C B D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H11.
destruct __TmpHyp as [x H12].
destruct H12 as [x0 H13].
destruct H13 as [x1 H14].
destruct H14 as [x2 H15].
destruct H15 as [x3 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H37 by exact H7.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H37.
destruct __TmpHyp0 as [x4 H38].
destruct H38 as [x5 H39].
destruct H39 as [x6 H40].
destruct H40 as [x7 H41].
destruct H41 as [x8 H42].
destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col D B u) /\ ((euclidean__axioms.Col D B v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C D B)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H63 by exact H6.
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col D B u) /\ ((euclidean__axioms.Col D B v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C D B)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp1 by exact H63.
destruct __TmpHyp1 as [x9 H64].
destruct H64 as [x10 H65].
destruct H65 as [x11 H66].
destruct H66 as [x12 H67].
destruct H67 as [x13 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
exact H59.
------- assert (* Cut *) (euclidean__axioms.neq A B) as H12.
-------- assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B D u) /\ ((euclidean__axioms.Col B D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C B D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H12 by exact H1.
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B D u) /\ ((euclidean__axioms.Col B D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C B D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H12.
destruct __TmpHyp as [x H13].
destruct H13 as [x0 H14].
destruct H14 as [x1 H15].
destruct H15 as [x2 H16].
destruct H16 as [x3 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H38 by exact H7.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H38.
destruct __TmpHyp0 as [x4 H39].
destruct H39 as [x5 H40].
destruct H40 as [x6 H41].
destruct H41 as [x7 H42].
destruct H42 as [x8 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col D B u) /\ ((euclidean__axioms.Col D B v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C D B)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H64 by exact H6.
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col D B u) /\ ((euclidean__axioms.Col D B v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C D B)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp1 by exact H64.
destruct __TmpHyp1 as [x9 H65].
destruct H65 as [x10 H66].
destruct H66 as [x11 H67].
destruct H67 as [x12 H68].
destruct H68 as [x13 H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
destruct H87 as [H88 H89].
exact H44.
-------- assert (* Cut *) (euclidean__axioms.neq C D) as H13.
--------- assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B D u) /\ ((euclidean__axioms.Col B D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C B D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H13 by exact H1.
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B D u) /\ ((euclidean__axioms.Col B D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C B D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H13.
destruct __TmpHyp as [x H14].
destruct H14 as [x0 H15].
destruct H15 as [x1 H16].
destruct H16 as [x2 H17].
destruct H17 as [x3 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H39 by exact H7.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H39.
destruct __TmpHyp0 as [x4 H40].
destruct H40 as [x5 H41].
destruct H41 as [x6 H42].
destruct H42 as [x7 H43].
destruct H43 as [x8 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col D B u) /\ ((euclidean__axioms.Col D B v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C D B)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H65 by exact H6.
assert (exists U V u v X, (euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.Col A C U) /\ ((euclidean__axioms.Col A C V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col D B u) /\ ((euclidean__axioms.Col D B v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A C D B)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp1 by exact H65.
destruct __TmpHyp1 as [x9 H66].
destruct H66 as [x10 H67].
destruct H67 as [x11 H68].
destruct H68 as [x12 H69].
destruct H69 as [x13 H70].
destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
destruct H88 as [H89 H90].
exact H47.
--------- assert (* Cut *) (~(euclidean__axioms.Col B C A)) as H14.
---------- intro H14.
assert (* Cut *) (euclidean__axioms.Col A B C) as H15.
----------- assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H15.
------------ apply (@lemma__collinearorder.lemma__collinearorder B C A H14).
------------ destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H20.
----------- assert (* Cut *) (C = C) as H16.
------------ apply (@logic.eq__refl Point C).
------------ assert (* Cut *) (euclidean__axioms.Col C D C) as H17.
------------- right.
left.
exact H16.
------------- assert (* Cut *) (euclidean__defs.Meet A B C D) as H18.
-------------- exists C.
split.
--------------- exact H12.
--------------- split.
---------------- exact H13.
---------------- split.
----------------- exact H15.
----------------- exact H17.
-------------- apply (@H11 H18).
---------- assert (* Cut *) (euclidean__axioms.TS A B C D) as H15.
----------- exists M.
split.
------------ exact H4.
------------ split.
------------- exact H10.
------------- apply (@euclidean__tactics.nCol__notCol B C A H14).
----------- assert (* Cut *) (euclidean__defs.CongA A B C B C D) as H16.
------------ apply (@proposition__29B.proposition__29B A D B C H7 H15).
------------ assert (* Cut *) (~(euclidean__axioms.Col B C D)) as H17.
------------- intro H17.
assert (* Cut *) (euclidean__axioms.Col C D B) as H18.
-------------- assert (* Cut *) ((euclidean__axioms.Col C B D) /\ ((euclidean__axioms.Col C D B) /\ ((euclidean__axioms.Col D B C) /\ ((euclidean__axioms.Col B D C) /\ (euclidean__axioms.Col D C B))))) as H18.
--------------- apply (@lemma__collinearorder.lemma__collinearorder B C D H17).
--------------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
exact H21.
-------------- assert (* Cut *) (B = B) as H19.
--------------- apply (@logic.eq__refl Point B).
--------------- assert (* Cut *) (euclidean__axioms.Col A B B) as H20.
---------------- right.
right.
left.
exact H19.
---------------- assert (* Cut *) (euclidean__defs.Meet A B C D) as H21.
----------------- exists B.
split.
------------------ exact H12.
------------------ split.
------------------- exact H13.
------------------- split.
-------------------- exact H20.
-------------------- exact H18.
----------------- assert (~(euclidean__defs.Meet A B C D)) as H22 by exact H11.
apply (@H11 H21).
------------- assert (* Cut *) (euclidean__defs.CongA B C D D C B) as H18.
-------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B C D).
---------------apply (@euclidean__tactics.nCol__notCol B C D H17).

-------------- assert (* Cut *) (euclidean__defs.CongA A B C D C B) as H19.
--------------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive A B C B C D D C B H16 H18).
--------------- assert (* Cut *) (euclidean__axioms.Col C B M) as H20.
---------------- assert (* Cut *) ((euclidean__axioms.Col C B M) /\ ((euclidean__axioms.Col C M B) /\ ((euclidean__axioms.Col M B C) /\ ((euclidean__axioms.Col B M C) /\ (euclidean__axioms.Col M C B))))) as H20.
----------------- apply (@lemma__collinearorder.lemma__collinearorder B C M H10).
----------------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H21.
---------------- assert (* Cut *) (euclidean__axioms.nCol C B A) as H21.
----------------- assert (* Cut *) (euclidean__axioms.nCol B C A) as H21.
------------------ apply (@euclidean__tactics.nCol__notCol B C A H14).
------------------ assert (* Cut *) ((euclidean__axioms.nCol C B A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol B A C) /\ (euclidean__axioms.nCol A C B))))) as H22.
------------------- apply (@lemma__NCorder.lemma__NCorder B C A H21).
------------------- destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H23.
----------------- assert (* Cut *) (euclidean__axioms.TS A C B D) as H22.
------------------ exists M.
split.
------------------- exact H4.
------------------- split.
-------------------- exact H20.
-------------------- exact H21.
------------------ assert (* Cut *) (euclidean__defs.CongA A C B C B D) as H23.
------------------- apply (@proposition__29B.proposition__29B A D C B H1 H22).
------------------- assert (* Cut *) (euclidean__axioms.nCol A B C) as H24.
-------------------- assert (* Cut *) ((euclidean__axioms.nCol B C A) /\ ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol A C B) /\ ((euclidean__axioms.nCol C A B) /\ (euclidean__axioms.nCol A B C))))) as H24.
--------------------- apply (@lemma__NCorder.lemma__NCorder C B A H21).
--------------------- destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H32.
-------------------- assert (* Cut *) (euclidean__defs.CongA B C A A C B) as H25.
--------------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B C A).
----------------------apply (@euclidean__tactics.nCol__notCol B C A H14).

--------------------- assert (* Cut *) (euclidean__defs.CongA B C A C B D) as H26.
---------------------- apply (@lemma__equalanglestransitive.lemma__equalanglestransitive B C A A C B C B D H25 H23).
---------------------- assert (euclidean__axioms.Triangle A B C) as H27 by exact H24.
assert (* Cut *) (euclidean__axioms.nCol D C B) as H28.
----------------------- apply (@euclidean__tactics.nCol__notCol D C B).
------------------------apply (@euclidean__tactics.nCol__not__Col D C B).
-------------------------apply (@lemma__equalanglesNC.lemma__equalanglesNC A B C D C B H19).

----------------------- assert (euclidean__axioms.Triangle D C B) as H29 by exact H28.
assert (* Cut *) (euclidean__axioms.Cong B C C B) as H30.
------------------------ apply (@euclidean__axioms.cn__equalityreverse B C).
------------------------ assert (* Cut *) ((euclidean__axioms.Cong A B D C) /\ ((euclidean__axioms.Cong A C D B) /\ (euclidean__defs.CongA B A C C D B))) as H31.
------------------------- apply (@proposition__26A.proposition__26A A B C D C B H27 H29 H19 H26 H30).
------------------------- assert (* Cut *) (euclidean__axioms.Cong A B C D) as H32.
-------------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
assert (* Cut *) ((euclidean__axioms.Cong B A C D) /\ ((euclidean__axioms.Cong B A D C) /\ (euclidean__axioms.Cong A B C D))) as H36.
--------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A B D C H32).
--------------------------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H40.
-------------------------- assert (* Cut *) (euclidean__axioms.Cong A C B D) as H33.
--------------------------- destruct H31 as [H33 H34].
destruct H34 as [H35 H36].
assert (* Cut *) ((euclidean__axioms.Cong C A B D) /\ ((euclidean__axioms.Cong C A D B) /\ (euclidean__axioms.Cong A C B D))) as H37.
---------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A C D B H35).
---------------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H41.
--------------------------- assert (* Cut *) (euclidean__axioms.Cong C A B D) as H34.
---------------------------- destruct H31 as [H34 H35].
destruct H35 as [H36 H37].
assert (* Cut *) ((euclidean__axioms.Cong C A D B) /\ ((euclidean__axioms.Cong C A B D) /\ (euclidean__axioms.Cong A C D B))) as H38.
----------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A C B D H33).
----------------------------- destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
exact H41.
---------------------------- assert (* Cut *) (euclidean__axioms.Cong C B B C) as H35.
----------------------------- destruct H31 as [H35 H36].
destruct H36 as [H37 H38].
apply (@euclidean__axioms.cn__equalityreverse C B).
----------------------------- assert (* Cut *) (euclidean__axioms.Cong__3 C A B B D C) as H36.
------------------------------ destruct H31 as [H36 H37].
destruct H37 as [H38 H39].
split.
------------------------------- exact H34.
------------------------------- split.
-------------------------------- exact H36.
-------------------------------- exact H35.
------------------------------ assert (* Cut *) (euclidean__defs.CongA C A B B D C) as H37.
------------------------------- destruct H31 as [H37 H38].
destruct H38 as [H39 H40].
apply (@lemma__equalanglesflip.lemma__equalanglesflip B A C C D B H40).
------------------------------- assert (* Cut *) (euclidean__axioms.Cong A D D A) as H38.
-------------------------------- destruct H31 as [H38 H39].
destruct H39 as [H40 H41].
apply (@euclidean__axioms.cn__equalityreverse A D).
-------------------------------- assert (* Cut *) (A = A) as H39.
--------------------------------- destruct H31 as [H39 H40].
destruct H40 as [H41 H42].
apply (@logic.eq__refl Point A).
--------------------------------- assert (* Cut *) (D = D) as H40.
---------------------------------- destruct H31 as [H40 H41].
destruct H41 as [H42 H43].
apply (@logic.eq__refl Point D).
---------------------------------- assert (* Cut *) (euclidean__axioms.neq A C) as H41.
----------------------------------- destruct H31 as [H41 H42].
destruct H42 as [H43 H44].
assert (* Cut *) ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq D B) /\ (euclidean__axioms.neq C B)))))) as H45.
------------------------------------ apply (@lemma__angledistinct.lemma__angledistinct B A C C D B H44).
------------------------------------ destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
exact H48.
----------------------------------- assert (* Cut *) (euclidean__axioms.neq C A) as H42.
------------------------------------ destruct H31 as [H42 H43].
destruct H43 as [H44 H45].
apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A C H41).
------------------------------------ assert (* Cut *) (euclidean__axioms.neq C D) as H43.
------------------------------------- destruct H31 as [H43 H44].
destruct H44 as [H45 H46].
assert (* Cut *) ((euclidean__axioms.neq C A) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq D C) /\ (euclidean__axioms.neq B C)))))) as H47.
-------------------------------------- apply (@lemma__angledistinct.lemma__angledistinct C A B B D C H37).
-------------------------------------- destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H13.
------------------------------------- assert (* Cut *) (euclidean__axioms.neq B A) as H44.
-------------------------------------- destruct H31 as [H44 H45].
destruct H45 as [H46 H47].
assert (* Cut *) ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq D B) /\ (euclidean__axioms.neq C B)))))) as H48.
--------------------------------------- apply (@lemma__angledistinct.lemma__angledistinct B A C C D B H47).
--------------------------------------- destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
destruct H56 as [H57 H58].
exact H49.
-------------------------------------- assert (* Cut *) (euclidean__axioms.neq D B) as H45.
--------------------------------------- destruct H31 as [H45 H46].
destruct H46 as [H47 H48].
assert (* Cut *) ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq D B) /\ (euclidean__axioms.neq C B)))))) as H49.
---------------------------------------- apply (@lemma__angledistinct.lemma__angledistinct B A C C D B H48).
---------------------------------------- destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
exact H58.
--------------------------------------- assert (* Cut *) (euclidean__axioms.neq B D) as H46.
---------------------------------------- destruct H31 as [H46 H47].
destruct H47 as [H48 H49].
apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric D B H45).
---------------------------------------- assert (* Cut *) (euclidean__defs.Out C A A) as H47.
----------------------------------------- destruct H31 as [H47 H48].
destruct H48 as [H49 H50].
apply (@lemma__ray4.lemma__ray4 C A A).
------------------------------------------right.
left.
exact H39.

------------------------------------------ exact H42.
----------------------------------------- assert (* Cut *) (euclidean__defs.Out C D D) as H48.
------------------------------------------ destruct H31 as [H48 H49].
destruct H49 as [H50 H51].
apply (@lemma__ray4.lemma__ray4 C D D).
-------------------------------------------right.
left.
exact H40.

------------------------------------------- exact H43.
------------------------------------------ assert (* Cut *) (euclidean__defs.Out B A A) as H49.
------------------------------------------- destruct H31 as [H49 H50].
destruct H50 as [H51 H52].
apply (@lemma__ray4.lemma__ray4 B A A).
--------------------------------------------right.
left.
exact H39.

-------------------------------------------- exact H44.
------------------------------------------- assert (* Cut *) (euclidean__defs.Out B D D) as H50.
-------------------------------------------- destruct H31 as [H50 H51].
destruct H51 as [H52 H53].
apply (@lemma__ray4.lemma__ray4 B D D).
---------------------------------------------right.
left.
exact H40.

--------------------------------------------- exact H46.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong B A C D) as H51.
--------------------------------------------- destruct H31 as [H51 H52].
destruct H52 as [H53 H54].
assert (* Cut *) ((euclidean__axioms.Cong B A D C) /\ ((euclidean__axioms.Cong B A C D) /\ (euclidean__axioms.Cong A B D C))) as H55.
---------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip A B C D H32).
---------------------------------------------- destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
exact H58.
--------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong C A B D) as H52.
---------------------------------------------- destruct H31 as [H52 H53].
destruct H53 as [H54 H55].
assert (* Cut *) ((euclidean__axioms.Cong A B D C) /\ ((euclidean__axioms.Cong A B C D) /\ (euclidean__axioms.Cong B A D C))) as H56.
----------------------------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip B A C D H51).
----------------------------------------------- destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
exact H34.
---------------------------------------------- assert (* Cut *) (euclidean__axioms.Cong B D C A) as H53.
----------------------------------------------- destruct H31 as [H53 H54].
destruct H54 as [H55 H56].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B C A D H52).
----------------------------------------------- assert (* Cut *) (~(euclidean__axioms.Col A B D)) as H54.
------------------------------------------------ intro H54.
assert (* Cut *) (D = D) as H55.
------------------------------------------------- destruct H31 as [H55 H56].
destruct H56 as [H57 H58].
exact H40.
------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col C D D) as H56.
-------------------------------------------------- right.
right.
left.
exact H55.
-------------------------------------------------- assert (* Cut *) (euclidean__defs.Meet A B C D) as H57.
--------------------------------------------------- exists D.
split.
---------------------------------------------------- exact H12.
---------------------------------------------------- split.
----------------------------------------------------- exact H43.
----------------------------------------------------- split.
------------------------------------------------------ exact H54.
------------------------------------------------------ exact H56.
--------------------------------------------------- apply (@H11 H57).
------------------------------------------------ assert (* Cut *) (euclidean__defs.CongA A B D D C A) as H55.
------------------------------------------------- exists A.
exists D.
exists D.
exists A.
split.
-------------------------------------------------- exact H49.
-------------------------------------------------- split.
--------------------------------------------------- exact H50.
--------------------------------------------------- split.
---------------------------------------------------- exact H48.
---------------------------------------------------- split.
----------------------------------------------------- exact H47.
----------------------------------------------------- split.
------------------------------------------------------ exact H51.
------------------------------------------------------ split.
------------------------------------------------------- exact H53.
------------------------------------------------------- split.
-------------------------------------------------------- exact H38.
-------------------------------------------------------- apply (@euclidean__tactics.nCol__notCol A B D H54).
------------------------------------------------- split.
-------------------------------------------------- exact H32.
-------------------------------------------------- split.
--------------------------------------------------- exact H33.
--------------------------------------------------- split.
---------------------------------------------------- exact H37.
---------------------------------------------------- split.
----------------------------------------------------- exact H55.
----------------------------------------------------- exact H36.
Qed.


Require Import List.
Import ListNotations.

Require Import StructTact.StructTactics.
Require Import Net.
Require Import StructTact.Util.

Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import FunctionalExtensionality.

Require Import mathcomp.ssreflect.ssreflect.

Set Implicit Arguments.

Class BaseParamsTotMap (P0 : BaseParams) (P1 : BaseParams) :=
  {
    tot_map_data : @data P0 -> @data P1 ;
    tot_map_input : @input P0 -> @input P1 ;
    tot_map_output : @output P0 -> @output P1
  }.

Class MultiParamsTotMap
 (B0 : BaseParams) (B1 : BaseParams)
 (B : BaseParamsTotMap B0 B1)
 (P0 : MultiParams B0) (P1 : MultiParams B1)  :=
{
   tot_map_msg : @msg B0 P0 -> @msg B1 P1 ;
   tot_map_name : @name B0 P0 -> @name B1 P1 ;
   tot_map_name_inv : @name B1 P1 -> @name B0 P0
}.

Section TotMapSimulations.

Context {base_fst : BaseParams}.
Context {base_snd : BaseParams}.
Context {multi_fst : MultiParams base_fst}.
Context {multi_snd : MultiParams base_snd}.
Context {base_map : BaseParamsTotMap base_fst base_snd}.
Context {multi_map : MultiParamsTotMap base_map multi_fst multi_snd}.

Hypothesis tot_map_name_inv_inverse : forall n, tot_map_name_inv (tot_map_name n) = n.

Hypothesis tot_map_name_inverse_inv : forall n, tot_map_name (tot_map_name_inv n) = n.

Hypothesis tot_init_handlers_eq : forall n, tot_map_data (init_handlers n) = init_handlers (tot_map_name n).

Definition tot_map_name_msgs :=
  map (fun nm => (tot_map_name (fst nm), tot_map_msg (snd nm))).

Definition tot_mapped_net_handlers me src m st :=
  let '(out, st', ps) := net_handlers me src m st in
  (map tot_map_output out, tot_map_data st', tot_map_name_msgs ps).

Hypothesis tot_net_handlers_eq : forall me src m st,
  tot_mapped_net_handlers me src m st =
  net_handlers (tot_map_name me) (tot_map_name src) (tot_map_msg m) (tot_map_data st).

Definition tot_mapped_input_handlers me inp st :=
  let '(out, st', ps) := input_handlers me inp st in
  (map tot_map_output out, tot_map_data st', tot_map_name_msgs ps).

Hypothesis tot_input_handlers_eq : forall me inp st,
  tot_mapped_input_handlers me inp st = input_handlers (tot_map_name me) (tot_map_input inp) (tot_map_data st).

Hypothesis tot_map_output_injective :
  forall o o', tot_map_output o = tot_map_output o' -> o = o'.

Lemma tot_map_name_injective :
forall n n', tot_map_name n = tot_map_name n' -> n = n'.
Proof using tot_map_name_inv_inverse.
move => n n'.
case (name_eq_dec n n') => H_dec //.
move => H_eq.
rewrite -(tot_map_name_inv_inverse n) in H_dec.
rewrite H_eq in H_dec.
by rewrite tot_map_name_inv_inverse in H_dec.
Qed.

Definition tot_map_trace_occ (e : @name _ multi_fst * (@input base_fst + list (@output base_fst))) :=
match e with
| (n, inl io) => (tot_map_name n, inl (tot_map_input io))
| (n, inr lo) => (tot_map_name n, inr (map tot_map_output lo))
end.

Definition tot_map_packet (p : @packet base_fst multi_fst)  :=
match p with
| mkPacket src dst m =>
  mkPacket (tot_map_name src) (tot_map_name dst) (tot_map_msg m)
end.

Definition tot_map_net (net : @network _ multi_fst) : @network _ multi_snd :=
mkNetwork (map tot_map_packet net.(nwPackets)) (fun n => tot_map_data (net.(nwState) (tot_map_name_inv n))).

Lemma tot_map_update_eq :
  forall f d h,
    (fun n : name => tot_map_data (update f h d (tot_map_name_inv n))) =
    update (fun n : name => tot_map_data (f (tot_map_name_inv n))) (tot_map_name h) (tot_map_data d).
Proof using tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => net d h.
apply functional_extensionality => n.
rewrite /update /=.
case (name_eq_dec _ _) => H_dec; case (name_eq_dec _ _) => H_dec' //.
  rewrite -H_dec in H_dec'.
  by rewrite tot_map_name_inverse_inv in H_dec'.
rewrite H_dec' in H_dec.
by rewrite tot_map_name_inv_inverse in H_dec.
Qed.

Corollary tot_map_update_packet_eq :
forall f p d,
  (fun n : name => tot_map_data (update f (pDst p) d (tot_map_name_inv n))) =
  (update (fun n : name => tot_map_data (f (tot_map_name_inv n))) (pDst (tot_map_packet p)) (tot_map_data d)).
Proof using tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => f.
case => src dst m d.
exact: tot_map_update_eq.
Qed.

Lemma tot_map_packet_app_eq :
  forall l p ms ms',
    map tot_map_packet (map (fun m : name * msg => {| pSrc := pDst p; pDst := fst m; pBody := snd m |}) l ++ ms ++ ms') =
    map (fun m : name * msg => {| pSrc := pDst (tot_map_packet p); pDst := fst m; pBody := snd m |}) (tot_map_name_msgs l) ++ map tot_map_packet ms ++ map tot_map_packet ms'.
Proof using.
move => l; case => src dst m ms ms'.
rewrite 2!map_app.
elim: l => //=.
case => /= n m' l IH.
by rewrite IH.
Qed.

Lemma tot_map_packet_eq :
  forall l l' h,
    map tot_map_packet (map (fun m : name * msg => {| pSrc := h; pDst := fst m; pBody := snd m |}) l ++ l') =
    map (fun m : name * msg => {| pSrc := tot_map_name h; pDst := fst m; pBody := snd m |}) (tot_map_name_msgs l) ++ map tot_map_packet l'.
Proof using.
elim => //=.
case => n m l IH l' h.
by rewrite IH.
Qed.

Lemma tot_init_handlers_fun_eq :
    init_handlers = fun n : name => tot_map_data (init_handlers (tot_map_name_inv n)).
Proof using tot_init_handlers_eq tot_map_name_inverse_inv.
apply functional_extensionality => n.
rewrite tot_init_handlers_eq.
by rewrite tot_map_name_inverse_inv.
Qed.

Lemma tot_map_trace_occ_inv :
  forall tr n ol,
    map tot_map_trace_occ tr = [(n, inr ol)] ->
    exists n', exists lo, tr = [(n', inr lo)] /\ tot_map_name n' = n /\ map tot_map_output lo = ol.
Proof using.
case => //=.
case.
move => n ol tr n' lo H_eq.
case: tr H_eq => //=.
case: ol => //=.
move => out H_eq.
exists n; exists out.
split => //.
by inversion H_eq.
Qed.

Lemma tot_map_trace_occ_in_inv :
  forall tr h inp out,
    map tot_map_trace_occ tr = [(h, inl inp); (h, inr out)] ->
    exists h', exists inp', exists out', tr = [(h', inl inp'); (h', inr out')] /\
      tot_map_name h' = h /\ map tot_map_output out' = out /\ tot_map_input inp' = inp.
Proof using tot_map_name_inv_inverse.
case => //=.
case.
move => h.
case => //.
move => inp.
case => //.
case.
move => h'.
case => //.
move => out.
case => //=.
move => h0.
move => inp' out' H_eq.
inversion H_eq; subst.
apply tot_map_name_injective in H2.
rewrite H2.
by exists h; exists inp; exists out.
Qed.

Theorem step_m_tot_mapped_simulation_1 :
  forall net net' tr,
    @step_m _ multi_fst net net' tr ->
    @step_m _ multi_snd (tot_map_net net) (tot_map_net net') (map tot_map_trace_occ tr).
Proof using tot_input_handlers_eq tot_net_handlers_eq tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => net net' tr.
case => {net net' tr}.
- move => net net' p ms ms' out d l H_eq H_hnd H_eq'.
  rewrite /tot_map_trace_occ /=.
  have ->: tot_map_name (pDst p) = pDst (tot_map_packet p) by case: p H_eq H_hnd H_eq' => src dst m H_eq H_hnd H_eq'.
  apply (@SM_deliver _ _ _ _ _ (map tot_map_packet ms) (map tot_map_packet ms') (map tot_map_output out) (tot_map_data d) (tot_map_name_msgs l)).
  * by rewrite /tot_map_net /= H_eq /= map_app.
  * rewrite /=.
    case: p H_eq H_hnd H_eq' => /= src dst m H_eq H_hnd H_eq'.
    have H_q := tot_net_handlers_eq dst src m (nwState net dst).
    rewrite /tot_mapped_net_handlers in H_q.
    rewrite H_hnd in H_q.
    rewrite H_q.
    by rewrite tot_map_name_inv_inverse.
  * rewrite /= H_eq' /= /tot_map_net /=.
    rewrite -tot_map_update_packet_eq.
    by rewrite tot_map_packet_app_eq.
- move => h net net' out inp d l H_hnd H_eq.
  apply (@SM_input _ _ _ _ _ _ _ (tot_map_data d) (tot_map_name_msgs l)).
    rewrite /=.
    have H_q := tot_input_handlers_eq h inp (nwState net h).
    rewrite /tot_mapped_input_handlers /= in H_q.
    rewrite H_hnd in H_q.
    rewrite H_q.
    by rewrite tot_map_name_inv_inverse.
  rewrite /= H_eq /= /tot_map_net /=.
  rewrite -tot_map_update_eq.
  by rewrite tot_map_packet_eq.
Qed.

Corollary step_m_tot_mapped_simulation_star_1 :
  forall net tr,
    @step_m_star _ multi_fst step_m_init net tr ->
    @step_m_star _ multi_snd step_m_init (tot_map_net net) (map tot_map_trace_occ tr).
Proof using tot_input_handlers_eq tot_net_handlers_eq tot_init_handlers_eq tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => net tr H_step.
remember step_m_init as y in *.
move: Heqy.
induction H_step using refl_trans_1n_trace_n1_ind => H_init /=.
  rewrite H_init.
  rewrite /step_m_init /= /tot_map_net /=.
  rewrite tot_init_handlers_fun_eq.
  exact: RT1nTBase.
concludes.
rewrite H_init in H_step2 H_step1.
apply step_m_tot_mapped_simulation_1 in H.
rewrite map_app.
have H_trans := refl_trans_1n_trace_trans IHH_step1.
apply: H_trans.
rewrite (app_nil_end (map _ _)).
apply: (@RT1nTStep _ _ _ _ (tot_map_net x'')) => //.
exact: RT1nTBase.
Qed.

Theorem step_m_tot_mapped_simulation_2 :
  forall net net' out mnet mout,
      @step_m _ multi_snd net net' out ->
      tot_map_net mnet = net ->
      map tot_map_trace_occ mout = out ->
      exists mnet',
        @step_m _ multi_fst mnet mnet' mout /\
        tot_map_net mnet' = net'.
Proof using tot_map_output_injective tot_input_handlers_eq tot_net_handlers_eq tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => net net' out mnet mout H_step H_eq H_eq'.
invcs H_step.
- case: p H4 H H0 => /= src dst m H4 H H0.
  rewrite /tot_map_net /=.
  case: mnet H H0 => /= pks sts H_eq H_hnd.
  have [pks1 [pks2 [H_eq_pks [H_eq_pks1 H_eq_pks2]]]] := map_eq_inv _ _ _ _ H_eq.
  case: pks2 H_eq_pks H_eq_pks2 => //= p pks2 H_eq_pks H_eq_pks2.
  rewrite H_eq_pks.
  inversion H_eq_pks2.
  case H_hnd': (net_handlers (pDst p) (pSrc p) (pBody p) (sts (pDst p))) => [dout l'].
  case: dout H_hnd' => out' d' H_hnd'.
  rewrite -H_eq_pks1.
  exists {| nwPackets := send_packets (pDst p) l' ++ pks1 ++ pks2 ; nwState := update sts (pDst p) d' |}.
  split.
  * have [n' [lo [H_eq_mout [H_eq_n H_eq_lo]]]] := tot_map_trace_occ_inv _ (eq_sym H4).
    rewrite H_eq_mout.
    have H_eq_dst: n' = pDst p.
      rewrite -(tot_map_name_inv_inverse n').
      rewrite H_eq_n.
      case: p H_eq_pks H_eq_pks2 H0 H_hnd' => src' dst' m' H_eq_pks H_eq_pks2 H0 H_hnd'.
      rewrite /=.
      rewrite /= in H0.
      inversion H0.
      by rewrite tot_map_name_inv_inverse.
    rewrite H_eq_dst.
    apply (@SM_deliver _ _ _ _ _ pks1 pks2 _ d' l') => //=.
    suff H_suff: lo = out' by rewrite H_suff.
    have H_eq_hnd := tot_net_handlers_eq (pDst p) (pSrc p) (pBody p) (sts (pDst p)).
    rewrite /tot_mapped_net_handlers /= in H_eq_hnd.
    repeat break_let.
    inversion H_hnd'.
    rewrite H2 H3 H5 in H_eq_hnd.
    rewrite -{1}H_eq_dst H_eq_n in H_eq_hnd.
    rewrite -H_eq_dst in H_eq_hnd.
    rewrite -(tot_map_name_inv_inverse n') H_eq_n in H_eq_hnd.
    move {Heqp1 Heqp0 H_hnd'}.
    have H_eq_src: tot_map_name (pSrc p) = src.
      case: p H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_hnd => src' dst' m' H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_hnd.
      rewrite /=.
      rewrite /= in H0.
      by inversion H0.
    rewrite H_eq_src /= {H_eq_src} in H_eq_hnd.
    have H_eq_body: tot_map_msg (pBody p) = m.
      case: p H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_hnd => src' dst' m' H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_hnd.
      rewrite /=.
      rewrite /= in H0.
      by inversion H0.
    rewrite H_eq_body H_hnd in H_eq_hnd.
    inversion H_eq_hnd.
    rewrite -H_eq_lo in H6.
    symmetry.
    move: H6.
    apply map_eq_inv_eq.
    exact: tot_map_output_injective.
  * rewrite /=.
    rewrite /update /=.
    have H_eq_dst: tot_map_name (pDst p) = dst.
      case: p H_eq_pks H_eq_pks2 H0 H_hnd' => src' dst' m' H_eq_pks H_eq_pks2 H0 H_hnd'.
      by inversion H0.
    have H_eq_src: tot_map_name (pSrc p) = src.
      case: p H_eq_pks H_eq_pks2 H0 H_hnd' H_eq_dst => src' dst' m' H_eq_pks H_eq_pks2 H0 H_hnd' H_eq_dst.
      by inversion H0.
    have H_eq_body: tot_map_msg (pBody p) = m.
      case: p H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_src H_hnd' => src' dst' m' H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_src H_hnd'.
      by inversion H0.
    rewrite 2!map_app.
    have H_eq_hnd := tot_net_handlers_eq (pDst p) (pSrc p) (pBody p) (sts (pDst p)).
    rewrite /tot_mapped_net_handlers /= in H_eq_hnd.
    repeat break_let.
    inversion H_hnd'.
    rewrite H_eq_dst H_eq_src H_eq_body in H_eq_hnd.
    rewrite -{2}H_eq_dst tot_map_name_inv_inverse in H_hnd.
    rewrite H_hnd in H_eq_hnd.
    inversion H_eq_hnd.
    rewrite H2 in H6.
    rewrite H3 in H7.
    rewrite H5 in H8.
    rewrite H3 H5.
    set nwP1 := map tot_map_packet _.
    set nwP2 := map (fun _ => _) (tot_map_name_msgs _).
    set nwS1 := fun _ => _.
    set nwS2 := fun _ => _.
    have H_eq_nw: nwP1 = nwP2.
      rewrite /nwP1 /nwP2 {H_hnd' H5 H8 nwP1 nwP2}.
      elim: l' => //=.
      case => /= n' m' l' IH.
      rewrite IH.
      by rewrite H_eq_dst.
    rewrite -H_eq_nw /nwP1 {H_eq_nw nwP1 nwP2}.
    have H_eq_sw: nwS1 = nwS2.
      rewrite /nwS1 /nwS2.
      apply functional_extensionality => n'.
      rewrite -H_eq_dst.
      case (name_eq_dec _ _) => H_dec.
        rewrite -H_dec.
        rewrite tot_map_name_inverse_inv.
        by case (name_eq_dec _ _).
      case (name_eq_dec _ _) => H_dec' //.
      rewrite H_dec' in H_dec.
      by rewrite tot_map_name_inv_inverse in H_dec.
    by rewrite H_eq_sw.
- rewrite /tot_map_net /=.
  case: mnet H => /= pks sts H_hnd.
  have [h' [inp' [out' [H_eq_mout [H_eq_n [H_eq_out H_eq_inp]]]]]] := tot_map_trace_occ_in_inv _ (eq_sym H3).
  have H_q := tot_input_handlers_eq h' inp' (sts h').
  rewrite /tot_mapped_input_handlers in H_q.
  repeat break_let.
  rewrite H_eq_n H_eq_inp in H_q.
  rewrite -{2}H_eq_n tot_map_name_inv_inverse in H_hnd.
  rewrite H_hnd in H_q.
  inversion H_q.
  rewrite -H_eq_out in H0.
  rewrite H1 H2.
  exists ({| nwPackets := send_packets h' l0 ++ pks ; nwState := update sts h' d0 |}).
  split.
  * rewrite H_eq_mout.
    apply (@SM_input _ _ _ _ _ _ _ d0 l0) => //.
    rewrite /= Heqp.
    suff H_suff: l1 = out' by rewrite H_suff.
    move: H0.
    apply map_eq_inv_eq.
    exact: tot_map_output_injective.
  * rewrite /= map_app.
    set nwP1 := map tot_map_packet _.
    set nwP2 := map (fun _ => _) l.
    set nwS1 := fun _ => _.
    set nwS2 := update _ _ _.
    have H_eq_nwp: nwP1 = nwP2.
      rewrite /nwP1 /nwP2 {Heqp H_q nwP1 nwP2}.
      rewrite -H2 {H2}.
      elim: l0 => //=.
      case => /= n m l0 IH.
      by rewrite H_eq_n IH.
    have H_eq_nws: nwS1 = nwS2.
      rewrite /nwS1 /nwS2.
      rewrite /update /=.
      apply functional_extensionality => n.
      rewrite -H_eq_n -H1.
      case (name_eq_dec _ _) => H_dec.
        case (name_eq_dec _ _) => H_dec' //.
        by rewrite -H_dec tot_map_name_inverse_inv in H_dec'.
      case (name_eq_dec _ _) => H_dec' //.
      by rewrite H_dec' tot_map_name_inv_inverse in H_dec.
    by rewrite H_eq_nwp H_eq_nws.
Qed.

Context {fail_fst : FailureParams multi_fst}.
Context {fail_snd : FailureParams multi_snd}.

Hypothesis tot_reboot_eq : forall d, tot_map_data (reboot d) = reboot (tot_map_data d).

Lemma not_in_failed_not_in :
  forall n failed,
    ~ In n failed ->
    ~ In (tot_map_name n) (map tot_map_name failed).
Proof using tot_map_name_inv_inverse.
move => n.
elim => //=.
move => n' failed IH H_in H_in'.
case: H_in' => H_in'.
  case: H_in.
  left.
  rewrite -(tot_map_name_inv_inverse n').
  rewrite H_in'.
  exact: tot_map_name_inv_inverse.
contradict H_in'.
apply: IH.
move => H_in'.
case: H_in.
by right.
Qed.

Lemma in_failed_in :
  forall n failed,
    In n failed ->
    In (tot_map_name n) (map tot_map_name failed).
Proof using.
move => n.
elim => //.
move => n' l IH H_in.
case: H_in => H_in.
  rewrite H_in.
  by left.
right.
exact: IH.
Qed.

Lemma remove_tot_map_eq :
  forall h failed,
    map tot_map_name (remove name_eq_dec h failed) =
    remove name_eq_dec (tot_map_name h) (map tot_map_name failed).
Proof using tot_map_name_inv_inverse.
move => h.
elim => //=.
move => n failed IH.
case (name_eq_dec _ _) => H_eq; case (name_eq_dec _ _) => H_eq' //.
- by rewrite H_eq in H_eq'.
- rewrite -(tot_map_name_inv_inverse h) in H_eq.
  rewrite H_eq' in H_eq.
  by rewrite tot_map_name_inv_inverse in H_eq.
- by rewrite /= IH.
Qed.

Lemma tot_map_reboot_eq :
forall h net,
    (fun n : name =>
      tot_map_data
        (match name_eq_dec (tot_map_name_inv n) h with
         | left _ => reboot (nwState net (tot_map_name_inv n))
         | right _ => nwState net (tot_map_name_inv n)
        end)) =
    (fun nm : name =>
       match name_eq_dec nm (tot_map_name h) with
       | left _ => reboot (tot_map_data (nwState net (tot_map_name_inv nm)))
       | right _ => tot_map_data (nwState net (tot_map_name_inv nm))
       end).
Proof using tot_reboot_eq tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => h net.
apply: functional_extensionality => n.
case (name_eq_dec _ _) => H_dec; case (name_eq_dec _ _) => H_dec' //.
- rewrite -H_dec in H_dec'.
  by rewrite tot_map_name_inverse_inv in H_dec'.
- rewrite H_dec' in H_dec.
  by rewrite tot_map_name_inv_inverse in H_dec.
Qed.

Theorem step_f_tot_mapped_simulation_1 :
  forall net net' failed failed' tr,
    @step_f _ _ fail_fst (failed, net) (failed', net') tr ->
    @step_f _ _ fail_snd (map tot_map_name failed, tot_map_net net) (map tot_map_name failed', tot_map_net net') (map tot_map_trace_occ tr).
Proof using tot_reboot_eq tot_input_handlers_eq tot_net_handlers_eq tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => net net' failed failed' tr H_step.
invcs H_step.
- have ->: tot_map_name (pDst p) = pDst (tot_map_packet p) by case: p H3 H4 H6 => src dst m.
  apply (@SF_deliver _ _ _ _ _ _ _ (map tot_map_packet xs) (map tot_map_packet ys) _ (tot_map_data d) (tot_map_name_msgs l)).
  * by rewrite /tot_map_net /= H3 /= map_app.
  * case: p H3 H4 H6 => /= src dst m H3 H4 H6.
    exact: not_in_failed_not_in.
  * case: p H3 H4 H6 => /= src dst m H3 H4 H6.
    have H_q := tot_net_handlers_eq dst src m (nwState net dst).
    rewrite /tot_mapped_net_handlers in H_q.
    rewrite H6 in H_q.
    rewrite H_q.
    by rewrite tot_map_name_inv_inverse.
  * rewrite /= -tot_map_update_packet_eq /=.
    rewrite /tot_map_net /=.
    by rewrite tot_map_packet_app_eq.
- apply (@SF_input _ _ _ _ _ _ _ _ _ (tot_map_data d) (tot_map_name_msgs l)).
  * exact: not_in_failed_not_in.
  * rewrite /=.
    have H_q := tot_input_handlers_eq h inp (nwState net h).
    rewrite /tot_mapped_input_handlers /= in H_q.
    rewrite H5 in H_q.
    rewrite H_q.
    by rewrite tot_map_name_inv_inverse.
  * rewrite /= /tot_map_net /=.
    rewrite -tot_map_update_eq.
    by rewrite tot_map_packet_eq.
- apply (@SF_drop _ _ _ _ _ _ (tot_map_packet p) (map tot_map_packet xs) (map tot_map_packet ys)).
  * by rewrite /tot_map_net /= H4 map_app.
  * by rewrite /tot_map_net /= map_app.
- apply (@SF_dup _ _ _ _ _ _ (tot_map_packet p) (map tot_map_packet xs) (map tot_map_packet ys)).
  * by rewrite /tot_map_net /= H4 map_app.
  * by rewrite /tot_map_net /= map_app.
- exact: SF_fail.
- apply: (SF_reboot (tot_map_name h)).
  * exact: in_failed_in.
  * by rewrite remove_tot_map_eq.
  * rewrite /tot_map_net /=.
    by rewrite tot_map_reboot_eq.
Qed.

Corollary step_f_tot_mapped_simulation_star_1 :
  forall net failed tr,
    @step_f_star _ _ fail_fst step_f_init (failed, net) tr ->
    @step_f_star _ _ fail_snd step_f_init (map tot_map_name failed, tot_map_net net) (map tot_map_trace_occ tr).
Proof using tot_reboot_eq tot_input_handlers_eq tot_net_handlers_eq tot_init_handlers_eq tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => net failed tr H_step.
remember step_f_init as y in *.
have H_eq_f: failed = fst (failed, net) by [].
have H_eq_n: net = snd (failed, net) by [].
rewrite H_eq_f {H_eq_f}.
rewrite {2}H_eq_n {H_eq_n}.
move: Heqy.
induction H_step using refl_trans_1n_trace_n1_ind => H_init /=.
  rewrite H_init.
  rewrite /step_f_init /= /step_m_init /tot_map_net /=.
  rewrite tot_init_handlers_fun_eq.
  exact: RT1nTBase.
concludes.
rewrite H_init {H_init x} in H_step2 H_step1.
case: x' H IHH_step1 H_step1 => failed' net'.
case: x'' H_step2 => failed'' net''.
rewrite /=.
move => H_step2 H IHH_step1 H_step1.
apply step_f_tot_mapped_simulation_1 in H.
rewrite map_app.
have H_trans := refl_trans_1n_trace_trans IHH_step1.
apply: H_trans.
rewrite (app_nil_end (map tot_map_trace_occ _)).
apply (@RT1nTStep _ _ _ _ (map tot_map_name failed'', tot_map_net net'')) => //.
exact: RT1nTBase.
Qed.

Lemma map_eq_name_eq_eq :
  forall l l', map tot_map_name l = map tot_map_name l' -> l = l'.
Proof using tot_map_name_inv_inverse.
elim.
case => //=.
move => n l IH.
case => //=.
move => n' l' H_eq.
inversion H_eq.
apply tot_map_name_injective in H0.
by rewrite H0 (IH l').
Qed.

Theorem step_f_tot_mapped_simulation_2 :
  forall net net' failed failed' out mnet mfailed mfailed' mout,
      @step_f _ _ fail_snd (failed, net) (failed', net') out ->
      tot_map_net mnet = net ->
      map tot_map_name mfailed = failed ->
      map tot_map_name mfailed' = failed' ->
      map tot_map_trace_occ mout = out ->
      exists mnet',
        @step_f _ _ fail_fst (mfailed, mnet) (mfailed', mnet') mout /\
        tot_map_net mnet' = net'.
Proof using tot_reboot_eq tot_map_output_injective tot_input_handlers_eq tot_net_handlers_eq tot_map_name_inverse_inv tot_map_name_inv_inverse.
move => net net' failed failed' out mnet mfailed mfailed' mout H_step H_eq_net H_eq_f H_eq_f' H_eq_out.
invcs H_step.
- case: p H4 H5 H3 H6 => /= src dst m H4 H5 H3 H6.
  rewrite /tot_map_net /=.
  case: mnet H3 H6 => /= pks sts H_eq H_hnd.
  have [pks1 [pks2 [H_eq_pks [H_eq_pks1 H_eq_pks2]]]] := map_eq_inv _ _ _ _ H_eq.
  case: pks2 H_eq_pks H_eq_pks2 => //= p pks2 H_eq_pks H_eq_pks2.
  rewrite H_eq_pks.
  inversion H_eq_pks2.
  case H_hnd': (net_handlers (pDst p) (pSrc p) (pBody p) (sts (pDst p))) => [dout l'].
  case: dout H_hnd' => out' d' H_hnd'.
  rewrite -H_eq_pks1.
  exists {| nwPackets := send_packets (pDst p) l' ++ pks1 ++ pks2 ; nwState := update sts (pDst p) d' |}.
  split.
  * have [n' [lo [H_eq_mout [H_eq_n H_eq_lo]]]] := tot_map_trace_occ_inv _ (eq_sym H5).
    rewrite H_eq_mout.
    have H_eq_dst: n' = pDst p.
      rewrite -(tot_map_name_inv_inverse n').
      rewrite H_eq_n.
      case: p H_eq_pks H_eq_pks2 H0 H_hnd' => src' dst' m' H_eq_pks H_eq_pks2 H0 H_hnd'.
      rewrite /=.
      rewrite /= in H0.
      inversion H0.
      by rewrite tot_map_name_inv_inverse.
    rewrite H_eq_dst.
    apply map_eq_name_eq_eq in H1.
    rewrite H1.
    apply (@SF_deliver _ _ _ _ _ _ _ pks1 pks2 _ d' l') => //=.
      rewrite -H_eq_dst.
      rewrite -H_eq_n in H4.
      move => H_in.
      by apply in_failed_in in H_in.
    suff H_suff: lo = out' by rewrite H_suff.
    have H_eq_hnd := tot_net_handlers_eq (pDst p) (pSrc p) (pBody p) (sts (pDst p)).
    rewrite /tot_mapped_net_handlers /= in H_eq_hnd.
    repeat break_let.
    inversion H_hnd'.
    rewrite H3 H6 H7 in H_eq_hnd.
    rewrite -{1}H_eq_dst H_eq_n in H_eq_hnd.
    rewrite -H_eq_dst in H_eq_hnd.
    rewrite -(tot_map_name_inv_inverse n') H_eq_n in H_eq_hnd.
    move {Heqp1 Heqp0 H_hnd'}.
    have H_eq_src: tot_map_name (pSrc p) = src.
      case: p H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_hnd => src' dst' m' H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_hnd.
      rewrite /=.
      rewrite /= in H0.
      by inversion H0.
    rewrite H_eq_src /= {H_eq_src} in H_eq_hnd.
    have H_eq_body: tot_map_msg (pBody p) = m.
      case: p H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_hnd => src' dst' m' H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_hnd.
      rewrite /=.
      rewrite /= in H0.
      by inversion H0.
    rewrite H_eq_body H_hnd in H_eq_hnd.
    inversion H_eq_hnd.
    rewrite -H_eq_lo in H8.
    symmetry.
    move: H8.
    apply map_eq_inv_eq.
    exact: tot_map_output_injective.
  * rewrite /=.
    rewrite /update /=.
    have H_eq_dst: tot_map_name (pDst p) = dst.
      case: p H_eq_pks H_eq_pks2 H0 H_hnd' => src' dst' m' H_eq_pks H_eq_pks2 H0 H_hnd'.
      by inversion H0.
    have H_eq_src: tot_map_name (pSrc p) = src.
      case: p H_eq_pks H_eq_pks2 H0 H_hnd' H_eq_dst => src' dst' m' H_eq_pks H_eq_pks2 H0 H_hnd' H_eq_dst.
      by inversion H0.
    have H_eq_body: tot_map_msg (pBody p) = m.
      case: p H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_src H_hnd' => src' dst' m' H_eq_pks H_eq_pks2 H0 H_eq_dst H_eq_src H_hnd'.
      by inversion H0.
    rewrite 2!map_app.
    have H_eq_hnd := tot_net_handlers_eq (pDst p) (pSrc p) (pBody p) (sts (pDst p)).
    rewrite /tot_mapped_net_handlers /= in H_eq_hnd.
    repeat break_let.
    inversion H_hnd'.
    rewrite H_eq_dst H_eq_src H_eq_body in H_eq_hnd.
    rewrite -{2}H_eq_dst tot_map_name_inv_inverse in H_hnd.
    rewrite H_hnd in H_eq_hnd.
    inversion H_eq_hnd.
    rewrite H3 in H8.
    rewrite H6 in H9.
    rewrite H7 in H10.
    rewrite H6 H7.
    set nwP1 := map tot_map_packet _.
    set nwP2 := map (fun _ => _) (tot_map_name_msgs _).
    set nwS1 := fun _ => _.
    set nwS2 := fun _ => _.
    have H_eq_nw: nwP1 = nwP2.
      rewrite /nwP1 /nwP2 {H_hnd' H7 H10 nwP1 nwP2}.
      elim: l' => //=.
      case => /= n' m' l' IH.
      rewrite IH.
      by rewrite H_eq_dst.
    rewrite -H_eq_nw /nwP1 {H_eq_nw nwP1 nwP2}.
    have H_eq_sw: nwS1 = nwS2.
      rewrite /nwS1 /nwS2.
      apply functional_extensionality => n'.
      rewrite -H_eq_dst.
      case (name_eq_dec _ _) => H_dec.
        rewrite -H_dec.
        rewrite tot_map_name_inverse_inv.
        by case (name_eq_dec _ _).
      case (name_eq_dec _ _) => H_dec' //.
      rewrite H_dec' in H_dec.
      by rewrite tot_map_name_inv_inverse in H_dec.
    by rewrite H_eq_sw.
- rewrite /tot_map_net /=.
  case: mnet H5 => /= pks sts H_hnd.
  have [h' [inp' [out' [H_eq_mout [H_eq_n [H_eq_out H_eq_inp]]]]]] := tot_map_trace_occ_in_inv _ (eq_sym H4).
  have H_q := tot_input_handlers_eq h' inp' (sts h').
  rewrite /tot_mapped_input_handlers in H_q.
  repeat break_let.
  rewrite H_eq_n H_eq_inp in H_q.
  rewrite -{2}H_eq_n tot_map_name_inv_inverse in H_hnd.
  rewrite H_hnd in H_q.
  inversion H_q.
  rewrite -H_eq_out in H0.
  rewrite H2 H5.
  apply map_eq_name_eq_eq in H1.
  rewrite -H1.
  rewrite -H1 in H3.
  exists ({| nwPackets := send_packets h' l0 ++ pks ; nwState := update sts h' d0 |}).
  split.
  * rewrite H_eq_mout.
    apply (@SF_input _ _ _ _ _ _ _ _ _ d0 l0) => //.
      rewrite -H_eq_n in H3.
      move => H_in.
      by apply in_failed_in in H_in.
    rewrite /= Heqp.
    suff H_suff: l1 = out' by rewrite H_suff.
    move: H0.
    apply map_eq_inv_eq.
    exact: tot_map_output_injective.
  * rewrite /= map_app.
    set nwP1 := map tot_map_packet _.
    set nwP2 := map (fun _ => _) l.
    set nwS1 := fun _ => _.
    set nwS2 := update _ _ _.
    have H_eq_nwp: nwP1 = nwP2.
      rewrite /nwP1 /nwP2 {Heqp H_q nwP1 nwP2}.
      rewrite -H5 {H5}.
      elim: l0 => //=.
      case => /= n m l0 IH.
      by rewrite H_eq_n IH.
    have H_eq_nws: nwS1 = nwS2.
      rewrite /nwS1 /nwS2.
      rewrite /update /=.
      apply functional_extensionality => n.
      rewrite -H_eq_n -H2.
      case (name_eq_dec _ _) => H_dec.
        case (name_eq_dec _ _) => H_dec' //.
        by rewrite -H_dec tot_map_name_inverse_inv in H_dec'.
      case (name_eq_dec _ _) => H_dec' //.
      by rewrite H_dec' tot_map_name_inv_inverse in H_dec.
    by rewrite H_eq_nwp H_eq_nws.
- case: mout H2 => // H_eq_mout {H_eq_mout}.
  apply map_eq_name_eq_eq in H1.
  rewrite -H1.
  have [pks1 [pks2 [H_eq_pks [H_eq_pks1 H_eq_pks2]]]] := map_eq_inv _ _ _ _ H4.
  case: pks2 H_eq_pks H_eq_pks2 => //= p' pks2 H_eq_pks H_eq_pks2.
  inversion H_eq_pks2.
  rewrite -H_eq_pks1.
  exists {| nwPackets := pks1 ++ pks2 ; nwState := nwState mnet |}.
  split; first exact: (@SF_drop _ _ _ _ _ _ p' pks1 pks2).
  by rewrite /tot_map_net /= map_app.
- case: mout H2 => // H_eq_mout {H_eq_mout}.
  apply map_eq_name_eq_eq in H1.
  rewrite -H1.
  have [pks1 [pks2 [H_eq_pks [H_eq_pks1 H_eq_pks2]]]] := map_eq_inv _ _ _ _ H4.
  case: pks2 H_eq_pks H_eq_pks2 => //= p' pks2 H_eq_pks H_eq_pks2.
  inversion H_eq_pks2.
  rewrite -H_eq_pks1.
  exists {| nwPackets := p' :: pks1 ++ p' :: pks2 ; nwState := nwState mnet |}.
  split; first exact: (@SF_dup _ _ _ _ _ _ p' pks1 pks2).
  by rewrite /tot_map_net /= map_app.
- case: mout H2 => // H_eq_mout {H_eq_mout}.
  case: mfailed' H => //= h' mfailed' H_eq.
  inversion H_eq.
  apply map_eq_name_eq_eq in H1.
  rewrite -H1.
  exists mnet.
  split => //.
  exact: SF_fail.
- case: mout H4 => // H_eq_mout {H_eq_mout}.
  have H_in := H3.
  apply in_split in H_in.
  move: H_in => [ns1 [ns2 H_eq]].
  have [mns1 [mns2 [H_eq_mns [H_eq_mns1 H_eq_mns2]]]] := map_eq_inv _ _ _ _ H_eq.
  case: mns2 H_eq_mns H_eq_mns2 => //= h' mns2 H_eq_mns H_eq_mns2.
  exists {| nwPackets := nwPackets mnet ;
       nwState := (fun nm => match name_eq_dec nm h' with
                           | left _ => (reboot (nwState mnet nm))
                           | right _ => (nwState mnet nm)
                           end) |}.
  split.
  * apply (@SF_reboot _ _ _ h') => //.
    + rewrite H_eq_mns.
      apply in_or_app.
      by right; left.
    + inversion H_eq_mns2.
      rewrite -H0 in H5.
      move {H3 ns1 ns2 H_eq mns1 H_eq_mns1 h mns2 H_eq_mns H_eq_mns2 H0 H1}.
      have H_eq: remove name_eq_dec (tot_map_name h') (map tot_map_name mfailed) = map tot_map_name (remove name_eq_dec h' mfailed).
        move {H5 mfailed'}.
        elim: mfailed => //=.
        move => n l IH.
        case (name_eq_dec _ _) => H_dec; case (name_eq_dec _ _) => H_dec' => //.
        + by apply tot_map_name_injective in H_dec.
        + by rewrite H_dec' in H_dec.
        + by rewrite /= IH.
      rewrite H_eq in H5.
      by apply map_eq_name_eq_eq in H5.
  * rewrite /tot_map_net /=.
    inversion H_eq_mns2.
    set nwS1 := fun _ => _.
    set nwS2 := fun _ => _.
    have H_eq_sw: nwS1 = nwS2.
      rewrite /nwS1 /nwS2 {nwS1 nwS2}.
      apply functional_extensionality => n.
      case (name_eq_dec _ _) => H_dec; case (name_eq_dec _ _) => H_dec' => //.
      + rewrite -H_dec in H_dec'.
        by rewrite tot_map_name_inverse_inv in H_dec'.
      + rewrite H_dec' in H_dec.
        by rewrite tot_map_name_inv_inverse in H_dec.
    by rewrite H_eq_sw.
Qed.

End TotMapSimulations.


Require Import Basics.
Require Import Types.
Require Import Pointed.Core.
Require Import Pointed.Loops.
Require Import Pointed.pMap.
Require Import Pointed.pHomotopy.
Require Import Pointed.pTrunc.
Require Import Pointed.pEquiv.
Require Import Homotopy.Suspension.
Require Import Homotopy.Freudenthal.
Require Import Truncations.
Import TrM.

Generalizable Variables X A B f g n.

Local Open Scope path_scope.
Local Open Scope pointed_scope.

(** ** Pointedness of [Susp] and path spaces thereof *)
(** We arbitrarily choose [North] to be the point. *)
Global Instance ispointed_susp {X : Type} : IsPointed (Susp X) | 0
  := North.

Global Instance ispointed_path_susp `{IsPointed X}
  : IsPointed (North = South :> Susp X) | 0 := merid (point X).

Global Instance ispointed_path_susp' `{IsPointed X}
  : IsPointed (South = North :> Susp X) | 0 := (merid (point X))^.

Definition psusp (X : pType) : pType
  := Build_pType (Susp X) _.

(** ** Suspension Functor *)

(* Definition of pointed suspension functor *)
Definition psusp_functor {X Y : pType} (f : X ->* Y) : psusp X ->* psusp Y
  := Build_pMap (psusp X) (psusp Y) (functor_susp f) 1.

(* Suspension functor preserves composition *)
Definition psusp_functor_compose {X Y Z : pType} (g : Y ->* Z) (f : X ->* Y)
  : psusp_functor (g o* f) ==* psusp_functor g o* psusp_functor f.
Proof.
  pointed_reduce; srefine (Build_pHomotopy _ _); cbn.
  { serapply Susp_ind; try reflexivity; cbn.
    intros x.
    refine (transport_paths_FlFr _ _ @ _).
    rewrite concat_p1; apply moveR_Vp.
    by rewrite concat_p1, ap_compose, !Susp_rec_beta_merid. }
  reflexivity.
Qed.

(* Suspension functor preserves identity *)
Definition psusp_functor_idmap {X : pType}
  : psusp_functor (@pmap_idmap X) ==* pmap_idmap.
Proof.
  serapply Build_pHomotopy.
  { serapply Susp_ind; try reflexivity.
    intro x.
    refine (transport_paths_FFlr _ _ @ _).
    by rewrite ap_idmap, Susp_rec_beta_merid,
      concat_p1, concat_Vp. }
  reflexivity.
Qed.

Definition psusp_2functor {X Y} {f g : X ->* Y} (p : f ==* g)
  : psusp_functor f ==* psusp_functor g.
Proof.
  pointed_reduce.
  serapply Build_pHomotopy.
  { simpl.
    serapply Susp_ind.
    1,2: reflexivity.
    intro x; cbn.
    rewrite transport_paths_FlFr.
    rewrite concat_p1.
    rewrite 2 Susp_rec_beta_merid.
    destruct (p x).
    apply concat_Vp. }
  reflexivity.
Defined.

Definition pequiv_psusp_functor {X Y : pType} (f : X <~>* Y)
  : psusp X <~>* psusp Y.
Proof.
  serapply pequiv_adjointify.
  1: apply psusp_functor, f.
  1: apply psusp_functor, f^-1*.
  1,2: refine ((psusp_functor_compose _ _)^* @* _ @* psusp_functor_idmap).
  1,2: apply psusp_2functor.
  1: apply peisretr.
  apply peissect.
Defined.

(** ** Loop-Suspension Adjunction *)

Module Book_Loop_Susp_Adjunction.

  (** Here is the proof of the adjunction isomorphism given in the book (6.5.4); we put it in a non-exported module for reasons discussed below. *)
  Definition loop_susp_adjoint `{Funext} (A B : pType)
  : (psusp A ->* B) <~> (A ->* loops B).
  Proof.
    refine (_ oE (issig_pmap (psusp A) B)^-1).
    refine (_ oE (equiv_functor_sigma'
                 (Q := fun NSm => fst NSm.1 = point B)
                 (equiv_Susp_rec A B)
                 (fun f => 1%equiv))).
    refine (_ oE (equiv_sigma_assoc _ _)^-1); simpl.
    refine (_ oE
              (equiv_functor_sigma'
                 (Q := fun a => {_ : fst a = point B & A -> fst a = snd a })
                 (equiv_idmap (B * B))
                 (fun NS => equiv_sigma_symm0
                              (A -> fst NS = snd NS)
                              (fst NS = point B)))).
    refine (_ oE (equiv_sigma_prod _)^-1); simpl.
    refine (_ oE
              (equiv_functor_sigma'
                 (Q := fun b => {_ : b = point B & { p : B & A -> b = p}})
                 1
                 (fun b => equiv_sigma_symm (A := B) (B := b = point B)
                             (fun p _ => A -> b = p)))).
    refine (_ oE equiv_sigma_assoc' _ _).
    refine (_ oE equiv_contr_sigma _); simpl.
    refine (_ oE (equiv_sigma_contr
                   (A := {p : B & A -> point B = p})
                   (fun pm => { q : point B = pm.1 & pm.2 (point A) = q }))^-1).
    refine (_ oE (equiv_sigma_assoc _ _)^-1); simpl.
    refine (_ oE
              (equiv_functor_sigma'
                 (Q := fun b => {q : point B = b & {p : A -> point B = b & p (point A) = q}})
                 1
                 (fun b => equiv_sigma_symm (fun p q => p (point A) = q)))).
    refine (_ oE equiv_sigma_assoc' _ _).
    refine (_ oE equiv_contr_sigma _); simpl.
    refine (issig_pmap A (loops B)).
  Defined.

  (** Unfortunately, with this definition it seems to be quite hard to prove that the isomorphism is natural on pointed maps.  The following proof gets partway there, but ends with a pretty intractable goal.  It's also quite slow, so we don't want to compile it all the time. *)
  (**
<<
  Definition loop_susp_adjoint_nat_r `{Funext} (A B B' : pType)
             (f : psusp A ->* B) (g : B ->* B')
  : loop_susp_adjoint A B' (g o* f)
    ==* loops_functor g o* loop_susp_adjoint A B f.
  Proof.
    pointed_reduce.
    refine (Build_pHomotopy _ _).
    - intros a. simpl.
      refine (_ @ (concat_1p _)^).
      refine (_ @ (concat_p1 _)^).
      rewrite !transport_sigma. simpl.
      rewrite !(transport_arrow_fromconst (B := A)).
      rewrite !transport_paths_Fr.
      rewrite !ap_V, !ap_pr1_path_basedpaths.
      rewrite ap_pp, !(ap_compose f g), ap_V.
      reflexivity.
    - cbn.
      Fail reflexivity.
  Abort.
>>
   *)

End Book_Loop_Susp_Adjunction.

(** Thus, instead we will construct the adjunction in terms of a unit and counit natural transformation. *)

Definition loop_susp_unit (X : pType) : X ->* loops (psusp X)
  := Build_pMap X (loops (psusp X))
      (fun x => merid x @ (merid (point X))^) (concat_pV _).

(** By Freudenthal, we have that this map is 2n-connected for a n-connected X *)
Instance conn_map_loop_susp_unit `{Univalence} (X : pType) `{IsConnected n.+1 X}
  : IsConnMap (n +2+ n) (fun x => merid x @ (merid (point X))^).
Proof.
  refine (conn_map_compose _ _ (equiv_concat_r (merid (point _))^ _)).
Defined.

(** We also have this corollary *)
Lemma pequiv_ptr_loop_psusp `{Univalence} (X : pType) n `{IsConnected n.+1 X}
  : pTr (n +2+ n) X <~>* pTr (n +2+ n) (loops (psusp X)).
Proof.
  serapply (Build_pEquiv _ _ _ (isequiv_conn_map_ino (n +2+ n) _)).
  { apply ptr_functor.
    apply loop_susp_unit. }
  exact _.
Defined.

Definition loop_susp_unit_natural {X Y : pType} (f : X ->* Y)
  : loop_susp_unit Y o* f
  ==* loops_functor (psusp_functor f) o* loop_susp_unit X.
Proof.
  pointed_reduce.
  simple refine (Build_pHomotopy _ _); cbn.
  - intros x; symmetry.
    refine (concat_1p _@ (concat_p1 _ @ _)).
    refine (ap_pp (Susp_rec North South (merid o f))
                  (merid x) (merid (point X))^ @ _).
    refine ((1 @@ ap_V _ _) @ _).
    refine (Susp_rec_beta_merid _ @@ inverse2 (Susp_rec_beta_merid _)).
  - cbn. rewrite !inv_pp, !concat_pp_p, concat_1p; symmetry.
    apply moveL_Vp.
    refine (concat_pV_inverse2 _ _ (Susp_rec_beta_merid (point X)) @ _).
    apply moveL_Vp, moveL_Vp.
    refine (ap_pp_concat_pV _ _ @ _).
    apply moveL_Vp, moveL_Vp.
    rewrite concat_p1_1, concat_1p_1.
    cbn; symmetry.
    refine (concat_p1 _ @ _).
    refine (ap_compose
      (fun p' => (ap (Susp_rec North South (merid o f))) p' @ 1)
      (fun p' => 1 @ p')
      (concat_pV (merid (point X))) @ _).
    apply ap.
    refine (ap_compose (ap (Susp_rec North South (merid o f)))
      (fun p' => p' @ 1) _).
Qed.

Definition loop_susp_counit (X : pType) : psusp (loops X) ->* X
  :=  Build_pMap (psusp (loops X)) X (Susp_rec (point X) (point X) idmap) 1.

Definition loop_susp_counit_natural {X Y : pType} (f : X ->* Y)
  : f o* loop_susp_counit X
  ==* loop_susp_counit Y o* psusp_functor (loops_functor f).
Proof.
  pointed_reduce.
  simple refine (Build_pHomotopy _ _); simpl.
  - simple refine (Susp_ind _ _ _ _); cbn; try reflexivity; intros p.
    rewrite transport_paths_FlFr, ap_compose, concat_p1.
    apply moveR_Vp.
    refine (ap_compose
              (Susp_rec North South (fun x0 => merid (1 @ (ap f x0 @ 1))))
              (Susp_rec (point Y) (point Y) idmap) (merid p) @ _).
    do 2 rewrite Susp_rec_beta_merid.
    refine (concat_1p _ @ _). f_ap. f_ap. symmetry.
    refine (Susp_rec_beta_merid _).
  - reflexivity.
Qed.

(** Now the triangle identities *)

Definition loop_susp_triangle1 (X : pType)
  : loops_functor (loop_susp_counit X) o* loop_susp_unit (loops X)
  ==* pmap_idmap.
Proof.
  simple refine (Build_pHomotopy _ _).
  - intros p; cbn.
    refine (concat_1p _ @ (concat_p1 _ @ _)).
    refine (ap_pp (Susp_rec (point X) (point X) idmap)
                  (merid p) (merid (point (point X = point X)))^ @ _).
    refine ((1 @@ ap_V _ _) @ _).
    refine ((Susp_rec_beta_merid p
      @@ inverse2 (Susp_rec_beta_merid (point (loops X)))) @ _).
    exact (concat_p1 _).
  - destruct X as [X x]; cbn; unfold point.
    apply whiskerR.
    rewrite (concat_pV_inverse2
               (ap (Susp_rec x x idmap) (merid 1))
               1 (Susp_rec_beta_merid 1)).
    rewrite (ap_pp_concat_pV (Susp_rec x x idmap) (merid 1)).
    rewrite ap_compose, (ap_compose _ (fun p => p @ 1)).
    rewrite concat_1p_1; apply ap.
    apply concat_p1_1.
Qed.

Definition loop_susp_triangle2 (X : pType)
  : loop_susp_counit (psusp X) o* psusp_functor (loop_susp_unit X)
  ==* pmap_idmap.
Proof.
  simple refine (Build_pHomotopy _ _);
  [ simple refine (Susp_ind _ _ _ _) | ]; try reflexivity; cbn.
  - exact (merid (point X)).
  - intros x.
    rewrite transport_paths_FlFr, ap_idmap, ap_compose.
    rewrite Susp_rec_beta_merid.
    apply moveR_pM; rewrite concat_p1.
    refine (inverse2 (Susp_rec_beta_merid _) @ _).
    rewrite inv_pp, inv_V; reflexivity.
Qed.

(** Now we can finally construct the adjunction equivalence. *)

Definition loop_susp_adjoint `{Funext} (A B : pType)
  : (psusp A ->* B) <~> (A ->* loops B).
Proof.
  refine (equiv_adjointify
            (fun f => loops_functor f o* loop_susp_unit A)
            (fun g => loop_susp_counit B o* psusp_functor g) _ _).
  - intros g. apply path_pmap.
    refine (pmap_prewhisker _ (loops_functor_compose _ _) @* _).
    refine (pmap_compose_assoc _ _ _ @* _).
    refine (pmap_postwhisker _ (loop_susp_unit_natural g)^* @* _).
    refine ((pmap_compose_assoc _ _ _)^* @* _).
    refine (pmap_prewhisker g (loop_susp_triangle1 B) @* _).
    apply pmap_postcompose_idmap.
  - intros f. apply path_pmap.
    refine (pmap_postwhisker _ (psusp_functor_compose _ _) @* _).
    refine ((pmap_compose_assoc _ _ _)^* @* _).
    refine (pmap_prewhisker _ (loop_susp_counit_natural f)^* @* _).
    refine (pmap_compose_assoc _ _ _ @* _).
    refine (pmap_postwhisker f (loop_susp_triangle2 A) @* _).
    apply pmap_precompose_idmap.
Defined.

(** And its naturality is easy. *)

Definition loop_susp_adjoint_nat_r `{Funext} (A B B' : pType)
  (f : psusp A ->* B) (g : B ->* B') : loop_susp_adjoint A B' (g o* f)
  ==* loops_functor g o* loop_susp_adjoint A B f.
Proof.
  cbn.
  refine (_ @* pmap_compose_assoc _ _ _).
  apply pmap_prewhisker.
  refine (loops_functor_compose g f).
Defined.

Definition loop_susp_adjoint_nat_l `{Funext} (A A' B : pType)
  (f : A ->* loops B) (g : A' ->* A) : (loop_susp_adjoint A' B)^-1 (f o* g)
  ==* (loop_susp_adjoint A B)^-1 f o* psusp_functor g.
Proof.
  cbn.
  refine (_ @* (pmap_compose_assoc _ _ _)^*).
  apply pmap_postwhisker.
  refine (psusp_functor_compose f g).
Defined.


From Coq Require Import Logic.StrictProp.
From SPropTools Require Import Logic.

Definition decidable P := { P } + {~ P }.

Class squash_modal X := from_squash : Squash X -> X.

Definition squash_modal_decidable {P} : decidable P -> squash_modal P :=
  fun decP sqP =>
    match decP with
    | left p => p
    | right np => ltac:(scontradiction (destruct sqP as [[]%np]))
    end.

Instance squash_modal_False : squash_modal False.
Proof. intros sqF; scontradiction (destruct sqF as [[]]). Qed.

Instance  squash_modal_True : squash_modal True.
Proof. intros; constructor. Qed.

Instance squash_modal_unit : squash_modal unit.
Proof. intros; constructor. Qed.

Definition bind_squash {A B} (f : A -> Squash B) (sqA : Squash A) : Squash B :=
  match sqA with | squash a => f a end.

Definition map_squash {A B} (f : A -> B) (sqA : Squash A) : Squash B :=
  match sqA with | squash a => squash (f a) end.

Instance squash_modal_prod {X Y} `{squash_modal X} `{squash_modal Y} : squash_modal (X * Y) :=
  fun sqXY => (from_squash (map_squash fst sqXY), from_squash (map_squash snd sqXY)).


Require Import Iron.Language.SystemF2Data.Type.
Require Import Iron.Language.SystemF2Data.Exp.Relation.TypeX.
Require Import Iron.Language.SystemF2Data.Exp.Operator.SubstXX.

(* Substitute several expressions.
   Note that in the definition, each time we substitute an
   exp (u), we need to lift it by the number of exps remaining
   in the list (us). This is because we're placing the substitued
   exp under the binders corresponding to the remaining ones.
   The added lifting is then gradually "undone" each time we
   substitue one of the remaining expressions. This happens due
   to the free variable/Gt case in the definition of substX.
   Example:
               (A->B), A |- 0 :: A
               (A->B), A |- 1 :: (A->B)
    (A->B), A, A, (A->B) |- (0 1) [1 0] :: B

    Substitute first exp in list.
            (A->B), A, A |- (2 0) [0] :: B
    We get '2' by adding the length of the remaining substitution
    (1) to the index substituted (1). The argument of the function
    is changed from 1 to 0 by the free variable case of substX.
    Substitute remaining exp in list.
               (A->B), A |- (1 0) :: B
    Here, 0 is subst for 0, and 2 changes to 1 due as it's a free
    variable.
*)
Fixpoint substXXs (d: nat) (us: list exp) (xx: exp) :=
 match us with
 | nil      => xx
 | u :: us' => substXXs d us'
                 (substXX d (liftXX (List.length us') 0 u)
                            xx)
 end.

(* Substitution of several expressions at once. *)
Theorem subst_exp_exp_list
 :  forall ds ks te x1 xs t1 ts
 ,  Forall2 (TYPE ds ks te)         xs ts
 -> TYPE ds ks (te >< ts) x1 t1
 -> TYPE ds ks te    (substXXs 0 xs x1) t1.
Proof.
 intros ds ks te x1 xs t1 ts HF HT.
 gen ts ks x1.
 induction xs; intros; inverts_type.

 - Case "base case".
   destruct ts.
   + simpl. auto.
   + nope.

 - Case "step case".
   simpl.
   destruct ts.
   + nope.
   + inverts HF.
     eapply IHxs.
     * eauto.
     * simpl in HT.
       eapply subst_exp_exp.
        eauto.
        rrwrite (length xs = length ts).
        eapply type_tyenv_weaken_append. auto.
Qed.


From HoTT Require Import Basics.
From HoTT Require Import Categories.
From HoTT Require Import Spaces.Finite.
Require Import Graph.

Definition Arrows (C : PreCategory) : Type :=
  exists(a b : object C), morphism C a b.

Include FunctorCoreNotations.

Definition eq_to_iso {C : PreCategory} {x y : object C} (p : x = y) : morphism C x y.
Proof.
  rewrite p. exact 1%morphism.
Defined.

Local Open Scope morphism.

Record GraphDiagram {size arrows : nat} {C I : PreCategory}
       {D : Functor I C} {G : Graph C size arrows} :=
  mkGraphDiagram
    { ftgr_objs : Fin size -> object I
    ; ftgr_objs_equiv : IsEquiv ftgr_objs
    ; ftgr_vertices : Fin arrows -> Arrows I
    ; ftgr_vertices_equiv : IsEquiv ftgr_vertices
    ; ftgr_src_comm : forall(a : Fin arrows), ftgr_objs (gr_src G a) = proj1 (ftgr_vertices a)
    ; ftgr_dst_comm : forall(a : Fin arrows), ftgr_objs (gr_dst G a) = proj1 (proj2 (ftgr_vertices a))
    ; ftgr_objs_comm : forall(v : Fin size), (D _0 (ftgr_objs v))%object = gr_vertex G v
    ; ftgr_edge_comm : forall(a : Fin arrows), D _1 (proj2 (proj2 (ftgr_vertices a)))
                                          = D _1 (eq_to_iso (ftgr_dst_comm a))
                                            o eq_to_iso (ftgr_objs_comm (gr_dst G a))^
                                            o gr_edge G a
                                            o eq_to_iso (ftgr_objs_comm (gr_src G a))
                                            o D _1 (eq_to_iso (ftgr_src_comm a)^)
    }.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import utils ill_form ill_rules phase_sem.

Set Implicit Arguments.

Section Rules.

  Variable (s1 s2 : bool).

  Let P := (ill_proof s1 s2).

  Notation "Γ ⊨ A" := (P Γ A) (at level 70, no associativity).

  Implicit Types (X Y : list ill_form -> Type).

  Definition cl_ctx X Ω := forall Γ Δ A, (forall ϴ, X ϴ -> Γ++ϴ++Δ ⊨ A)
                                       ->                  Γ++Ω++Δ ⊨ A.

  Definition comp_ctx (Γ Δ ϴ : list ill_form) := Γ++Δ ~[s1] ϴ.

  Notation cl := cl_ctx.
  Notation comp := comp_ctx.

  Infix "∘" := (Composes comp_ctx) (at level 50, no associativity).

  Notation J := (fun Γ => cl (sg ∅) Γ * cl (sg Γ ∘ sg Γ) Γ)%type.
  Notation K := (fun Γ => { Δ | Γ = ‼Δ }).

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

  Fact cl_ctx_increase X : X ⊆ cl X.
  Proof. intros ? ? ? ?; auto. Qed.

  Fact cl_ctx_mono X Y : X ⊆ Y -> cl X ⊆ cl Y.
  Proof.
    intros H1 om Hom ga de x HY.
    apply Hom.
    intros; apply HY, H1; auto.
  Qed.

  Fact cl_ctx_idem X : cl (cl X) ⊆ cl X.
  Proof.
    intros om Hom ga de x HX.
    apply Hom.
    intros th Hth.
    apply Hth, HX.
  Qed.

  Hint Resolve cl_ctx_increase cl_ctx_mono cl_ctx_idem.

  Let P_perm : forall Γ Δ A, Γ ~[s1] Δ -> Γ ⊨ A -> Δ ⊨ A.
  Proof.
    intros ? ? ?; apply in_llp_perm.
  Qed.

  Hint Resolve perm_bang_t_refl.

  Local Fact cl_comm : s1 = true -> forall Γ Δ, sg Γ ∘ sg Δ ⊆ cl (sg Δ ∘ sg Γ).
  Proof.
    intros E ? ? _ [ ga de th ? ? Hth ]; subst Γ Δ.
    intros rho del x H; subst s1. apply H.
    constructor 1 with de ga; auto.
    revert Hth; unfold comp.
    apply ill_perm_t_trans; auto.
    subst s1; simpl.
    apply perm_t_app_comm.
  Qed.

  Local Fact cl_neutral_1 : forall Γ, cl (sg ∅ ∘ sg Γ) Γ.
  Proof.
    intros ga de th x H.
    apply H.
    constructor 1 with nil ga; auto.
    red; simpl; auto.
  Qed.

  Local Fact cl_neutral_3 : forall Γ, cl (sg Γ ∘ sg ∅) Γ.
  Proof.
    intros ga de th x H.
    apply H.
    constructor 1 with ga nil; auto.
    red; simpl; rewrite <- app_nil_end; auto.
  Qed.

  Local Fact cl_neutral_2 : forall Γ, sg ∅ ∘ sg Γ ⊆ cl (sg Γ).
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho om x G; subst th de.
    cbv in H1.
    generalize (G _ eq_refl).
    apply P_perm.
    do 2 (apply ill_perm_t_app; auto).
  Qed.

  Local Fact cl_neutral_4 : forall Γ, sg Γ ∘ sg ∅ ⊆ cl (sg Γ).
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho om x G; subst th de.
    red in H1; rewrite <- app_nil_end in H1.
    generalize (G _ eq_refl).
    apply P_perm.
    do 2 (apply ill_perm_t_app; auto).
  Qed.

  Fact cl_ctx_stable_l : forall X Y, cl X ∘ Y ⊆ cl (X ∘ Y).
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho om x HXY.
    red in H1; red in H3.
    apply P_perm with (rho++ga++de++om).
    1: { apply ill_perm_t_app; auto.
         rewrite <- app_ass.
         apply ill_perm_t_app; auto. }
    apply H1.
    intros ka Hka.
    replace (rho ++ ka ++ de ++ om)
    with    (rho ++ (ka ++ de) ++ om) by solve list eq.
    apply HXY.
    constructor 1 with ka de; auto.
    red; auto.
  Qed.

  Fact cl_ctx_stable_r : forall X Y, X ∘ cl Y ⊆ cl (X ∘ Y).
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho om x HXY.
    red in H2; red in H3.
    apply P_perm with ((rho++ga)++de++om).
    1: { rewrite app_ass.
         apply ill_perm_t_app; auto.
         rewrite <- app_ass.
         apply ill_perm_t_app; auto. }
    apply H2.
    intros ka Hka.
    replace ((rho ++ ga) ++ ka ++ om)
    with    (rho ++ (ga ++ ka) ++ om) by solve list eq.
    apply HXY.
    constructor 1 with ga ka; auto.
    red; auto.
  Qed.

  Local Fact cl_assoc_1 : forall Γ Δ ϴ, sg Γ ∘ (sg Δ ∘ sg ϴ) ⊆ cl ((sg Γ ∘ sg Δ) ∘ sg ϴ).
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H3 as [ de' th' to ? ? H3 ]; subst ga' de' th'.
    red in H3, H4.
    intros u x v Hu.
    specialize (Hu ((ga++de)++th)).
    spec all in Hu.
    constructor 1 with (ga++de) th; auto.
    constructor 1 with ga de; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply P_perm, ill_perm_t_app; auto.
    apply ill_perm_t_app; auto.
    rewrite app_ass.
    apply ill_perm_t_trans with (2 := H4).
    apply ill_perm_t_app; auto.
  Qed.

  Local Fact cl_assoc_2 : forall Γ Δ ϴ, (sg Γ ∘ sg Δ) ∘ sg ϴ ⊆ cl (sg Γ ∘ (sg Δ ∘ sg ϴ)).
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H2 as [ de' th' to ? ? H2 ]. subst rho de' th'.
    red in H2, H4.
    intros u x v Hu.
    specialize (Hu (ga++de++th)).
    spec all in Hu.
    constructor 1 with (ga) (de++th); auto.
    constructor 1 with de th; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply P_perm, ill_perm_t_app; auto.
    apply ill_perm_t_app; auto.
    apply ill_perm_t_trans with (2 := H4).
    rewrite <- app_ass.
    apply ill_perm_t_app; auto.
  Qed.

  Local Fact sub_monoid_1 : cl K ∅.
  Proof.
    intros ga de A H.
    apply H; exists ∅; auto.
  Qed.

  Local Fact sub_monoid_2 : K ∘ K ⊆ K.
  Proof.
    intros _ [ a b c [ga Ha] [de Hb] H ]; subst a b.
    red in H; simpl in H.
    unfold ill_lbang in H.
    rewrite <- map_app in H.
    revert H; apply ill_perm_t_map_inv_t; auto.
  Qed.

  Section sub_J_cs.

    Let P_weak : ∀ ϴ Γ Δ A, ϴ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A.
    Proof.
      intros ? ? ?; apply ill_weak_ctx.
    Qed.

    Let P_cntr : ∀ ϴ Γ Δ A, ϴ++‼Γ++‼Γ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A.
    Proof.
      intros ? ? ? ?; apply ill_cntr_ctx.
    Qed.

    Local Fact sub_J_1 : K ⊆ J.
    Proof.
      intros x (de & Hde); subst x.
      constructor; red.
      + intros ga th A H.
        specialize (H _ eq_refl); simpl in H.
        apply P_weak; auto.
      + intros ga th A H.
        specialize (H (‼de++‼de)).
        spec all in H.
        { constructor 1 with (‼de) (‼de); auto; red; auto. }
        rewrite app_ass in H.
        apply P_cntr; auto.
    Qed.

  End sub_J_cs.

  Section sub_J_cn.

    Hypothesis K_inc_J : K ⊆ J.

    Let J_banged Γ : J (‼Γ).
    Proof. apply K_inc_J; exists Γ; auto. Qed.

    Let weak Γ : cl (sg nil) (‼Γ).
    Proof. apply J_banged. Qed.

    Let cntr Γ : cl (sg (‼Γ) ∘ sg (‼Γ)) (‼Γ).
    Proof. apply J_banged. Qed.

    Local Fact sub_J_2 Γ Δ A : Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Proof.
      intros H.
      apply (weak _ nil).
      intros _ []; apply H.
    Qed.

    Local Fact sub_J_3 Γ Δ A : ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Proof.
      intros H.
      apply (cntr _ nil).
      intros _ [ x y th [] [] H1 ].
      revert H; apply P_perm.
      rewrite <- app_ass.
      simpl; apply ill_perm_t_app; auto.
    Qed.

  End sub_J_cn.

  Fact sub_J_eq : K ⊆ J ≡ (∀ Γ Δ A, Δ ⊨ A -> ‼Γ++Δ ⊨ A)
                         * (∀ Γ Δ A, ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A).
  Proof.
    split.
    + split.
      * apply sub_J_2; auto.
      * apply sub_J_3; auto.
    + intros; apply sub_J_1; tauto.
  Qed.

  Definition rules_nc_sound := ill_nc_soundness    cl_ctx_increase cl_ctx_mono
                                                   cl_ctx_idem
                                                   cl_ctx_stable_l
                                                   cl_ctx_stable_r
                                                   cl_neutral_1
                                                   cl_neutral_2
                                                   cl_neutral_3
                                                   cl_neutral_4
                                                   cl_assoc_1
                                                   cl_assoc_2
                                                   sub_monoid_1
                                                   sub_monoid_2
                                                   sub_J_1.

  Check rules_nc_sound.

  Section Comm.

    Hypothesis Hs1 : s1 = true.

    Definition rules_comm_sound := ill_comm_soundness    cl_ctx_increase cl_ctx_mono
                                                   cl_ctx_idem
                                                   (cl_comm Hs1)
                                                   cl_ctx_stable_l
                                                   cl_ctx_stable_r
                                                   cl_neutral_1
                                                   cl_neutral_2
                                                   cl_neutral_3
                                                   cl_neutral_4
                                                   cl_assoc_1
                                                   cl_assoc_2
                                                   sub_monoid_1
                                                   sub_monoid_2
                                                   sub_J_1.

  End Comm.

  Notation "↓" := (fun A Γ => Γ ⊨ A).

  Fact dc_closed A : cl (↓A) ⊆ ↓A.
  Proof.
    intros ga Hga; red in Hga.
    replace ga with (nil++ga++nil) by solve list eq.
    apply Hga.
    intro; rewrite <- app_nil_end; auto.
  Qed.

  Notation sg := (@eq _).
  Infix "⊸" := (Magicwand_l comp) (at level 51, right associativity).
  Infix "⟜" := (Magicwand_r comp) (at level 52, left associativity).

  Section equivalences.

    (* We show that each rule has an algebraic counterpart *)

    (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

    Fact rule_ax_eq A : ↓A (A::∅)
                    ≡ A::∅ ⊨ A.
    Proof. split; auto. Qed.

    Fact rule_limp_l_eq A B : (↓A ⊸ cl (sg (B::∅))) (A -o B::∅)
                          ≡ ∀ ϴ Γ Δ C, Γ ⊨ A -> ϴ++B::Δ ⊨ C -> ϴ++Γ++A -o B::Δ ⊨ C.
    Proof.
      split.
      + intros H Ga De Th C H1 H2.
        specialize (H (De++A -o B::nil)).
        spec all in H.
        constructor 1 with De (A -o B :: nil); auto; red; simpl; auto.
        replace (Ga++De++A -o B::Th) with (Ga++(De++A -o B::nil)++Th) by solve list eq.
        apply H; intros _ []; auto.
      + intros H0 th Hth de om C H.
        destruct Hth as [ rho ga th H1 H2 H3 ].
        subst ga; red in H3; simpl in H3.
        apply P_perm with (de++(rho++A -o B::nil)++om).
        { do 2 (apply ill_perm_t_app; auto). }
        rewrite app_ass; simpl; apply H0; auto.
        apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_limp_r_eq A B : sg (A::∅) ⊸ ↓B ⊆ ↓(A -o B)
                          ≡ ∀ Γ, A::Γ ⊨ B -> Γ ⊨ A -o B.
    Proof.
      split.
      + intros H Ga H1.
        apply H.
        intros _ [ ? ? De [] [] H2 ].
        apply P_perm with (1 := H2).
        apply P_perm with (2 := H1); auto.
      + intros H th Hth.
        apply H, Hth.
        constructor 1 with (A :: nil) th; auto.
        red; auto.
    Qed.

    Fact rule_rimp_l_eq A B : (cl (sg (B::∅)) ⟜ ↓A) (B o- A::∅)
                          ≡ ∀ ϴ Γ Δ C, Γ ⊨ A -> ϴ++B::Δ ⊨ C -> ϴ++B o- A::Γ++Δ ⊨ C.
    Proof.
      split.
      + intros H Ga De Th C H1 H2.
        specialize (H (B o- A::De)).
        spec all in H.
        constructor 1 with (B o- A::nil) De; auto; red; simpl; auto.
        replace (Ga++B o- A::De++Th) with (Ga++(B o- A::De)++Th) by solve list eq.
        apply H; intros _ []; auto.
      + intros H0 th Hth de om C H.
        destruct Hth as [ rho ga th H1 H2 H3 ].
        subst rho; red in H3; simpl in H3.
        apply P_perm with (de++(B o- A::ga)++om).
        { do 2 (apply ill_perm_t_app; auto). }
        simpl; apply H0; auto.
        apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_rimp_r_eq A B : ↓B ⟜ sg (A::∅) ⊆ ↓(B o- A)
                          ≡ ∀ Γ, Γ++A::nil ⊨ B -> Γ ⊨ B o- A.
    Proof.
      split.
      + intros H Ga H1.
        apply H.
        intros _ [ ? ? De [] [] H2 ].
        apply P_perm with (1 := H2).
        apply P_perm with (2 := H1); auto.
      + intros H th Hth.
        apply H, Hth.
        constructor 1 with th (A :: nil); auto.
        red; auto.
    Qed.

    Fact rule_times_l_eq A B : cl (sg (A::B::nil)) (A⊗B::nil)
                           ≡ ∀ ϴ Γ C, ϴ++A::B::Γ ⊨ C -> ϴ++A ⊗ B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_times_r_eq A B : ↓A ∘ ↓B ⊆ ↓(A⊗B)
                           ≡ ∀ Γ Δ, Γ ⊨ A -> Δ ⊨ B -> Γ++Δ ⊨ A ⊗ B.
    Proof.
      split.
      + intros H Ga De H1 H2.
        apply H.
        constructor 1 with Ga De; auto; red; auto.
      + intros H _ [ Ga Gb Gc HGa HGb HGc ].
        apply P_perm with (1 := HGc).
        apply H; auto.
    Qed.

    Fact rule_with_l1_eq A B : cl (sg (A::∅)) (A&B::∅)
                           ≡ ∀ ϴ Γ C, ϴ++A::Γ ⊨ C -> ϴ++A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_l2_eq A B : cl (sg (B::∅)) (A&B::∅)
                           ≡ ∀ ϴ Γ C, ϴ++B::Γ ⊨ C -> ϴ++A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H The Ga C H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_r_eq A B : ↓A ∩ ↓B ⊆ ↓(A & B)
                          ≡ ∀ Γ, Γ ⊨ A -> Γ ⊨ B -> Γ ⊨ A﹠B.
    Proof.
      split.
      + intros H Ga H1 H2; apply H; auto.
      + intros H ? []; apply H; auto.
    Qed.

    Fact rule_plus_l_eq A B : cl (sg (A::∅) ∪ sg (B::∅)) (A⊕B::∅)
                          ≡ ∀ ϴ Γ C, ϴ++A::Γ ⊨ C -> ϴ++B::Γ ⊨ C -> ϴ++A⊕B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1 H2.
        apply H; intros _ [ [] | [] ]; auto.
      + intros H0 ? ? ? H; apply H0; apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_plus_r1_eq A B : ↓A ⊆ ↓(A⊕B)
                           ≡ ∀ Γ, Γ ⊨ A -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_plus_r2_eq A B : ↓B ⊆ ↓(A⊕B)
                           ≡ ∀ Γ, Γ ⊨ B -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_bang_l_eq A : cl (sg (A::∅)) (!A::∅)
                        ≡ ∀ ϴ Γ B, ϴ++A::Γ ⊨ B -> ϴ++!A::Γ ⊨ B.
    Proof.
      split.
      + intros H Th Ga B H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_bang_r_eq A : K ∩ ↓A ⊆ ↓(!A)
                        ≡   ∀ Γ, ‼ Γ ⊨ A -> ‼ Γ ⊨ !A.
    Proof.
      split.
      + intros H Ga H1.
        apply H; split; auto.
        exists Ga; auto.
      + intros H0 Ga [ (De & H1) H2 ]; subst.
        apply H0; auto.
    Qed.

    Fact rule_unit_l_eq : cl (sg ∅) (𝝐::nil)
                      ≡ ∀ ϴ Γ A, ϴ++Γ ⊨ A -> ϴ++𝝐 :: Γ ⊨ A.
    Proof.
      split.
      + intros H Th Ga A H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_unit_r_eq : sg ∅ ⊆ ↓𝝐  ≡ ∅ ⊨ 𝝐.
    Proof.
      split.
      + intros H; apply H; auto.
      + intros H x []; apply H.
    Qed.

    Fact rule_bot_l_eq : cl (fun _ => False) (⟘::∅)
                     ≡ ∀ ϴ Γ A, ϴ++⟘ :: Γ ⊨ A.
    Proof.
      split.
      + intros H Th Ga A; apply H; tauto.
      + intros H0 ? ? ? _; apply H0.
    Qed.

    Fact rule_top_r_eq : (fun _ => True) ⊆ ↓⟙ ≡ ∀ Γ, Γ ⊨ ⟙.
    Proof.
      split.
      + intros H Ga; apply H; auto.
      + intros H ? _; apply H.
    Qed.

  End equivalences.

End Rules.