Require Import Coq.Init.Wf Coq.Arith.Wf_nat.
Require Import Coq.Lists.List Coq.Strings.String.
Require Import Coq.omega.Omega.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Coq.Program.Equality.
Require Import Fiat.Common.
Require Import Fiat.Common.StringFacts.
Require Import Fiat.Common.Wf.
Require Import Fiat.Common.NatFacts.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretationDefinitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretation.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Fix.

Set Implicit Arguments.

Local Open Scope grammar_fixedpoint_scope.

Definition length_result_lub (l1 l2 : nat) : lattice_for nat
  := if beq_nat l1 l2 then constant l1 else ⊤.

Global Instance length_result_lattice : grammar_fixedpoint_lattice_data nat.
Proof.
  refine {| prestate_lt x y := false;
            prestate_beq := beq_nat;
            preleast_upper_bound := length_result_lub |};
    try abstract (repeat match goal with
                         | [ |- is_true true ] => reflexivity
                         | _ => congruence
                         | [ |- Equivalence _ ] => split; hnf
                         | [ |- Proper _ _ ] => unfold Proper, respectful
                         | _ => progress intros
                         | _ => progress simpl in *
                         | _ => progress unfold length_result_lub, is_true in *
                         | _ => progress subst
                         | [ H : constant _ = constant _ |- _ ] => inversion H; clear H
                         | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true_iff in H
                         | _ => rewrite <- beq_nat_refl
                         | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
                         | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
                         end).
  { unfold Basics.flip; constructor; simpl; intros ? H; exfalso; clear -H.
    abstract congruence. }
Defined.

Global Instance length_result_aidata {Char} : @AbstractInterpretation Char nat _.
Proof.
  refine {| on_terminal t := constant 1;
            on_nil_production := constant 0;
            precombine_production x y := constant (x + y) |}.
  { simpl; unfold state, state_beq, prestate_beq, length_result_lattice.
    abstract (
        repeat match goal with
               | _ => intro
               | _ => progress simpl in *
               | _ => progress unfold is_true in *
               | _ => progress subst
               | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true_iff in H
               | [ |- beq_nat _ _ = true ] => apply beq_nat_true_iff
               | _ => reflexivity
               end
      ). }
Defined.

