Require Import List Arith.
Import ListNotations.
Require Import core.

Notation eqdec := eq_nat_dec.

Require Import Lia.

Module renSubst.

Notation upT vs := (0 :: vs).

(* Inductive fin : list nat -> Type := *)
(*   | finO : fin [0] *)
(*   | finS : forall l, fin l -> fin (List.map S l) *)
(*   | finU : forall l, fin l -> fin (upT l). *)

(* Arguments finS {l}. *)
(* Arguments finU {l}. *)

(* should be able to represent any number in an ordered list *)
(* wait that does not really work *)
(* Check finO. *)
(* Check finS finO : fin [1]. *)
(* Check finU (finS finO) : fin [0;2]. *)

Inductive fin : list nat -> Type :=
  | finH : forall n l, fin (n::l) (* the position in the list *)
  | finT : forall n l, fin l -> fin (n::l). (* how big the jump is to the next number *)

Arguments finH _ {l}.
Arguments finT _ {l}.

Fixpoint denote {l: list nat} (x: fin l) : nat :=
  match x with
  | finH n => n
  | finT n x' => n + S (denote x')
  end.

(* flatten [0;1;2] -> [0;0;0]
 * flatten [0;2;3] -> [0;1;0]
 * flatten [1;2;3] -> [1;0;0]
 * flatten [0;3;5] -> [0;2;1] *)
Fixpoint flatten (l: list nat) (acc: nat) : list nat :=
  match l with
  | [] => []
  | x :: l =>
    let x' := x - acc in
    x' :: flatten l (S x)
  end.
Definition fl (l: list nat) : list nat := flatten l 0.

Compute (fl [0]).
Compute (fl [0;1;2]).
Compute (fl [0;2;3]).
Compute (fl [1;2;3]).
Compute (fl [0;3;5]).

Definition f0 : fin (fl [0]) := finH 0.
Definition f1 : fin (fl [0;2;3]) := finH 0. (* denotes 0 *)
Definition f2 : fin (fl [0;2;3]) := finT 0 (finH 1). (* denotes 2 *)
Definition f3 : fin (fl [0;2;3]) := finT 0 (finT 1 (finH 0)). (* denotes 3 *)

Compute (denote f0).
Compute (denote f1).
Compute (denote f2).
Compute (denote f3).

Inductive tm (vs : list nat) : Type :=
  | var_tm : fin vs -> tm vs
  | app : tm vs -> tm vs -> tm vs
  | lam : tm (upT vs) -> tm vs.
Arguments var_tm {vs}.
Arguments app {vs}.
Arguments lam {vs}.

Lemma congr_app {vs : list nat} {s0 : tm vs} {s1 : tm vs} {t0 : tm vs}
  {t1 : tm vs} (H0 : s0 = t0) (H1 : s1 = t1) :
  app s0 s1 = app t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => app x s1) H0))
         (ap (fun x => app t0 x) H1)).
Qed.

Lemma congr_lam {vs : list nat} {s0 : tm (upT vs)} {t0 : tm (upT vs)}
  (H0 : s0 = t0) : lam s0 = lam t0.
Proof.
exact (eq_trans eq_refl (ap (fun x => lam x) H0)).
Qed.

(* Inductive finList3 : list nat -> Type := *)
(*     list0 : forall l, finList3 (0::l) *)
(*   | listC : forall (v w:nat) (vs: list nat), finList3 (v::vs) -> finList3 (S v :: List.map S vs) *)
(*   | listT : forall v vs, finList3 vs -> finList3 (v::vs). *)

Open Scope type.

Definition scons {X : Type} {vs : list nat} (x : X) (f : fin vs -> X) (m : fin (upT vs)) : X.
Proof.
  revert m.
  enough (H: forall vs' (Heq: vs' = upT vs), fin vs' -> X).
  - intros m. exact (H (upT vs) eq_refl m).
  - intros vs' Heq m.
    destruct m.
    + exact x.
    + injection Heq.
      intros -> _.
      exact (f m).
Defined.

Compute (@scons nat (fl [1;2]) 1 (fun _ => 6) f1).
Compute (@scons nat (fl [1;2]) 1 (fun _ => 6) f2).
Compute (@scons nat (fl [1;2]) 1 (fun _ => 6) f3).

Definition var_zero {vs: list nat} : fin (upT vs) := finH 0.

Definition shift {vs: list nat} : fin vs -> fin (upT vs) := finT 0.

Definition up_ren_traced {vs0 vs1 : list nat} (xi: fin vs0 -> fin vs1) : fin (upT vs0) -> fin (upT vs1) :=
  scons var_zero (funcomp shift xi).

Fixpoint ren_tm {vs0 vs1: list nat} (xi_tm : fin vs0 -> fin vs1) (s: tm vs0) {struct s} : tm vs1.
Proof.
  refine (match s with
          | var_tm x => _
          | app s0 s1 => _
          | lam s0 => _
          end).
  - exact (var_tm (xi_tm x)).
  - exact (app (ren_tm _ _ xi_tm s0) (ren_tm _ _ xi_tm s1)).
  - exact (lam (ren_tm _ _ (up_ren_traced xi_tm) s0)).
Defined.

Print Assumptions ren_tm.

Lemma up_tm_tm {vs0 : list nat} {vs1 : list nat} (sigma : fin vs0 -> tm vs1) :
  fin (upT vs0) -> tm (upT vs1).
Proof.
  exact (scons (@var_tm (upT vs1) var_zero) (funcomp (ren_tm shift) sigma)).
Defined.

Fixpoint subst_tm {vs0 : list nat} {vs1 : list nat} (sigma_tm : fin vs0 -> tm vs1) (s : tm vs0) {struct s}
  : tm vs1.
Proof.
  refine (match s with
          | var_tm x => _
          | app s0 s1 => _
          | lam s0 => _
          end).
  - exact (sigma_tm x).
  - exact (app (subst_tm _ _ sigma_tm s0) (subst_tm _ _ sigma_tm s1)).
  - exact (lam (subst_tm _ _ (up_tm_tm sigma_tm) s0)).
Defined.

Print Assumptions subst_tm.

