(* Defined Registers ANalysis *)
(* For Assume and Framestate insertion, we need to know the *)
(* exact set of defined registers at some program point *)
(* This analysis tracks defined registers, using Kildall library *)

Require Import specIR.
Require Import Lattice.
Require Import Kildall.
Require Import Coq.MSets.MSetPositive.

Definition regset: Type := PositiveSet.t.
Lemma regset_eq_refl: forall x, PositiveSet.eq x x.
Proof. apply PositiveSet.eq_equiv. Qed.
Lemma regset_eq_sym: forall x y, PositiveSet.eq x y -> PositiveSet.eq y x.
Proof. apply PositiveSet.eq_equiv. Qed.
Lemma regset_eq_trans: forall x y z, PositiveSet.eq x y -> PositiveSet.eq y z -> PositiveSet.eq x z.
Proof. apply PositiveSet.eq_equiv. Qed.

(* A Flat Semi-Lattice for sets of defined registers *)
(* Either Bot, a given set, or Top *)
Module DefFlatRegset <: SEMILATTICE_WITH_TOP.

Inductive t' : Type :=
  | Bot: t'
  | Inj: regset -> t'
  | Top: t'.

Definition t : Type := t'.

Definition eq (x y: t) : Prop :=
  match x with
  | Bot => match y with
          | Bot => True
          | _ => False
          end
  | Top => match y with
          | Top => True
          | _ => False
          end
  | Inj rsx => match y with
              | Inj rsy => PositiveSet.Equal rsx rsy
              | _ => False
              end
  end.

Lemma eq_refl: forall x, eq x x.
Proof. intros.   destruct x; simpl; auto. apply regset_eq_refl. Qed.

Lemma eq_sym: forall x y, eq x y -> eq y x.
Proof. intros. destruct x; destruct y; simpl; auto. simpl in H. apply regset_eq_sym. auto. Qed.

Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
Proof.
  intros. destruct x; destruct y; destruct z; simpl; auto; simpl in H; simpl in H0.
  inv H. eapply regset_eq_trans; eauto. inv H.
Qed.

Definition beq (x y: t) : bool :=
  match x, y with
  | Bot, Bot => true
  | Inj u, Inj v => if PositiveSet.equal u v then true else false
  | Top, Top => true
  | _, _ => false
  end.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold eq; destruct x; destruct y; simpl; try congruence; intro; auto.
  destruct (PositiveSet.equal r r0) eqn:EQ; auto; inv H. apply PositiveSet.equal_spec. auto.
Qed.

Definition ge (x y: t) : Prop :=
  match x, y with
  | Top, _ => True
  | _, Bot => True
  | Inj a, Inj b => PositiveSet.eq a b
  | _, _ => False
  end.

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold eq, ge. intros. destruct x; destruct y; simpl; auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge; destruct x; destruct y; try destruct z; intuition.
  eapply regset_eq_trans; eauto.
Qed.

Definition bot: t := Bot.

Lemma ge_bot: forall x, ge x bot.
Proof.
  destruct x; simpl; auto.
Qed.

Definition top: t := Top.

Lemma ge_top: forall x, ge top x.
Proof.
  destruct x; simpl; auto.
Qed.

Definition lub (x y: t) : t :=
  match x, y with
  | Bot, _ => y
  | _, Bot => x
  | Top, _ => Top
  | _, Top => Top
  | Inj a, Inj b => if PositiveSet.equal a b then Inj a else Top
  end.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof.
  destruct x; destruct y; simpl; auto. apply regset_eq_refl.
  destruct (PositiveSet.equal r r0); simpl; auto. apply regset_eq_refl.
Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof.
  destruct x; destruct y; simpl; auto. apply regset_eq_refl.
  destruct (PositiveSet.equal r r0) eqn:EQ; simpl; auto. apply PositiveSet.equal_spec. auto.
Qed.

End DefFlatRegset.

(* Top means we can't know for sure the set of defined registers *)
(* Inj rs means rs is the set of defined registers at this point *)
(* Bot is the initial value *)
Definition def_abs_dr: Type := DefFlatRegset.t.

(* Associating an abs_dr to each label *)
Definition def_abs_state : Type := PMap.t def_abs_dr.
Definition def_absstate_get (pc:label) (abs:def_abs_state) : def_abs_dr :=
  PMap.get pc abs.

(* At the function entry, we know parameters are defined *)
Fixpoint def_entry_set (params:list reg): regset :=
  match params with
  | nil => PositiveSet.empty
  | p::params' => PositiveSet.add p (def_entry_set params')
  end.

Definition def_entry_abs_dr (params:list reg): def_abs_dr :=
  DefFlatRegset.Inj (def_entry_set params).

Module DS := Dataflow_Solver (DefFlatRegset) (NodeSetBackward).

(* Inserting a new defined register into an abstract set *)
Definition def_insert (r:reg) (adr:def_abs_dr) : def_abs_dr :=
  match adr with
  | DefFlatRegset.Top => DefFlatRegset.Top
  | DefFlatRegset.Bot => DefFlatRegset.Inj (PositiveSet.singleton r)
  | DefFlatRegset.Inj rs => DefFlatRegset.Inj (PositiveSet.add r rs)
  end.

Fixpoint def_insert_list (lr:list reg) (adr:def_abs_dr) : def_abs_dr :=
  match lr with
  | nil => adr
  | r::lr' => def_insert r (def_insert_list lr' adr)
  end.