Section correctness.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition length_result_accurate
             (P : String -> Prop) (n : nat)
    : Prop
    := forall str, P str -> length str = n.

  Local Ltac t_Proper_step :=
    idtac;
    match goal with
    | _ => tauto
    | _ => congruence
    | [ |- is_true _ ] => reflexivity
    | _ => omega_with_min_max
    | _ => progress unfold respectful, pointwise_relation, length_result_accurate, length_result_accurate, ensemble_bottom, ensemble_top, ensemble_least_upper_bound, ensemble_on_terminal, ensemble_combine_production, lattice_for_related, not, length_result_lub, prestate_le in *
    | _ => intro
    | _ => progress subst
    | [ H : is_true (beq_nat _ _) |- _ ] => apply beq_nat_true_iff in H
    | _ => progress destruct_head lattice_for
    | [ |- iff _ _ ] => split
    | [ H : forall x y, _ -> (_ <-> _) |- _ ] => specialize (fun x => H x x (reflexivity _))
    | _ => progress split_iff
    | _ => progress destruct_head ex
    | _ => progress destruct_head and
    | _ => solve [ eauto using length_singleton with nocore
                 | exfalso; eauto with nocore ]
    | [ H : forall str, length str = ?v |- _ ] => apply not_all_lengths in H
    | [ H : forall v, True -> _ |- _ ] => specialize (fun v => H v I)
    | [ H : String -> False |- _ ] => apply not_not_string in H
    | [ H : forall a, ?x a = ?y a, H' : context[?x _] |- _ ] => setoid_rewrite H in H'
    | [ H : forall a, ?x a = ?y a, H' : context[?x _] |- _ ] => rewrite H in H'
    | [ H : forall a, ?x a = ?y a |- _ ] => is_var x; clear x H
    | [ H : constant _ = constant _ |- _ ] => inversion H; clear H
    | _ => progress unfold state_le in *
    | _ => progress simpl in *
    | [ H : forall v, (forall x y, True) -> _ |- _ ]
      => specialize (fun v => H v (fun _ _ => I))
    | [ H : forall P str, P str -> @?A str |- _ ]
      => specialize (fun str => H (fun _ => True) str I)
    | [ H : _ |- _ ] => rewrite Bool.orb_false_r in H
    | _ => rewrite Bool.orb_false_r
    | [ |- is_true (beq_nat _ _) ] => apply beq_nat_true_iff
    | [ H : beq_nat _ _ = true |- _ ] => apply beq_nat_true_iff in H
    | [ H : forall P, (forall str, P str -> @?P' str) -> forall str, P str -> @?Q' str |- _ ]
      => specialize (H P' (fun str pf => pf))
    | [ H : forall str, length str = ?n -> length str = ?n' |- _ ]
      => let H' := fresh in
         destruct (strings_nontrivial n) as [? H'];
         specialize (H _ H')
    | [ H : forall str, length str = ?n -> ?T |- _ ]
      => let H' := fresh in
         destruct (strings_nontrivial n) as [? H'];
         specialize (H _ H')
    | [ H : forall str, ?P str -> @?Q str, H' : ?P ?str' |- _ ]
      => is_var P; pose proof (H _ H'); clear P H H'
    | _ => progress rewrite ?take_length, ?drop_length
    | _ => progress destruct_head or
    | [ |- context[match ?e with _ => _ end] ] => destruct e eqn:?
    | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
    end.

  Local Ltac t_Proper := repeat t_Proper_step.

  Section instances.
    Local Obligation Tactic := t_Proper.
    Global Program Instance length_result_accurate_Proper0
      : Proper ((beq ==> iff) ==> eq ==> iff) length_result_accurate.
    Global Program Instance length_result_accurate_Proper1
      : Proper ((beq ==> iff) ==> prestate_beq ==> iff) length_result_accurate.
    Global Program Instance length_result_accurate_Proper2
      : Proper (pointwise_relation _ iff ==> eq ==> iff) length_result_accurate.
    Global Program Instance length_result_accurate_Proper3
      : Proper (pointwise_relation _ iff ==> prestate_beq ==> iff) length_result_accurate.
    Global Program Instance length_result_accurate_Proper4
      : Proper (pointwise_relation _ eq ==> eq ==> iff) length_result_accurate.
    Global Program Instance length_result_accurate_Proper5
      : Proper (pointwise_relation _ eq ==> prestate_beq ==> iff) length_result_accurate.
  End instances.

  Global Instance length_result_aicdata
    : AbstractInterpretationCorrectness length_result_accurate.
  Proof.
    split; try exact _;
      try solve [ t_Proper ].
  Qed.
End correctness.

Definition length_result := lattice_for nat.
Coercion collapse_length_result (v : length_result) : option nat
  := Eval cbv [collapse_lattice_for] in collapse_lattice_for v.

Definition length_of_any {Char} (G : pregrammar' Char)
: String.string -> length_result
  := fun nt => lookup_state (fold_grammar G) (@of_nonterminal _ (@rdp_list_predata _ G) nt).

Section has_only_terminals.
  Context {Char}
          {HSLM : StringLikeMin Char}
          {HSL : StringLike Char}
          {HSLP : StringLikeProperties Char}
          (G : pregrammar' Char) {n}
          nt
          (H : length_of_any G nt = constant n)
          (str : String).

  Lemma has_only_terminals_parse_of_item_length
        (p : parse_of_item G str (NonTerminal nt))
    : length str = n.
  Proof.
    unfold length_of_any in H.
    apply fold_grammar_correct_item in p.
    rewrite H in p.
    destruct p; intuition.
  Qed.

  Lemma has_only_terminals_parse_of_length
        (p : parse_of G str (Lookup G nt))
    : length str = n.
  Proof.
    unfold length_of_any in H.
    apply fold_grammar_correct in p.
    rewrite H in p.
    destruct p; intuition.
  Qed.
End has_only_terminals.


Require Export Lia.
From Equations Require Import Equations.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Wellfounded.Lexicographic_Product.

Inductive id : Type := Id : nat -> id.
Inductive var : Type :=
| varF : id -> var
| varB : id -> var.

Inductive ty : Set :=
| TTop : ty
| TAll : ty -> ty -> ty
| TSel : var -> ty -> ty.

Inductive tm : Set :=
| tvar : id -> tm.

Fixpoint tsize_flat(T: ty) :=
  match T with
    | TTop => 1
    | TAll T1 T2 => S (tsize_flat T1 + tsize_flat T2)
    | TSel _ U => 1 + tsize_flat U
  end.

Definition val_type_termRel :=
  Program.Wf.MR (lexprod lt (fun _ => lt)) (fun p => let '(T, n) := p in (existT (fun _ => nat) n (tsize_flat T))).

Ltac smaller_n := autounfold; apply left_lex; lia.

#[export]
Instance WF_val_type_termRel: WellFounded val_type_termRel.
  apply Wf.measure_wf; apply wf_lexprod; intro; apply Wf_nat.lt_wf.
Qed.

Equations? val_type (Tn: ty * nat) : Prop by wf Tn val_type_termRel :=
    val_type (pair T (S n)) := val_type (pair T n);
    val_type (pair T O) := True.
Proof. smaller_n. Defined.

Fail Next Obligation.


Require Import
  Coq.Classes.RelationClasses
  MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms MathClasses.interfaces.canonical_names MathClasses.theory.categories MathClasses.interfaces.abstract_algebra.
Require
  MathClasses.categories.algebras MathClasses.theory.forget_algebra.

Section subalgebras.
  Context `{Algebra sign A} (P: ∀ s, A s → Prop).

  (* We begin by describing what it means for P to be a proper closed subset: *)

  Fixpoint op_closed {o: OpType (sorts sign)}: op_type A o → Prop :=
    match o with
    | ne_list.one x => P x
    | ne_list.cons _ _ => λ d, ∀ z, P _ z → op_closed (d z)
    end.

  Global Instance op_closed_proper: ∀ `{∀ s, Proper ((=) ==> iff) (P s)} o, Proper ((=) ==> iff) (@op_closed o).
  Proof with intuition.
   induction o; simpl; intros x y E.
    rewrite E...
   split; intros.
    apply (IHo (x z))... apply E...
   apply (IHo _ (y z))... apply E...
  Qed.

  Class ClosedSubset: Prop :=
    { subset_proper:> ∀ s, Proper ((=) ==> iff) (P s)
    ; subset_closed: ∀ o, op_closed (algebra_op o) }.

  (* Now suppose P is closed in this way. *)

  Context `{ClosedSubset}.

  (* Our new algebra's elements are just those for which P holds: *)

  Definition carrier s := sig (P s).

  Hint Extern 4 => progress unfold carrier: typeclass_instances.

  (* We can implement closed operations in the new algebra: *)

  Program Fixpoint close_op {d}: ∀ (o: op_type A d), op_closed o → op_type carrier d :=
    match d with
    | ne_list.one _ => λ o c, exist _ o (c)
    | ne_list.cons _ _ => λ o c X, close_op (o X) (c X (proj2_sig X))
    end.

  Global Instance impl: AlgebraOps sign carrier := λ o, close_op (algebra_op o) (subset_closed o).

  (* By showing that these ops are proper, we get our new algebra: *)

  Definition close_op_proper d (o0 o1: op_type A d)
    (P': op_closed o0) (Q: op_closed o1): o0 = o1 → close_op o0 P' = close_op o1 Q.
  Proof with intuition.
   induction d; simpl in *...
   intros [x p] [y q] U.
   apply (IHd _ _ (P' x p) (Q y q)), H2...
  Qed.

  Global Instance subalgebra: Algebra sign carrier.
  Proof. constructor. apply _. intro. apply close_op_proper, algebra_propers. Qed.

  (* And we have the obvious projection morphism: *)

  Definition proj s := @proj1_sig (A s) (P s).

  Global Instance: HomoMorphism sign carrier A proj.
  Proof with try apply _.
   constructor...
    constructor...
    firstorder.
   intro.
   unfold impl, algebra_op.
   generalize (subset_closed o).
   unfold algebra_op.
   generalize (H o).
   induction (sign o); simpl; intuition.
  Qed.

  (* Which is mono because proj is injective. *)
  Instance: `{Injective (proj i)}.
  Proof.
    split.
     firstorder.
    apply (@homo_proper sign carrier A
      (fun s : sorts sign => @sig_equiv (A s) (e s) (P s)) _ _ _ _).
    apply _.
  Qed.

  Global Instance: Mono (algebras.arrow _ proj).
  Proof.
   apply forget_algebra.mono.
   apply categories.product.mono.
   intro. apply setoids.mono.
   simpl. apply _.
  Qed. (* this really should be completely automatic. *)
End subalgebras.

#[global]
Hint Extern 10 (Equiv (carrier _ _)) => apply @sig_equiv : typeclass_instances.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e141m9_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e285m9_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import Equations Utf8.
Set Universe Polymorphism.
Import Sigma_Notations.
Open Scope equations_scope.
Polymorphic
Definition pr1_seq {A} {P : A -> Type} {p q : sigma A P} (e : p = q) : p.1 = q.1.
Proof. destruct e. apply eq_refl. Defined.

Require Vector.
Derive NoConfusion for Vector.t.

Notation " 'rew' H 'in' c " := (@eq_rect _ _ _ c _ H) (at level 20).

Definition J {A} {x : A} (P : forall y : A, x = y -> Type)
           (p : P x eq_refl) (y : A) (e : x = y) : P y e.
  destruct e. exact p.
Defined.

Lemma J_on_refl {A} (x y : A) (e : x = y) : J (λ (y : A) _, x = y) eq_refl y e = e.
Proof. destruct e. constructor. Defined.

Definition subst {A : Type} {x : A} {P : A -> Type} {y : A} (e : x = y) (f : P x) : P y :=
  J (fun x _ => P x) f y e.

Definition subst2 {A : Type} {x : A} {P : A -> Type} (f : P x) (y : A) (e : x = y) : P y :=
  J (fun x _ => P x) f y e.

Definition cong@{i j} {A : Type@{i}} {B : Type@{j}} (f : A -> B) {x y : A} (e : x = y) : f x = f y :=
  J@{i j} (fun y _ => f x = f y) (@eq_refl _ (f x)) y e.
(* aka ap *)

Lemma cong_iter {A B C} (f : A -> B) (g : B -> C) (x y : A) (e : x = y) :
  Top.cong g (Top.cong f e) = Top.cong (fun x => g (f x)) e.
Proof. revert y e. refine (Top.J _ _). reflexivity. Qed.

Lemma cong_subst2 {A B C} (f : C -> B) (x y : A) (e : x = y) (z w : A -> C) (p : z x = w x) :
  Top.cong f (Top.subst2 (P:=fun x : A => z x = w x) p y e) =
  Top.subst2 (P := fun x : A => f (z x) = f (w x)) (Top.cong f p) y e.
Proof. revert y e. refine (Top.J _ _). simpl. reflexivity. Defined.

Definition congd {A} {B : A -> Type} (f : forall x : A, B x) {x y : A} (p : x = y) :
  subst p (f x) = f y :=
  J (fun y p => subst p (f x) = f y) (@eq_refl _ (f x)) y p.
(* aka apd *)

Notation " 'rew' H 'in' c " := (@subst _ _ _ _ H c) (at level 20).

Notation "p =_{ P ; e } q" := (subst (P:=P) e p = q) (at level 90, format "p  =_{ P ; e }  q").

Definition subst_expl {A : Type} {x : A} {P : A -> Type} {y : A} (e : x = y) (f : P x) : P y :=
  subst e f.
Notation " 'rewP' H 'at' P 'in' c " := (@subst_expl _ _ P _ H c) (at level 20).

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

(** A typeclass that includes the data making [f] into an adjoin equivalence*)
Set Printing Universes.
Cumulative Class IsEquiv@{i} {A : Type@{i}} {B : Type@{i}} (f : A -> B) := BuildIsEquiv {
  equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = cong f (eissect x)
}.
Arguments eisretr {A B} f {_} _.
Arguments eissect {A B} f {_} _.
Arguments eisadj {A B} f {_} _.

Record Equiv@{i} (A B : Type@{i}) := { equiv :> A -> B ; is_equiv :> IsEquiv equiv }.
Arguments equiv {A B} e.

Instance Equiv_IsEquiv {A B} (e : Equiv A B) : IsEquiv (equiv e).
Proof. apply is_equiv. Defined.

Definition inv_equiv {A B} (E: Equiv A B) : B -> A :=
  equiv_inv (IsEquiv:=is_equiv _ _ E).

Definition equiv_inv_equiv@{i} {A B : Type@{i}} {E: Equiv A B} (x : A) : inv_equiv _ (equiv E x) = x := eissect _ x.
Definition inv_equiv_equiv@{i} {A B : Type@{i}} {E: Equiv A B} (x : B) : equiv E (inv_equiv _ x) = x := eisretr _ x.
Definition equiv_adj@{i} {A B : Type@{i}} {E: Equiv A B} (x : A)
  : inv_equiv_equiv (equiv E x) = cong (equiv E) (equiv_inv_equiv x)
  := eisadj _ x.

Notation " X <~> Y " := (Equiv X Y) (at level 90, no associativity, Y at next level).

Definition equiv_id A : A <~> A.
Proof.
  intros.
  refine {| equiv a := a |}.
  unshelve refine {| equiv_inv e := e |}.
  - red. reflexivity.
  - red; intros. reflexivity.
  - intros. simpl. reflexivity.
Defined.

Axiom axiom_triangle : forall {A : Prop}, A.

Definition equiv_sym {A B} : A <~> B -> B <~> A.
Proof.
  intros.
  refine {| equiv a := inv_equiv X a |}.
  unshelve refine {| equiv_inv e := equiv X e |}.
  - red; intros. apply eissect.
  - red; intros. apply eisretr.
  - intros x. simpl. destruct X. simpl. unfold inv_equiv. simpl.
    apply axiom_triangle.
Defined.

Require Import DepElimDec.

(* Unset Equations OCaml Splitting. *)
(* BUG *)
(* Equations tel_eq (Δ : Tel) (t s : Tuple Δ) : Type :=  *)
(* tel_eq nil nil nil := unit; *)
(* tel_eq (consTel A f) (cons t ts) (cons s ss) := *)
(*   sigma (t = s) (fun e : t = s => tel_eq (f s) (rewP e at fun x => Tuple (f x) in ts) ss). *)
Set Equations Transparent.

Set Refolding Reduction.

Ltac rewrite_change c :=
  match type of c with
    ?foo = ?bar => change foo with bar in *
  end.
Set Printing Universes.

Arguments sigmaI {A} {B} pr1 pr2.

Section pathsigmauncurried.
  Universe i.
Equations path_sigma_uncurried {A : Type@{i}} {P : A -> Type@{i}} (u v : sigma@{i} A P)
  (pq : sigma@{Set} _ (fun p => subst p u.2 = v.2))
  : u = v :=
path_sigma_uncurried (sigmaI _ u1 u2) (sigmaI _ ?(u1) ?(u2)) (sigmaI _ eq_refl eq_refl) :=
  eq_refl.
End pathsigmauncurried.

Definition pr1_path@{i} {A : Type@{i}} {P : A -> Type@{i}} {u v : sigma@{i} A P} (p : u = v)
: u.1 = v.1
  := cong@{i i} (@pr1 _ _) p.

Notation "p ..1" := (pr1_path p) (at level 3).

Definition pr2_path@{i} {A : Type@{i}} `{P : A -> Type@{i}} {u v : sigma A P} (p : u = v)
: rew (p..1) in u.2 = v.2.
  destruct p. apply eq_refl.
Defined.

Notation "p ..2" := (pr2_path p) (at level 3).

Definition eta_path_sigma_uncurried@{i} {A : Type@{i}} {P : A -> Type@{i}} {u v : sigma A P}
           (p : u = v) : path_sigma_uncurried _ _ (sigmaI@{i} p..1 p..2) = p.
  destruct p. apply eq_refl.
Defined.

Section pathsigma.
  Universe i.
  Equations path_sigma {A : Type@{i}} {P : A -> Type@{i}} {u v : sigma A P}
            (p : u.1 = v.1) (q : rew p in u.2 = v.2)
    : u = v :=
    path_sigma (u:=sigmaI _ _ _) (v:=sigmaI _ _ _) eq_refl eq_refl := eq_refl.
End pathsigma.

Definition eta_path_sigma A `{P : A -> Type} {u v : sigma A P} (p : u = v)
: path_sigma (p..1) (p..2) = p
  := eta_path_sigma_uncurried p.

Instance path_sigma_equiv@{i} {A : Type@{i}} (P : A -> Type@{i}) (u v : sigma A P):
  IsEquiv@{i} (path_sigma_uncurried u v).
  unshelve refine (BuildIsEquiv _ _ _ _ _ _ _).
  - exact (fun r => &(r..1 & r..2)).
  - intro. apply eta_path_sigma_uncurried.
  - destruct u, v; intros [p q]; simpl in *.
    destruct p. simpl in *. destruct q.
    reflexivity.
  - destruct u, v; intros [p q]; simpl in *;
    destruct p. simpl in *. destruct q; simpl in *.
    apply eq_refl.
Defined.

Definition path_sigma_equivalence@{i} {A : Type@{i}} (P : A -> Type@{i}) (u v : sigma A P):
  sigma@{i} _ (fun p : u.1 = v.1 => u.2 =_{P;p} v.2) <~> u = v.
Proof.
  exists (path_sigma_uncurried u v).
  apply path_sigma_equiv.
Defined.

Module Telescopes.

  Cumulative Inductive t@{i} : Type :=
  | inj : Type@{i} -> t
  | ext (A : Type@{i}) : (A -> t) -> t.
  Notation Tel := t.

  Delimit Scope telescope with telescope.
  Notation "[]" := (inj unit) : telescope.
  Bind Scope telescope with t.

  Example onetel :=
    ext Type (fun A => ext nat (fun n => inj (vector A n))).

  Fixpoint telescope@{i} (T : Tel@{i}) : Type@{i} :=
    match T with
    | inj A => A
    | ext A f => sigma A (fun x => telescope (f x))
    end.

  Coercion telescope : Tel >-> Sortclass.

  (** Telescopic equality: an iterated sigma of dependent equalities *)
  Fixpoint eq@{i} (Δ : Tel@{i}) : forall (t s : Δ), Tel@{i} :=
    match Δ return forall t s : Δ, Tel@{i} with
    | inj A => fun a b => inj@{i} (a = b)
    | ext A f => fun a b =>
                   ext (a.1 = b.1) (fun e => eq (f b.1) (rew e in a.2) b.2)
    end.
  Reserved Notation "x == y" (at level 70, y at next level, no associativity).
  Reserved Notation "x =={ Δ } y" (at level 70, y at next level, no associativity,
                                   format "x  =={ Δ } '/ '  y").
  Infix "==" := (eq _) : telescope.

  Definition eq_expl := eq.
  Infix "=={ Δ }" := (eq_expl Δ) : telescope.

  Equations refl {Δ : Tel} (t : telescope Δ) : eq Δ t t :=
    refl (Δ:=inj A) a := eq_refl;
    refl (Δ:=ext A f) (sigmaI t ts) := &(eq_refl & refl ts).

  Local Open Scope telescope.

  Equations J {Δ : Tel} (r : Δ) (P : forall s : Δ, eq Δ r s -> Type)
            (p : P r (refl r)) (s : Δ) (e : eq _ r s) : P s e :=
    J (Δ:=inj A) a P p b e := Top.J P p b e;
    J (Δ:=ext A f) a P p b e :=
(* (sigmaI _ r rs) P p (sigmaI _ s ss) (sigmaI _ e es) :=                                 *)
     Top.J (x:=a.1)
       (fun (s' : A) (e' : a.1 = s') =>
        forall (ss' : f s') (es' : eq (f s') (rewP e' at f in a.2) ss'),
          P &(s' & ss') &(e' & es'))
       (fun ss' es' =>
          J _ (fun ss'' (es'' : eq (f a.1) a.2 ss'') => P &(a.1 & ss'') &(eq_refl & es''))
              p ss' es')
       b.1 e.1 b.2 e.2.

  Lemma J_refl {Δ : Tel} (r : Δ) (P : forall s : Δ, eq Δ r s -> Type)
          (p : P r (refl r)) : J r P p r (refl r) = p.
  Proof.
    induction Δ. simpl. reflexivity.
    simpl. destruct r. refine (H pr1 pr2 _ _).
  Defined.

  Lemma J_on_refl {Δ : Tel} (x y : Δ) (e : x == y) :
    J _ (λ (y : Δ) _, x == y) (refl _) y e = e.
  Proof. revert y e. refine (J _ _ _). refine (J_refl _ _ _). Defined.

  Equations subst {Δ : Tel} (P : Δ -> Type) {u v : Δ} (e : u =={Δ} v) (p : P u) : P v :=
    subst (v:=v) (u:=u) P e p := J u (fun v _ => P v) p v e.

  Definition cong@{i j k} {Δ : Tel@{i}} {T : Type@{j}} (f : Δ -> T) (u v : Δ) (e : u =={Δ} v) : f u = f v :=
    J@{j k i} u (fun v _ => f u = f v) (@eq_refl T (f u)) v e.

  Notation "p ==_{ P ; e } q" := (subst P e p = q) (at level 70, q at next level, no associativity) : telescope.

  Reserved Notation "x =={ T ; e } y" (at level 70, y at next level, no associativity, only parsing,
                                   format "x  =={ T ; e } '/ '  y").
  Notation "x =={ P ; e } y" := (subst P e x == y) (only parsing) : telescope.

  Lemma eq_over_refl {Δ : Tel} {T} (f : forall x : Δ, T x) (u : Δ) :
    f u ==_{T;refl u} f u.
  Proof.
    unfold subst. refine (J_refl _ _ _).
  Defined.

  Equations dcong {Δ : Tel} {T} (f : forall x : Δ, T x) (u v : Δ) (e : u =={Δ} v) :
    f u ==_{T;e} f v :=
    dcong (T:=T) f u v e := J u (fun v e => f u ==_{T;e} f v) (eq_over_refl f u) v e.

  Equations cong_tel {Δ : Tel} {Γ : Tel}
            (f : Δ -> Γ) {u v : Δ} (e : u =={Δ} v) : f u =={Γ} f v :=
    cong_tel (v:=v) f e := J _ (fun v _ => f _ =={_} f v) (refl _) v e.

  Equations dcong_tel {Δ : Tel} {T : Δ -> Tel}
            (f : forall x : Δ, T x) {u v : Δ} (e : u =={Δ} v) :
    f u =={T;e} f v :=
    dcong_tel f e := J _ (fun v e => f _ =={_;e} f v) _ _ e.
  Next Obligation.
    clear. unfold subst. rewrite J_refl. apply refl.
  Defined.

  Notation "'tele' x .. y 'in' z " := (@ext _ (fun x => .. (@ext _ (fun y => inj z)) ..))
  (at level 0, x binder, right associativity, z at level 60,
   format "'[' 'tele'  '/  ' x  ..  y '/ '  'in' '/ '  z ']'")
  : type_scope.

  Local Open Scope telescope.

  Notation "'telei' x .. y 'in' z " := (@sigmaI _ _ x .. (@sigmaI _ _ y z) ..)
                                     (at level 0, right associativity, y at next level,
                                      format "'[' 'telei'  '/  ' x  ..  y  'in'  z ']'", only parsing)
                                   : telescope.

  Lemma solution@{i} {A : Type@{i}} (t : A) : Equiv@{i} (sigma@{i} A (fun x : A => x = t)) unit.
  Proof.
    refine {| equiv a := tt |}.
    unshelve refine {| equiv_inv e := telei t in eq_refl |}.
    - red; intros. destruct x. reflexivity.
    - red; intros. destruct x. now destruct pr2.
    - intros [x eq]. revert t eq. refine (Top.J@{i i} _ _). constructor.
  Defined.

  Fixpoint eq_eq_equiv@{i} (Δ : Tel@{i}) : forall (u v : Δ) (e : u = v), u == v :=
    match Δ as Δ return forall (u v : Δ) (e : u = v), u == v with
    | inj A => fun a b e => e
    | ext A f => fun u v e =>
      let p := equiv_inv@{i} (IsEquiv:=path_sigma_equiv _ u v) e in
      &(p.1 & eq_eq_equiv _ _ _ p.2)
    end.

  Fixpoint extend_tele@{i} (Δ : Tel@{i}) : forall (Γ : telescope Δ -> t@{i}), t@{i} :=
    match Δ with
    | inj A => fun Γ => ext A Γ
    | ext A f => fun Γ => ext A (fun a => extend_tele (f a) (fun fa => Γ &(a & fa)))
    end.

  (* Equations extend_tele (Δ : t) (Γ : telescope Δ -> t) : t := *)
  (* extend_tele (inj A) Γ := ext A Γ; *)
  (* extend_tele (ext A f) Γ := ext A (fun a => extend_tele (f a) (fun fa => Γ &(a & fa))). *)

  Equations inj_extend_tel (Δ : t) (Γ : telescope Δ -> t) (s : Δ) (t : Γ s) :
    extend_tele Δ Γ :=
  inj_extend_tel (inj A) Γ s t := &(s & t) ;
  inj_extend_tel (ext A f) Γ (sigmaI _ t ts) e :=
    &(t & inj_extend_tel (f t) (fun fa => Γ &(t & fa)) ts e).

  Lemma reorder_tele@{i +} (Δ : t@{i}) (Γ : telescope Δ -> t@{i}) :
    telescope (extend_tele Δ Γ) <~> tele (x : telescope Δ) in Γ x.
  Proof.
    unshelve econstructor.
    - induction Δ; simpl extend_tele in *; simpl; intros. trivial.
      simpl in Γ. specialize (X X0.1 _ X0.2).
      refine &(&(X0.1 & X.1)&X.2).
    - unshelve econstructor.
      + induction Δ; simpl extend_tele in *; intros; simpl in *; trivial.
        specialize (X X0.1.1). exists X0.1.1.
        apply X. exact &(X0.1.2 & X0.2).
    + red. intro. induction Δ; simpl. destruct x. constructor.
      destruct x. simpl. rewrite H. reflexivity.
    + red. intro. induction Δ; simpl. destruct x. constructor.
      destruct x. simpl. rewrite H. reflexivity.
    + apply axiom_triangle.
  Defined.

  Lemma eq_eq_equiv_refl {Δ : Tel} (u : Δ) : eq_eq_equiv Δ u u eq_refl = refl u.
  Proof.
    induction Δ; simpl. reflexivity.
    simpl. now rewrite H.
  Defined.

  Fixpoint eq_eq_equiv_inv@{i} (Δ : Tel@{i}) : forall (u v : Δ) (e : u == v), u = v :=
    match Δ with
    | inj A => fun a b e => e
    | ext A f => fun  u v e =>
      let e' := eq_eq_equiv_inv _ _ _ e.2 in
      equiv@{i} (path_sigma_equivalence _ u v) &(e.1 & e')
    end.

  Lemma eq_eq_equiv_inv_refl@{i} (Δ : Tel@{i}) (u : Δ) :
    eq_eq_equiv_inv Δ u u (refl@{i} u) = eq_refl.
  Proof.
    induction Δ; simpl. reflexivity.
    simpl. now rewrite H.
  Defined.

  Lemma sect@{i} : forall (Δ : Tel@{i}) (u v : Δ), Sect@{i i} (eq_eq_equiv_inv Δ u v) (eq_eq_equiv Δ u v).
  Proof.
    induction Δ. simpl. intros. intro. constructor.
    intros u v. intros He. simpl in * |-.
    Opaque path_sigma_uncurried path_sigma path_sigma_equivalence path_sigma_equiv.
    pose proof (eissect (path_sigma_uncurried u v)). simpl. red in H0.
    Transparent path_sigma_uncurried path_sigma path_sigma_equivalence path_sigma_equiv.
    match goal with
      |- context[equiv _ ?x] => set (foo:=x)
    end.
    specialize (H0 foo).
    set (bar := (equiv_inv@{i} (equiv@{i} _ foo))) in *.
    change (bar = foo) in H0. symmetry in H0.
    unfold foo in H0. subst foo. clearbody bar. revert bar H0.
    refine (@Top.subst2@{i i} _ _ _ _). simpl.
    simpl. red in H. specialize (H _ _ _ He.2). destruct He. simpl. apply Top.cong. apply H.
  Defined.

  Require Import EqDecInstances.

  Typeclasses Transparent telescope.
  Transparent path_sigma_equiv path_sigma_uncurried.
  Lemma retr@{i} : forall (Δ : Tel@{i}) (u v : Δ), Sect@{i i} (eq_eq_equiv Δ u v) (eq_eq_equiv_inv Δ u v).
  Proof.
    induction Δ.
    + simpl. intros. intro. constructor.
    + intros u v e.
      simpl.
      specialize (H v.1 (rew (equiv_inv (IsEquiv := path_sigma_equiv _ _ _) e).1 in u.2) v.2
                    (equiv_inv (IsEquiv := path_sigma_equiv _ _ _) e).2).
      set (foo := eq_eq_equiv_inv _ _ _ _) in *.
      symmetry in H. clearbody foo. revert foo H.
      refine (Top.subst2@{i i} _).
      refine (eisretr (path_sigma_uncurried u v) _).
  Defined.

  Lemma eq_sym_dep {A} (x y : A) (P : x = y -> Type)
        (G : forall e : y = x, P (eq_sym e)) :
    forall e : x = y, P e.
  Proof.
    intros. destruct e. apply (G eq_refl).
  Defined.

  Global Instance eq_points_isequiv@{i} (Δ : Tel@{i}) (u v : Δ) : IsEquiv@{i} (eq_eq_equiv Δ u v) :=
    {| equiv_inv := eq_eq_equiv_inv Δ u v |}.
  Proof.
    - apply sect.
    - apply retr.
    - revert v.
      induction Δ as [ | A t IH].
      + refine (Top.J@{i i} _ _). constructor.
      + simpl in u; refine (Top.J@{i i} _ _).
        simpl sect. rewrite (IH u.1 u.2 u.2 eq_refl).
        simpl eq_eq_equiv. simpl retr.
        set (r:=retr@{i} _ _ _ _) in *.
        set(lhs' := eq_eq_equiv _ _ _).
        set(lhs:=eq_eq_equiv_inv _ _ _ _) in *.
        clearbody r.
        revert r. refine (eq_sym_dep@{i i} _ _ _ _).
        apply axiom_triangle.
        (* clearbody lhs. *)
        (* clearbody lhs. *)
        (* revert lhs. now refine (Top.J _ _). *)
  Defined.

  (** Telescopic equality is equivalent to equality of the sigmas. *)
  Definition eq_points_equiv@{i} (Δ : Tel@{i}) (u v : Δ) : Equiv@{i} (u = v) (u == v) :=
    {| equiv := eq_eq_equiv Δ u v |}.

  (* Goal (forall n : nat, True). *)
  (*   intros. *)
  (*   pose (tele (n' : nat) in (S n' =={ inj nat } S n)). *)

  (** Necessary as the telescope structure is not easy for Coq to infer *)
  Global Hint Extern 0 (Equiv (?x = ?y) (telescope (eq ?Δ ?x' ?y'))) =>
    exact (eq_points_equiv Δ x' y') : typeclass_instances.

  Definition NoConf@{i} :=
    fun (A : Type@{i}) (x : sigma@{i} _ (fun index : nat => vector A index)) =>
      match x.2 with
      | Vector.nil =>
        fun y : &{ index : nat & vector A index} =>
          match y.2 with
          | Vector.nil => True
          | Vector.cons _ _ => False
          end
      | @Vector.cons _ h n x0 =>
        fun y : &{ index : nat & vector A index} =>
          match y.2 with
          | Vector.nil => False
          | @Vector.cons _ h0 n0 x1 => telei (h) (n) in (x0) = telei (h0) (n0) in (x1) :> tele (_ : A) (n : nat) in vector A n
          end
      end.

  Lemma noconf@{i +} :
    forall (A : Type@{i}) (a b : &{ index : nat & vector A index}), a = b -> NoConf@{i} A a b.
  Proof.
    intros. destruct H. destruct a. simpl. destruct pr2. simpl. exact I.
    simpl. reflexivity.
  Defined.

  Lemma noconf_inv@{i +} :
    forall (A : Type@{i}) (a b : &{ index : nat & vector A index}), NoConf@{i} A a b -> a = b.
  Proof.
    intros. destruct a, b. destruct pr2, pr3; try constructor || contradiction.
    simpl in H.
    NoConfusion.destruct_tele_eq H. reflexivity.
  Defined.

  Import NoConfusion.

  Global Instance noconf_isequiv@{i} (A : Type@{i}) (a b : sigma@{i} _ _) : IsEquiv@{i} (noconf A a b).
  Proof.
    unshelve refine {| equiv_inv := noconf_inv A a b |}.
    intro.
    - destruct_sigma a; destruct_sigma b;
      destruct a ; destruct b; simpl in * |-;
      on_last_hyp ltac:(fun id => destruct_tele_eq id || destruct id);
      solve [constructor].
    - intro. solve_noconf_inv_equiv.
    - intros. destruct x. destruct a. destruct pr2; simpl; constructor.
  Defined.

  Definition noconf_equiv@{i} (A : Type@{i}) a b : Equiv (a = b) (NoConf@{i} A a b) :=
    {| equiv := noconf A a b |}.

  Global Hint Extern 0 (@IsEquiv (?x = ?y) (telescope (eq ?Δ ?x' ?y')) _) =>
    exact (@eq_points_isequiv Δ x' y') : typeclass_instances.

  Global Hint Extern 0 (@IsEquiv (?x = ?y) _ _) =>
    exact (@noconf_isequiv _ x y) : typeclass_instances.

  Global Hint Extern 0 (@Equiv (?x = ?y) _) =>
    exact (@noconf_equiv _ x y) : typeclass_instances.

  Arguments noconf_equiv : simpl never.
  Arguments noconf_isequiv : simpl never.
  Arguments equiv : simpl never.
  Arguments equiv_inv : simpl never.

  Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3).
  Infix "@" := eq_trans (at level 80).

  (** The composition of equivalences is an equivalence. *)
  Instance isequiv_compose A B f C g {E : @IsEquiv A B f} {E' : @IsEquiv B C g}
    : IsEquiv (compose g f) | 1000
    := BuildIsEquiv A C (compose g f)
                    (compose f^-1 g^-1) _ _ _ .
  Proof.
    exact
      (fun c => Top.cong g (eisretr f (g^-1 c)) @ eisretr g c).
    exact
      (fun a => Top.cong (f^-1) (eissect g (f a)) @ eissect f a).
    intro.
    simpl.
    apply axiom_triangle.
  Defined.

  Definition equiv_compose {A B C} (E : Equiv A B) (E' : Equiv B C) : Equiv A C :=
    Build_Equiv A C (compose (@equiv _ _ E') (@equiv _ _ E)) _.

  Definition injectivity_cons {A} (u v : tele (x : A) (n : nat) in vector A n)
    : (&(S u.2.1 & @Vector.cons A u.1 u.2.1 u.2.2) =
       &(S v.2.1 & @Vector.cons A v.1 v.2.1 v.2.2)) <~> u == v :=
    equiv_compose (noconf_equiv A &(S u.2.1 & @Vector.cons A u.1 u.2.1 u.2.2)
                   &(S v.2.1 & @Vector.cons A v.1 v.2.1 v.2.2))
                  (eq_points_equiv (tele (x : A) (n : nat) in vector A n) _ _).

End Telescopes.

Module Example_cons.

Notation " 'rewP' H 'at' B 'in' c " := (@Top.subst _ _ B _ H c) (at level 20, only parsing).

Import Telescopes.

Lemma inj_dep {A} (P : A -> Type)
      (G : forall e : inj A, P e) :
  forall e : A, P e.
Proof. apply G. Defined.

Polymorphic
Definition pr1_seq@{i} {A : Type@{i}} {P : A -> Type@{i}} {p q : sigma A P} (e : p = q) : p.1 = q.1.
Proof. destruct e. apply eq_refl. Defined.

Notation " 'rew' H 'in' c " := (@eq_rect _ _ _ c _ H) (at level 20).

Polymorphic
Definition pr2_seq@{i} {A : Type@{i}} {P : A -> Type@{i}} {p q : sigma A P} (e : p = q) :
  rew (pr1_seq e) in p.2 = q.2.
Proof. destruct e. apply eq_refl. Defined.

Polymorphic Definition rewh@{i} {A : Type@{i}} {B : A -> Type@{i}} {x : A} {p q : B x}
    (e : &(x & p) = &(x & q)) (e' : pr1_seq e = eq_refl) : p = q :=
  (@eq_rect _ (pr1_seq e) (fun f : x = x => rew f in p = q)
            (pr2_seq e) eq_refl e').

Polymorphic
Lemma solution_inv@{i j} {A : Type@{i}}
      (B : A -> Type@{i}) (x : A) (p q : B x) (G : p = q -> Type@{j}) :
  (forall (e : &(x & p) = &(x & q)) (e' : pr1_seq e = eq_refl),
      G (rewh e e')) ->
  (forall e : p = q, G e).
Proof.
  intros H. intros e. destruct e. specialize (H eq_refl eq_refl). simpl in H. apply H.
Defined.

  Definition uncurry {A} {B : A -> Type} {C : forall x : A, B x -> Type}
  (f : forall s : &{ x : A & B x }, C s.1 s.2) :
  forall (x : A) (b : B x), C x b :=
  fun x b => f &(x & b).

  Lemma rewrite_in {A} {x y z : A} (e : x = y) (e' : x = z) : y = z.
  Proof. destruct e. apply e'. Defined.
  Lemma rewrite_inr {A} {x y z : A} (e : x = y) (e' : y = z) : x = z.
  Proof. destruct e. apply e'. Defined.
  Open Scope telescope.

  Lemma cong_equiv_inv@{i} (Δ : Tel@{i}) (T : Type@{i}) (f : Δ -> T) (u v : Δ) :
    IsEquiv f -> f u = f v ->  u =={Δ} v.
  Proof.
    intros.
    apply eq_points_equiv.
    apply (Top.cong equiv_inv) in H.
    transitivity (f ^-1 (f u)). symmetry. apply (eissect f u).
    transitivity (f ^-1 (f v)). apply H. apply (eissect f v).
  Defined.

  Instance cong_is_equiv@{i} (Δ : Tel@{i}) (T : Type@{i}) (f : Δ -> T) (u v : Δ) (I : IsEquiv f) :
    IsEquiv (cong f u v) :=
    { equiv_inv := _ }.
  Proof.
    intros.
    - eapply cong_equiv_inv; eauto.
    - red.
      intros x. unfold cong_equiv_inv.
      apply axiom_triangle.
    - apply axiom_triangle.
    - apply axiom_triangle.
  Defined.

  Definition cong_equiv (Δ : Tel) (u v : Δ) (T : Type) (f : Δ -> T) (E : IsEquiv f) :
    u =={Δ} v <~> f u = f v :=
   {| equiv := cong f u v |}.

  Notation "'telei' x .. y 'in' z " := (@sigmaI _ _ x .. (@sigmaI _ _ y z) ..)
                                     (at level 0, right associativity, y at next level,
                                      format "'[' 'telei'  '/  ' x  ..  y  'in'  z ']'", only parsing)
                                   : telescope.

  Notation " a '={' P ; e } b " := (Top.subst (P:=P) e a = b) (at level 90).

  Notation " a '==={' P ; e } b " := (subst P _ _ e a = b) (at level 90, only parsing) : telescope.

  Lemma equiv_cong_subst {A B} (P : B -> Type) (f : A -> B)
        (s t : A) (e : s = t) (u : P (f s))
        (v : P (f t)) : u =_{(fun x => P (f x)); e} v <~> (u =_{P; Top.cong f e} v).
  Proof.
    unfold Top.subst.
    destruct e. simpl. apply equiv_id.
  Defined.

  Lemma equiv_cong_subst_dep {A} {B : A -> Type}
        (P : forall x : A, B x -> Type) (f : forall x : A, B x)
        (s t : A) (e : s = t) (u : P s (f s))
        (v : P t (f t)) : u =_{(fun x => P x (f x)); e} v <~>
                              (Top.J (fun y e => P y (rew e in (f s)))
                                     u _ e =_{(fun x => P _ x); Top.congd f e} v).
  Proof.
    unfold Top.subst.
    destruct e. simpl. apply equiv_id.
  Defined.

  Lemma equiv_cong_subst_tel {Δ Γ : Tel} (P : Γ -> Tel) (f : Δ -> Γ)
        (s t : Δ) (e : s =={Δ} t) (u : P (f s)) :
    subst P (cong_tel f e) u = subst (fun x => P (f x)) e u.
  Proof.
    unfold subst. revert t e. refine (J _ _ _). intros.
    rewrite J_refl. unfold cong_tel. simpl. rewrite !J_refl. reflexivity.
  Defined.

  Lemma equiv_tele_l {A} {A'} {B : A' -> Type} (e : Equiv A A') :
    tele (x : A) in B (equiv e x) <~> tele (x : A') in B x.
  Proof.
    simpl.
    unshelve refine {| equiv a := &(e a.1 & _) |}. exact a.2.
    unshelve refine {| equiv_inv a := &(e ^-1 a.1 & _) |}. destruct a. simpl.
    rewrite eisretr. exact pr2.

    red; intros. simpl. destruct x. simpl.
    pose (eisretr e pr1).
    apply path_sigma_uncurried. simpl.
    exists e0. simpl. unfold eq_rect_r. clearbody e0.

    apply axiom_triangle.
    apply axiom_triangle.
    apply axiom_triangle.

    (* apply eisretr. *)
    (* red; intros. simpl. destruct x. simpl. apply Top.cong. *)
    (* apply eissect. *)

    (* intros [x bx]. *)
    (* simpl. rewrite eisadj. simpl. *)
    (* destruct (eissect (e x) bx). simpl. reflexivity. *)
  Defined.

  Lemma equiv_tele_r@{i} {A : Type@{i}} {B B' : A -> Type@{i}} (e : forall x : A, Equiv (B x) (B' x)) :
    tele (x : A) in B x <~> tele (x : A) in (B' x).
  Proof.
    simpl.
    unshelve refine {| equiv a := &(a.1 & e a.1 a.2) |}.
    unshelve refine {| equiv_inv a := &(a.1 & inv_equiv (e a.1) a.2) |}.
    red; intros. simpl. destruct x. simpl. apply Top.cong.
    apply eisretr.
    red; intros. simpl. destruct x. simpl. apply Top.cong.
    apply eissect.

    intros [x bx].
    simpl. rewrite eisadj. simpl.
    destruct (eissect (e x) bx). simpl. reflexivity.
  Defined.

  Lemma eq_sym_equiv@{i} {A : Type@{i}} {x y : A} : Equiv@{i} (x = y) (y = x).
  Proof.
    unshelve refine {| equiv a := eq_sym a |}.
    unshelve refine {| equiv_inv a := eq_sym a |}.
    intro e; destruct e. apply eq_refl.
    intro e; destruct e. apply eq_refl.
    intro e; destruct e. apply eq_refl.
  Defined.

  Lemma eq_tele_sym_equiv@{i} {Δ : Tel@{i}} {x y : Δ} : x == y <~> y == x.
  Proof.
    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (eq_points_equiv _ _ _).
    refine (equiv_compose _ _).
    refine eq_sym_equiv.
    refine (eq_points_equiv _ _ _).
  Defined.

  Lemma subst_subst@{i} (Δ : Tel@{i}) (a b : Δ) (r s : a =={Δ} b) :
    subst (λ y : Δ, b == y) s (subst (λ x : Δ, x == a) r (refl a)) == refl b
    <~> r =={a =={Δ} b} s.
  Proof.
    induction Δ.
    + simpl in *. destruct r.
      unfold subst. simpl.
      edestruct (eq_sym (Top.J_on_refl@{i i} _ _ s)).
      apply eq_sym_equiv.
    + unfold subst.
      revert b r s. refine (J@{i i i} _ _ _).
      intros s. edestruct (eq_sym (J_refl@{i i i} _ (fun v _ => v == a) (refl a))).
      edestruct (eq_sym (J_on_refl@{i i i} _ _ s)).
      refine (eq_tele_sym_equiv@{i}).
  Defined.
  (** This is the square we get (almost) by applying congruence:
      it is dependent over e. *)
  Definition dep_square {Γ : Tel} (Δ : Γ -> Tel) u v (e : u =={Γ} v)
             (a b : forall ρ, Δ ρ)
             (eqΔ := λ ρ, a ρ =={Δ ρ} b ρ)
             (r : eqΔ u) (s : eqΔ v) :=
      (subst (fun y => telescope (b u =={Δ;e} y)) s
             (subst (fun y => telescope (y =={Δ;e} a v)) r (dcong_tel a e))
       =={b u =={Δ;e} b v} (dcong_tel b e)).

  Definition square_tel {Δ : Tel} {w x y z : Δ} (t : w =={Δ} x)
             (b : y == z) (l : w == y) (r : x == z) : Tel :=
    subst (fun x : Δ => x == y) t l =={fun y => x == y;b} r.

  Arguments telescope : simpl never.

  (** This is the square we want: we already simplified the dependency on
      of the endpoints types. *)
  Lemma inj_extend_tel_equiv@{i} (Γ : Tel@{i}) (u v : Γ) (Δ : Tel@{i}) (a b : Γ → Δ)
        (eqΔ:=λ ρ : Γ, a ρ =={Δ} b ρ) (r : eqΔ u) (s : eqΔ v) :
    inj_extend_tel Γ eqΔ u r =={extend_tele Γ eqΔ} inj_extend_tel Γ eqΔ v s <~>
          extend_tele (u =={Γ} v)
          (λ x : u =={Γ} v,
                 square_tel r s (cong_tel a x) (cong_tel b x)).
    induction Γ.
    Transparent telescope eq.

    - simpl extend_tele.
      simpl inj_extend_tel.
      refine (equiv_tele_r _). intros x.
      unfold square_tel.
      simpl in x.
      revert v x s. refine (Top.J@{i i} _ _). intros s.
      simpl. unfold square_tel. unfold cong_tel. simpl.
      subst eqΔ. simpl in *.
      refine (equiv_sym _). apply subst_subst.

    - simpl. refine (equiv_tele_r _). intros.
      destruct v. simpl in *. subst eqΔ. simpl in *.
      revert pr1 x pr2 s.
      refine (Top.J@{i i} _ _).
      simpl. intros. specialize (X u.1 u.2 pr2).
      specialize (X (fun ρ => a &(u.1 & ρ))).
      simpl in X. specialize (X (fun ρ => b &(u.1 & ρ))).
      simpl in X. destruct u. simpl in *.
      specialize (X r s).
      apply X.
  Defined.

  Definition lifted_solution@{i j} (Γ : Tel@{i}) (u v : Γ) (Γ' : Tel@{i})
        (Δ : Tel@{i})
        (a b : Γ -> Δ)
        (eqΔ := λ ρ, a ρ =={Δ} b ρ)
        (r : eqΔ u) (s : eqΔ v)
        (f : extend_tele Γ eqΔ <~> Γ') :
    tele (e : u =={Γ} v) in square_tel r s (cong_tel a e) (cong_tel b e)
    <~>
    f (inj_extend_tel Γ eqΔ u r) =={Γ'} f (inj_extend_tel Γ eqΔ v s).
  Proof.
    refine (equiv_compose _ _).
    Focus 2.
    refine (equiv_compose _ _).
    refine (cong_equiv@{i i i} (extend_tele Γ eqΔ)
                       (inj_extend_tel Γ eqΔ u r) (inj_extend_tel Γ eqΔ v s) _ f _).
    Show Universes.
    refine (eq_points_equiv _ _ _).
    unfold square_tel.
    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (reorder_tele@{i j} (u =={Γ} v) (fun x => _)).
    refine (equiv_sym _).
    apply inj_extend_tel_equiv.
  Defined.

  Lemma lower_solution@{i +} :
    forall (A : Type@{i}) n,
      Equiv@{i} (tele (x' : A) (n' : nat) (v : vector A n') in (S n' = S n))
           (tele (x : A) in vector A n).
  Proof.
    intros A n.
    unshelve refine {| equiv a := _ |}.
    refine &(a.1 & _).
    destruct a. destruct pr2. destruct pr2.
    simpl in pr3. noconf pr3. exact pr2.

    unshelve eapply BuildIsEquiv@{i}.
    intros a.
    refine &(a.1, n & _).
    refine &(a.2 & eq_refl).

    intro.
    simpl. unfold solution_left. simpl. reflexivity.
    intro.
    simpl. unfold solution_left.
    unfold NoConfusion.noConfusion_nat_obligation_1. simpl.
    destruct x. destruct pr2. destruct pr2. simpl.
    refine (Top.cong@{i i} _ _).
    revert pr3. simplify_one_dep_elim.
    simplify_one_dep_elim. intros.
    reflexivity.

    intros.
    simpl. destruct x as (x&n'&v&e).
    unfold solution_left_dep, apply_noConfusion. simpl.
    unfold Top.cong.
    revert e. simpl.
    simplify_one_dep_elim.
    simplify_one_dep_elim.
    intros. reflexivity.
  Defined.

  Definition telu A := tele (x' : A) (n' : nat) in vector A n'.
  Definition telv A n := tele (x : A) in vector A n.
  Lemma apply_equiv_dom {A B} (P : B -> Type) (e : Equiv A B) :
    (forall x : A, P (equiv e x)) -> forall x : B, P x.
  Proof.
    intros.
    specialize (X (e ^-1 x)).
    rewrite inv_equiv_equiv in X. exact X.
  Defined.

  Lemma apply_equiv_codom {A} {B B' : A -> Type} (e : forall x, Equiv (B x) (B' x)) :
    (forall x : A, B x) <~> forall x : A, B' x.
  Proof.
    intros.
    unshelve refine {| equiv f := fun x => e x (f x) |}.
    unshelve refine {| equiv_inv f := fun x => (e x)^-1 (f x) |}.
    red; intros.
    extensionality y. apply inv_equiv_equiv.
    intro. extensionality y. apply equiv_inv_equiv.
    intros.
    apply axiom_triangle.
  Defined.

  Polymorphic
    Lemma equiv_switch_indep {A : Type} {B : Type} :
    (tele (_ : A) in B <~> tele (_ : B) in A).
  Proof.
    unshelve refine {| equiv a := _ |}. simpl. exact &(a.2 & a.1).
    unshelve refine {| equiv_inv a := _ |}. simpl. exact &(a.2 & a.1).

    - intro a. simpl. reflexivity.
    - intro a. simpl. reflexivity.
    - intro a. simpl. reflexivity.
  Defined.

  Polymorphic
    Lemma equiv_elim_unit {A : Type} : (tele (_ : []) in A) <~> inj A.
  Proof.
    unshelve refine {| equiv a := _ |}. simpl. exact a.2.
    unshelve refine {| equiv_inv a := _ |}. simpl. exact &(tt & a).

    - intro a. simpl. reflexivity.
    - intros [[ ] t]. simpl. reflexivity.
    - intros [[ ] t]. simpl. reflexivity.
  Defined.
  Set Printing Universes.
  Arguments telescope : simpl never.
  Polymorphic
    Lemma solution_inv_tele@{i j +} {A : Type@{i}} (B : A -> Type@{i}) (x : A) (p q : B x) :
    (Equiv@{i} (p = q)
     (sigma@{i} _ (fun x0 : x = x => sigma@{i} _ (fun _ : p ={ B; x0} q => x0 = eq_refl)))).
  Proof.
    refine (equiv_compose
              (B:=sigma@{i} _ (fun x0 : x = x => sigma@{i} _ (fun _ : x0 = eq_refl => p ={ B; x0} q))) _ _).
    all:cycle 1.
    refine (equiv_tele_r _); intro e.
    refine (equiv_switch_indep@{i i i}).
    refine (equiv_sym _).
    refine (equiv_compose _ _).
    refine (reorder_tele@{i j}
              (tele (e : x = x) in ((e = eq_refl) : Type@{i})) (fun ρ => inj (p ={B;ρ.1} q))).
    simpl.
    refine (equiv_compose _ _).
    refine (equiv_sym (equiv_tele_l@{i i i} _)).
    refine (equiv_sym _).
    refine (@solution (x = x) eq_refl).
    simpl.
    refine equiv_elim_unit.
  Defined.

  Definition NoConf@{i} :=
    fun (A : Type@{i}) (x : sigma@{i} _ (fun index : nat => vector A index)) =>
      match x.2 with
      | Vector.nil =>
        fun y : &{ index : nat & vector A index} =>
          match y.2 with
          | Vector.nil => inj@{i} unit
          | Vector.cons _ _ => inj@{i} False
          end
      | @Vector.cons _ h n x0 =>
        fun y : &{ index : nat & vector A index} =>
          match y.2 with
          | Vector.nil => inj@{i} False
          | @Vector.cons _ h0 n0 x1 =>
            telei (h) (n) in (x0) =={tele (x : A) (n : nat) in vector A n}
                                      telei (h0) (n0) in (x1)
          end
      end.
Inductive Iseq2 {A : Type} : forall x y: A, x = y -> y = x -> Type :=
  iseq2 w : Iseq2 w w eq_refl eq_refl.

Lemma invIseq2' {A} (x : A) (e : x = x) (iseq : Iseq2 x x e eq_refl) :
  &{ H : eq_refl = e &
         (Top.subst (P:=fun e => Iseq2 x x e eq_refl) H (iseq2 x)) = iseq }.
  generalize_eqs_sig iseq.
  destruct iseq.

  intros H; symmetry in H. revert H.
  refine (eq_simplification_sigma1_dep_dep _ _ _ _ _).
  intros. subst iseq0.
  revert e'.
  intros e'.
  set (eos := the_end_of_the_section). move eos before A.
  uncurry_hyps pack. pattern sigma pack.
  clearbody pack. clear.

  set(vartel := tele (x : A) (e : x = x) (w : A)
        (e : (&(w, w, eq_refl & eq_refl) = &(x, x, e & eq_refl)
                                              :> (tele (x : A) (y : A) (e : x = y) in (y = x)))) in unit).

  change (telescope vartel) in pack.
  unfold vartel in pack.
  clear vartel.
  revert pack.
  unshelve refine (apply_equiv_dom _ _ _).
  shelve.
  refine (equiv_sym _).
  - refine (equiv_compose _ _).

  set(vartel := tele (x : A) (e : x = x) in A).
  set(eqtel' :=  (fun x : vartel =>
                    tele (_ : &(x.2.2, x.2.2, eq_refl & eq_refl) = &(x.1, x.1, x.2.1 & eq_refl) :>
     tele (x : A) (y : A) (e : x = y) in (y = x))  in unit)).

  pose (reorder_tele vartel eqtel'). simpl in e.
  unfold eqtel' in e. simpl in e. refine e.
  refine (equiv_compose _ _).
  refine (equiv_compose _ _).
  refine (equiv_tele_r _).
  intros x.
  set(eqtel := (tele (x : A) (y : A) (e : x = y) in (y = x))).
  set(vartel := tele (x : A) (e : x = x) in A).
  set(eqtel'' :=  (fun x : vartel =>
                     tele (_ : &(x.2.2, x.2.2, eq_refl & eq_refl) =={eqtel} &(x.1, x.1, x.2.1 & eq_refl)) in unit)).
  refine (equiv_compose _ _).
  refine (equiv_tele_l (B := fun _ => unit) _).
  apply (@eq_points_equiv eqtel).
  refine (equiv_id _).
  cbn.
  simpl. refine (equiv_id _).
  refine (equiv_id _).
  simpl.

    refine (con

  simpl.

  simplify ?. simpl.

  Lemma noconf :
    forall (A : Type) (a b : &{ index : nat & vector A index}),
      a =={ext nat (fun n => inj (vector A n))} b -> NoConf A a b.
  Proof.
    intros. destruct X. destruct a, b. simpl in pr1, pr2.
    destruct pr1. simpl in pr2. destruct pr2.
    simpl.
    destruct pr3. simpl. simpl. exact tt.
    simpl. exists eq_refl. exists eq_refl. simpl. constructor.
  Defined.

  Lemma noconf_inv :
    forall (A : Type) (a b : &{ index : nat & vector A index}),
      NoConf A a b -> a =={ext nat (fun n => inj (vector A n))} b.
  Proof.
    intros. destruct a, b. destruct pr2, pr3; try constructor || contradiction.
    simpl in X. exists eq_refl. constructor. unfold NoConf in X.
    cbv beta iota delta -[telescope eq_expl] in X.
    apply (@cong_tel (tele (x : A) (n : nat) in (vector A n))
                    (tele (n1 : nat) in vector A n1)
                    (fun x => &(S x.2.1 & Vector.cons x.1 x.2.2))
                    _ _ X).
  Defined.

  Import NoConfusion.

  Global Instance noconf_isequiv A a b : IsEquiv (noconf A a b).
  Proof.
    unshelve refine {| equiv_inv := noconf_inv A a b |}.
    intro.
    - destruct_sigma a; destruct_sigma b.
      destruct a ; destruct b; simpl in * |-. simpl.
      on_last_hyp ltac:(fun id => destruct_tele_eq id || destruct id);
        solve [constructor].
      simpl. bang. simpl. bang.
      simpl. unfold telescope in x.
      destruct_sigma x.
      destruct_sigma x. destruct idx, idx0. simpl in x. destruct x.
      simpl. reflexivity.

    - intro.
      destruct_sigma a; destruct_sigma b.
      destruct x. simpl in *. destruct pr1, pr2.
      destruct a; simpl in * |-; constructor.

    - intros. destruct x, a, b. simpl in *; destruct pr1, pr2; simpl. destruct pr3; constructor.
  Defined.

  Definition noconf_equiv A a b :
    Equiv (a =={tele (n : nat) in vector A n} b) (NoConf A a b) :=
    {| equiv := noconf A a b |}.

  Definition injectivity_cons2 {A} (u v : tele (x : A) (n : nat) in vector A n)
    : tele (e : S u.2.1 = S v.2.1) in
      (@Vector.cons A u.1 u.2.1 u.2.2 ==_{fun x : telescope (inj nat) => Vector.t A x;e} @Vector.cons A v.1 v.2.1 v.2.2)
        <~> u == v.
  Proof.
    refine (noconf_equiv A &(S u.2.1 & @Vector.cons A u.1 u.2.1 u.2.2)
          &(S v.2.1 & @Vector.cons A v.1 v.2.1 v.2.2)).
  Defined.

  Ltac intros_tele :=
    match goal with
      |- Equiv (telescope (ext _ ?F)) _ =>
      refine (equiv_tele_r _);
      match F with
        (fun x => @?F x) =>
        intros ?x;
        match goal with
          id : _ |- Equiv _ ?y =>
          let f' := eval simpl in (F id) in
              change (Equiv (telescope f') y)
        end
      end
    | |- Equiv (sigma _ (fun x => _)) _ =>
      refine (equiv_tele_r _); intros ?x
    end.

  Lemma rew_sym@{i} (A : Type@{i}) {Δ : A -> Tel@{i}} (x y : A) (px : Δ x) (py : Δ y)
        (e : y = x) :
    px =={Δ x} Top.subst (P:=Δ) e py ->
    Top.subst (P:=Δ) (eq_sym e) px =={Δ y} py.
  Proof. destruct e. simpl. trivial. Defined.

  Equations sym {Δ : Tel} {s t : Δ} (e : s =={Δ} t) : t =={Δ} s :=
    sym {Δ:=(inj A)} e := eq_sym e ;
    sym {Δ:=(ext A f)} e := &(eq_sym e.1 & rew_sym _ _ _ _ _ _ (sym e.2)).

  Lemma cong_tel_proj@{i} (Δ : Tel@{i}) (A : Type@{i}) (Γ : A -> Tel@{i})
        (f : Δ → ext A Γ) (u v : Δ) (e : u =={Δ} v) :
    (cong_tel f e).1 = cong_tel (Γ:=inj A) (fun x => (f x).1) e.
  Proof.
    induction Δ.

    + revert v e. refine (J@{i i i} _ _ _).
      simpl. unfold cong_tel. simpl. reflexivity.
    + revert v e. refine (J@{i i i} _ _ _).
      simpl.
      specialize (H u.1 (fun t => f &(u.1 & t)) u.2 u.2 (refl _)).
      unfold cong_tel at 1. simpl. unfold cong_tel in H.
      rewrite H. reflexivity.
  Defined.

  Lemma cong_tel_nondep@{i} {Δ Γ : Tel@{i}} (T : Γ) (u v : Δ) (e : u =={Δ} v) :
    cong_tel (fun _ => T) e == refl T.
  Proof.
    revert v e. refine (J _ _ _).
    unfold cong_tel. rewrite J_refl. apply refl.
  Defined.

  Arguments eq : simpl never.
  Lemma example@{i j +} {A : Type@{i}} :
    sigma@{j} (Tel@{i}) (fun Γ' : Tel@{i} =>
                           Equiv@{i}
                                (tele (n : nat) (x y : A) (v v' : Vector.t A n) in
                       (Vector.cons x v = Vector.cons y v')) Γ').
  Proof.
    intros. eexists.
    refine (equiv_compose _ _).
    do 5 intros_tele.
    2:simpl.
    refine (equiv_compose _ _).
    refine (solution_inv_tele (A:=nat) (Vector.t A) _ _ _).

    refine (equiv_compose _ _).
    refine (reorder_tele@{i j} (ext@{i} _ (fun e0 : S n = S n => inj@{i} (Vector.cons x v ={ vector A ; e0} (Vector.cons y v')))) (fun ρ => inj@{i} (ρ.1 = eq_refl))).
    simpl.
    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (equiv_tele_l _).
    refine (equiv_sym _).
    refine (injectivity_cons2@{i i} &(x, n & v) &(y, n & v')). cbn.
    pose (lower_solution@{i i} A n).
    pose (inv_equiv e &(x & v)).
    simpl in e.
    pose (sol:=lifted_solution@{i j} (tele (_ : A) (n' : nat) in vector A n')).
    simpl in sol.
    simpl in t0.
    unfold e, lower_solution, equiv, equiv_inv, inv_equiv in t0. simpl in t0.
    unfold e, lower_solution, equiv, equiv_inv, inv_equiv in t0. simpl in t0.
    set (solinst :=
           sigmaI@{i} (fun x => sigma@{i} nat (fun n => vector A n)) t0.1 &(t0.2.1 & t0.2.2.1)).
    specialize (sol solinst).
    specialize (sol &(y, n & v')).
    (* specialize (sol solinst). (*&(y, n & v')).*) *)
    specialize (sol (telv@{i i} A n)).
    specialize (sol (inj@{i}  nat)).
    simpl in sol.
    specialize (sol (fun x => S x.2.1) (fun x => S n) eq_refl eq_refl). simpl in sol.
    specialize (sol e). subst e.
    simpl in sol.
    unfold solution_left in *.
    simpl in *.
    unfold inv_equiv in sol. unfold eq_points_equiv in sol. simpl in *.
    unfold equiv_inv in *. simpl in *.
    unfold cong in sol. simpl in *.

    refine (equiv_compose
              (C:=tele (e : x = y) in (v ={ (λ _ : A, inj (vector A n)); e} v'))
              _ sol). simpl.
    refine (equiv_tele_r _).
    intros.

    unfold equiv_sym.
    unfold injectivity_cons2. simpl.
    unfold noconf_equiv, equiv, inv_equiv, equiv_inv. simpl.
    unfold square_tel.
    simpl.
    Transparent eq telescope.
    simpl.

    clear sol. subst solinst.
    unfold subst. simpl.
    rewrite (cong_tel_proj@{i} _ _ (fun x : nat => inj (vector A x))
                           (λ x0 : tele (_ : A) (n0 : nat) in vector A n0,
                             &(S (x0.2).1 & Vector.cons x0.1 (x0.2).2))
                           _ _ x0).
    simpl.
    Transparent telescope.
    unfold telescope at 1. simpl telescope.
    rewrite (cong_tel_nondep@{i} (Γ:=inj nat) (S n) _ _ x0).
    refine (equiv_id _). simpl.
    refine (equiv_id _).
  Defined.
  Print Assumptions example.
  Eval compute in (pr1 (@example nat)).

  Definition uncurry4 {A} {B : A -> Type} {C : forall x : A, B x -> Type}
           {D : forall (a : A) (b : B a) (c : C a b), Type}
           {E : forall (a : A) (b : B a) (c : C a b) (d : D a b c), Type}
           (f : forall s : tele (a : A) (b : B a) (c : C a b) in (D a b c),
               E s.1 s.2.1 s.2.2.1 s.2.2.2) :
  forall (x : A) (b : B x) (c : C x b) (d : D x b c), E x b c d :=
  fun x b c d => f &(x , b , c & d).

  Definition uncurry5 {A} {B : A -> Type} {C : forall x : A, B x -> Type}
           {D : forall (a : A) (b : B a) (c : C a b), Type}
           {E : forall (a : A) (b : B a) (c : C a b) (d : D a b c), Type}
           {F : forall (a : A) (b : B a) (c : C a b) (d : D a b c) (e : E a b c d), Type}
           (f : forall s : tele (a : A) (b : B a) (c : C a b) (d : D a b c) in E a b c d,
               F s.1 s.2.1 s.2.2.1 s.2.2.2.1 s.2.2.2.2) :
    forall (x : A) (b : B x) (c : C x b) (d : D x b c) (e : E x b c d),
           F x b c d e :=
  fun x b c d e => f &(x , b , c , d & e).
  (* Lemma apply_equiv_dom {A B} (P : B -> Type) (e : Equiv A B) : *)
  (*   (forall x : A, P (equiv e x)) -> forall x : B, P x. *)
  (* Proof. *)
  (*   intros. *)
  (*   specialize (X (e ^-1 x)). *)
  (*   rewrite inv_equiv_equiv in X. exact X. *)
  (* Defined. *)

  Definition uncurry6 {A} {B : A -> Type} {C : forall x : A, B x -> Type}
           {D : forall (a : A) (b : B a) (c : C a b), Type}
           {E : forall (a : A) (b : B a) (c : C a b) (d : D a b c), Type}
           {F : forall (a : A) (b : B a) (c : C a b) (d : D a b c) (e : E a b c d), Type}
           {G : forall (a : A) (b : B a) (c : C a b) (d : D a b c) (e : E a b c d) (f : F a b c d e), Type}
           (fn : forall s : tele (a : A) (b : B a) (c : C a b) (d : D a b c)
                                (e : E a b c d)
               in F a b c d e,
               G s.1 s.2.1 s.2.2.1 s.2.2.2.1 s.2.2.2.2.1 s.2.2.2.2.2) :
    forall (x : A) (b : B x) (c : C x b) (d : D x b c) (e : E x b c d)
      (f : F x b c d e), G x b c d e f :=
  fun x b c d e f => fn &(x , b , c , d , e & f).

  Goal forall {A} n (x y : A) (v v' : Vector.t A n)
              (e : Vector.cons x v = Vector.cons y v')
              (P : forall n x y v v' (e : Vector.cons x v = Vector.cons y v'), Type),
      (P n x x v v eq_refl) -> P n x y v v' e.
  Proof.
    intros. revert e P X.
    revert n x y v v'.
    refine (uncurry6 _).
    unshelve refine (apply_equiv_dom _ _ _).
    shelve.
    refine (equiv_sym _).
    refine (pr2 (@example A)).
    intros.
    Transparent telescope eq.
    simpl in x.
    destruct x as (n&x&y&v&v'&e&e').
    vm_compute in X. simpl in e'.
    destruct e. destruct e'.
    vm_compute.
    unfold cong_tel_proj.
    exact X.
  Defined.

  Lemma NoConfusionPackage_isequiv {A} (a b : A) {e : NoConfusionPackage A} : Equiv (a = b) (NoConfusion a b).
  Proof.
    unshelve refine {| equiv := noConfusion |}.
    unshelve refine {| equiv_inv := noConfusion_inv |}.
    red; intros.
    apply axiom_triangle.
    red. apply noConfusion_is_equiv.
    apply axiom_triangle.
  Defined.

  (* Lemma equiv_K A {NC : NoConfusionPackage A} (x y : A) : forall p q : NoConfusion x y, p = q. *)
  (* Proof. *)
  (*   intros. *)
  (*   pose (NoConfusionPackage_isequiv x y). *)
  (*   destruct x, y; simpl in *. *)
  (*   destruct p, q. reflexivity. *)
  (*   destruct p. *)
  (*   destruct p. *)
  (*   destruct p. *)

  Equations noConf_nat (x y : nat) : Type :=
    noConf_nat 0 0 := True;
    noConf_nat (S x) (S y) := noConf_nat x y;
    noConf_nat _ _ := False.
  (* BUG if with ind *)
  Equations(noind) noConf_nat_inv (x y : nat) (e : x = y) : noConf_nat x y :=
    noConf_nat_inv x ?(x) eq_refl <= x =>
    { | 0 => I;
      | S n => (noConf_nat_inv n n eq_refl) }.

  Next Obligation.
    Transparent noConf_nat_inv.
    unfold noConf_nat_inv.
    destruct x.
    simpl. apply eq_refl.
    apply eq_refl.
  Defined.

  Lemma noConfusion_nat_k (x y : nat) (p : noConf_nat x y) : x = y.
  Proof.
    induction x in y, p |- *; destruct y.
    destruct p. reflexivity.
    destruct p.
    destruct p.
    apply Top.cong. apply IHx.
    apply p.
  Defined.

  Lemma iseq x y : IsEquiv (noConfusion_nat_k x y).
  Proof.
    unshelve refine {| equiv_inv := noConf_nat_inv x y |}.
    apply axiom_triangle.
    apply axiom_triangle.
    apply axiom_triangle.
  Defined.

  Definition equiv' x y : Equiv (noConf_nat x y) (x = y) .
  Proof.
    refine {| equiv := noConfusion_nat_k x y |}.
    apply iseq.
  Defined.

  Lemma noConfusion_nat_k3 (x : nat) (p : noConf_nat x x) : noConfusion_nat_k x x p = eq_refl.
  Proof.
    induction x.
    simpl. destruct p. reflexivity.
    simpl. rewrite IHx.
    reflexivity.
  Defined.

  Lemma equiv_unit A (x : A) : inj (@eq_refl A x = eq_refl) <~> inj unit.
  Proof.
    refine {| equiv x := tt |}.
    unshelve refine {| equiv_inv x := eq_refl |}.
    red; intros.
    destruct x0.
    reflexivity.

    red; intros.
    revert x0.
    set (foo:=@eq_refl A x).
    clearbody foo.
    intros x0.
    apply axiom_triangle.
    apply axiom_triangle.
  Defined.

  Lemma noConf_nat_refl_true n : noConf_nat n n <~> inj unit.
  Proof.
    refine {| equiv x := tt |}.
    unshelve refine {| equiv_inv x := _ |}.
    induction n. constructor.
    apply IHn.

    red; intros.
    destruct x.
    reflexivity.
    red; intros.
    induction n.
    destruct x.
    reflexivity.
    simpl.
    apply IHn.

    simpl. intros.
    induction n ; simpl.
    destruct x. reflexivity.
    simpl.
    apply IHn.
  Defined.

  Lemma example' {A} :
    &{ Γ' : Tel &
           tele (n : nat) (x y : A) (v v' : Vector.t A n) in
        (Vector.cons x v = Vector.cons y v') <~> Γ' }.
  Proof.
    intros. eexists.
    refine (equiv_compose _ _).
    do 5 intros_tele.
    2:simpl.
    refine (equiv_compose _ _).
    refine (solution_inv_tele (A:=nat) (Vector.t A) _ _ _).

    refine (equiv_compose _ _).
    refine (reorder_tele (tele (e0 : S n = S n) in (Vector.cons x v ={ vector A ; e0} (Vector.cons y v'))) (fun ρ => inj (ρ.1 = eq_refl))).
    simpl.
    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (equiv_tele_l _).
    refine (equiv_sym _).
    refine (injectivity_cons2 &(x, n & v) &(y, n & v')).
    refine (equiv_compose
              (C:=tele (e : x = y) in (v ={ (λ _ : A, inj (vector A n)); e} v'))
              _ _).
    refine (equiv_tele_r _).
    intros.

    unfold telescope in x0. simpl in x0.

    destruct x0.

    destruct pr2.
    destruct pr1.

    simpl in *.
    unfold injectivity_cons2.
    simpl.
    unfold noconf_equiv, equiv, equiv_sym, inv_equiv, equiv_inv.
    simpl.

    simpl.
    intros. eexists.
    refine (equiv_compose _ _).
    do 5 intros_tele.
    2:simpl.
    refine (equiv_compose _ _).
    refine (solution_inv_tele (A:=nat) (Vector.t A) _ _ _).

    refine (reorder_tele (tele (e0 : S n = S n) in (Vector.cons x v ={ vector A ; e0} (Vector.cons y v'))) (fun ρ => inj (ρ.1 = eq_refl))).
    simpl.
    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (equiv_tele_l _).
    refine (equiv_sym _).
    refine (injectivity_cons2 &(x, n & v) &(y, n & v')).

    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (equiv_tele_l _).
    refine (equiv' _ _).
    simpl.
    unfold equiv', equiv.
    simpl.
    refine (equiv_compose _ _).
    intros_tele.
    rewrite noConfusion_nat_k3. simpl.
    unfold telescope. intros_tele.
    refine (equiv_unit _ _).
    simpl.
    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (equiv_tele_l _).
    refine (equiv_sym _).
    refine (noConf_nat_refl_true _).
    simpl.
    intros_tele.
    simpl.
    refine (equiv_compose _ _).
    unfold telescope.
    intros_tele.
    refine (equiv_id _).
    refine (equiv_id _).

    simpl. rewrite noConfusion_nat_k3. simpl.
    unfold telescope. intros_tele.
    refine (equiv_unit _ _).
    simpl.

    pose (lower_solution A n).
    pose (inv_equiv e &(x & v)).
    simpl in e.
    pose (telei x n in v : telu A).
    pose (sol:=lifted_solution (tele (_ : A) (n' : nat) in vector A n')).
    simpl in sol.
    simpl in t0.
    unfold e, lower_solution, equiv, equiv_inv, inv_equiv in t0. simpl in t0.
    unfold e, lower_solution, equiv, equiv_inv, inv_equiv in t0. simpl in t0.
    set (solinst :=
           sigmaI (fun x => sigma nat (fun n => vector A n)) t0.1 &(t0.2.1 & t0.2.2.1)).
    specialize (sol solinst).
    specialize (sol &(y, n & v')).
    (* specialize (sol solinst). (*&(y, n & v')).*) *)
    specialize (sol (telv A n)).
    specialize (sol (inj nat)).
    simpl in e.
    specialize (sol (fun x => S x.2.1) (fun x => S n) eq_refl eq_refl). simpl in sol.
    specialize (sol e). subst e.
    simpl in sol.
    unfold solution_left in *.
    simpl in *.
    unfold inv_equiv in sol. unfold eq_points_equiv in sol. simpl in *.
    unfold equiv_inv in *. simpl in *.
    unfold cong in sol. simpl in *.

    refine (equiv_compose
              (C:=tele (e : x = y) in (v ={ (λ _ : A, inj (vector A n)); e} v'))
              _ sol).
    refine (equiv_tele_r _).
    intros.

  Lemma noConfusion_nat_k2 (x y : nat) (p q : noConf_nat x y) : p = q.
  Proof.
    induction x in y, p, q |- *; destruct y.
    destruct p, q. reflexivity.
    destruct p.
    destruct p.
    simpl in p, q.
    apply IHx.
  Defined.

  Lemma noConf_HProp (x y : nat) :  (forall p q : x = y, p = q).
  Proof.
    unshelve refine (apply_equiv_dom _ _ _).
    shelve.
    refine (equiv_sym (NoConfusionPackage_isequiv x y)).
    intros x0.
    unshelve refine (apply_equiv_dom _ _ _).
    shelve.
    refine (equiv_sym (NoConfusionPackage_isequiv x y)).
    revert x0.
    revert x y. fix 1.
    unfold equiv, equiv_inv, equiv_sym, inv_equiv, NoConfusionPackage_isequiv, NoConfusion.noConfusion_nat_obligation_1;
    simpl;
    unfold equiv, equiv_inv, equiv_sym, inv_equiv, NoConfusionPackage_isequiv, NoConfusion.noConfusion_nat_obligation_1;
    simpl.
    destruct x; destruct y;
    intros. destruct x0, x.
    reflexivity.
    destruct x0.
    destruct x0.
    change (Top.cong S x0 = Top.cong S x1).
    apply Top.cong.
    simpl in x0, x1.

    intros.
    simpl in x0, x1.
    pose (equiv (NoConfusionPackage_isequiv x y) x0).
    pose (equiv (NoConfusionPackage_isequiv x y) x1).
    specialize (noConf_HProp _ _ n n0).
    simpl.
    subst n n0.
    change (
        @equiv (@NoConfusion nat NoConfusionPackage_nat x y) (@Logic.eq nat x y)
               (@equiv_sym (@Logic.eq nat x y) (@NoConfusion nat NoConfusionPackage_nat x y)
                           (@NoConfusionPackage_isequiv nat x y NoConfusionPackage_nat)))
      with (@inv_equiv _ _ (@NoConfusionPackage_isequiv nat x y NoConfusionPackage_nat)) in *.
    rewrite equiv_inv_equiv in noConf_HProp.
    rewrite equiv_inv_equiv in noConf_HProp.
    apply noConf_HProp.
  Defined.

  Eval compute in noConf_HProp.
  Lemma noConf_HProp : (forall x y : nat, NoConfusion_nat x y) <~> (forall x y : nat, forall p q : x = y, p = q).
  Proof.
    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (apply_equiv_codom _).
    intros x. refine (apply_equiv_codom _).
    intros x0.
    refine (NoConfusionPackage_isequiv x x0).
    simpl.

    unshelve refine {| equiv f := fun x y p q => _ |}.
    pose (f x y).
    transitivity e.
    destruct p.

    unshelve refine {| equiv_inv f := fun x y => _ |}.
    refine (match f x y with
            | left p => p
            | right e => _
            end).

  Lemma noConf_K : (forall x y : nat, NoConfusion_nat x y) <~> (forall x y : nat, { x = y } + { x <> y }).
  Proof.
    refine (equiv_compose _ _).
    refine (equiv_sym _).
    refine (apply_equiv_codom _).
    intros x. refine (apply_equiv_codom _).
    intros x0.
    refine (NoConfusionPackage_isequiv x x0).
    simpl.

    unshelve refine {| equiv f := fun x y => left (f x y) |}.
    unshelve refine {| equiv_inv f := fun x y => _ |}.
    refine (match f x y with
            | left p => p
            | right e => _
            end).


(* In this final module, we define the minimum necessary qualities
   a type system (for the target calculus) needs to be able to
   ensure progress, preservation, and non-interference with our
   translation. *)

Require Import source_calculus.
Require Import target_calculus.
Require Import translation.
Require Import labels.
Require Import Autosubst.
Require Import List.

(* Following Pottier & Conchon, rather than define a particular
   type system, we simply call for a typing predicate defined over
   closed terms of the target calculus and an almost entirely
   abstract set of types that satisfies particular axioms. We encode
   this specification a typeclass. *)

Class TypeSystem
    (type : Type)
    (has_type : term -> type -> Prop)
    (lift_label : label -> type)
    (int : type)
    (pair : type -> type -> type)
:= {
  compositionality : forall e f t,
    is_closed e ->
    is_subexpr e f ->
    has_type f t ->
    exists u, has_type e u;
  subj_red : forall e f t,
    has_type e t -> full_step e f -> has_type f t;
  eta_type : forall e f t,
    has_type e t -> eta_eq e f -> has_type f t;
  progress : forall e t,
    has_type e t -> (exists f, cbn e f) \/ is_value e;
  labels1 : forall l, has_type (Label l) (lift_label l);
  labels2 : forall l m,
    has_type (Label l) (lift_label m) -> precedes l m;
  integers : forall v, has_type v int <-> exists k, v = (Const k);
  pairs1 : forall e f t u,
    has_type (Pair e f) (pair t u) -> has_type e t /\ has_type f u;
  pairs2 : forall e f t u,
    has_type e t -> has_type f u -> exists v, has_type (Pair e f) v
}.

(* For the remainder of this section, we assume we have a valid
   type system and show properties of it. *)
Parameter type : Type.
Parameter has_type : term -> type  -> Prop.
Parameter lift_label : label -> type.
Parameter int : type.
Parameter pair : type -> type -> type.
Parameter TS : TypeSystem type has_type lift_label int pair.

(* Our first goal is to show that this type system can be used
   to show progress and preservation for the source calculus -
   that is, programs whose translation is well-typed do not go wrong.
*)

(* Preservation is fairly straightforward to show, falling almost
   immediately out of preservation of the target calculus and
   simulation. *)

(* This lemma extends subject reduction from a single step to
   full sequences. *)
Lemma subj_red_star e f t :
  has_type e t -> star e f -> has_type f t.
Proof.
  induction 2.
  - assumption.
  - apply IHstar. eapply subj_red.
    + apply H.
    + assumption.
Qed.

(* This lemma shows subject reduction for the source calculus, based
   on the types of the terms' translations. *)
Theorem source_subj_red e f t :
  has_type ⦇e⦈ t ->
  source_calculus.full_step e f ->
  has_type ⦇f⦈ t.
Proof.
  intros. edestruct (simulation e f) as [u []] ; auto.
  assert (has_type u t) by eauto using subj_red_star.
  eapply eta_type ; eassumption.
Qed.

(* And, as before, we extend it to the reflexive transitive closure,
   completing our proof of preservation.*)
Lemma source_subj_red_star e f t :
  has_type ⦇e⦈ t ->
  source_calculus.star e f ->
  has_type ⦇f⦈ t.
Proof.
  induction 2.
  - assumption.
  - apply IHstar. eapply source_subj_red ; eauto.
Qed.

(* Progress, the proof of which follows, requires considerably
   more groundwork. *)

(* The following two lemmas are straightforward corollaries of
   compositionality, defined here for convenience when proving
   progress. *)
Lemma pair_types e f t :
  is_closed e ->
  is_closed f ->
  has_type (Pair e f) t ->
  exists u v, has_type e u /\ has_type f v.
Proof.
  intros.
  destruct (compositionality e (Pair e f) t) ;
    eauto using is_subexpr.
  destruct (compositionality f (Pair e f) t) ;
    eauto using is_subexpr.
Qed.

Lemma app_types e f t :
  is_closed e ->
  is_closed f ->
  has_type (App e f) t ->
  exists u v, has_type e u /\ has_type f v.
Proof.
  intros.
  destruct (compositionality e (App e f) t) ; eauto using is_subexpr.
  destruct (compositionality f (App e f) t) ; eauto using is_subexpr.
Qed.

(* The following lemma shows that if both halves of a translation
   are well typed, the translation is well-typed. *)
Lemma translate_etas e t u  :
  source_calculus.is_closed e ->
  has_type (eta_fst ⦇e⦈) t ->
  has_type (eta_snd ⦇e⦈) u ->
  exists v, has_type ⦇e⦈ v.
Proof.
  induction e ; simpl ; ainv ; eauto using pairs2, labels1.
Qed.

(* TODO: cite the private paper *)
(* We say a term s is appliable precisely when (App s t) can make
   CBN progress. From the definition of CBN, we see that this occurs
   precisely when it's of the form l1 : l2 : ... : ln : λ. s'. *)
Inductive appliable : prefix -> Prop :=
| AppliableAbs s : appliable (source_calculus.Abs s)
| AppliableLift s l :
    appliable s -> appliable (source_calculus.Label s l).

Lemma appliable_exist_cbn s t :
  appliable s ->
  exists u, source_calculus.cbn (source_calculus.App s t) u.
Proof.
  induction 1 ;
    eauto using source_calculus.cbn, source_calculus.step.
Qed.

(* If the first component of a value's translation makes progress
   when applied, the value is appliable. *)
Lemma translation_appliable s t u :
  cbn (App (eta_fst ⦇s⦈) t) u ->
  source_calculus.is_value s ->
  appliable s.
Proof.
  intro H. induction s ; ainv.
  - inversion H ; ainv.
  - constructor.
  - constructor. apply IHs ; auto.
Qed.

Lemma app_translation_val e1 e2 :
  ~is_value (App (eta_fst ⦇e1⦈) ⦇e2⦈).
Proof.
  intro. induction e1 ; ainv.
  apply IHe1. rewrite <- H1, <- H0. constructor.
Qed.

(* TODO: clean this proof up? *)
Lemma source_progress e t :
  source_calculus.is_closed e ->
  has_type ⦇e⦈ t ->
  (exists f, source_calculus.cbn e f) \/ source_calculus.is_value e.
Proof.
  revert t. induction e ; simpl ; ainv.
  - right. constructor.
  - right. constructor.
  - apply pair_types in H0. destruct H0 as [u [v []]].
    apply app_types in H. repeat destruct H.
    apply app_types in H1. repeat destruct H1.
    apply app_types in H0. repeat destruct H0.
    apply app_types in H0. repeat destruct H0.
    + assert (exists u, has_type ⦇e1⦈ u) by eauto using translate_etas.
      destruct H7. edestruct IHe1 ; eauto.
      * destruct H8. left. eauto using source_calculus.cbn.
      * apply app_types in H5. repeat destruct H5. apply progress in H9. destruct H9.
        { destruct H9. left. apply appliable_exist_cbn. eapply translation_appliable ; eauto. }
        { exfalso. eapply app_translation_val ; eassumption. }
        { constructor. }
        { constructor ; auto using translation_closed_fst, translation_closed. }
    + constructor.
    + now apply translation_closed_snd, translation_closed.
    + repeat constructor.
      now apply translation_closed_snd, translation_closed.
    + repeat constructor ;
        auto using translation_closed_fst, translation_closed.
    + now apply translation_closed_fst, translation_closed.
    + now apply translation_closed.
    + constructor.
    + constructor ;
        auto using translation_closed_fst, translation_closed.
    + repeat constructor ;
        auto using translation_closed_fst, translation_closed.
    + constructor ;
        auto using translation_closed_fst, translation_closed_snd,
        translation_closed, n_closed.
  - left. esplit. repeat constructor.
  - apply pair_types in H0. destruct H0 as [u [v []]].
    apply app_types in H0. repeat destruct H0.
    + assert (exists u, has_type ⦇e⦈ u) by eauto using translate_etas.
      destruct H3. edestruct IHe ; eauto.
      * destruct H4. left. eauto using source_calculus.cbn.
      * right. now constructor.
    + repeat constructor.
    + now apply translation_closed_snd, translation_closed.
    + now apply translation_closed_fst, translation_closed.
    + repeat constructor.
      now apply translation_closed_snd, translation_closed.
Qed.

(* Our final goal is showing that any type system satisfying the
   above axioms can be used to enforce non-interference in the
   source calculus - that is, we can translate a source calculus
   term and the type of the translated term will tell us the labels
   of the data that the term depends on. As per usual, this key
   theorem will require a number of auxillary lemmas. *)

(* As part of the proof of non-interference, we need to talk about
   source calculus terms of the form l1 : l2 : ... : ln : s. The
   function apply_labels takes a list of labels [l1;l2;...;ln] and
   a term s and produces such a term. *)
Fixpoint apply_labels (ls : list label) (e : prefix) : prefix :=
match ls with
| nil => e
| cons l ls => source_calculus.Label (apply_labels ls e) l
end.

(* The following series of lemmas encodes reasoning used by the
   Pottier & Conchon paper in their proof of non-interference:

   "...according to axiom 5 [integers], [eta_fst ⦇v⦈] cannot be a
    λ-abstraction. Considering v is a value, v must be of the form
    l1 : l2 : ... : ln : k, for some n ≥ 0."
*)
Lemma int_value_fst (v : prefix) :
  source_calculus.is_value v ->
  has_type (eta_fst ⦇v⦈) int ->
  exists ls k, v = apply_labels ls (source_calculus.Const k).
Proof.
  induction v ; simpl ; intros H H0 ; ainv.
  - now exists nil, k.
  - apply integers in H0. ainv.
  - edestruct IHv as [ls [k]] ; auto. subst.
    now exists (cons l ls), k.
Qed.

Lemma int_trans_fst_type (v : prefix) l :
  source_calculus.is_value v ->
  has_type ⦇v⦈ (pair int l) ->
  has_type (eta_fst ⦇v⦈) int.
Proof.
  destruct v ; simpl ; intros ; ainv.
  - apply integers ; eauto.
  - edestruct pairs1 ; eauto.
  - edestruct pairs1 ; eauto.
Qed.

Lemma int_value (v : prefix) l :
  source_calculus.is_value v ->
  has_type ⦇v⦈ (pair int l) ->
  exists ls k, v = apply_labels ls (source_calculus.Const k).
Proof.
  intros. apply int_value_fst.
  - assumption.
  - eapply int_trans_fst_type ; eassumption.
Qed.

(* This lemma tells us that if every label in a list of labels ls
   precedes some label L, then applying the label filter operation
   using the cone of L as the inclusion predicate on a term
   labeled with ls has no effect. That is, it encodes the following
   reasoning from Pottier & Conchon's non-inteference proof:

   "[if] every li is an element of ↓l [then] ⌊v⌋↓l equals v" *)
Lemma filter_list_const L ls k :
  (forall l, In l ls -> precedes l L) ->
  ⌊apply_labels ls (source_calculus.Const k)⌋(↓L)  =
  apply_labels ls (source_calculus.Const k).
Proof.
  intro H. induction ls as [|l ls] ; simpl.
  - reflexivity.
  - rewrite IHls.
    + unfold cone. destruct (precedes_dec l L) as [_|p] ; simpl.
      * reflexivity.
      * exfalso. apply p, H. simpl. tauto.
    + intros. apply H. simpl. tauto.
Qed.

(* lift_labels turns a list of labels into a target calculus
   term of label joinings *)
Fixpoint lift_labels (ls : list label) : term := match ls with
| nil => Label bottom
| cons l ls' => (Label l) @ (lift_labels ls')
end.

(* This lemma tells us that there exists a "max" label in a list of
   labels *)
Lemma join_labels ls :
  exists L, (star (lift_labels ls) (Label L)) /\
            (forall l, In l ls -> precedes l L).
Proof.
  induction ls as [|l ls] ; simpl.
  - exists bottom. split.
    + eauto using star.
    + inversion 1.
  - destruct IHls as [L [H0 H1]]. exists (join l L). split.
    + eapply star_trans.
       * apply app_star_r. eassumption.
       * apply star_step, FullStep_step. constructor.
    + intro l'. destruct (label_eq l l') ; subst ; ainv.
       * apply semilattice.precedes_join.
       * apply semilattice.precedes_join3. apply H1. tauto.
Qed.

(* this lemma tells us that the type of a list of labels, lifted
   to a target calculus term, is an upper bound on the labels in
   the list *)
Lemma labels_bound ls L :
  has_type (lift_labels ls) (lift_label L) ->
  forall l, (In l ls -> precedes l L).
Proof.
  destruct (join_labels ls) as [L' [H1 H2]]. intro Htype.
  assert (has_type (Label L') (lift_label L))
    by eauto using subj_red_star.
  assert (precedes L' L) by auto using labels2.
  intros. apply poset.transitivity with (b := L') ; auto.
Qed.

(* The form of a labeled constant's translation *)
Lemma int_value_translation ls k :
  ⦇apply_labels ls (source_calculus.Const k)⦈ =
  Pair (Const k) (lift_labels ls).
Proof.
  induction ls ; simpl.
  - reflexivity.
  - now rewrite IHls.
Qed.

Theorem non_interference (e v : source_calculus.prefix) (l : label) :
  is_term e ->
  has_type ⦇e⦈ (pair int (lift_label l)) ->
  source_calculus.star e v ->
  source_calculus.is_value v ->
  source_calculus.star (⌊e⌋↓l) v.
Proof.
  intros.
  assert (is_term v) by eauto using term_star.
  assert (has_type ⦇v⦈ (pair int (lift_label l))) as H4 by
    eauto using source_subj_red_star.
  assert (exists ls k, v = apply_labels ls (source_calculus.Const k))
    as [ls [k]] by eauto using int_value ; subst.
  rewrite int_value_translation in H4. apply pairs1 in H4.
  apply stability ; try assumption.
  now apply filter_list_const, labels_bound.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype finfun.
Require Import bigop finset ssralg fingroup zmodp matrix vector falgebra.

(*****************************************************************************)
(*  * Finite Group as an algebra                                             *)
(*    (galg F gT)       ==  the algebra generated by gT on F                 *)
(*****************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Reserved Notation "g %:FG"
  (at level 2, left associativity, format "g %:FG").

Open Local Scope ring_scope.
Import GRing.Theory.

Section GroupAlgebraDef.
Variables (F : fieldType) (gT : finGroupType).

Inductive galg : predArgType := GAlg of {ffun gT -> F}.

Definition galg_val A := let: GAlg f := A in f.

Canonical galg_subType := Eval hnf in [newType for galg_val].
Definition galg_eqMixin := Eval hnf in [eqMixin of galg by <:].
Canonical galg_eqType := Eval hnf in EqType galg galg_eqMixin.
Definition galg_choiceMixin := [choiceMixin of galg by <:].
Canonical galg_choiceType := Eval hnf in ChoiceType galg galg_choiceMixin.

Definition fun_of_galg A (i : gT) := galg_val A i.

Coercion fun_of_galg : galg >-> Funclass.

Lemma galgE : forall f, GAlg (finfun f) =1 f.
Proof. by move=> f i; rewrite /fun_of_galg ffunE. Qed.

Definition injG (g : gT) :=  GAlg ([ffun k => (k == g)%:R]).
Notation Local "g %:FG" := (injG g).

Implicit Types v: galg.

Definition g0 := GAlg 0.
Definition g1 := 1%g %:FG.
Definition opprg v :=  GAlg (-galg_val v).
Definition addrg v1 v2 := GAlg (galg_val v1 + galg_val v2).
Definition mulvg a v :=  GAlg ([ffun k => a * galg_val v k]).
Definition mulrg v1 v2 :=
 GAlg ([ffun g => \sum_(k : gT) (v1 k) * (v2 ((k^-1) * g)%g)]).

Lemma addrgA : associative addrg.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addrA.
Qed.
Lemma addrgC : commutative addrg.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addrC.
Qed.
Lemma addr0g : left_id g0 addrg.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE add0r.
Qed.
Lemma addrNg : left_inverse g0 opprg addrg.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> ?; rewrite !ffunE addNr.
Qed.

(* abelian group structure *)
Definition gAlgZmodMixin := ZmodMixin addrgA addrgC addr0g addrNg.
Canonical Structure gAlgZmodType :=
 Eval hnf in ZmodType galg gAlgZmodMixin.

Lemma GAlg_morph : {morph GAlg: x y / x + y}.
Proof. by move=> f1 f2; apply/eqP. Qed.

Lemma mulvgA : forall a b v, mulvg a (mulvg b v) = mulvg (a * b) v.
Proof.
by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrA.
Qed.

Lemma mulvg1 : forall v, mulvg 1 v = v.
Proof. by move=> v; apply: val_inj; apply/ffunP=> g; rewrite ffunE mul1r. Qed.

Lemma mulvg_addr : forall a u v, mulvg a (u + v) = (mulvg a u) + (mulvg a v).
Proof.
by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrDr.
Qed.

Lemma mulvg_addl : forall u a b, mulvg (a + b) u = (mulvg a u) + (mulvg b u).
Proof.
by move=> *; apply: val_inj; apply/ffunP=> g; rewrite !ffunE mulrDl.
Qed.

Definition gAlgLmodMixin := LmodMixin mulvgA mulvg1 mulvg_addr mulvg_addl.
Canonical gAlgLmodType := Eval hnf in LmodType F galg gAlgLmodMixin.

Lemma sum_fgE : forall I r (P : pred I) (E : I -> galg) i,
  (\sum_(k <- r | P k) E k) i = \sum_(k <- r | P k) E k i.
Proof.
move=> I r P E i.
by apply: (big_morph (fun A : galg => A i)) => [A B|]; rewrite galgE.
Qed.

Lemma mulrgA : associative mulrg.
Proof.
move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE; symmetry.
rewrite (eq_bigr (fun k => \sum_i x i * (y (i^-1 * k)%g * z (k^-1 * g)%g)))
 => [| *]; last by rewrite galgE big_distrl; apply: eq_bigr => *; rewrite mulrA.
rewrite exchange_big /=.
transitivity (\sum_j x j * \sum_i y (j^-1 * i)%g * z (i^-1 * g)%g).
  by apply: eq_bigr => i _; rewrite big_distrr /=.
apply: eq_bigr => i _; rewrite galgE (reindex (fun j => (i * j)%g)); last first.
  by exists [eta mulg i^-1] => /= j _; rewrite mulgA 1?mulgV 1?mulVg mul1g.
by congr (_ * _); apply: eq_bigr => *; rewrite mulgA mulVg mul1g invMg mulgA.
Qed.

Lemma mulr1g : left_id g1 mulrg.
Proof.
move=> x; apply: val_inj; apply/ffunP=> g.
rewrite ffunE (bigD1 1%g) //= galgE eqxx invg1.
by rewrite mul1g mul1r big1 1?addr0 // => i Hi; rewrite galgE (negbTE Hi) mul0r.
Qed.

Lemma mulrg1 : right_id g1 mulrg.
Proof.
move=> x; apply: val_inj; apply/ffunP=> g.
rewrite ffunE (bigD1 g) //= galgE mulVg eqxx mulr1.
by rewrite big1 1?addr0 // => i Hi; rewrite galgE -eq_mulVg1 (negbTE Hi) mulr0.
Qed.

Lemma mulrg_addl : left_distributive mulrg addrg.
Proof.
move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE -big_split /=.
by apply: eq_bigr => i _; rewrite galgE mulrDl.
Qed.

Lemma mulrg_addr : right_distributive mulrg addrg.
Proof.
move=> x y z; apply: val_inj; apply/ffunP=> g; rewrite !ffunE -big_split /=.
by apply: eq_bigr => i _; rewrite galgE mulrDr.
Qed.

Lemma nong0g1 : g1 != 0 :> galg.
Proof.
apply/eqP; case.
move/ffunP; move/(_ 1%g); rewrite !ffunE eqxx.
by move/eqP; rewrite oner_eq0.
Qed.

Definition gAlgRingMixin :=
  RingMixin mulrgA mulr1g mulrg1 mulrg_addl mulrg_addr nong0g1.
Canonical gAlgRingType := Eval hnf in RingType galg gAlgRingMixin.

Implicit Types x y : galg.

Lemma mulg_mulvl : forall a x y, a *: (x * y) = (a *: x) * y.
Proof.
move=> a x y; apply: val_inj; apply/ffunP=> g.
rewrite !ffunE big_distrr /=.
by apply: eq_bigr => i _; rewrite mulrA galgE.
Qed.

Lemma mulg_mulvr : forall a x y, a *: (x * y) = x * (a *: y).
Proof.
move=> a x y; apply: val_inj; apply/ffunP=> g.
rewrite !ffunE big_distrr /=.
by apply: eq_bigr => i _; rewrite galgE mulrCA.
Qed.

Canonical gAlgLalgType := Eval hnf in LalgType F galg mulg_mulvl.
Canonical gAlgAlgType := Eval hnf in AlgType F galg mulg_mulvr.

Lemma injGM : forall g h, (g * h)%g %:FG = (g %:FG) * (h %:FG).
Proof.
move=> g h; apply: val_inj; apply/ffunP=> k.
rewrite !ffunE (bigD1 g) //= !galgE eqxx mul1r.
rewrite big1 1?addr0 => [| i Hi]; last by rewrite !galgE (negbTE Hi) mul0r.
by rewrite -(inj_eq (mulgI (g^-1)%g)) mulgA mulVg mul1g.
Qed.

Fact gAlg_iso_vect : Vector.axiom #|gT| galg.
Proof.
exists (fun x => \row_(i < #|gT|) x (enum_val i)) => [k x y | ].
  by apply/rowP=> i; rewrite !mxE !galgE !ffunE.
exists (fun x : 'rV[F]_#|gT| => GAlg ([ffun k => (x 0 (enum_rank k))])) => x.
  by apply: val_inj; apply/ffunP=> i; rewrite ffunE mxE enum_rankK.
by apply/rowP=> i; rewrite // !mxE galgE enum_valK.
Qed.

Definition galg_vectMixin := VectMixin gAlg_iso_vect.
Canonical galg_vectType := VectType F galg galg_vectMixin.

Canonical galg_unitRingType := FalgUnitRingType galg.
Canonical galg_unitAlgFType := [unitAlgType F of galg].
Canonical gAlgAlgFType := [FalgType F of galg].

Variable G : {group gT}.

Definition gvspace: {vspace galg} := (\sum_(g in G) <[g%:FG]>)%VS.

Fact gspace_subproof : has_algid gvspace && (gvspace * gvspace <= gvspace)%VS.
Proof.
apply/andP; split.
  apply: has_algid1.
  rewrite /gvspace (bigD1 (1)%g) //=.
  apply: subv_trans (addvSl _ _).
  by apply/vlineP; exists 1; rewrite scale1r.
apply/prodvP=> u v Hu Hv.
case/memv_sumP: Hu => u_ Hu ->; rewrite big_distrl /=.
apply: memv_suml=> i Hi.
case/memv_sumP: Hv => v_ Hv ->; rewrite big_distrr /=.
apply: memv_suml=> j Hj.
rewrite /gvspace (bigD1 (i*j)%g) /=; last by apply: groupM.
apply: subv_trans (addvSl _ _).
case/vlineP: (Hu _ Hi)=> k ->; case/vlineP: (Hv _ Hj)=> l ->.
apply/vlineP; exists (k * l).
by rewrite -scalerAl -scalerAr scalerA injGM.
Qed.

Definition gaspace : {aspace galg} := ASpace gspace_subproof.

End GroupAlgebraDef.

Notation " g %:FG " := (injG _ g).


(* Banach-Tarski paradox. *)

Require Import Utf8 List Relations NPeano Wf_nat.
Import ListNotations.
Require Import Misc.

Inductive letter := la | lb.

Inductive free_elem := FE : letter → bool → free_elem.

Notation "'ạ'" := (FE la false).
Notation "'ạ⁻¹'" := (FE la true).
Notation "'ḅ'" := (FE lb false).
Notation "'ḅ⁻¹'" := (FE lb true).

Definition negf '(FE t d) := FE t (negb d).

Theorem letter_dec : ∀ l1 l2 : letter, {l1 = l2} + {l1 ≠ l2}.
Proof.
intros.
now destruct l1, l2; try (now left); right.
Defined.

Theorem free_elem_dec : ∀ e₁ e₂ : free_elem, { e₁ = e₂ } + { e₁ ≠ e₂ }.
Proof.
intros.
destruct e₁ as (t₁, d₁).
destruct e₂ as (t₂, d₂).
destruct (letter_dec t₁ t₂) as [H₁| H₁]; [ subst t₂ | ].
 destruct (Bool.bool_dec d₁ d₂) as [H₂| H₂]; [ subst d₂ | ].
  now left.

  right; intros H; apply H₂.
  now injection H.

 right; intros H; apply H₁.
 now injection H.
Qed.

Theorem letter_dec_diag : ∀ t, letter_dec t t = left (eq_refl _).
Proof.
intros t.
destruct (letter_dec t t) as [p| p]; [ | exfalso; now apply p ].
destruct t; refine (match p with eq_refl => eq_refl end).
Qed.

Definition letter_opp '(FE l₁ d₁) '(FE l₂ d₂) :=
  if letter_dec l₁ l₂ then
    if Bool.bool_dec d₁ d₂ then False else True
  else False.

Theorem letter_opp_dec : ∀ e₁ e₂,
  {letter_opp e₁ e₂} + {not (letter_opp e₁ e₂)}.
Proof.
intros.
destruct e₁ as (x₁, d₁).
destruct e₂ as (x₂, d₂); simpl.
destruct (letter_dec x₁ x₂) as [Hx| Hx].
 destruct (Bool.bool_dec d₁ d₂) as [Hd| Hd]; [ | left; constructor ].
 now right.

 now right.
Defined.

Theorem letter_opp_inv : ∀ x d, letter_opp (FE x d) (FE x (negb d)).
Proof.
intros.
unfold letter_opp.
rewrite letter_dec_diag, bool_dec_negb_r.
constructor.
Qed.

Theorem letter_opp_iff : ∀ x₁ d₁ x₂ d₂,
  letter_opp (FE x₁ d₁) (FE x₂ d₂)
  ↔ x₁ = x₂ ∧ d₂ = negb d₁.
Proof.
intros x₁ d₁ x₂ d₂.
split; intros H.
 unfold letter_opp in H.
 destruct (letter_dec x₁ x₂) as [H₁| H₁]; [ | easy ].
 split; [ easy | ].
 destruct (Bool.bool_dec d₁ d₂) as [H₂| H₂]; [ easy | ].
 now apply neq_negb, not_eq_sym.

 destruct H; subst x₂ d₂.
 apply letter_opp_inv.
Qed.

Theorem letter_opp_negf : ∀ e₁ e₂, letter_opp e₁ e₂ ↔ e₁ = negf e₂.
Proof.
intros.
destruct e₁ as (t₁, d₁).
destruct e₂ as (t₂, d₂).
split; intros H.
 apply letter_opp_iff in H.
 destruct H; subst t₂ d₂; simpl.
 now rewrite Bool.negb_involutive.

 injection H; intros; subst; simpl.
 rewrite letter_dec_diag, bool_dec_negb_l.
 constructor.
Qed.

Theorem no_fixpoint_negf : ∀ e, negf e ≠ e.
Proof.
intros * H.
destruct e as (t, d).
injection H.
apply Bool.no_fixpoint_negb.
Qed.

Theorem negf_involutive : ∀ e, negf (negf e) = e.
Proof.
intros (t, d); simpl.
now rewrite Bool.negb_involutive.
Qed.

Theorem letter_opp_negf_r : ∀ e, letter_opp e (negf e).
Proof.
intros.
apply letter_opp_negf.
now rewrite negf_involutive.
Qed.

Theorem letter_opp_sym : ∀ e₁ e₂, letter_opp e₁ e₂ → letter_opp e₂ e₁.
Proof.
intros * H.
apply letter_opp_negf in H.
subst e₁.
apply letter_opp_negf_r.
Qed.

Theorem negf_eq_eq : ∀ e₁ e₂, negf e₁ = negf e₂ → e₁ = e₂.
Proof.
intros e₁ e₂ Hn.
destruct e₁ as (t₁, d₁).
destruct e₂ as (t₂, d₂).
simpl in Hn.
injection Hn; intros H₁ H₂; subst.
now apply negb_eq_eq in H₁; subst d₁.
Qed.


From RelationAlgebra Require Import
     monoid
     kat
     kat_tac
     prop
     rel
     srel
     comparisons
     rewriting
     normalisation.

From Coinduction Require Import
	 coinduction rel tactics.

From CTree Require Import
	   CTree Eq.Shallow Eq.Equ.

Import CTree.
Import CTreeNotations.
Import EquNotations.
Open Scope ctree.

Set Implicit Arguments.
Set Primitive Projections.

#[local] Tactic Notation "step" "in" ident(H) := __step_in_equ H.

Section Visible.

  Context {E C : Type -> Type} {R : Type}.

  Notation S' := (ctree' E C R).
  Notation S  := (ctree  E C R).

  Definition SS : EqType :=
	{| type_of := S ; Eq := equ eq |}.

  Inductive visible_ : hrel S' S' :=
  | VisibleI {X} (c : C X) x k t :
    visible_ (observe (k x)) t ->
    visible_ (BrF false c k) t

  | VisibleV {X} (c : C X) (x : X) k1 k2 :
    (forall x, k1 x ≅ k2 x) ->
    visible_ (BrF true c k1) (BrF true c k2)

  | VisibleVis {X} (e : E X) k1 k2 :
    (forall x, k1 x ≅ k2 x) ->
    visible_ (VisF e k1) (VisF e k2)

  | VisibleRet r :
    visible_ (RetF r) (RetF r)
  .
  Hint Constructors visible_ : core.

  Definition visibleR : hrel S S :=
	  fun u v => visible_ (observe u) (observe v).

  #[local] Instance visible__equ_aux1 t :
	  Proper (going (equ eq) ==> flip impl) (visible_ t).
  Proof.
	  intros x x' equ TR.
	  inv equ; rename H into equ.
	  step in equ. cbn in equ.
	  dependent induction TR; intros; eauto; inv equ; try invert; auto;
	    (constructor; auto; etransitivity; [apply H | symmetry; auto]).
  Qed.

  #[local] Instance visible__equ_aux2 :
	  Proper (going (equ eq) ==> going (equ eq) ==> impl) visible_.
  Proof.
	  intros x x' xequ y y' yequ TR. rewrite <- yequ. clear yequ y'.
	  inv xequ; rename H into xequ.	step in xequ. cbn in xequ.
    revert x' xequ.
	  dependent induction TR; intros; eauto; inv xequ; try invert; auto.
    2, 3: constructor; auto; intros; rewrite <- H; symmetry; auto.
    econstructor. apply IHTR. rewrite REL. reflexivity.
  Qed.

  #[global] Instance visible__equ :
	  Proper (going (equ eq) ==> going (equ eq) ==> iff) visible_.
  Proof.
	  intros ? ? eqt ? ? equ; split; intros TR.
	  - eapply visible__equ_aux2; eauto.
	  - symmetry in equ; symmetry in eqt; eapply visible__equ_aux2; eauto.
  Qed.

  #[global] Instance visible_equ :
	  Proper (equ eq ==> equ eq ==> iff) visibleR.
  Proof.
	  intros ? ? eqt ? ? equ; unfold visibleR.
    rewrite eqt, equ. reflexivity.
  Qed.

  Definition visible : srel SS SS := {| hrel_of := visibleR : hrel SS SS |}.

End Visible.