(* lambda x y . x w (lambda z . w z y) *)
(* lambda . lambda . 1 2 (lambda . 3 0 1) *)
Definition testtm : tm [1].
Proof.
  refine (lam (lam (app (app (* x w *) _ _)
                        (lam (app (app (* w z *) _ _) (* y *) _))))).
  - (* x *)
    cbv.
    (* apparently here Coq's unification is too weak *)
    refine (@var_tm [0;0;1] var_zero).
  - (* outer w *)
    refine (@var_tm [0;0;1] (shift var_zero)).
  - (* inner w *)
    refine (@var_tm [0;0;0;1] (shift (shift var_zero))).
  - (* z *)
    exact (@var_tm (fl [0;1;2;4]) var_zero).
  - (* y *)
    refine (@var_tm (fl [0;1;2;4]) (shift (shift var_zero))).
Defined.

Print Assumptions testtm.
Print testtm.
Compute (ren_tm shift testtm).
Compute (subst_tm var_tm testtm).

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

Definition cast {X} {x y: X} {p: X -> Type}
  : x = y -> p x -> p y
  := fun e a => match e with eq_refl => a end.

(* Lemma In_0 : forall vs (H: InN 0 (upT vs)), H = InNCons. *)

Require Import Eqdep_dec.
Module DecList <: DecidableType.
  Definition U := list nat.
  Definition eq_dec (x y: list nat) :=
    list_eq_dec Nat.eq_dec x y.
End DecList.

Module UIPList := DecidableEqDep DecList.
Lemma UIP_list (l : list nat) (e: l = l) : e = eq_refl.
Proof.
  apply (UIPList.UIP_refl l e).
Qed.

(* Lemma up_helper (vs: list nat) (F: forall vs, fin vs -> Prop) *)
(*       (H0: F (upT vs) (finH 0)) *)
(*       (H1: forall x, F (upT vs) (finT 0 x)) *)
(*       : forall (x: fin (upT vs)), F _ x. *)
(* Proof. *)
(*   enough (He: forall vs' (Heq: vs' = upT vs) (x: fin vs'), F vs' x). *)
(*   - intros x. apply (He (upT vs) eq_refl x). *)
(*   - intros vs' Heq x. *)
(*     destruct x. *)
(*     + injection Heq. *)
(*       intros -> ->. *)
(*       apply H0. *)
(*     + injection Heq. *)
(*       intros -> ->. *)
(*       apply H1. *)
(* Qed. *)

Lemma upId_tm_tm {vs : list nat} (sigma : fin vs -> tm vs)
  (Eq : forall x, sigma x = var_tm x) :
  forall x, up_tm_tm sigma x = @var_tm (upT vs) x.
Proof.
  unfold up_tm_tm.
  enough (He: forall vs' (Heq: vs' = upT vs) (x : fin vs'), scons (var_tm var_zero) (funcomp (ren_tm shift) sigma) (cast Heq x) = var_tm (cast Heq x)).
  - apply (He (upT vs) eq_refl).
  - intros vs' Heq x.
    destruct x.
    + injection Heq.
      intros -> ->.
      rewrite (UIP_list _ Heq).
      reflexivity.
    + injection Heq.
      intros -> ->.
      rewrite (UIP_list _ Heq).
      cbn.
      exact (ap (ren_tm shift) (Eq x)).
Qed.

Fixpoint idSubst_tm {vs : list nat} (sigma_tm : fin vs -> tm vs)
(Eq_tm : forall x, sigma_tm x = var_tm x) (s : tm vs) {struct s} :
subst_tm sigma_tm s = s :=
  match s as s0 return subst_tm sigma_tm s0 = s0
  with
  | var_tm s0 => Eq_tm s0
  | app s0 s1 => congr_app (idSubst_tm sigma_tm Eq_tm s0) (idSubst_tm sigma_tm Eq_tm s1)
  | lam s0 => congr_lam (idSubst_tm (up_tm_tm sigma_tm) (upId_tm_tm sigma_tm Eq_tm) s0)
  end.

Fail Check 1.
(* Lemma upRen_tm_tm {m : nat} {n : nat} (xi : fin m -> fin n) : *)
(*   fin (S m) -> fin (S n). *)
(* Proof. *)
(* exact (up_ren xi). *)
(* Defined. *)

(* Fixpoint ren_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm) *)
(* (s : tm m_tm) {struct s} : tm n_tm := *)
(*   match s with *)
(*   | var_tm _ s0 => var_tm n_tm (xi_tm s0) *)
(*   | app _ s0 s1 => app n_tm (ren_tm xi_tm s0) (ren_tm xi_tm s1) *)
(*   | lam _ s0 => lam n_tm (ren_tm (upRen_tm_tm xi_tm) s0) *)
(*   end. *)

Lemma up_tm_tm {m : nat} {n_tm : nat} (sigma : fin m -> tm n_tm) :
  fin (S m) -> tm (S n_tm).
Proof.
exact (scons (var_tm (S n_tm) var_zero) (funcomp (ren_tm shift) sigma)).
Defined.

Lemma up_list_tm_tm (p : nat) {m : nat} {n_tm : nat}
  (sigma : fin m -> tm n_tm) : fin (plus p m) -> tm (plus p n_tm).
Proof.
exact (scons_p p (funcomp (var_tm (plus p n_tm)) (zero_p p))
         (funcomp (ren_tm (shift_p p)) sigma)).
Defined.

Fixpoint subst_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
(s : tm m_tm) {struct s} : tm n_tm :=
  match s with
  | var_tm _ s0 => sigma_tm s0
  | app _ s0 s1 => app n_tm (subst_tm sigma_tm s0) (subst_tm sigma_tm s1)
  | lam _ s0 => lam n_tm (subst_tm (up_tm_tm sigma_tm) s0)
  end.

Lemma upId_tm_tm {m_tm : nat} (sigma : fin m_tm -> tm m_tm)
  (Eq : forall x, sigma x = var_tm m_tm x) :
  forall x, up_tm_tm sigma x = var_tm (S m_tm) x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upId_list_tm_tm {p : nat} {m_tm : nat} (sigma : fin m_tm -> tm m_tm)
  (Eq : forall x, sigma x = var_tm m_tm x) :
  forall x, up_list_tm_tm p sigma x = var_tm (plus p m_tm) x.
Proof.
exact (fun n =>
       scons_p_eta (var_tm (plus p m_tm))
         (fun n => ap (ren_tm (shift_p p)) (Eq n)) (fun n => eq_refl)).
Qed.

Fixpoint idSubst_tm {m_tm : nat} (sigma_tm : fin m_tm -> tm m_tm)
(Eq_tm : forall x, sigma_tm x = var_tm m_tm x) (s : tm m_tm) {struct s} :
subst_tm sigma_tm s = s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (idSubst_tm sigma_tm Eq_tm s0) (idSubst_tm sigma_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam (idSubst_tm (up_tm_tm sigma_tm) (upId_tm_tm _ Eq_tm) s0)
  end.

Lemma upExtRen_tm_tm {m : nat} {n : nat} (xi : fin m -> fin n)
  (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) :
  forall x, upRen_tm_tm xi x = upRen_tm_tm zeta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap shift (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upExtRen_list_tm_tm {p : nat} {m : nat} {n : nat} (xi : fin m -> fin n)
  (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) :
  forall x, upRen_list_tm_tm p xi x = upRen_list_tm_tm p zeta x.
Proof.
exact (fun n =>
       scons_p_congr (fun n => eq_refl) (fun n => ap (shift_p p) (Eq n))).
Qed.

Fixpoint extRen_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
(zeta_tm : fin m_tm -> fin n_tm) (Eq_tm : forall x, xi_tm x = zeta_tm x)
(s : tm m_tm) {struct s} : ren_tm xi_tm s = ren_tm zeta_tm s :=
  match s with
  | var_tm _ s0 => ap (var_tm n_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm xi_tm zeta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (extRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upExtRen_tm_tm _ _ Eq_tm) s0)
  end.

Lemma upExt_tm_tm {m : nat} {n_tm : nat} (sigma : fin m -> tm n_tm)
  (tau : fin m -> tm n_tm) (Eq : forall x, sigma x = tau x) :
  forall x, up_tm_tm sigma x = up_tm_tm tau x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upExt_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (sigma : fin m -> tm n_tm) (tau : fin m -> tm n_tm)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_list_tm_tm p sigma x = up_list_tm_tm p tau x.
Proof.
exact (fun n =>
       scons_p_congr (fun n => eq_refl)
         (fun n => ap (ren_tm (shift_p p)) (Eq n))).
Qed.

Fixpoint ext_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
(tau_tm : fin m_tm -> tm n_tm) (Eq_tm : forall x, sigma_tm x = tau_tm x)
(s : tm m_tm) {struct s} : subst_tm sigma_tm s = subst_tm tau_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm sigma_tm tau_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (ext_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm) (upExt_tm_tm _ _ Eq_tm)
           s0)
  end.

Lemma up_ren_ren_tm_tm {k : nat} {l : nat} {m : nat} (xi : fin k -> fin l)
  (zeta : fin l -> fin m) (rho : fin k -> fin m)
  (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_tm_tm zeta) (upRen_tm_tm xi) x = upRen_tm_tm rho x.
Proof.
exact (up_ren_ren xi zeta rho Eq).
Qed.

Lemma up_ren_ren_list_tm_tm {p : nat} {k : nat} {l : nat} {m : nat}
  (xi : fin k -> fin l) (zeta : fin l -> fin m) (rho : fin k -> fin m)
  (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x,
  funcomp (upRen_list_tm_tm p zeta) (upRen_list_tm_tm p xi) x =
  upRen_list_tm_tm p rho x.
Proof.
exact (up_ren_ren_p Eq).
Qed.

Fixpoint compRenRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
(rho_tm : fin m_tm -> fin l_tm)
(Eq_tm : forall x, funcomp zeta_tm xi_tm x = rho_tm x) (s : tm m_tm) {struct
 s} : ren_tm zeta_tm (ren_tm xi_tm s) = ren_tm rho_tm s :=
  match s with
  | var_tm _ s0 => ap (var_tm l_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compRenRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upRen_tm_tm rho_tm) (up_ren_ren _ _ _ Eq_tm) s0)
  end.

Lemma up_ren_subst_tm_tm {k : nat} {l : nat} {m_tm : nat}
  (xi : fin k -> fin l) (tau : fin l -> tm m_tm) (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_tm_tm tau) (upRen_tm_tm xi) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma up_ren_subst_list_tm_tm {p : nat} {k : nat} {l : nat} {m_tm : nat}
  (xi : fin k -> fin l) (tau : fin l -> tm m_tm) (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp tau xi x = theta x) :
  forall x,
  funcomp (up_list_tm_tm p tau) (upRen_list_tm_tm p xi) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ _ n)
         (scons_p_congr (fun z => scons_p_head' _ _ z)
            (fun z =>
             eq_trans (scons_p_tail' _ _ (xi z))
               (ap (ren_tm (shift_p p)) (Eq z))))).
Qed.

Fixpoint compRenSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp tau_tm xi_tm x = theta_tm x) (s : tm m_tm) {struct
 s} : subst_tm tau_tm (ren_tm xi_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compRenSubst_tm (upRen_tm_tm xi_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_ren_subst_tm_tm _ _ _ Eq_tm) s0)
  end.

Lemma up_subst_ren_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (zeta_tm : fin l_tm -> fin m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (ren_tm zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_tm_tm zeta_tm)) (up_tm_tm sigma) x =
  up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n =>
           eq_trans
             (compRenRen_tm shift (upRen_tm_tm zeta_tm)
                (funcomp shift zeta_tm) (fun x => eq_refl) (sigma fin_n))
             (eq_trans
                (eq_sym
                   (compRenRen_tm zeta_tm shift (funcomp shift zeta_tm)
                      (fun x => eq_refl) (sigma fin_n)))
                (ap (ren_tm shift) (Eq fin_n)))
       | None => eq_refl
       end).
Qed.

Lemma up_subst_ren_list_tm_tm {p : nat} {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (zeta_tm : fin l_tm -> fin m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (ren_tm zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_list_tm_tm p zeta_tm)) (up_list_tm_tm p sigma) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ _ n)
         (scons_p_congr
            (fun x => ap (var_tm (plus p m_tm)) (scons_p_head' _ _ x))
            (fun n =>
             eq_trans
               (compRenRen_tm (shift_p p) (upRen_list_tm_tm p zeta_tm)
                  (funcomp (shift_p p) zeta_tm)
                  (fun x => scons_p_tail' _ _ x) (sigma n))
               (eq_trans
                  (eq_sym
                     (compRenRen_tm zeta_tm (shift_p p)
                        (funcomp (shift_p p) zeta_tm) (fun x => eq_refl)
                        (sigma n))) (ap (ren_tm (shift_p p)) (Eq n)))))).
Qed.

Fixpoint compSubstRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp (ren_tm zeta_tm) sigma_tm x = theta_tm x)
(s : tm m_tm) {struct s} :
ren_tm zeta_tm (subst_tm sigma_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compSubstRen_tm (up_tm_tm sigma_tm) (upRen_tm_tm zeta_tm)
           (up_tm_tm theta_tm) (up_subst_ren_tm_tm _ _ _ Eq_tm) s0)
  end.

Lemma up_subst_subst_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (tau_tm : fin l_tm -> tm m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (subst_tm tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_tm_tm tau_tm)) (up_tm_tm sigma) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n =>
           eq_trans
             (compRenSubst_tm shift (up_tm_tm tau_tm)
                (funcomp (up_tm_tm tau_tm) shift) (fun x => eq_refl)
                (sigma fin_n))
             (eq_trans
                (eq_sym
                   (compSubstRen_tm tau_tm shift
                      (funcomp (ren_tm shift) tau_tm) (fun x => eq_refl)
                      (sigma fin_n))) (ap (ren_tm shift) (Eq fin_n)))
       | None => eq_refl
       end).
Qed.

Lemma up_subst_subst_list_tm_tm {p : nat} {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (tau_tm : fin l_tm -> tm m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (subst_tm tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_list_tm_tm p tau_tm)) (up_list_tm_tm p sigma) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans
         (scons_p_comp' (funcomp (var_tm (plus p l_tm)) (zero_p p)) _ _ n)
         (scons_p_congr
            (fun x => scons_p_head' _ (fun z => ren_tm (shift_p p) _) x)
            (fun n =>
             eq_trans
               (compRenSubst_tm (shift_p p) (up_list_tm_tm p tau_tm)
                  (funcomp (up_list_tm_tm p tau_tm) (shift_p p))
                  (fun x => eq_refl) (sigma n))
               (eq_trans
                  (eq_sym
                     (compSubstRen_tm tau_tm (shift_p p) _
                        (fun x => eq_sym (scons_p_tail' _ _ x)) (sigma n)))
                  (ap (ren_tm (shift_p p)) (Eq n)))))).
Qed.

Fixpoint compSubstSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp (subst_tm tau_tm) sigma_tm x = theta_tm x)
(s : tm m_tm) {struct s} :
subst_tm tau_tm (subst_tm sigma_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (compSubstSubst_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_subst_subst_tm_tm _ _ _ Eq_tm) s0)
  end.

Lemma rinstInst_up_tm_tm {m : nat} {n_tm : nat} (xi : fin m -> fin n_tm)
  (sigma : fin m -> tm n_tm)
  (Eq : forall x, funcomp (var_tm n_tm) xi x = sigma x) :
  forall x, funcomp (var_tm (S n_tm)) (upRen_tm_tm xi) x = up_tm_tm sigma x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma rinstInst_up_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (xi : fin m -> fin n_tm) (sigma : fin m -> tm n_tm)
  (Eq : forall x, funcomp (var_tm n_tm) xi x = sigma x) :
  forall x,
  funcomp (var_tm (plus p n_tm)) (upRen_list_tm_tm p xi) x =
  up_list_tm_tm p sigma x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ (var_tm (plus p n_tm)) n)
         (scons_p_congr (fun z => eq_refl)
            (fun n => ap (ren_tm (shift_p p)) (Eq n)))).
Qed.

Fixpoint rinst_inst_tm {m_tm : nat} {n_tm : nat}
(xi_tm : fin m_tm -> fin n_tm) (sigma_tm : fin m_tm -> tm n_tm)
(Eq_tm : forall x, funcomp (var_tm n_tm) xi_tm x = sigma_tm x) (s : tm m_tm)
{struct s} : ren_tm xi_tm s = subst_tm sigma_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm xi_tm sigma_tm Eq_tm s1)
  | lam _ s0 =>
      congr_lam
        (rinst_inst_tm (upRen_tm_tm xi_tm) (up_tm_tm sigma_tm)
           (rinstInst_up_tm_tm _ _ Eq_tm) s0)
  end.

Lemma renRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  (s : tm m_tm) :
  ren_tm zeta_tm (ren_tm xi_tm s) = ren_tm (funcomp zeta_tm xi_tm) s.
Proof.
exact (compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma renRen'_tm_pointwise {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  pointwise_relation _ eq (funcomp (ren_tm zeta_tm) (ren_tm xi_tm))
    (ren_tm (funcomp zeta_tm xi_tm)).
Proof.
exact (fun s => compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma substRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  (s : tm m_tm) :
  ren_tm zeta_tm (subst_tm sigma_tm s) =
  subst_tm (funcomp (ren_tm zeta_tm) sigma_tm) s.
Proof.
exact (compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma substRen_tm_pointwise {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  pointwise_relation _ eq (funcomp (ren_tm zeta_tm) (subst_tm sigma_tm))
    (subst_tm (funcomp (ren_tm zeta_tm) sigma_tm)).
Proof.
exact (fun s => compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) (s : tm m_tm)
  : subst_tm tau_tm (ren_tm xi_tm s) = subst_tm (funcomp tau_tm xi_tm) s.
Proof.
exact (compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm_pointwise {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  pointwise_relation _ eq (funcomp (subst_tm tau_tm) (ren_tm xi_tm))
    (subst_tm (funcomp tau_tm xi_tm)).
Proof.
exact (fun s => compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
  (s : tm m_tm) :
  subst_tm tau_tm (subst_tm sigma_tm s) =
  subst_tm (funcomp (subst_tm tau_tm) sigma_tm) s.
Proof.
exact (compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm_pointwise {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  pointwise_relation _ eq (funcomp (subst_tm tau_tm) (subst_tm sigma_tm))
    (subst_tm (funcomp (subst_tm tau_tm) sigma_tm)).
Proof.
exact (fun s => compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
  (s : tm m_tm) : ren_tm xi_tm s = subst_tm (funcomp (var_tm n_tm) xi_tm) s.
Proof.
exact (rinst_inst_tm xi_tm _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_tm_pointwise {m_tm : nat} {n_tm : nat}
  (xi_tm : fin m_tm -> fin n_tm) :
  pointwise_relation _ eq (ren_tm xi_tm)
    (subst_tm (funcomp (var_tm n_tm) xi_tm)).
Proof.
exact (fun s => rinst_inst_tm xi_tm _ (fun n => eq_refl) s).
Qed.

Lemma instId'_tm {m_tm : nat} (s : tm m_tm) : subst_tm (var_tm m_tm) s = s.
Proof.
exact (idSubst_tm (var_tm m_tm) (fun n => eq_refl) s).
Qed.

Lemma instId'_tm_pointwise {m_tm : nat} :
  pointwise_relation _ eq (subst_tm (var_tm m_tm)) id.
Proof.
exact (fun s => idSubst_tm (var_tm m_tm) (fun n => eq_refl) s).
Qed.

Lemma rinstId'_tm {m_tm : nat} (s : tm m_tm) : ren_tm id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id s)).
Qed.

Lemma rinstId'_tm_pointwise {m_tm : nat} :
  pointwise_relation _ eq (@ren_tm m_tm m_tm id) id.
Proof.
exact (fun s => eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id s)).
Qed.

Lemma varL'_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
  (x : fin m_tm) : subst_tm sigma_tm (var_tm m_tm x) = sigma_tm x.
Proof.
exact (eq_refl).
Qed.

Lemma varL'_tm_pointwise {m_tm : nat} {n_tm : nat}
  (sigma_tm : fin m_tm -> tm n_tm) :
  pointwise_relation _ eq (funcomp (subst_tm sigma_tm) (var_tm m_tm))
    sigma_tm.
Proof.
exact (fun x => eq_refl).
Qed.

Lemma varLRen'_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
  (x : fin m_tm) : ren_tm xi_tm (var_tm m_tm x) = var_tm n_tm (xi_tm x).
Proof.
exact (eq_refl).
Qed.

Lemma varLRen'_tm_pointwise {m_tm : nat} {n_tm : nat}
  (xi_tm : fin m_tm -> fin n_tm) :
  pointwise_relation _ eq (funcomp (ren_tm xi_tm) (var_tm m_tm))
    (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (fun x => eq_refl).
Qed.

Class Up_tm X Y :=
    up_tm : X -> Y.

Instance Subst_tm  {m_tm n_tm : nat}: (Subst1 _ _ _) := (@subst_tm m_tm n_tm).

Instance Up_tm_tm  {m n_tm : nat}: (Up_tm _ _) := (@up_tm_tm m n_tm).

Instance Ren_tm  {m_tm n_tm : nat}: (Ren1 _ _ _) := (@ren_tm m_tm n_tm).

Instance VarInstance_tm  {n_tm : nat}: (Var _ _) := (@var_tm n_tm).

Notation "[ sigma_tm ]" := (subst_tm sigma_tm)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s [ sigma_tm ]" := (subst_tm sigma_tm s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "↑__tm" := up_tm (only printing) : subst_scope.

Notation "↑__tm" := up_tm_tm (only printing) : subst_scope.

Notation "⟨ xi_tm ⟩" := (ren_tm xi_tm)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xi_tm ⟩" := (ren_tm xi_tm s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "'var'" := var_tm ( at level 1, only printing) : subst_scope.

Notation "x '__tm'" := (@ids _ _ VarInstance_tm x)
  ( at level 5, format "x __tm", only printing) : subst_scope.

Notation "x '__tm'" := (var_tm x) ( at level 5, format "x __tm") :
  subst_scope.

Instance subst_tm_morphism  {m_tm : nat} {n_tm : nat}:
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@subst_tm m_tm n_tm)).
Proof.
exact (fun f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => subst_tm f_tm s = subst_tm g_tm t')
         (ext_tm f_tm g_tm Eq_tm s) t Eq_st).
Qed.

Instance ren_tm_morphism  {m_tm : nat} {n_tm : nat}:
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@ren_tm m_tm n_tm)).
Proof.
exact (fun f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => ren_tm f_tm s = ren_tm g_tm t')
         (extRen_tm f_tm g_tm Eq_tm s) t Eq_st).
Qed.

Ltac auto_unfold := repeat
                     unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                      Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1.

Tactic Notation "auto_unfold" "in" "*" := repeat
                                           unfold VarInstance_tm, Var, ids,
                                            Ren_tm, Ren1, ren1, Up_tm_tm,
                                            Up_tm, up_tm, Subst_tm, Subst1,
                                            subst1 in *.

Ltac asimpl' := repeat (first
                 [ progress setoid_rewrite substSubst_tm_pointwise
                 | progress setoid_rewrite substSubst_tm
                 | progress setoid_rewrite renSubst_tm_pointwise
                 | progress setoid_rewrite renSubst_tm
                 | progress setoid_rewrite substRen_tm_pointwise
                 | progress setoid_rewrite substRen_tm
                 | progress setoid_rewrite renRen'_tm_pointwise
                 | progress setoid_rewrite renRen_tm
                 | progress setoid_rewrite varLRen'_tm_pointwise
                 | progress setoid_rewrite varLRen'_tm
                 | progress setoid_rewrite varL'_tm_pointwise
                 | progress setoid_rewrite varL'_tm
                 | progress setoid_rewrite rinstId'_tm_pointwise
                 | progress setoid_rewrite rinstId'_tm
                 | progress setoid_rewrite instId'_tm_pointwise
                 | progress setoid_rewrite instId'_tm
                 | progress
                    unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm,
                     upRen_tm_tm, up_ren
                 | progress cbn[subst_tm ren_tm]
                 | progress fsimpl ]).

Ltac asimpl := check_no_evars;
                repeat
                 unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                  Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1 in *;
                asimpl'; minimize.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case ltac:(asimpl; cbn; eauto).

Ltac substify := auto_unfold; try setoid_rewrite rinstInst'_tm_pointwise;
                  try setoid_rewrite rinstInst'_tm.

Ltac renamify := auto_unfold; try setoid_rewrite_left rinstInst'_tm_pointwise;
                  try setoid_rewrite_left rinstInst'_tm.

End renSubst.

Module fext.

Import
renSubst.

Lemma rinstInst_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm) :
  ren_tm xi_tm = subst_tm (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => rinst_inst_tm xi_tm _ (fun n => eq_refl) x)).
Qed.

Lemma instId_tm {m_tm : nat} : subst_tm (var_tm m_tm) = id.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => idSubst_tm (var_tm m_tm) (fun n => eq_refl) (id x))).
Qed.

Lemma rinstId_tm {m_tm : nat} : @ren_tm m_tm m_tm id = id.
Proof.
exact (eq_trans (rinstInst_tm (id _)) instId_tm).
Qed.

Lemma varL_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm) :
  funcomp (subst_tm sigma_tm) (var_tm m_tm) = sigma_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma varLRen_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm) :
  funcomp (ren_tm xi_tm) (var_tm m_tm) = funcomp (var_tm n_tm) xi_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma renRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  funcomp (ren_tm zeta_tm) (ren_tm xi_tm) = ren_tm (funcomp zeta_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renRen_tm xi_tm zeta_tm n)).
Qed.

Lemma substRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  funcomp (ren_tm zeta_tm) (subst_tm sigma_tm) =
  subst_tm (funcomp (ren_tm zeta_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substRen_tm sigma_tm zeta_tm n)).
Qed.

Lemma renSubst'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  funcomp (subst_tm tau_tm) (ren_tm xi_tm) = subst_tm (funcomp tau_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renSubst_tm xi_tm tau_tm n)).
Qed.

Lemma substSubst'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  funcomp (subst_tm tau_tm) (subst_tm sigma_tm) =
  subst_tm (funcomp (subst_tm tau_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substSubst_tm sigma_tm tau_tm n)).
Qed.

Ltac asimpl_fext' := repeat (first
                      [ progress setoid_rewrite substSubst_tm_pointwise
                      | progress setoid_rewrite substSubst_tm
                      | progress setoid_rewrite renSubst_tm_pointwise
                      | progress setoid_rewrite renSubst_tm
                      | progress setoid_rewrite substRen_tm_pointwise
                      | progress setoid_rewrite substRen_tm
                      | progress setoid_rewrite renRen'_tm_pointwise
                      | progress setoid_rewrite renRen_tm
                      | progress setoid_rewrite substSubst'_tm
                      | progress setoid_rewrite renSubst'_tm
                      | progress setoid_rewrite substRen'_tm
                      | progress setoid_rewrite renRen'_tm
                      | progress setoid_rewrite varLRen_tm
                      | progress setoid_rewrite varL_tm
                      | progress setoid_rewrite rinstId_tm
                      | progress setoid_rewrite instId_tm
                      | progress
                         unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm,
                          upRen_tm_tm, up_ren
                      | progress cbn[subst_tm ren_tm]
                      | fsimpl_fext ]).

Ltac asimpl_fext := check_no_evars; repeat try unfold_funcomp;
                     repeat
                      unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                       Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1
                       in *; asimpl_fext'; repeat try unfold_funcomp.

Tactic Notation "asimpl_fext" "in" hyp(J) := revert J; asimpl_fext; intros J.

Ltac substify_fext := auto_unfold; try repeat erewrite ?rinstInst_tm.

Ltac renamify_fext := auto_unfold; try repeat erewrite <- ?rinstInst_tm.

End fext.

Module interface.

Export renSubst.

Export
fext.

Arguments var_tm {n_tm}.

Arguments lam {n_tm}.

Arguments app {n_tm}.

Hint Opaque subst_tm: rewrite.

Hint Opaque ren_tm: rewrite.

End interface.

Export interface.


Require Export Coq.Program.Tactics.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Arith.Arith_base.
Require Export Coq.Relations.Relations.
Require Export Coq.Lists.List.

Import EqNotations.
Import ListNotations.

(***
 *** Semi-PreOrders
 ***)

(* Semi-reflexivity: reflexivity on the field of the relation *)
Class SemiReflexive {A} (R : relation A) :=
  {
    semi_reflexivity_l : forall (x y : A), R x y -> R x x;
    semi_reflexivity_r : forall (x y : A), R x y -> R y y
  }.

(* A Semi-PreOrder is a pre-order just on the field of the relation *)
Class SemiPreOrder {A} (R : relation A) : Prop :=
  {
    SemiPreOrder_SemiReflexive :> SemiReflexive R | 2 ;
    SemiPreOrder_Transitive :> Transitive R | 2
  }.

(* A PreOrder is always a Semi-PreOrder. We don't make this an Instance because
we don't want Coq always doing these searches for us. *)
Lemma SemiPreOrder_PreOrder A R (H:@PreOrder A R) : SemiPreOrder R.
destruct H; constructor; [ | assumption ].
constructor; intros x y Rxy; reflexivity.
Qed.

(* Tactic to apply semi-reflexivity to goals x <o= x if there is an assumption
with the form x <o= y or y <o= x *)
Ltac assumption_semi_refl :=
  match goal with
  | H : ?R ?x ?y |- ?R ?x ?x => apply (semi_reflexivity_l _ _ H)
  | H : ?R ?x ?y |- ?R ?y ?y => apply (semi_reflexivity_r _ _ H)
  end.

(***
 *** Canonical Relations for Types
 ***)

(* Set the universe levels in OTRelation and OType (was getting some "universe
undefined" errors...) *)
Definition Type0 := Type.

(* An "ordered type relation" is "the" relation for a give type *)
Class OTRelation (A:Type0) : Type := ot_R : relation A.

(* A valid ordered type is a SemiPreOrder *)
Class OType (A:Type0) {RA:OTRelation A} : Prop :=
  {
    SemiPreOrder_OType :> SemiPreOrder RA
  }.

Arguments OTRelation A%type.
Arguments OType A%type {RA}.

Instance SemiReflexive_OType A `{OType A} : SemiReflexive ot_R.
Proof. apply SemiPreOrder_OType. Qed.

Instance Transitive_OType A `{OType A} : Transitive ot_R.
Proof. apply SemiPreOrder_OType. Qed.

(* The equivalence relation for an OrderedType *)
Definition ot_equiv {A} `{OTRelation A} : relation A :=
  fun x y => ot_R x y /\ ot_R y x.

Lemma ot_equiv_PER A `{OType A} : PER _ ot_equiv.
Proof.
  constructor; intro; intros.
  { destruct H0; split; assumption. }
  { destruct H0; destruct H1; split; transitivity y; assumption. }
Qed.

Notation "x <o= y" :=
  (ot_R x y) (no associativity, at level 70).
Notation "x =o= y" :=
  (ot_equiv x y) (no associativity, at level 70).

(***
 *** Definining Some OTypes
 ***)

(* The only ordered type over unit is the discrete one *)
Instance OTunit_R : OTRelation unit := eq.

Instance OTunit : OType unit := Build_OType _ _ (SemiPreOrder_PreOrder _ _ _).

(* The pointwise relation on pairs *)
Instance OTpair_R A B (RA:OTRelation A) (RB:OTRelation B) : OTRelation (A*B) :=
  fun p1 p2 => ot_R (fst p1) (fst p2) /\ ot_R (snd p1) (snd p2).

Instance OTpair A B `(OType A) `(OType B) : OType (A*B).
Proof.
  constructor; split.
  - split; intros x y Rxy; destruct Rxy as [ Rx Ry ]; split;
      assumption_semi_refl.
  - intros p1 p2 p3 R12 R23.
    destruct R12 as [ R12l R12r ]; destruct R23 as [ R23l R23r ].
    split; [ transitivity (fst p2) | transitivity (snd p2) ]; assumption.
Qed.

(* The pointwise relation on functions *)
Instance OTarrow_R A B (RA:OTRelation A) (RB:OTRelation B) : OTRelation (A -> B) :=
  fun f1 f2 =>
    forall a1 a2,
      RA a1 a2 ->
      ot_R (f1 a1) (f2 a2) /\ ot_R (f1 a1) (f1 a2) /\ ot_R (f2 a1) (f2 a2).

Instance OTarrow A B `(OType A) `(OType B) : OType (A -> B).
Proof.
  constructor; split.
  - split; intros f1 f2 Rf a1 a2 Ra; repeat split;
      apply (Rf a1 a2 Ra).
  - intros f1 f2 f3 R12 R23 a1 a2 Ra; repeat split.
    + transitivity (f2 a2); [ apply R12 | try apply R23 ];
        try assumption; assumption_semi_refl.
    + apply R12; assumption.
    + apply R23; assumption.
Qed.

Inductive OExpr : forall A {RA:OTRelation A} (a1 a2:A), Type :=
| Embed {A} {RA:OTRelation A} {a1 a2:A} (Ra:RA a1 a2) :
    @OExpr A RA a1 a2
| App {A B} {RA:OTRelation A} {RB:OTRelation B} {f1 f2 a1 a2}
       (e1: OExpr (A -> B) f1 f2) (e2: OExpr A a1 a2) :
    OExpr B (f1 a1) (f2 a2)
| Lam {A B} {RA:OTRelation A} {RB:OTRelation B} {f1 f2}
      (e: forall (a1 a2:A), RA a1 a2 -> OExpr B (f1 a1) (f2 a2)) :
    OExpr (A -> B) f1 f2
.

FIXME HERE NOW: this is not going to work, because we need to know that
the e in the Lam constructor has all three types:
OExpr B (f1 a1) (f1 a2), OExpr B (f1 a1) (f2 a2), and OExpr B (f2 a1) (f2 a2)!

Definition mkLam {A B} {RA:OTRelation A} {RB:OTRelation B} {f1 f2}
           (f: forall {a1 a2}, OExpr A a1 a2 -> OExpr B (f1 a1) (f2 a2)) :
  OExpr (A -> B) f1 f2 :=
  Lam (fun a1 a2 Ra => f (Embed Ra)).

Definition OConst A {RA:OTRelation A} {a} : Prop :=
  Proper RA a.

Definition ott : @OConst unit _ tt := eq_refl.

Definition opair {A} {RA:OTRelation A} {B} {RB:OTRelation B} :
  @OConst _ _ (pair (A:=A) (B:=B)).
Proof.
  repeat intro; split; assumption.
Qed.

Definition ofst A {RA:OTRelation A} B {RB:OTRelation B} :
  @OConst _ _ (fst (A:=A) (B:=B)).
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Check (fun A {RA:OTRelation A} => mkLam (fun (_:A) _ x => x)).
Check (mkLam (A:=unit) (fun _ _ x => Embed ott)).
Check (mkLam (A:=unit -> unit) (fun _ _ f => App f (Embed ott))).
Check (mkLam (fun _ _ f =>
                App f (App (App (Embed opair) (Embed ott)) (Embed ott)))).


Require Import HoTT.
Require Import HoTT_axioms.
Require Import Equiv_def.
Require Import Param_CComega.
From Coq Require Import ssreflect.

Set Universe Polymorphism.

Unset Universe Minimization ToSet.

(* ########################################################### *)
(* ###        Parametricity for Inductive Types            ### *)
(* ########################################################### *)

(** Generic Lemma to prove contractibility of telescope **)

Definition IsContr_telescope2 {A} {P RA : A -> Type}
           {RP : forall a, RA a -> P a -> Type}
  : IsContr {a:A & RA a} ->
    (forall a Xa, IsContr {b : P a & RP a Xa b}) ->
    IsContr {a : A & {b : P a & {Xa : RA a & RP a Xa b}}}.
Proof.
  intros WFa WFb. apply (contr_equiv2 {a : A & RA a}); try apply WFa.
  apply EquivSigma. intro a. eapply Equiv_inverse.
  eapply equiv_compose. eapply swap_sigma.
  cbn. apply IsContrSigma_codomain. intro H. apply WFb.
Defined.

Definition IsContr_telescope3 {A} {B RA : A -> Type}
           {RB : forall a, RA a -> B a -> Type}
           {C : forall a, B a -> Type}
           {RC : forall a (Ra : RA a) (b : B a) , RB a Ra b -> C a b -> Type}
  : IsContr {a:A & RA a} ->
    (forall a Xa, IsContr {b : B a & RB a Xa b}) ->
    (forall a Xa b Xb, IsContr {c : C a b & RC a Xa b Xb c}) ->
    IsContr {a : A & {b : B a & {c : C a b & {Xa : RA a & {Xb : RB a Xa b & RC a Xa b Xb c}}}}}.
Proof.
  intros WFa WFb WFc.
  apply (contr_equiv2 {a : A & RA a}); try apply WFa.
  apply EquivSigma. intro a. eapply Equiv_inverse.
  eapply equiv_compose. eapply EquivSigma. intro. eapply swap_sigma. cbn.
  eapply equiv_compose. eapply swap_sigma. cbn.
  cbn. apply IsContrSigma_codomain. intro Ha.
  apply IsContr_telescope2; auto.
Defined.

Definition IsContr_telescope4 {A} {RA : A -> Type}
           {B :A -> Type}
           {RB : forall a, RA a -> B a -> Type}
           {C : forall a, B a -> Type}
           {RC : forall a (Ra : RA a) (b : B a) , RB a Ra b -> C a b -> Type}
           {D : forall a (b : B a), C a b -> Type}
           {RD : forall a (Ra : RA a) (b : B a) (Rb : RB a Ra b) (c : C a b)
                        (Rc : RC a Ra b Rb c), D a b c -> Type}
  : IsContr {a:A & RA a} ->
    (forall a Xa, IsContr {b : B a & RB a Xa b}) ->
    (forall a Xa b Xb, IsContr {c : C a b & RC a Xa b Xb c}) ->
    (forall a Xa b Xb c Xc, IsContr {d : D a b c & RD a Xa b Xb c Xc d}) ->
    IsContr {a : A & {b : B a & {c : C a b & { d : D a b c &
            {Xa : RA a & {Xb : RB a Xa b & { Xc : RC a Xa b Xb c & RD a Xa b Xb c Xc d}}}}}}}.
Proof.
  intros WFa WFb WFc WFd.
  apply (contr_equiv2 {a : A & RA a}); try apply WFa.
  apply EquivSigma. intro a. eapply Equiv_inverse.
  eapply equiv_compose. eapply EquivSigma. intro.
  eapply equiv_compose. eapply EquivSigma. intro.
  eapply swap_sigma. cbn.
  eapply swap_sigma. cbn.
  eapply equiv_compose. eapply swap_sigma. cbn.
  cbn. apply IsContrSigma_codomain. intro Ha.
  apply IsContr_telescope3; auto.
Defined.

Definition IsContr_telescope5 {A} {RA : A -> Type}
           {B :A -> Type}
           {RB : forall a, RA a -> B a -> Type}
           {C : forall a, B a -> Type}
           {RC : forall a (Ra : RA a) (b : B a) , RB a Ra b -> C a b -> Type}
           {D : forall a (b : B a), C a b -> Type}
           {RD : forall a (Ra : RA a) (b : B a) (Rb : RB a Ra b) (c : C a b)
                        (Rc : RC a Ra b Rb c), D a b c -> Type}
           {E : forall a (b : B a) (c: C a b), D a b c -> Type}
           {RE : forall a (Ra : RA a) (b : B a) (Rb : RB a Ra b)
                        (c : C a b) (Rc : RC a Ra b Rb c)
                        (d : D a b c) (Rd : RD a Ra b Rb c Rc d),
               E a b c d -> Type}
  : IsContr {a:A & RA a} ->
    (forall a Xa, IsContr {b : B a & RB a Xa b}) ->
    (forall a Xa b Xb, IsContr {c : C a b & RC a Xa b Xb c}) ->
    (forall a Xa b Xb c Xc, IsContr {d : D a b c & RD a Xa b Xb c Xc d}) ->
    (forall a Xa b Xb c Xc d Xd,
        IsContr {e : E a b c d & RE a Xa b Xb c Xc d Xd e}) ->
    IsContr {a : A & {b : B a & {c : C a b & { d : D a b c & { e : E a b c d &
            {Xa : RA a & {Xb : RB a Xa b & { Xc : RC a Xa b Xb c & {Xd : RD a Xa b Xb c Xc d & RE a Xa b Xb c Xc d Xd e}}}}}}}}}.
Proof.
  intros WFa WFb WFc WFd WFe.
  apply (contr_equiv2 {a : A & RA a}); try apply WFa.
  apply EquivSigma. intro a. eapply Equiv_inverse.
  eapply equiv_compose. eapply EquivSigma. intro.
  eapply equiv_compose. eapply EquivSigma. intro.
  eapply equiv_compose. eapply EquivSigma. intro.
  eapply swap_sigma. cbn.
  eapply swap_sigma. cbn.
  eapply swap_sigma. cbn.
  eapply equiv_compose. eapply swap_sigma. cbn.
  cbn. apply IsContrSigma_codomain. intro Ha.
  apply IsContr_telescope4; auto.
Defined.

Ltac erefine f  := first [ refine f | refine (f _) | refine (f _ _) | refine (f _ _ _) | refine (f _ _ _ _) | refine (f _ _ _ _ _) | refine (f _ _ _ _ _ _) | refine (f _ _ _ _ _ _ _) | refine (f _ _ _ _ _ _ _ _) | refine (f _ _ _ _ _ _ _ _ _) | refine (f _ _ _ _ _ _ _ _ _ _) | refine (f _ _ _ _ _ _ _ _ _ _ _) | refine (f _ _ _ _ _ _ _ _ _ _ _ _)  ].

Ltac eapply_assumption := match goal with | H : _ |- _ => eapply H end.

Ltac isFun f :=
  eapply contr_equiv2 ; try (apply Equiv_inverse; erefine f);
  try first [ eapply IsContr_telescope5 |
              eapply IsContr_telescope4 |
              eapply IsContr_telescope3 |
              eapply IsContr_telescope2 |
              idtac
             ];
  try first [
        intros; eapply_assumption |
        cbn; typeclasses eauto ].

Ltac FP :=
   unshelve econstructor; split ; typeclasses eauto.

Ltac rdestruct_ l :=
  let x := fresh "x" in let y := fresh "y" in
  first [ destruct l as [ x y ] ; rdestruct_ x ; rdestruct_ y |
          destruct l as [] |
          idtac
        ].

Ltac rdestruct := repeat (let l := fresh "l" in intro l ; rdestruct_ l).

#[export] Hint Unfold sym : typeclass_instances.

#[export] Hint Unfold rel : typeclass_instances.

#[export] Hint Extern 0 (Rel _ _)  =>
 match goal with | H : _ ≈ _ |- _ => progress (compute in H) end: typeclass_instances.

(* ###########################################################*)
(* ###                     nat ⋈ nat                       ###*)
(* ###########################################################*)

Fixpoint FR_nat (n m : nat) : Type :=
  match n , m with
    | 0 , 0 => unit
    | S n , S m => FR_nat n m
    | _ , _ => empty
  end.

Instance Rel_nat : Rel nat nat := FR_nat.

Definition code_nat_arg (n : nat) :
  Type :=
  match n with
    0 => FR_nat 0 0
  | S n => {m : nat & FR_nat (S n) (S m)}
  end.

Definition Equiv_nat_arg (n : nat) :
  Equiv ({m : nat & n ≈ m}) (code_nat_arg n).
Proof.
  destruct n as [ | n ]; unshelve econstructor ; cbn.
  - exact (fun lr => match lr with
                         ( 0 ; r ) => tt
                       | ( S m ; r ) => match r with end
                       end).
  - exact (fun lr => match lr with
                         ( 0 ; r ) => match r with end
                       | ( S m ; r ) => (m ; r)
                       end).
  - unshelve eapply isequiv_adjointify.
    -- exact (fun r => (0 ; r)).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
  - unshelve eapply isequiv_adjointify.
    -- intros [m r]. exact (S m ; r ).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
Defined.

Instance IsFun_nat : IsFun FR_nat.
Proof.
  intro n; induction n; isFun @Equiv_nat_arg.
Defined.

Definition code_nat_arg_sym (n : nat) :
  Type :=
  match n with
    0 => FR_nat 0 0
  | S n => {m : nat & FR_nat (S m) (S n)}
  end.

Definition Equiv_nat_arg_sym (m : nat) :
  Equiv ({n : nat & n ≈ m}) (code_nat_arg_sym m).
Proof.
  destruct m as [ | m ]; unshelve econstructor ; cbn.
  - exact (fun lr => match lr with
                         ( 0 ; r ) => tt
                       | ( S m ; r ) => match r with end
                       end).
  - exact (fun lr => match lr with
                         ( 0 ; r ) => match r with end
                       | ( S n ; r ) => (n ; r)
                       end).
  - unshelve eapply isequiv_adjointify.
    -- exact (fun r => (0 ; r)).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
  - unshelve eapply isequiv_adjointify.
    -- intros [n r]. exact (S n ; r ).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
Defined.

Instance IsFun_sym_nat : IsFun (sym FR_nat).
Proof.
  intro n; induction n; isFun @Equiv_nat_arg_sym.
Defined.

Definition FP_nat : nat ≈ nat.
  FP.
Defined.

#[export] Hint Extern 0 (nat ≈ nat) => exact FP_nat : typeclass_instances.
#[export] Hint Extern 0 (nat ⋈ nat) => exact FP_nat : typeclass_instances.

Definition FR_0 : 0 ≈ 0 := tt.

#[export] Hint Extern 0 (0 ≈ 0) => exact FR_0 : typeclass_instances.

Definition FR_S : S ≈ S := fun n m e => e.

#[export] Hint Extern 0 (S _ ≈ S _) => refine (FR_S _ _ _) : typeclass_instances.

#[export] Hint Extern 0 (?a _ ⋈ ?a' _) => match goal with | H : _ |- _ => unshelve eapply H end : typeclass_instances.

Definition FR_nat_rect : @nat_rect ≈ @nat_rect.
Proof.
  intros P Q HPQ P0 Q0 H0 PS QS HS n.
  induction n ; rdestruct; eapply_assumption; eauto.
Defined.

(* ###########################################################*)
(* ###                   A ⊔ B ⋈ A' ⊔ B'                   ###*)
(* ###########################################################*)

Inductive somme (A:Type) (B:Type) : Type :=
  |inl : A -> somme A B
  |inr : B -> somme A B.

Arguments inl {_ _} _.
Arguments inr {_ _} _.

Notation "A ⊔ B" := (somme A B) (at level 30).

Definition FR_somme {A A' B B':Type} (RA : A ≈ A') (RB : B ≈ B')
         (x:A ⊔ B) (y:A' ⊔ B') : Type :=
  match x , y with
    inl a , inl a' => a ≈ a'
  | inr b , inr b' => b ≈ b'
  | _ , _ => empty
  end.

Instance Rel_Somme {A A' B B':Type} (RA : A ≈ A')
         (RB : B ≈ B') : Rel (A ⊔ B) (A' ⊔ B') := FR_somme RA RB.

Definition code_somme_arg {A A' B B' : Type} (RA : A ≈ A')
                          (RB : B ≈ B') (x : A ⊔ B) : Type :=
  match x with
    inl a => {a':A' & inl a ≈ inl a'}
  | inr b => {b':B' & inr b ≈ inr b'}
  end.

Definition Equiv_somme_arg {A A' B B' : Type} (RA : A ≈ A')
      (RB : B ≈ B') (x : A ⊔ B) :
  Equiv ({y : A' ⊔ B' & x ≈ y}) (code_somme_arg RA RB x).
Proof.
  destruct x as [a | b ]; unshelve econstructor ; cbn.
  - exact (fun lr => match lr with
                         ( inl a' ; r ) => (a' ; r)
                       | ( inr b' ; r ) => match r with end
                       end).
  - exact (fun lr => match lr with
                         ( inl a' ; r ) => match r with end
                       | ( inr b' ; r ) => (b' ; r)
                       end).
  - unshelve eapply isequiv_adjointify.
    -- intros [a' r]. exact (inl a' ; r).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
  - unshelve eapply isequiv_adjointify.
    -- intros [b' r]. exact (inr b' ; r ).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
Defined.

Instance IsFun_somme {A A' B B' : Type}
                       (RA : A ≈ A')
                       (RB : B ≈ B') :
                       IsFun (FR_somme RA RB).
Proof.
  intro x; induction x; isFun @Equiv_somme_arg.
Defined.

Definition code_somme_arg_sym {A A' B B' : Type} (RA : A ≈ A')
                          (RB : B ≈ B') (x : A' ⊔ B') : Type :=
  match x with
    inl a' => {a:A & inl a ≈ inl a'}
  | inr b' => {b:B & inr b ≈ inr b'}
  end.

Definition Equiv_somme_arg_sym {A A' B B' : Type} (RA : A ≈ A')
      (RB : B ≈ B') (x : A' ⊔ B') :
  Equiv ({y : A ⊔ B & y ≈ x}) (code_somme_arg_sym RA RB x).
Proof.
  destruct x as [a | b ]; unshelve econstructor ; cbn.
  - exact (fun lr => match lr with
                         ( inl a' ; r ) => (a' ; r)
                       | ( inr b' ; r ) => match r with end
                       end).
  - exact (fun lr => match lr with
                         ( inl a' ; r ) => match r with end
                       | ( inr b' ; r ) => (b' ; r)
                       end).
  - unshelve eapply isequiv_adjointify.
    -- intros [a' r]. exact (inl a' ; r).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
  - unshelve eapply isequiv_adjointify.
    -- intros [b' r]. exact (inr b' ; r ).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
Defined.

Instance IsFun_sym_somme {A A' B B' : Type}
                       (RA : A ≈ A')
                       (RB : B ≈ B') :
                       IsFun (sym (FR_somme RA RB)).
Proof.
  intro x; induction x; isFun @Equiv_somme_arg_sym.
Defined.

Definition FP_somme_ : somme ≈ somme.
  FP.
Defined.

Instance FP_somme {A A' B B' : Type} (eA : A ≈ A') (eB : B ≈ B') : (A ⊔ B) ⋈ (A' ⊔ B')
  := FP_somme_ A A' eA B B' eB.

(* Definition foo : (forall A B, A -> A ⊔ B) ⋈(forall A B, A -> A ⊔ B). *)
(*   eapply FP_forall. intros. cbn in H. *)
(*   eapply FP_forall. intros. cbn in H. *)
(*   unshelve eapply FP_forall. typeclasses eauto.  *)

Definition FP_inl : @inl ≈ @inl := fun A A' eA B B' eB a a' Ra => Ra.

#[export] Hint Extern 0 (inl _ ≈ inl _) => refine (FP_inl _ _ _ _ _ _ _ _ _) : typeclass_instances.

Definition FP_inr : @inr ≈ @inr := fun A A' eA B B' eB b b' Rb => Rb.

#[export] Hint Extern 0 (inr _ ≈ inr _) => refine (FP_inr _ _ _ _ _ _ _ _ _) : typeclass_instances.

Definition FP_somme_rect : @somme_rect ≈ @somme_rect.
intros A A' HA B B' HB P Q HPQ HinlP HinlQ Hinl HinrP HinrQ Hinr x.
induction x ; rdestruct; eapply_assumption; eauto.
Defined.

(* ###########################################################*)
(* ###                   list A ⋈ list A'                 ###*)
(* ###########################################################*)

Inductive list (A : Type) : Type :=
    nil : list A | cons : A -> list A -> list A.

Arguments nil {_}.
Arguments cons {_} _ _.

Notation "[ ]" := nil (format "[ ]").
Notation "[ x ]" := (cons x nil).
Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)).

Infix "::" := cons (at level 60, right associativity).

Fixpoint FR_list {A A'} (RA : A ≈ A') (l: list A) (l': list A') : Type :=
  match l , l' with
    [] , [] => unit
  | cons a l , cons a' l' => {Xa : a ≈ a' & FR_list RA l l'}
  | _ , _ => empty
  end.

Instance Rel_list {A A'} (RA : A ≈ A') : Rel (list A) (list A') := FR_list RA.

Definition code_list_arg {A A' : Type} (RA : A ≈ A') (l : list A) : Type :=
  match l with
    [] => [] ≈ []
  | cons a l => {a':_ & {l':_ & (a::l) ≈ (a'::l')}}
  end.

Definition Equiv_list_arg {A A' : Type} (RA : A ≈ A') (l: list A) :
      Equiv ({y : list A' & l ≈ y}) (code_list_arg RA l).
Proof.
  unshelve econstructor; [idtac | unshelve eapply isequiv_adjointify ]; revert l.
  - exact (fun l => match l with [] => fun lr => match lr with
                                          ([] ; r) => tt
                                        | (a' :: l' ; r) => match r with end
                                        end
                   | (a :: l) => fun lr => match lr with
                                             ([] ; r) => match r with end
                                           | (a' :: l' ; r) => (a' ; ( l' ; r))
                                           end
                    end).
  - intro l; destruct l.
    + cbn. exact (fun r => ([] ; r)).
    + cbn. exact (fun r => match r with (a' ; (l' ; r)) => ( a'::l' ; r) end).
  - rdestruct; reflexivity.
  - rdestruct; reflexivity.
Defined.

Instance IsFun_list (A A' : Type) (RA : A ≈ A') : IsFun (FR_list RA).
Proof.
  intro l; induction l; isFun @Equiv_list_arg.
Defined.

Definition code_list_arg_sym {A A' : Type} (RA : A ≈ A') (l' : list A') : Type :=
  match l' with
    [] => [] ≈ []
  | cons a' l' => {a:_ & {l: _ & (a::l) ≈ (a'::l')}}
  end.

Definition Equiv_list_arg_sym {A A' : Type} (RA : A ≈ A') (l': list A') :
      Equiv ({l : list A & l ≈ l'}) (code_list_arg_sym RA l').
Proof.
  destruct l' as [ | a l]; unfold code_list_arg; unshelve econstructor.
  - exact (fun lr => match lr with
                         ([] ; r) => tt
                       | (a' :: l' ; r) => match r with end
                       end).
  - exact (fun lr => match lr with
                         ([] ; r) => match r with end
                       | (a' :: l' ; r) => (a' ; ( l' ; r))
                       end).
  - unshelve eapply isequiv_adjointify.
    -- intro r. exists []. exact r.
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
  - unshelve eapply isequiv_adjointify.
    -- intros [a' [l' r]]. exact ( a'::l' ; r).
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
Defined.

Instance IsFun_sym_list (A A' : Type) (RA : A ≈ A') : IsFun (sym (FR_list RA)).
Proof.
  intro l; induction l; isFun @Equiv_list_arg_sym.
Defined.

Definition _FP_list : @list ≈ @list.
  FP.
Defined.

Instance FP_list (A A' : Type) (eA : A ≈ A') : list A ⋈ list A'
  := _FP_list A A' eA.

#[export] Hint Extern 0 (list ?A ≈ list ?A') => refine (FP_list _ _ _) : typeclass_instances.

Definition FP_nil : @nil ≈ @nil := fun A A' eA => tt.

#[export] Hint Extern 0 (nil ≈ nil) => refine (FP_nil _ _ _) : typeclass_instances.

Definition FP_cons : @cons ≈ @cons := fun A A' eA a a' ea l l' el => (ea ; el).

#[export] Hint Extern 0 (cons _ _ ≈ cons _ _) => refine (FP_cons _ _ _ _ _ _ _ _ _) : typeclass_instances.

Definition FP_list_rect : @list_rect ≈ @list_rect.
  intros A B HAB P Q PQ anil bnil Hnil a b Hcons l.
  induction l ; rdestruct; eapply_assumption; eauto.
Defined.

(* ###########################################################*)
(* ###                   tree A ⋈ tree A'                 ###*)
(* ###########################################################*)

Inductive tree A : Type :=
  |nil_tree : tree A
  |cons_tree : tree A -> A -> tree A -> tree A.

Arguments nil_tree {_}.
Arguments cons_tree {_} _ _ _.

Fixpoint FR_tree {A A' : Type} (RA : A ≈ A') (t : tree A) (t' : tree A') : Type :=
  match t, t' with
    | nil_tree , nil_tree => unit
    | cons_tree ls a rs , cons_tree ls' a' rs' =>
      {Xl : FR_tree RA ls ls' & {Xa : a ≈ a' & FR_tree RA rs rs'}}
    | _ , _ => empty
  end.

Instance Rel_tree {A A' : Type} (RA : A ≈ A') : Rel (tree A) (tree A') := FR_tree RA.

Definition code_tree_arg {A A' : Type} (RA : A ≈ A') (t : tree A) : Type :=
  match t with
  | nil_tree => nil_tree ≈ nil_tree
  | cons_tree ls a rs =>
    {ls' : _ & {a':_ & {rs' : _ & cons_tree ls a rs ≈ cons_tree ls' a' rs' }}}
  end.

Definition Equiv_tree_arg {A A' : Type} (RA : A ≈ A') (t : tree A) :
      Equiv ({t' : tree A' & t ≈ t'}) (code_tree_arg RA t).
Proof.
  unshelve econstructor;
    [idtac | unshelve eapply isequiv_adjointify] ; destruct t as [ | ls a rs].
  { intros [t' r]. destruct t' as [ | ls' a' rs']; try destruct r.
    exact tt. }
  { intros [t' r]. destruct t' as [ | ls' a' rs']; try destruct r.
    exists ls', a', rs', x. exact s. }
  { intro r. exists nil_tree. exact r. }
  { intros [ls' [a' [rs' r]]]. exists (cons_tree ls' a' rs'). exact r. }
  all: rdestruct; reflexivity.
Defined.

Instance IsFun_tree {A A' : Type} (RA : A ≈ A') : IsFun (FR_tree RA).
Proof.
  intro t; induction t; isFun @Equiv_tree_arg.
Defined.

Definition code_tree_arg_sym {A A' : Type} (RA : A ≈ A') (t : tree A') : Type :=
  match t with
  | nil_tree => nil_tree ≈ nil_tree
  | cons_tree ls' a' rs' =>
    {ls : _ & {a:_ & {rs : _ & cons_tree ls a rs ≈ cons_tree ls' a' rs' }}}
  end.

Definition Equiv_tree_arg_sym {A A' : Type} (RA : A ≈ A') (t' : tree A') :
      Equiv ({t : tree A & t ≈ t'}) (code_tree_arg_sym RA t').
Proof.
  destruct t' as [ | ls a rs]; cbn.
  * unshelve econstructor.
    - intros [t' r]. destruct t' as [ | ls' a' rs']; try destruct r.
      exact tt.
    - unshelve eapply isequiv_adjointify.
      -- intro r. exists nil_tree. exact r.
      -- rdestruct; reflexivity.
      -- rdestruct; reflexivity.
  * unshelve econstructor.
  - intros [t' r]. destruct t' as [ | ls' a' rs']; try destruct r.
    exists ls', a', rs', x. exact s.
  - unshelve eapply isequiv_adjointify.
    -- intros [ls' [a' [rs' r]]]. exists (cons_tree ls' a' rs'). exact r.
    -- rdestruct; reflexivity.
    -- rdestruct; reflexivity.
Defined.

Instance IsFun_sym_tree {A A' : Type} (RA : A ≈ A') : IsFun (sym (FR_tree RA)).
Proof.
  intro t; induction t; isFun @Equiv_tree_arg_sym.
Defined.

Definition _FP_tree : @tree ≈ @tree.
Proof.
  FP.
Defined.

Instance FP_tree {A A':Type} (eA : A ≈ A') : tree A ⋈ tree A' :=
  _FP_tree _ _ eA.

(* ###########################################################*)
(* ###                 Σ(a:A) B ⋈ Σ(a':A') B'             ###*)
(* ###########################################################*)

(* rappel
Inductive sigT {A:Type} (P:A -> Type) : Type :=
    existT : forall x:A, P x -> sigT P.

Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
Notation "x .1" := (projT1 x) (at level 3).
Notation "x .2" := (projT2 x) (at level 3).
Notation " ( x ; p ) " := (existT _ x p).

Definition EqSigma {A : Type} {P : A -> Type} (w w' : {a:A & P a}) : Equiv (w = w') {p: w .1 = w' .1 & p # (w .2) = w' .2}.
Proof. *)

#[export] Hint Extern 0 (Rel (?B ?a) (?B' ?a')) =>
  match goal with | H : ?R a a' , H' : _ |- _ => specialize (H' _ _ H) end
: typeclass_instances.

Fixpoint FR_sigma {A A'} {B : A -> Type} {B' : A' -> Type}
      (RA : A ≈ A')
      (RB : B ≈ B')
      (x : {a: A & B a}) (y:{a':A' & B' a'}) : Type :=
  match x , y with
    (a ; b) , (a' ; b') => {_ : a ≈ a' & b ≈ b' }
  end.

Instance Rel_sigma {A A'} {B : A -> Type} {B' : A' -> Type}
      (RA : A ≈ A')
      (RB : B ≈ B') : Rel {a: A & B a} {a':A' & B' a'} := FR_sigma RA RB.

#[export] Hint Extern 0 (Rel (sigT _) (sigT _)) =>
 refine (Rel_sigma _ _) ; intros : typeclass_instances.

Definition code_sigma_arg {A A':Type} {B : A -> Type} {B' : A' -> Type}
      (RA : A ≈ A')
      (RB : B ≈ B')
      (x: {a:A & B a}) : Type :=
  match x with
    (a ; b) => { a' : A' & { b' : B' a' & (a;b) ≈ (a';b')} }
  end.

Definition Equiv_sigma_arg {A A':Type} {B : A -> Type} {B' : A' -> Type}
      (RA : A ≈ A')
      (RB : B ≈ B')
      (x: {a:A & B a}) :
      Equiv ({y:{a':A' & B' a'} & x ≈ y}) (code_sigma_arg RA RB x).
Proof.
  destruct x as [a b]; unfold code_sigma_arg.
  unshelve econstructor.
  { intros [y r]. destruct y as [a' b'].
    exact (a';(b';r)). }
  unshelve eapply isequiv_adjointify.
  { intros [a' [b' r]]. exact ((a';b');r). }
  all: rdestruct; reflexivity.
Defined.

Instance IsFun_sigma {A A'} {B : A -> Type} {B' : A' -> Type}
      (RA : A ≈ A')
      (RB : B ≈ B') :
      IsFun (Rel_sigma RA RB).
Proof.
  intro x; induction x; isFun @Equiv_sigma_arg.
Defined.

(* Instance is not sufficient here *)

#[export] Hint Extern 0 (IsFun (Rel_sigma _ _))  =>
refine (IsFun_sigma _ _) : typeclass_instances.

Definition code_sigma_arg_sym {A A':Type} {B : A -> Type} {B' : A' -> Type}
      (RA : A ≈ A')
      (RB : B ≈ B')
      (x: {a':A' & B' a'}) : Type :=
  match x with
    (a' ; b') => {a:A & {b : B a & (a;b) ≈ (a';b')}}
  end.

Definition Equiv_sigma_arg_sym {A A':Type} {B : A -> Type} {B' : A' -> Type}
      (RA : A ≈ A')
      (RB : B ≈ B')
      (x: {a':A' & B' a'}) :
      Equiv ({y:{a:A & B a} & y ≈ x})
            (code_sigma_arg_sym RA RB x).
Proof.
  destruct x as [a b]; unfold code_sigma_arg.
  unshelve econstructor.
  { intros [y r]. destruct y as [a' b'].
    exact (a';(b';r)). }
  unshelve eapply isequiv_adjointify.
  { intros [a' [b' r]]. exact ((a';b');r). }
  all: rdestruct; reflexivity.
Defined.

Instance IsFun_sym_sigma {A A'} {B : A -> Type} {B' : A' -> Type}
      (RA : A ≈ A')
      (RB : B ≈ B') :
      IsFun (sym (Rel_sigma RA RB)).
Proof.
  intro x; induction x; isFun @Equiv_sigma_arg_sym.
Defined.

(* Instance is not sufficient here *)

#[export] Hint Extern 0 (IsFun (sym (Rel_sigma _ _)))  =>
refine (IsFun_sym_sigma _ _) : typeclass_instances.

Definition _FP_sigma : @sigT ≈ @sigT.
Proof.
  intros A A' eA B B' eB. FP.
Defined.

Instance FP_sigma (A A' : Type) (B : A -> Type) (B' : A' -> Type)
    (eA : A ≈ A') (eB : B ≈ B') :
    {a:A & B a} ⋈ {a':A' & B' a'} := _FP_sigma A A' eA B B' eB.

Definition FP_existT : @existT ≈ @existT := fun A A' eA B B' eB a a' ea b b' eb => (ea ; eb).

#[export] Hint Extern 0 ((_ ; _) ≈ (_ ; _ )) => refine (FP_existT _ _ _ _ _ _ _ _ _ _ _ _) : typeclass_instances.

Definition FP_sigT_rect : @sigT_rect ≈ @sigT_rect.
  intros A A' eA B B' eB P Q ePQ HexP HexQ Hex x.
  induction x ; rdestruct; eapply_assumption; eauto.
Defined.


Require Import set.
Require Import subset.

(******************************************************************************)
(*                        belong : set -> set -> Prop                         *)
(******************************************************************************)

Definition belong (a b:set) : Prop := subset (Singleton a) b.