(* The transf function that updates reg sets *)
Definition def_dr_transf (c:code) (l:label) (adr:def_abs_dr) : def_abs_dr :=
  match c!l with
  | None => adr
  | Some i =>
    match i with
    | Op expr reg next =>
      def_insert reg adr
    | Move ml next =>
      def_insert_list (map fst ml) adr
    | Call fid args retreg next =>
      def_insert retreg adr
    | Load expr reg next =>
      def_insert reg adr
    | _ => adr                   (* other instructions can't declare registers *)
    end
  end.

Definition defined_regs_analysis (c:code) (params:list reg) (entry:label): option def_abs_state:=
  DS.fixpoint
    (PTree.map1 instr_succ c)
    (def_dr_transf c)
    ((entry,(def_entry_abs_dr params))::nil).

(** * Correctness of the analysis *)

(* Matching abstract reg_sets with a concrete regmap *)
Definition defined (rm:reg_map) (adr:def_abs_dr) :=
  match adr with
  | DefFlatRegset.Top => True
  | DefFlatRegset.Bot => False
  | DefFlatRegset.Inj rs =>
    forall r, PositiveSet.In r rs <-> exists v, rm # r = Some v
  end.

Lemma mem_empty:
  forall r s, PositiveSet.is_empty s = true -> PositiveSet.mem r s = false.
Proof.
  intros r s H. generalize dependent r. induction s; intros; auto.
  inv H. destruct (negb b) eqn:NEG; inv H1.
  destruct (PositiveSet.is_empty s1) eqn:EMPTY1; inv H0.
  simpl. destruct r.
  - apply IHs2. auto.
  - apply IHs1. auto.
  - destruct b; auto.
Qed.

(* There might be a simpler way *)
Lemma mem_eq:
  forall r s1 s2,
    PositiveSet.eq s1 s2 ->
    PositiveSet.mem r s2 = PositiveSet.mem r s1.
Proof.
  intros. unfold PositiveSet.eq in H. rewrite <- PositiveSet.equal_spec in H.
  generalize dependent s2. generalize dependent r. induction s1; intros.
  - inv H. simpl. apply mem_empty. auto.
  - destruct s2.
    + inv H. destruct (negb b) eqn:NEG; inv H1. destruct (PositiveSet.is_empty s1_1) eqn:EMPTY; inv H0.
      simpl. destruct r.
      * symmetry. apply mem_empty. auto.
      * symmetry. apply mem_empty. auto.
      * destruct b; inv NEG. auto.
    + simpl in H. simpl. destruct (eqb b b0) eqn:EQ; inv H.
      destruct (PositiveSet.equal s1_1 s2_1) eqn:EQ1; inv H1. destruct r.
      * apply IHs1_2. auto.
      * apply IHs1_1. auto.
      * symmetry. apply eqb_true_iff. auto.
Qed.

Lemma eq_defined:
  forall s1 s2 rm,
    PositiveSet.eq s1 s2 ->
    defined rm (DefFlatRegset.Inj s2) ->
    defined rm (DefFlatRegset.Inj s1).
Proof.
  unfold defined, PositiveSet.In. intros s1 s2 rm EQ DEF. intros r. specialize (DEF r).
  apply mem_eq with (r:=r) in EQ. rewrite EQ in DEF. auto.
Qed.

Lemma defined_increasing:
  forall rm adr1 adr2,
    DefFlatRegset.ge adr1 adr2 ->
    defined rm adr2 ->
    defined rm adr1.
Proof.
  intros rm adr1 adr2 GE DEF.
  destruct adr1; destruct adr2; try inv GE; auto; try inv DEF.
  simpl in GE. eapply eq_defined; eauto. constructor.
Qed.

(* The iterative analysis is correct *)
Lemma def_analyze_successor:
  forall v params abs pc i pc',
    defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs ->
    (ver_code v) # pc = Some i ->
    In pc' (instr_succ i) ->
    DefFlatRegset.ge (def_absstate_get pc' abs) (def_dr_transf (ver_code v) pc (def_absstate_get pc abs)).
Proof.
  intros v params abs pc i pc' H H0 H1. unfold defined_regs_analysis in H.
  eapply DS.fixpoint_solution; eauto.
  assert (@PTree.get (list positive) pc (PTree.map1 instr_succ (ver_code v)) = Some (instr_succ i)).
  { rewrite PTree.gmap1. unfold option_map. rewrite H0. auto. }
  unfold successors_list. rewrite H2.
  simpl. auto.
Qed.

Theorem def_analyze_correct:
  forall v pc i pc' abs params rm,
    defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs ->
    (ver_code v) # pc = Some i ->
    In pc' (instr_succ i) ->
    defined rm (def_dr_transf (ver_code v) pc (def_absstate_get pc abs)) ->
    defined rm (def_absstate_get pc' abs).
Proof.
  intros. eapply def_analyze_successor in H; eauto.
  eapply defined_increasing; eauto.
Qed.

Lemma def_analyze_init':
  forall rm params valist,
    specIR.init_regs valist params = Some rm ->
    defined rm (def_entry_abs_dr params).
Proof.
  intros. unfold def_entry_abs_dr. simpl. generalize dependent valist. generalize dependent rm.
  induction params; intros.
  - destruct valist; inv H. split; intros; inv H.
    unfold empty_regmap in H0. rewrite PTree.gempty in H0. inv H0.
  - destruct valist; inv H. destruct (init_regs valist params) eqn:INIT; inv H1.
    specialize (IHparams r0 valist INIT r). split; intros.
    + simpl in H. apply PositiveSet.add_spec in H. destruct H.
      * subst. rewrite PTree.gss. eauto.
      * apply IHparams in H. destruct H. poseq_destr a r.
        rewrite PTree.gss; eauto.
        rewrite PTree.gso; auto. eauto.
    + apply PositiveSet.add_spec. fold def_entry_set. poseq_destr a r.
      * left. auto.
      * right. rewrite PTree.gso in H; auto. apply <- IHparams in H. auto.
Qed.

Theorem def_analyze_init:
  forall rm v params abs valist,
    defined_regs_analysis (ver_code v) params (ver_entry v) = Some abs ->
    specIR.init_regs valist params = Some rm ->
    defined rm (def_absstate_get (ver_entry v) abs).
Proof.
  unfold defined_regs_analysis. intros rm v params abs valist FIX INIT.
  assert (A: DefFlatRegset.ge (def_absstate_get (ver_entry v) abs) (def_entry_abs_dr params)).
  { eapply DS.fixpoint_entry; eauto. left. auto. }
  eapply defined_increasing; eauto.
  eapply def_analyze_init'; eauto.
Qed.

(** * More defined Properties *)
Lemma define_insert:
  forall rm reg v rs,
    defined rm rs ->
    defined rm # reg <- v (def_insert reg rs).
Proof.
  intros rm reg v rs DEF. destruct rs. inv DEF. 2: simpl; auto.
  simpl in DEF. simpl. intros x.
  split; intros.
  - apply PositiveSet.add_spec in H. destruct H.
    + subst. rewrite PTree.gss. eauto.
    + specialize (DEF x). apply DEF in H. destruct H.
      poseq_destr reg x. rewrite PTree.gss. eauto. rewrite PTree.gso; eauto.
  - apply PositiveSet.add_spec. poseq_destr x reg; auto.
    right. rewrite PTree.gso in H; auto. apply DEF in H. auto.
Qed.

Lemma define_insert_list:
  forall ml rm newrm rs,
    defined rm rs ->
    update_movelist ml rm newrm ->
    defined newrm (def_insert_list (map fst ml) rs).
Proof.
  unfold update_movelist. intros ml. induction ml; intros; inv H0. auto.
  simpl. apply define_insert. eapply IHml; eauto.
Qed.

(* Inequality between registers *)
Definition reg_neq (r1:reg) (r2:reg) : bool :=
  negb (Pos.eqb r1 r2).


Require Import HoTT.
From HoTT.Categories Require Import Category.Prod.
From GR.bicategories Require Import general_category bicategory.bicategory.

Local Notation "x ₁" := (Datatypes.fst x) (at level 80).
Local Notation "x ₂" := (Datatypes.snd x) (at level 80).

Section ProductBicategory.
  Variable (C D : BiCategory).

  Definition prod_d : BiCategory_d.
  Proof.
    make_bicategory.
    - exact (Datatypes.prod (Obj C) (Obj D)).
    - exact (fun x y => Category.Prod.prod (C⟦x ₁ , y ₁⟧) (D⟦x ₂ ,y ₂⟧)).
    - exact (fun X => (id₁ (X ₁), id₁ (X ₂))).
    - intros [X₁ X₂] [Y₁ Y₂] [Z₁ Z₂] [[g₁ g₂] [f₁ f₂]] ; simpl in *.
      exact (g₁ · f₁,g₂ · f₂).
    - intros [X₁ X₂] [Y₁ Y₂] [Z₁ Z₂]
             [[f₁ f₂] [f₃ f₄]] [[g₁ g₂] [g₃ g₄]]
             [[η₁ η₂] [η₃ η₄]] ; simpl in *.
      exact (η₁ * η₃,η₂ * η₄).
    - intros [X₁ X₂] [Y₁ Y₂] [f₁ f₂] ; simpl in *.
      split ; apply left_unit.
    - intros [X₁ X₂] [Y₁ Y₂] [f₁ f₂] ; simpl in *.
      split ; apply left_unit_inv.
    - intros [X₁ X₂] [Y₁ Y₂] [f₁ f₂] ; simpl in *.
      split ; apply right_unit.
    - intros [X₁ X₂] [Y₁ Y₂] [f₁ f₂] ; simpl in *.
      split ; apply right_unit_inv.
    - intros [W₁ W₂] [X₁ X₂] [Y₁ Y₂] [Z₁ Z₂] [h₁ h₂] [g₁ g₂] [f₁ f₂] ; simpl in *.
      split ; apply assoc.
    - intros [W₁ W₂] [X₁ X₂] [Y₁ Y₂] [Z₁ Z₂] [h₁ h₂] [g₁ g₂] [f₁ f₂] ; simpl in *.
      split ; apply assoc_inv.
  Defined.

  Definition prod_is_bicategory : is_bicategory prod_d.
  Proof.
    make_is_bicategory ; intros ; simpl in *.
    - apply path_prod ; apply hcomp_id₂.
    - apply path_prod ; apply interchange.
    - apply path_prod ; apply left_unit_natural.
    - apply path_prod ; apply left_unit_inv_natural.
    - apply path_prod ; apply right_unit_natural.
    - apply path_prod ; apply right_unit_inv_natural.
    - apply path_prod ; apply left_unit_left.
    - apply path_prod ; apply left_unit_right.
    - apply path_prod ; apply right_unit_left.
    - apply path_prod ; apply right_unit_right.
    - apply path_prod ; apply assoc_natural.
    - apply path_prod ; apply assoc_inv_natural.
    - apply path_prod ; apply assoc_left.
    - apply path_prod ; apply assoc_right.
    - apply path_prod ; apply triangle_r.
    - apply path_prod ; apply pentagon.
  Qed.

  Definition prod : BiCategory
    := Build_BiCategory prod_d prod_is_bicategory.
End ProductBicategory.


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Export Coq.QArith.QArith.
Require Import CoRN.model.totalorder.QposMinMax.

(** printing QposInf $\mathbb{Q}^{+}_{\infty}$ #Q+∞# *)
(** printing QposInfinity $\infty$ #∞# *)

(** The type of positive rational numbers, including positive infinity. *)

Set Implicit Arguments.

Local Open Scope Q_scope.
Local Open Scope Qpos_scope.

(**
* [Qpos]
We choose to define [QposInf] as the disjoint union of [Qpos] and an
Infinity token.
*)

Inductive QposInf : Set :=
| Qpos2QposInf : Qpos -> QposInf
| QposInfinity : QposInf.

Bind Scope QposInf_scope with QposInf.
Delimit Scope QposInf_scope with QposInf.

(** Qpos2QposInf is an injection from [Qpos] to [QposInf] that we
declare as a coercion.
*)
Coercion Qpos2QposInf : Qpos >-> QposInf.

(** This bind operation is useful for lifting operations to work
on [QposInf].  It will map [QposInfinity] to [QposInfinity]. *)
Definition QposInf_bind (f : Qpos -> QposInf) (x:QposInf) :=
 match x with
 | Qpos2QposInf x' => f x'
 | QposInfinity => QposInfinity
 end.

Lemma QposInf_bind_id : forall x, QposInf_bind (fun e => e) x = x.
Proof.
 intros [x|]; reflexivity.
Qed.

(** Equality *)
Definition QposInfEq (a b:QposInf) :=
 match a, b with
 | Qpos2QposInf x, Qpos2QposInf y => Qeq (proj1_sig x) (proj1_sig y)
 | QposInfinity, QposInfinity => True
 | _, _ => False
 end.

Lemma QposInfEq_refl x : QposInfEq x x.
Proof.
  destruct x as [x|]. apply Qeq_refl.
  simpl. trivial.
Qed.

Lemma QposInfEq_sym x y : QposInfEq x y -> QposInfEq y x.
Proof.
  destruct x as [x|], y as [y|]; simpl; trivial. apply Qeq_sym.
Qed.

Lemma QposInfEq_trans x y z : QposInfEq x y -> QposInfEq y z -> QposInfEq x z.
Proof.
  destruct x as [x|], y as [y|], z as  [z|]; simpl; try tauto. apply Qeq_trans.
Qed.

Add Relation QposInf QposInfEq
 reflexivity proved by QposInfEq_refl
 symmetry proved by QposInfEq_sym
 transitivity proved by QposInfEq_trans as QposInfSetoid.

#[global]
Instance: Proper (QposEq ==> QposInfEq) Qpos2QposInf.
Proof.
  intros x y H. exact H.
Qed.

#[global]
Instance QposInf_bind_wd (f : Qpos -> QposInf) {f_wd : Proper (QposEq ==> QposInfEq) f} :
  Proper (QposInfEq ==> QposInfEq) (QposInf_bind f).
Proof.
  intros [x|] [y|] E; simpl; auto.
   destruct E.
  destruct E.
Qed.

(** Addition *)
Definition QposInf_plus (x y : QposInf) : QposInf :=
QposInf_bind (fun x' => QposInf_bind (fun y' => Qpos_plus x' y') y) x.

#[global]
Instance: Proper (QposInfEq ==> QposInfEq ==> QposInfEq) QposInf_plus.
Proof with auto.
  intros [x1|] [y1|] E1 [x2|] [y2|] E2; simpl...
  apply Qplus_comp...
Qed.

(** Multiplication *)
Definition QposInf_mult (x y : QposInf) : QposInf :=
QposInf_bind (fun x' => QposInf_bind (fun y' => Qpos_mult x' y') y) x.

#[global]
Instance: Proper (QposInfEq ==> QposInfEq ==> QposInfEq) QposInf_mult.
Proof with auto.
  intros [x1|] [y1|] E1 [x2|] [y2|] E2; simpl...
  apply Qmult_comp...
Qed.

(** Order *)
Definition QposInf_le (x y: QposInf) : Prop :=
match y with
| QposInfinity => True
| Qpos2QposInf y' =>
 match x with
 | QposInfinity => False
 | Qpos2QposInf x' => proj1_sig x' <= proj1_sig y'
 end
end.

(** Minimum *)
Definition QposInf_min (x y : QposInf) : QposInf :=
match x with
| QposInfinity => y
| Qpos2QposInf x' =>
 match y with
 | QposInfinity => x'
 | Qpos2QposInf y' => Qpos2QposInf (Qpos_min x' y')
 end
end.

#[global]
Instance: Proper (QposInfEq ==> QposInfEq ==> QposInfEq) QposInf_min.
Proof with intuition.
  intros [x1|] [y1|] E1 [x2|] [y2|] E2; simpl in *...
  apply Qpos_min_compat_Proper...
Qed.

Lemma QposInf_min_lb_l : forall x y, QposInf_le (QposInf_min x y) x.
Proof.
 intros [x|] [y|]; simpl; try auto.
  apply Qpos_min_lb_l.
 apply Qle_refl.
Qed.

Lemma QposInf_min_lb_r : forall x y, QposInf_le (QposInf_min x y) y.
Proof.
 intros [x|] [y|]; simpl; try auto.
  apply Qpos_min_lb_r.
 apply Qle_refl.
Qed.

Infix "+" := QposInf_plus : QposInf_scope.
Infix "*" := QposInf_mult : QposInf_scope.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-28

Some results concerning permutations of lists.
*)

Set Implicit Arguments.

Require Import Multiset Permutation ListExtras NatUtil LogicUtil Setoid
  PermutSetoid.

Section Multiplicity.

  Variable A: Type.
  Variable eqA: relation A.
  Variable eqA_dec: forall x y, {eqA x y} + {~eqA x y}.
  Variable eqA_eq: Setoid_Theory A eqA.

  Add Setoid A eqA eqA_eq as smA.

  Lemma multiplicity_in: forall l x,
    multiplicity (list_contents eqA eqA_dec l) x > 0 ->
    exists x', eqA x' x /\ In x' l.

  Proof.
    induction l; simpl; intros.
    absurd_arith.
    destruct (eqA_dec a x).
    exists a; auto.
    destruct (IHl x) as [x' [x'x x'l]]; trivial.
    exists x'; split; auto.
  Qed.

  Lemma in_multiplicity: forall l a,
    In a l ->
    multiplicity (list_contents eqA eqA_dec l) a > 0.

  Proof.
    induction l; simpl; intros.
    omega.
    destruct H.
    destruct (eqA_dec a a0).
    omega.
    absurd (eqA a a0); trivial.
    rewrite H; intuition.
    set (w := IHl a0 H); omega.
  Qed.

  Lemma multiplicity_countIn: forall l el,
    multiplicity (list_contents eqA eqA_dec l) el = countIn eqA eqA_dec el l.

  Proof.
    induction l; simpl; intros; trivial.
    destruct (eqA_dec a el); destruct (eqA_dec el a).
    rewrite IHl; omega.
    absurd (eqA el a); intuition.
    absurd (eqA a el); intuition.
    rewrite IHl; omega.
  Qed.

  Lemma multiplicity_dropNth_eq: forall l p el el',
    nth_error l p = Some el' ->
    eqA el el' ->
    multiplicity (list_contents eqA eqA_dec (drop_nth l p)) el =
    multiplicity (list_contents eqA eqA_dec l) el - 1.

  Proof.
    intros.
    rewrite !multiplicity_countIn.
    apply countIn_dropNth_eq with el'; trivial.
  Qed.

  Lemma multiplicity_dropNth_neq: forall l p el el',
    nth_error l p = Some el' ->
    ~eqA el el' ->
    multiplicity (list_contents eqA eqA_dec (drop_nth l p)) el =
    multiplicity (list_contents eqA eqA_dec l) el.

  Proof.
    intros.
    rewrite !multiplicity_countIn.
    apply countIn_dropNth_neq with el'; trivial.
  Qed.

End Multiplicity.

Section Permutation.

  Variable A: Type.
  Variable eqA: relation A.
  Variable eqA_dec: forall x y, {eqA x y} + {~eqA x y}.
  Variable eqA_eq: Setoid_Theory A eqA.

  Add Setoid A eqA eqA_eq as spA.

  Lemma permutation_sym: forall l l',
    permutation eqA eqA_dec l l' ->
    permutation eqA eqA_dec l' l.

  Proof.
    intros; intro el; auto.
  Qed.

  Lemma permutation_in: forall l l' a,
    permutation eqA eqA_dec l l' ->
    In a l ->
    exists a', eqA a' a /\ In a' l'.

  Proof.
    intros.
    destruct (multiplicity_in eqA eqA_dec l' a) as [a' [aa' a'l']].
    rewrite <- (H a); trivial.
    apply in_multiplicity; trivial.
    exists a'; split; trivial.
  Qed.

  Lemma permutation_drop: forall (l l': list A) a b p,
    eqA a b ->
    nth_error l' p = Some b ->
    permutation eqA eqA_dec (a :: l) l' ->
    permutation eqA eqA_dec l (drop_nth l' p).

  Proof.
    intros; intro el.
    destruct (eqA_dec a el).
    assert (eqA el b).
    apply (Seq_trans A eqA eqA_eq) with a; intuition.
    rewrite (multiplicity_dropNth_eq eqA_dec eqA_eq l' p el H0 H2).
    set (w := H1 el); simpl in w.
    replace (if eqA_dec a el then 1 else 0) with 1 in w.
    omega.
    clear w; destruct (eqA_dec a el); [trivial | contr].
    assert (~eqA el b).
    intro elb.
    absurd (eqA a el); trivial.
    apply (Seq_trans A eqA eqA_eq) with b; intuition.
    rewrite (multiplicity_dropNth_neq eqA_dec eqA_eq l' p el H0 H2).
    set (w := H1 el); simpl in w.
    replace (if eqA_dec a el then 1 else 0) with 0 in w.
    omega.
    clear w; destruct (eqA_dec a el); [contr | trivial].
  Qed.

  Lemma permutation_cons: forall l l' a,
    permutation eqA eqA_dec (a :: l) l' ->
    exists p, exists a',
      nth_error l' p = Some a' /\
      eqA a a' /\
      permutation eqA eqA_dec l (drop_nth l' p).

  Proof.
    intros.
    destruct (permutation_in a H) as [a' [aa' a'l']].
    auto with datatypes.
    destruct (list_In_nth l' a' a'l') as [p l'p].
    exists p; exists a'; split; [idtac | split]; trivial.
    intuition.
    apply permutation_drop with a a'; trivial.
    intuition.
  Qed.

  Lemma permutation_length: forall (l l': list A),
    permutation eqA eqA_dec l l' ->
    length l = length l'.

  Proof.
    induction l; intros.
     (* base *)
    simpl.
    destruct l'; trivial.
    unfold permutation in H.
    elimtype False.
    assert (w := H a); simpl in w; clear H.
    destruct (eqA_dec a a).
    omega.
    intuition.
     (* step *)
    destruct (permutation_cons H) as [p [a' [l'p [aa' ll'p]]]].
    simpl.
    rewrite (IHl (drop_nth l' p)); trivial.
    set (w := nth_some l' p l'p).
    rewrite drop_nth_in_length; trivial.
    omega.
  Qed.

  Lemma insert_nth_permut: forall (l: list A) el n,
    permutation eqA eqA_dec (insert_nth l n el) (el::l).

  Proof.
    induction l; intros.
    unfold insert_nth, finalSeg; destruct n; simpl; apply permut_refl.
    destruct n; unfold insert_nth; simpl.
    rewrite finalSeg_full; apply permut_refl.
    unfold finalSeg; simpl.
    fold (finalSeg l n); fold (insert_nth l n el).
    apply permut_tran with (a :: el :: l).
    apply permut_cons.
    apply IHl.
    change (el :: a :: l) with ((el :: nil) ++ a :: l).
    change (a :: el :: l) with (a :: (el :: nil) ++ l).
    apply permut_middle.
  Qed.

  Lemma insert_nth_permut': forall (l l': list A) el n,
    permutation eqA eqA_dec l l' ->
    permutation eqA eqA_dec (insert_nth l n el) (el::l').

  Proof.
    intros; intro w.
    unfold insert_nth.
    change (el :: finalSeg l n) with ((el :: nil) ++ finalSeg l n).
    change (el :: l') with ((el :: nil) ++ l').
    rewrite !list_contents_app.
    simpl.
    rewrite plus_0_r.
    match goal with
    | |- ?a + (?b + ?c) = ?d => replace (a + (b + c)) with (a + c + b)
    end.
    replace (multiplicity (list_contents eqA eqA_dec (initialSeg l n)) w +
      multiplicity (list_contents eqA eqA_dec (finalSeg l n)) w)
    with (multiplicity
      (list_contents eqA eqA_dec (initialSeg l n ++ finalSeg l n)) w).
    rewrite initialSeg_finalSeg_full; trivial.
    rewrite (H w); auto with arith.
    rewrite list_contents_app; trivial.
    omega.
  Qed.

End Permutation.

Section ListSim.

  Variable A : Type.
  Variable B : Type.
  Variable R : A -> B -> Prop.

  Inductive list_sim: list A -> list B -> Prop :=
  | conv_empty:
      list_sim nil nil
  | conv_cons: forall x y xs ys,
      R x y ->
      list_sim xs ys ->
      list_sim (x::xs) (y::ys).

  Lemma list_sim_nth : forall p l l' a, list_sim l l' ->
    nth_error l p = Some a ->
    exists b, nth_error l' p = Some b /\ R a b.

  Proof.
    induction p.
    intros.
    inversion H.
    rewrite <- H1 in H0; discr.
    exists y; split; auto.
    replace a with x; trivial.
    rewrite <- H3 in H0; inversion H0; trivial.
    intros.
    destruct l; destruct l'; try discr.
    inversion H.
    inversion H.
    destruct (IHp l l' a); trivial.
    destruct H7.
    exists x0; split; trivial.
  Qed.

  Lemma list_sim_nth_rev : forall p l l' b, list_sim l l' ->
    nth_error l' p = Some b ->
    exists a, nth_error l p = Some a /\ R a b.

  Proof.
    induction p.
    intros.
    inversion H.
    rewrite <- H2 in H0; discr.
    exists x; split; auto.
    replace b with y; trivial.
    rewrite <- H4 in H0; inversion H0; trivial.
    intros.
    destruct l; destruct l'; try discr.
    inversion H.
    inversion H.
    destruct (IHp l l' b); trivial.
    destruct H7.
    exists x0; split; trivial.
  Qed.

  Lemma list_sim_app : forall l1 l1' l2 l2',
    list_sim l1 l1' -> list_sim l2 l2' -> list_sim (l1 ++ l2) (l1' ++ l2').

  Proof.
    induction l1; intros.
    inversion H; trivial.
    inversion H.
    simpl; constructor; trivial.
    apply IHl1; trivial.
  Qed.

  Lemma list_sim_unique : forall l m m',
    (forall x y y', In x l -> In y m -> In y' m' ->
      R x y -> R x y' -> y = y') ->
    list_sim l m -> list_sim l m' -> m = m'.

  Proof.
    induction l; intros; inversion H0; inversion H1; trivial.
    rewrite (H x y y0).
    rewrite (IHl ys ys0); trivial.
    intros.
    destruct (list_In_nth l x1 H12) as [p lp].
    apply H with x1; trivial.
    right; trivial.
    rewrite <- H5; right; trivial.
    rewrite <- H10; right; trivial.
    rewrite H2; auto with datatypes.
    rewrite <- H5; left; trivial.
    rewrite <- H10; left; trivial.
    rewrite H2; trivial.
    rewrite H2; trivial.
  Qed.

  Lemma list_sim_insert_nth : forall p l l' a a', nth_error l p = Some a ->
    nth_error l' p = Some a' -> R a a' ->
    list_sim (drop_nth l p) (drop_nth l' p) -> list_sim l l'.

  Proof.
    induction p; intros.
     (* induction base *)
    destruct l; destruct l'.
    constructor.
    inversion H2; discr.
    inversion H2; discr.
    constructor.
    inversion H; inversion H0; trivial.
    rewrite !drop_nth_cons in H2; trivial.
     (* induction step *)
    destruct l; destruct l'.
    constructor.
    inversion H2; discr.
    inversion H2; discr.
    rewrite !drop_nth_succ in H2.
    inversion H2.
    constructor; trivial.
    apply IHp with a a'; trivial.
  Qed.

  Lemma list_sim_length : forall l l', list_sim l l' -> length l = length l'.

  Proof.
    induction l; intros.
    inversion H; trivial.
    destruct l'.
    inversion H.
    simpl.
    rewrite (IHl l'); trivial.
    inversion H; trivial.
  Qed.

  Lemma list_sim_tail : forall l l',
    list_sim l l' -> list_sim (tail l) (tail l').

  Proof.
    intros.
    destruct H; trivial.
    simpl; constructor.
  Qed.

End ListSim.

Section ListSim_iso.

  Variable A : Type.
  Variable P : relation A.
  Variable eqA : relation A.
  Variable eqA_dec : forall x y, {eqA x y} + {~eqA x y}.
  Variable eqA_eq : Setoid_Theory A eqA.
  Variable P_eqA_comp : forall x x' y y',
    eqA x x' -> eqA y y' -> P x y -> P x' y'.

  Definition list_simA := @list_sim A A P.

  Lemma list_sim_permutation : forall l l' m,
    list_simA l l' -> permutation eqA eqA_dec l m ->
    exists m', list_simA m m' /\ permutation eqA eqA_dec l' m'.

  Proof.
    unfold Setoid_Theory in eqA_eq.
    induction l; intros.
     (* induction base *)
    exists (nil (A:=A)); split.
    destruct m.
    constructor.
    set (w := H0 a); inversion w.
    destruct (eqA_dec a a).
    absurd_arith.
    absurd (eqA a a); intuition.
    inversion H.
    apply permut_refl.
     (* induction step *)
    destruct l'.
    inversion H.
    destruct (permutation_cons eqA_eq H0) as [p [a' [mp [aa' lm]]]].
    destruct (IHl l' (drop_nth m p)) as [m' [mm' l'm']]; trivial.
    inversion H; trivial.
    assert (length m' >= p).
    rewrite <- (list_sim_length mm').
    set (h := nth_some m p mp).
    set (w := drop_nth_length m p).
    omega.
    exists (insert_nth m' p a0); split.
    unfold list_simA; apply list_sim_insert_nth with p a' a0; trivial.
    apply nth_insert_nth; trivial.
    apply P_eqA_comp with a a0; intuition.
    inversion H; intuition.
    rewrite drop_nth_insert_nth; trivial.
    apply permutation_sym.
    apply insert_nth_permut'.
    apply permutation_sym; trivial.
  Qed.

End ListSim_iso.


#[global]
Set Primitive Projections.
#[global]
Unset Printing Primitive Projection Parameters.

#[global]
Set Universe Polymorphism.

#[global]
Set Default Goal Selector "!".

#[global]
Unset Universe Minimization ToSet.

Require Import Coq.Unicode.Utf8.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.
Require Import Coq.Strings.String.

(* Prototype an approach based around "structured cospans" *)
#[universes(cumulative)]
Class Term := {
  T: Type ;
  T_Setoid: Setoid T ;

  mt: T ;
  trv: T ;
  sum: T → T → T ;
  prod: T → T → T ;
  exp: T → T → T ;

  sum_Proper: Proper (equiv ==> equiv ==> equiv) sum ;
  prod_Proper: Proper (equiv ==> equiv ==> equiv) prod ;
  exp_Proper: Proper (equiv ==> equiv ==> equiv) exp ;
}.
Coercion T: Term >-> Sortclass.

Existing Instance T_Setoid.
Existing Instance sum_Proper.
Existing Instance prod_Proper.
Existing Instance exp_Proper.

Notation "∅" := mt.
Notation "·" := trv.

Infix "+" := sum.
Infix "*" := prod.
Infix "^" := exp.

#[universes(cumulative)]
Class Homomorphism {A B: Term} (f: A → B): Prop := {
  map_Proper: Proper (equiv ==> equiv) f ;
  map_mt: f ∅ == ∅ ;
  map_trv: f · == · ;
  map_sum x y: f (x + y) == f x + f y ;
  map_prod x y: f (x * y) == f x * f y ;
  map_exp x y: f (exp x y) == exp (f x) (f y) ;
}.

Existing Instance map_Proper.

Module Import Hom.
  Definition Hom (A B: Term) := { f: A → B | Homomorphism f}.

  #[program]
   Definition id A : Hom A A := λ x, x.

  Next Obligation.
  Proof.
  Admitted.
End Hom.

Module Terminal.
  #[refine]
  Instance terminal_Setoid: Setoid unit := {
    equiv _ _ := True ;
  }.
  Proof.
    exists.
    all: exists.
  Defined.

  #[refine]
  Instance Terminal: Term := {
    T := unit ;
    mt := tt ;
    trv := tt ;
    sum _ _ := tt ;
    prod _ _ := tt ;
    exp _ _ := tt ;
  }.
  Proof.
    all: intros ? ? ? ? ? ?.
    all: reflexivity.
  Defined.
End Terminal.

Module Free.
  #[universes(cumulative)]
  Inductive free {U: Type} :=
  | η (u: U)
  | mt | trv
  | sum (A B: free)
  | prod (A B: free)
  | exp (B A: free)
  .
  Arguments free: clear implicits.

  Instance free_Setoid U: Setoid (free U) := {
    equiv := eq ;
  }.

  Instance Free U: Term := {
    T := free U ;
    mt := mt ;
    trv := trv ;
    sum := sum ;
    prod := prod ;
    exp := exp ;
  }.

  #[program]
  Definition ε (A: Term): Hom (Free A) A :=
    fix loop e :=
      match e with
      | η T => T
      | mt => ∅
      | trv => ·
      | sum A B => loop A + loop B
      | prod A B => loop A * loop B
      | exp A B => loop A ^ loop B
      end.

  Next Obligation.
  Proof.
    exists.
    all: cbn.
    all: try reflexivity.
    intros ? ? p.
    rewrite p.
    reflexivity.
  Qed.

  #[program]
  Definition map {A B} (f: A → B): Hom (Free A) (Free B) :=
    fix loop x :=
      match x with
      | η u => η (f u)
      | mt => mt
      | trv => trv
      | sum A B => sum (loop A) (loop B)
      | prod A B => prod (loop A) (loop B)
      | exp A B => exp (loop A) (loop B)
      end.
  Next Obligation.
  Proof.
    exists.
    all: cbn.
    all: try reflexivity.

    intros x y p.
    induction x.
    all: inversion p.
    all: subst.
    all: cbn.
    all: try reflexivity.
  Qed.

  #[program]
  Definition join (A: Type): Hom (Free (Free A)) (Free A) :=
    fix loop e :=
      match e with
      | η T => T
      | mt => ∅
      | trv => ·
      | sum A B => loop A + loop B
      | prod A B => loop A * loop B
      | exp A B => loop A ^ loop B
      end.

  Next Obligation.
  Proof.
    exists.
    all: cbn.
    all: try reflexivity.
    intros ? ? p.
    rewrite p.
    reflexivity.
  Qed.

  #[program]
   Definition bind {A B} (f: A → Free B): Hom (Free A) (Free B) := λ x, proj1_sig (join _) (proj1_sig (map f) x).
  Next Obligation.
  Proof.
  Admitted.
End Free.

Module Pullback.
  Definition pullback {A B C} (f: Hom A C) (g: Hom B C) :=
    { '(x, y) | proj1_sig f x == proj1_sig g y }.

  #[program]
  Instance pullback_Setoid {A B C} (f: Hom A C) (g: Hom B C): Setoid (pullback f g) := {
    equiv x y := fst (proj1_sig x) == fst (proj1_sig y) ∧ snd (proj1_sig x) == snd (proj1_sig y) ;
  }.
  Next Obligation.
  Proof.
    exists.
    - intros ?.
      split.
      all: reflexivity.
    - intros ? ? p.
      destruct p.
      split.
      all: symmetry.
      all: auto.
    - intros ? ? ? p q.
      destruct p as [p1 p2], q as [q1 q2].
      rewrite p1,p2,q1,q2.
      split.
      all: reflexivity.
  Defined.

  #[program]
  Instance Pullback {A B C} (f: Hom A C) (g: Hom B C): Term := {
    T := pullback f g ;
    mt := (∅, ∅) ;
    trv := (·, ·) ;
    sum A B := (fst A + fst B, snd A + snd B) ;
    prod A B := (fst A * fst B, snd A * snd B) ;
    exp A B := (fst A ^ fst B, snd A ^ snd B) ;
  }.

  Next Obligation.
  Proof.
    destruct f, g.
    cbn.
    repeat rewrite map_mt.
    reflexivity.
  Qed.

  Next Obligation.
  Proof.
    destruct f, g.
    cbn.
    repeat rewrite map_trv.
    reflexivity.
  Qed.

  Next Obligation.
  Proof.
    destruct f as [f fp], g as [g p],
             A as [[A1 A2] Ap], B as [[B1 B2] Bp].
    cbn in *.
    repeat rewrite map_sum.
    rewrite Ap, Bp.
    reflexivity.
  Qed.

  Next Obligation.
  Proof.
    destruct f as [f fp], g as [g p],
             A as [[A1 A2] Ap], B as [[B1 B2] Bp].
    cbn in *.
    repeat rewrite map_prod.
    rewrite Ap, Bp.
    reflexivity.
  Qed.

  Next Obligation.
  Proof.
    destruct f as [f fp], g as [g p],
             A as [[A1 A2] Ap], B as [[B1 B2] Bp].
    cbn in *.
    repeat rewrite map_exp.
    rewrite Ap, Bp.
    reflexivity.
  Qed.

  Next Obligation.
  Proof.
    intros x x' p y y' q.
    cbn in *.
    destruct x as [[x1 x2] xp],
             x' as [[x1' x2'] xp'],
             y as [[y1 y2] yp],
                  y' as [[y1' y2'] yp'].
    cbn in *.
    destruct p as [p1 p2], q as [q1 q2].
    cbn in *.
    rewrite p1, p2, q1, q2.
    split.
    all: reflexivity.
  Qed.

  Next Obligation.
  Proof.
    intros x x' p y y' q.
    cbn in *.
    destruct x as [[x1 x2] xp],
             x' as [[x1' x2'] xp'],
             y as [[y1 y2] yp],
                  y' as [[y1' y2'] yp'].
    cbn in *.
    destruct p as [p1 p2], q as [q1 q2].
    cbn in *.
    rewrite p1, p2, q1, q2.
    split.
    all: reflexivity.
  Qed.

  Next Obligation.
  Proof.
    intros x x' p y y' q.
    cbn in *.
    destruct x as [[x1 x2] xp],
             x' as [[x1' x2'] xp'],
             y as [[y1 y2] yp],
                  y' as [[y1' y2'] yp'].
    cbn in *.
    destruct p as [p1 p2], q as [q1 q2].
    cbn in *.
    rewrite p1, p2, q1, q2.
    split.
    all: reflexivity.
  Qed.
End Pullback.

Module Slice.
  (* Term/S *)
  #[universes(cumulative)]
  Record bundle A := {
    s: Term ;
    π: Hom s A ;
  }.

  Arguments s {A}.
  Arguments π {A}.

  Definition slice {S} (A B: bundle S) := { f : s A → s B | Homomorphism f ∧ ∀ x, proj1_sig (π B) (f x) == proj1_sig (π A) x }.

  #[program]
   Definition id {S} (A: bundle S): slice A A := λ x, x.

  Next Obligation.
  Proof.
    split.
    - exists.
      all: try reflexivity.
      intros ? ? ?.
      auto.
    - reflexivity.
  Qed.

  #[program]
   Definition compose {S} {A B C: bundle S} (f: slice B C) (g: slice A B): slice A C :=
    λ x, f (g x).

  Next Obligation.
  Proof.
    destruct f as [f [fH fp]], g as [g [gH gp]].
    cbn in *.
    split.
    - exists.
      + intros ? ? p.
        rewrite p.
        reflexivity.
      + repeat rewrite map_mt.
        reflexivity.
      + repeat rewrite map_trv.
        reflexivity.
      + intros.
        repeat rewrite map_sum.
        reflexivity.
      + intros.
        repeat rewrite map_prod.
        reflexivity.
      + intros.
        repeat rewrite map_exp.
        reflexivity.
    - intros.
      rewrite (fp _).
      rewrite (gp _).
      reflexivity.
  Qed.

  Import Terminal.

  #[program]
  Definition No (S: Term): bundle Terminal := {| π (_: S) := tt |}.

  Next Obligation.
  Proof.
    exists.
    all: try reflexivity.
    intros ? ? p.
    reflexivity.
  Qed.

  #[program]
  Definition map {A B} (f: Hom A B): slice (No A) (No B) := f.

  Next Obligation.
  Proof.
    destruct f as [f fh].
    cbn.
    split.
    - exists.
      + intros ? ? p.
        rewrite p.
        reflexivity.
      + rewrite map_mt.
        reflexivity.
      + rewrite map_trv.
        reflexivity.
      + intros.
        rewrite map_sum.
        reflexivity.
      + intros.
        rewrite map_prod.
        reflexivity.
      + intros.
        rewrite map_exp.
        reflexivity.
    - intros.
      exists.
  Qed.

  Infix "∘" := compose (at level 30).

  #[program]
  Definition basechange {A B: Term} (f: Hom A B) (x: bundle B): bundle A :=
    {| s := Pullback.Pullback f (π x) ;
       π x := fst x |}.

  Next Obligation.
  Proof.
    exists.
    all: cbn.
    all: try reflexivity.
    intros ? ? p.
    destruct p as [p q].
    rewrite p.
    reflexivity.
  Qed.

  #[program]
  Definition Σ {A B: Term} (f: Hom A B) (g: bundle A): bundle B :=
    {| π x := f (π g x) |}.

  Next Obligation.
  Proof.
    destruct f as [f fp], g as [s [g gp]].
    cbn.
    exists.
    all: cbn.
    - intros ? ? p.
      rewrite p.
      reflexivity.
    - repeat rewrite map_mt.
      reflexivity.
    - repeat rewrite map_trv.
      reflexivity.
    - intros.
      repeat rewrite map_sum.
      reflexivity.
    - intros.
      repeat rewrite map_prod.
      reflexivity.
    - intros.
      repeat rewrite map_exp.
      reflexivity.
  Qed.

  #[program]
  Definition Π {A B: Term} (f: Hom A B) (g: bundle A): bundle B :=
    {| s := Pullback.Pullback (π g) (Hom.id _) ;
       π x := f (snd (proj1_sig x)) ; |}.

  Next Obligation.
  Proof.
    destruct f as [f fp].
    destruct g as [s [g gp]].
    cbn.
    exists.
    all: cbn.
    - intros ? ? p.
      destruct p as [p q].
      rewrite q.
      reflexivity.
    - rewrite map_mt.
      reflexivity.
    - rewrite map_trv.
      reflexivity.
    - intros.
      rewrite map_sum.
      reflexivity.
    - intros.
      rewrite map_prod.
      reflexivity.
    - intros.
      rewrite map_exp.
      reflexivity.
  Qed.

  (* Reader monad IIRC *)
  #[program]
  Definition pure {S T} {A: bundle S} (f: Hom S T): slice A (basechange f (Π f A)) :=
    λ x, (proj1_sig (π A) x, (x, proj1_sig (π A) x)).

  Next Obligation.
  Proof.
    reflexivity.
  Qed.

  Next Obligation.
  Proof.
    reflexivity.
  Qed.

  Next Obligation.
  Proof.
    destruct A as [sA [A Ap]],
             f as [f fp].
    cbn in *.
    split.
    - exists.
      all: cbn.
      + intros ? ? p.
        cbn.
        repeat rewrite p.
        all: repeat split.
        all: reflexivity.
      + repeat rewrite map_mt.
        all: repeat split.
        all: reflexivity.
      + repeat rewrite map_trv.
        all: repeat split.
        all: reflexivity.
      + intros.
        repeat rewrite map_sum.
        all: repeat split.
        all: reflexivity.
      + intros.
        repeat rewrite map_prod.
        all: repeat split.
        all: reflexivity.
      + intros.
        repeat rewrite map_exp.
        all: repeat split.
        all: reflexivity.
    - intros.
      reflexivity.
  Qed.
End Slice.

Module StructuredSlice.
  Import Slice.
  Import Free.

  Definition Obj S := bundle (Free S).
  Definition Struct {S}: Obj S → Obj S → Type  := @slice (Free S).

  Definition id {S} (A: Obj S) := Slice.id A.
  Definition compose {S} {A B C: Obj S} := @Slice.compose _ A B C.

  Infix "∘" := compose (at level 30).

  Definition Any S: Obj S := {| π := Hom.id _ |}.

  Definition basechange {A B: Type} (f: A → Free B): Obj B → Obj A :=
    basechange (Free.bind f).

  Definition Σ {A B: Type} (f: A → Free B): Obj A → Obj B :=
    Σ (Free.bind f).

  Definition Π {A B: Type} (f: A → Free B): Obj A → Obj B :=
    Π (Free.bind f).

  Definition pure {S T} {A: Obj S} (f: S → Free T): Struct A (basechange f (Π f A)) :=
    pure (Free.bind f).

  Infix "::" := basechange.
End StructuredSlice.

Module Span.
  #[universes(cumulative)]
  Record span A B := {
    s: Term ;
    π1: Hom s A ;
    π2: Hom s B ;
  }.

  Arguments s {A B}.
  Arguments π1 {A B}.
  Arguments π2 {A B}.

  #[program]
   Definition id A: span A A := {| π1 x := x ; π2 x := x |}.

  Next Obligation.
  Proof.
    exists.
    all: try reflexivity.
    intros ? ? ?.
    auto.
  Qed.

  Next Obligation.
  Proof.
    exists.
    all: try reflexivity.
    intros ? ? ?.
    auto.
  Qed.

  #[program]
   Definition compose {A B C} (f: span B C) (g: span A B): span A C :=
    {|
    s := Pullback.Pullback (π1 f) (π2 g) ;
    π1 x := proj1_sig (π1 g) (snd (proj1_sig x)) ;
    π2 x := proj1_sig (π2 f) (fst (proj1_sig x)) ;
    |}.

  Next Obligation.
  Proof.
    destruct f as [fs [f1 f1p] [f2 f2p]].
    destruct g as [gs [g1 g1p] [g2 g2p]].
    cbn.
    exists.
    - intros ? ? p.
      destruct p as [p q].
      rewrite q.
      reflexivity.
    - cbn.
      rewrite map_mt.
      reflexivity.
    - cbn.
      rewrite map_trv.
      reflexivity.
    - intros.
      cbn.
      rewrite map_sum.
      reflexivity.
    - intros.
      cbn.
      rewrite map_prod.
      reflexivity.
    - intros.
      cbn.
      rewrite map_exp.
      reflexivity.
  Qed.

  Next Obligation.
  Proof.
    destruct f as [fs [f1 f1p] [f2 f2p]].
    destruct g as [gs [g1 g1p] [g2 g2p]].
    cbn.
    exists.
    - intros ? ? p.
      destruct p as [p q].
      rewrite p.
      reflexivity.
    - cbn.
      rewrite map_mt.
      reflexivity.
    - cbn.
      rewrite map_trv.
      reflexivity.
    - intros.
      cbn.
      rewrite map_sum.
      reflexivity.
    - intros.
      cbn.
      rewrite map_prod.
      reflexivity.
    - intros.
      cbn.
      rewrite map_exp.
      reflexivity.
  Qed.

  #[program]
   Definition transpose {A B} (f: span A B): span B A :=
    {| π1 := π2 f ; π2 := π1 f |}.

  #[program]
  Definition map {A B} (f: Hom A B): span A B := {| π1 x := x ; π2 := f |}.

  Next Obligation.
  Proof.
    exists.
    all: try reflexivity.
    intros ? ? ?.
    auto.
  Qed.

  Infix "∘" := compose (at level 30).
  Notation "f 'ᵀ'" := (transpose f) (at level 1).
End Span.

Module Structured.
  Import Span.
  Import Free.

  Definition Struct A B := span (Free A) (Free B).

  Definition id A := Span.id (Free A).
  Definition compose {A B C} := @Span.compose (Free A) (Free B) (Free C).
  Definition transpose {A B} := @Span.transpose (Free A) (Free B).

  Definition map {A B}: Hom (Free A) (Free B) → Struct A B := Span.map.

  Infix "∘" := compose (at level 30).
  Notation "f 'ᵀ'" := (transpose f) (at level 1).
End Structured.

Import Free.
Import Slice.
Import StructuredSlice.

Open Scope string_scope.

Definition subst x (e: Free string) y: Free string :=
  if string_dec x y then e else η y.

Infix "::=" := subst (at level 30).

(* FIXME define generic adjunction first then specialize to substutition *)
Definition eval {A: Term}: Obj A → bundle A := Slice.Π (ε _).

#[program]
Definition close (S: Term) {A B: Obj S} (f: Struct A B): slice (eval A) (eval B) :=
  λ x, (proj1_sig f (fst (proj1_sig x)), snd (proj1_sig x)).

Next Obligation.
Proof.
  destruct x as [[x y] xp].
  destruct f as [f [fH fp]].
  cbn in *.
  rewrite <- (fp x) in xp.
  auto.
Qed.

Next Obligation.
Proof.
  destruct f as [f [p q]].
  cbn in *.
  split.
  - exists.
    all: cbn.
    + intros ? ? r.
      destruct r as [r r'].
      cbn.
      rewrite r, r'.
      split.
      all: reflexivity.
    + split.
      2: reflexivity.
      rewrite map_mt.
      reflexivity.
    + split.
      2: reflexivity.
      rewrite map_trv.
      reflexivity.
    + split.
      2: reflexivity.
      rewrite map_sum.
      reflexivity.
    + split.
      2: reflexivity.
      rewrite map_prod.
      reflexivity.
    + split.
      2: reflexivity.
      rewrite map_exp.
      reflexivity.
  - intros x.
    reflexivity.
Qed.

Instance Type_Setoid: Setoid Type := {
  equiv := eq ;
}.

#[program]
Instance Set_Term: Term := {
  T := Set ;
  mt := Empty_set ;
  trv := unit ;
  sum := Datatypes.sum ;
  prod := Datatypes.prod ;
  exp A B := A → B ;
}.

Definition close_Term {A B} := @close Set_Term A B.

Definition Forsome (x: Obj nat): Obj nat := basechange (λ x, η (S x)) (Π (λ x, η (S x)) x).
Definition Forall (x: Obj nat): Obj nat := basechange (λ x, η (S x)) (Π (λ x, η (S x)) x).

(* weird *)
Definition foo: Struct (Any nat) (Forall (Any nat)) := pure (λ x, η (S x)).


From iris.algebra Require Import
  proofmode_classes.

From caml5 Require Import
  prelude.
From caml5.algebra Require Export
  base.

Record Z_add := {
  Z_add_car : Z ;
}.
Add Printing Constructor Z_add.

Canonical Z_add_O :=
  leibnizO Z_add.

Implicit Types n m : Z.
Implicit Types x y z : Z_add.

#[local] Instance Z_add_valid : Valid Z_add :=
  λ _,
    True.
#[local] Instance Z_add_validN : ValidN Z_add :=
  λ _ _,
    True.
#[local] Instance Z_add_pcore : PCore Z_add :=
  λ x,
    Some (Build_Z_add 0).
#[local] Instance Z_add_op : Op Z_add :=
  λ x1 x2,
    Build_Z_add (Z_add_car x1 + Z_add_car x2).
#[local] Instance Z_add_unit : Unit Z_add :=
  Build_Z_add 0.

Lemma Z_add_op_eq n1 n2 :
  Build_Z_add n1 ⋅ Build_Z_add n2 = Build_Z_add (n1 + n2).
Proof.
  done.
Qed.

Lemma Z_add_ra_mixin :
  RAMixin Z_add.
Proof.
  apply ra_total_mixin; apply _ || eauto.
  - intros [] [] []. rewrite !Z_add_op_eq Z.add_assoc //.
  - intros [] []. rewrite Z_add_op_eq Z.add_comm //.
  - intros []. rewrite Z_add_op_eq //.
  - intros [] []. exists (Build_Z_add 0). done.
Qed.
Canonical Z_add_R :=
  discreteR Z_add Z_add_ra_mixin.
#[global] Instance Z_add_cmra_discrete :
  CmraDiscrete Z_add_R.
Proof.
  apply discrete_cmra_discrete.
Qed.

Lemma Z_add_ucmra_mixin :
  UcmraMixin Z_add.
Proof.
  split; try done. intros []. done.
Qed.
Canonical Z_add_UR :=
  Ucmra Z_add Z_add_ucmra_mixin.

#[global] Instance Z_add_cancelable x :
  Cancelable x.
Proof.
  intros ? [] [] _. destruct x.
  rewrite !Z_add_op_eq => [=].
  rewrite Z.add_cancel_l => -> //.
Qed.

Lemma Z_add_local_update x1 y1 x2 y2 :
  (Z_add_car x1 + Z_add_car y2 = Z_add_car x2 + Z_add_car y1)%Z →
  (x1, y1) ~l~> (x2, y2).
Proof.
  move: x1 y1 x2 y2 => [n1] [m1] [n2] [m2] /= ?.
  rewrite local_update_unital_discrete => [[p]] _.
  rewrite !Z_add_op_eq => [= ?].
  split; first done. f_equal. lia.
Qed.

#[global] Instance Z_add_is_op n1 n2 :
  IsOp (Build_Z_add (n1 + n2)) (Build_Z_add n1) (Build_Z_add n2).
Proof.
  done.
Qed.


(** This file contains a formalization of several of my claims in my internship
    report.
    I would like to thank Kevin Quirin for his help in using HoTT and some of
    the proofs. **)

(* You need to compile it with HoTT (from the github HoTT/HoTT). *)
Require Import HoTT.

(*! Section 1. Operations on equality !*)
(* We implement them although they are already available in the HoTT library for
   the sake of the example. *)
Section Operations.

  (* Transport *)
  Definition ex_transport {A} {B} (p : A = B) : A -> B :=
    paths_rect _ A (fun B p => A -> B) (fun x => x) B p.

  (* Ap(plication) *)
  Definition ex_ap {A} {B} (f : A -> B) {x y : A} (p : x = y) : f x = f y :=
    paths_rect A x (fun y p => f x = f y) idpath y p.

  (* Symmetry *)
  Definition ex_sym {A} {x y : A} (p : x = y) : y = x :=
    paths_rect A x (fun y p => y = x) idpath y p.

  (* Transitivity *)
  Definition ex_trans {A} {x y z : A} (p : x = y) (q : y = z) : x = z :=
    paths_rect A x (fun y p => y = z -> x = z) (fun q => q) y p q.

  (* We also explicit the arrow between equality and equivalence. *)
  Definition ex_eq_equiv {A} {B} (p : A = B) : A <~> B.
    simple refine (BuildEquiv A B _ _).
    - exact (transport idmap p).
    - simple refine (BuildIsEquiv A B _ _ _ _ _).
      + exact (transport idmap (p^)).
      + intro x. destruct p. cbn. reflexivity.
      + intro x. destruct p. cbn. reflexivity.
      + intro x. cbn. destruct p. cbn. reflexivity.
  Qed.

End Operations.

(*! Section 3. Reduction between rules. !*)
Section OneRule.

  (* Propositions are embedded in True *)
  Lemma prop_in_top :
    forall (A : Type) `{h : IsHProp A}, { f : A -> True | IsEmbedding f}.
  Proof.
    intros A h.
    exists (fun a => tt). intro x. destruct x.

    intros x y. destruct x as [x p]. destruct y as [y q].
    assert (e : x = y).
    - apply path_ishprop.
    - destruct e. assert (e : p = q).
      + apply hset_decpaths. intros u v. destruct u. destruct v.
        left. reflexivity.
      + destruct e. exists idpath. intro y.
        apply hset_decpaths. intros u v.
        destruct u as [u q]. destruct v as [v r].
        assert (e : u = v).
        * apply path_ishprop.
        * { destruct e. assert (e : q = r).
            - apply hset_decpaths. intros v w.
              destruct v. destruct w. left. reflexivity.
            - destruct e. left. exact idpath.
          }
  Qed.

  (* Let's assume the excluded middle. *)
  Parameter em : forall (A : Type) `{h : IsHProp A}, A + (A -> False).

  (* We can build an equivalent in Type0 to any hProp. *)
  Definition propEquiv (A : Type) `{h : IsHProp A} : Type0 :=
    match em A with
    | inl a  => True
    | inr na => False
    end.

  Lemma equivHProp : forall (A : Type) `{h : IsHProp A}, A <~> propEquiv A.
  Proof.
    intros A h.
    simple refine (BuildEquiv A (propEquiv A) _ _).
    - intro a. unfold propEquiv. destruct (em A) as [_ | na].
      + exact tt.
      + exact (na a).
    - simple refine (BuildIsEquiv _ _ _ _ _ _ _).
      + intro p. unfold propEquiv in *. destruct (em A) as [a | na].
        * exact a.
        * destruct p.
      + unfold Sect. unfold propEquiv. destruct (em A).
        * intro x. destruct x. reflexivity.
        * intro x. destruct x.
      + unfold Sect. intro x. destruct (em A).
        * apply h.
        * destruct (t x).
      + intro x. cbn. unfold propEquiv. destruct (em A).
        * apply path_ishprop.
        * assert (f : False) by (destruct (t x)).
          destruct f.
  Qed.

  (* In order to prove equivalence between hProp and Bool we need univalence and
     funext (which is implied by univalence). *)

  Context `{fs : Funext}.
  Context `{un : Univalence}.

  (* We first show that hProp is equivalent do Decidable hProp (under LEM). *)
  Lemma equiv_hprop_to_dprop : hProp <~> DProp.
  Proof.
    simple refine (equiv_adjointify _ _ _ _).
    - intro A. exists A.
      + intro H'. exact _.
      + exact (em A).
    - intro A. exists (dprop_type A). apply (ishprop_dprop A fs).
    - intro A. cbn. apply path_dprop. cbn. exact idpath.
    - intro A. cbn. exact idpath.
  Defined.

  Lemma equiv_hprop_bool : hProp <~> Bool.
  Proof.
    transitivity DProp.
    - exact equiv_hprop_to_dprop.
    - exact equiv_dprop_to_bool.
  Defined.

  (* Finally we prove that if A embeds in B, then A is equivalent to its image
     through the embdedding. *)

  Definition IsMono {A B : Type} (f : A -> B)
    := forall x y, IsEquiv (ap f (x:=x) (y:=y)).

  Open Scope path_scope.
  Require Import Utf8_core.

  Lemma IsEmbedding_IsMono {A B : Type} (f : A -> B)
  : IsEmbedding f <-> IsMono f.
    split.
    - intros H x y.
      apply isequiv_fcontr. intro q.
      pose (Y := equiv_path_hfiber (x;1) (y;q^)); cbn in Y.
      simple refine (contr_equiv' (∃ q0 : x = y, 1 = ap f q0 @ q^) _).
      simple refine (equiv_functor_sigma_id _); intro a.
      pose (ff:= (equiv_inverse (BuildEquiv _ _ _ (isequiv_moveL_pV q 1 (ap f a))))).
      rewrite concat_1p in ff.
      exact (equiv_compose' (equiv_path_inverse q (ap f a)) ff).
      simple refine (@contr_equiv' ((x; 1) = (y; q^)) _ (equiv_inverse Y) _).
    - intros H b x y; simpl. pose (Y:=equiv_path_hfiber x y).
      simple refine (@contr_equiv' _ _ Y _).
      pose (fcontr_isequiv (ap f) (H x.1 y.1) (x.2@y.2^)).
      match goal with
        |[ i : Contr ?AA |- Contr ?BB ] => assert (X: AA <~> BB)
      end.
      simple refine (equiv_functor_sigma_id _); intro a.
      pose (ff:= (equiv_inverse (BuildEquiv _ _ _ (isequiv_moveL_pV y.2 (ap f a) x.2)))).
      exact (equiv_compose' (equiv_path_inverse (ap f a @ y.2) x.2) ff).
      simple refine (@contr_equiv' _ _ X _).
  Qed.

  Definition Im {A B} (f : A -> B) := { b : B & Trunc (-1) (hfiber f b) }.

  Lemma embed_image : forall A B (f : A -> B) `{IsEmbedding f}, A <~> himage f.
  Proof.
    intros A B f h.
    simple refine (BuildEquiv A (himage f) _ _).
    - intro a. exists (f a). apply tr. exists a. exact idpath.
    - apply isequiv_surj_emb.
      + intro b. destruct b as [b p].
        unfold TrM.IsConnected. apply equiv_hprop_inhabited_contr.
        * exact _.
        * simple refine (Trunc_ind _ _ p).
          intro fa. destruct fa as [a pf].
          apply tr. exists a. destruct pf. exact idpath.
      + apply IsEmbedding_IsMono. intros x y.
        simple refine (isequiv_adjointify _ _ _ _).
        * intro e.
          assert (Emb : IsMono f) by (apply IsEmbedding_IsMono ; exact h).
          apply (equiv_inv (IsEquiv := Emb x y)).
          exact e..1.
        * intro p.
          simple refine (path_path_sigma _ _ _ _ _ _ _).
          2: apply path_ishprop.
          unfold pr1_path.
          match goal with
            |[|- ap ?ff (ap ?gg ?pp) = _]
             => rewrite <- (ap_compose gg ff pp)
          end.
          cbn.
          rewrite eisretr. reflexivity.
        * intro p. destruct p. cbn.
          apply moveR_equiv_V ; reflexivity.
  Defined.

End OneRule.

(*! Section 4.  We prove here our admissible rules. !*)
Section Translation.

  Context `{Funext}.

  (* Pointed types as Sigmas *)
  Definition BuildPType A (a : A) : { typ : Type & typ }.
    exists A. exact a.
  Defined.
  Notation "[ A , a ]" := (BuildPType A a) (at level 0).

  (* We state our parametricity axiom. *)
  Axiom axType : forall p : Type = Type, p = idpath.

  (* And its corolarry. *)
  Lemma typeq : forall A B, ([Type, A] = [Type, B]) ->
                       A = B.
  Proof.
    intros A B p.
    pose proof (equiv_path_sigma _ [Type,A] [Type,B]) as h.
    pose proof (h ^-1 p) as h'. simpl in h'.
    destruct h' as [p1 p2].
    rewrite (axType p1) in p2. simpl in p2. exact p2.
  Qed.

  Lemma HSubst : forall A B (p : A = B) (t : A),
                   ([A, t] = [B, p # t]).
  Proof.
    intros A B p t.
    simple refine (path_sigma _ _ _ _ _) ; simpl.
    - exact p.
    - reflexivity.
  Qed.

  Lemma HProd : forall A A' B B'
                  (p : [Type, A] = [Type, A'])
                  (q : forall (x : A) (y : A') (e : [A, x] = [A', y]),
                         [Type, (B x)] = [Type, (B' y)]),
                  [Type, (forall x:A, B x)] = [Type, (forall y:A', B' y)].
  Proof.
    intros A A' B B' p q.
    assert (e : (forall x : A, B x) = (forall y : A', B' y)).
    { cut (A = A').
      - intro h. destruct h.
        cut (forall x:A, B x = B' x).
        + intro h. pose proof (path_forall B B' h) as h'. destruct h'.
          reflexivity.
        + intro x. assert (e : [A, x] = [A, x]) by reflexivity.
          pose proof (q x x e) as h. apply typeq. apply h.
      - apply typeq. apply p.
    }
    simple refine (path_sigma _ _ _ _ _).
    - exact idpath.
    - simpl. exact e.
  Qed.

  Definition forall_eq {A} {B1} {B2} (p : forall x : A, B1 x = B2 x) :
    (forall x : A, B1 x) = (forall x : A, B2 x).
  Proof.
    cut (B1 = B2).
    - intro e. destruct e. exact idpath.
    - apply path_forall. exact p.
  Defined.

  Lemma forall_eq_transport :
    forall A B1 B2 (p : forall (x:A), B1 x = B2 x) (t1 : forall (x : A), B1 x),
      @paths (forall (x:A), B2 x)
             (transport idmap (@forall_eq A B1 B2 p) (fun (x : A) => t1 x))
             (fun (x : A) => transport idmap (p x) (t1 x)).
  Proof.
    intros A B1 B2 p t1. cbn.
    apply path_forall; intro x. unfold forall_eq. cbn.

    path_via (transport idmap ((apD10 (path_forall B1 B2 p)) x) (t1 x)).
    - generalize (path_forall B1 B2 p). intro q; destruct q.
      reflexivity.
    - rewrite apD10_path_forall. reflexivity.
  Defined.

  Lemma HLam : forall A1 A2 B1 B2 t1 t2,
                 [Type, A1] = [Type, A2] ->
                 (forall (x : A1) (y : A2) (p : [A1,x] = [A2,y]),
                    [B1 x, t1 x] = [B2 y, t2 y]) ->
                 [forall (x : A1), B1 x, fun (x:A1) => t1 x] =
                 [forall (y : A2), B2 y, fun (y:A2) => t2 y].
  Proof.
    intros A1 A2 B1 B2 t1 t2 p h.
    assert (e : A1 = A2).
    { apply typeq. exact p. }
    destruct e. rename A1 into A.
    assert (eq : forall x : A, [A, x] = [A, x]) by (intro x ; exact idpath).
    simple refine (path_sigma _ _ _ _ _) ; simpl.
    - exact (forall_eq (fun x => (h x x (eq x))..1)).
    - eapply transitivity.
      + apply forall_eq_transport.
      + cbn. apply path_forall. intro x.
        exact ((h x x (eq x))..2).
  Qed.

  (* We state the parametricity axiom necessary for HApp. *)
  Axiom PiExt :
    forall A B1 B2,
      IsEquiv (fun p => transport idmap (@forall_eq A B1 B2 p)).

  Lemma PiEquiv :
    forall A B1 B2,
      (forall x:A, B1 x = B2 x) <~> ((forall x:A, B1 x) -> (forall x:A, B2 x)).
  Proof.
    intros A B1 B2.
    exists (fun p => transport idmap (@forall_eq A B1 B2 p)).
    apply PiExt.
  Defined.

  Lemma PiGet' :
    forall A B1 B2 (tp : (forall x : A, B1 x) -> (forall x : A, B2 x)),
      exists (q : forall x : A, B1 x = B2 x),
        transport idmap (forall_eq q) = tp.
  Proof.
    intros A B1 B2 tp.
    exists ((PiEquiv A B1 B2)^-1 (tp)).
    apply (eisretr (fun p => transport idmap (@forall_eq A B1 B2 p))).
  Defined.

  Lemma PiGet :
    forall A B1 B2 (p : (forall x : A, B1 x) = (forall x : A, B2 x)),
      exists (q : forall x : A, B1 x = B2 x),
        transport idmap (forall_eq q) = transport idmap p.
  Proof.
    intros A B1 B2 p.
    apply PiGet'.
  Defined.

  Lemma HApp :
    forall A1 A2 B1 B2 t1 t2 u1 u2,
      [forall x:A1, B1 x, t1] = [forall y:A2, B2 y, t2] -> [A1, u1] = [A2, u2] ->
      [B1 u1, t1 u1] = [B2 u2, t2 u2].
  Proof.
    intros A1 A2 B1 B2 t1 t2 u1 u2 p q.
    pose (e' := q..2). cbn in e'.
    pose (e := q..1). cbn in e. assert (h : e = q..1) by reflexivity.
    rewrite <- h in e'. clear h.
    destruct e. cbn in e'. destruct e'.
    rename A1 into A. rename u1 into u.
    pose (p1 := p..1). cbn in p1.
    assert (
        e : exists (q : forall x : A, B1 x = B2 x),
              transport idmap (forall_eq q) = transport idmap p1
    ) by (apply PiGet).
    destruct e as [e he].
    simple refine (path_sigma _ _ _ _ _) ; simpl.
    - exact (e u).
    - pose proof (p..2) as p2. cbn in p2.
      assert (triv : p..1 = p1) by reflexivity. rewrite triv in p2. clear triv.
      pose proof (ap (fun f => f t1) he) as h1. cbn in h1.
      pose proof (h1 @ p2) as h2.
      pose proof (forall_eq_transport _ _ _ e t1) as ht.
      pose proof (ht^ @ h2) as h3.
      exact (ap (fun f => f u) h3).
  Qed.

End Translation.