(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Rbase.
Require Export Rsequence.
Require Import Ranalysis.
Require Import Rfunctions.
Require Import Rseries_def.
Require Import Lra.
Require Import RiemannInt.
Require Import SeqProp.
Require Import MyRIneq.
Require Import Rinterval Ranalysis_def Ranalysis_def_simpl.
Require Import Ranalysis_continuity.
Require Import Ass_handling.

Local Open Scope R_scope.

(** * Intermediate Value Theorem on an Interval and its corollary *)
(** This proof was mainly taken from Reals.Rsqrt_def *)

Lemma dicho_steps_interval_compat : forall x y P N, x <= y ->
  interval x y (dicho_up x y P N)
  /\ interval x y (dicho_lb x y P N).
Proof.
intros x y P N x_le_y ; induction N.
 simpl ; split ; [apply interval_r | apply interval_l] ; assumption.
 simpl ; split ; fold (middle (Dichotomy_lb x y P N) (Dichotomy_ub x y P N)) ;
 destruct (P (middle (Dichotomy_lb x y P N) (Dichotomy_ub x y P N))) ;
 try apply interval_middle_compat ; apply IHN.
Qed.

Lemma dicho_interval_compat : forall x y l P, x <= y ->
  Rseq_cv (dicho_up x y P) l -> interval x y l.
Proof.
intros x y l P x_le_y Hl ; eapply Rseq_interval_compat ;
 [| eassumption] ; intro ; apply dicho_steps_interval_compat ;
 assumption.
Qed.

Lemma cond_positivity_car: forall x,
  cond_positivity x = true <-> 0 <= x.
Proof.
intro ; unfold cond_positivity ; destruct (Rle_dec 0 x) ;
 intuition ; discriminate.
Qed.

Lemma cond_positivity_car': forall x,
  cond_positivity x = false <-> x < 0.
Proof.
intro ; unfold cond_positivity ; destruct (Rle_dec 0 x) ; intuition.
 discriminate.
 destruct (Rlt_irrefl 0) ; eapply Rle_lt_trans ; eassumption.
Qed.

Lemma Rseq_cv_0_abs_compat : forall Un,
  Rseq_cv (| Un |) 0 -> Rseq_cv Un 0.
Proof.
intros Un HUn eps eps_pos ; destruct (HUn _ eps_pos) as [N HN] ;
 exists N ; intros n n_lb ; apply Rle_lt_trans with (R_dist (|Un| n)%R 0).
  right ; unfold R_dist, Rseq_abs ; do 2 rewrite Rminus_0_r ;
  rewrite Rabs_Rabsolu ; reflexivity.
  apply HN ; assumption.
Qed.

Lemma dicho_diff_cv : forall x y P, x <= y ->
  Rseq_cv (dicho_up x y P - dicho_lb x y P) 0.
Proof.
intros x y P xley ; eapply Rseq_cv_eq_compat.
 intro n ; apply dicho_lb_dicho_up ; assumption.
 eapply Rseq_cv_pos_infty_div_compat, Rseq_constant_cv.
 apply Rseq_pow_gt_1_cv ; lra.
Qed.

Lemma interval_open_interval : forall x y z,
  interval x y z -> x <> z -> y <> z ->
  open_interval x y z.
Proof.
intros x y z [xz zy] x_neq y_neq ; split ;
 apply Rle_neq_lt ; auto.
Qed.

Lemma IVT_open_interval_prelim : forall (f : R -> R) (x y : R),
  continuity_interval x y f -> x < y -> open_interval (f x) (f y) 0 ->
  {z : R | open_interval x y z /\ f z = 0}.
Proof.
intros f x y Hf xlty O_in ; assert (xley := Rlt_le _ _ xlty) ;
 pose (P := fun z => cond_positivity (f z)) ; pose (Zn := dicho_up x y P) ;
 pose (Zn' := dicho_lb x y P) ; assert (Hcv := dicho_diff_cv _ _ P xley) ;
 destruct (dicho_up_cv x y P xley) as [z Hz] ; exists z.
 assert (Hz' : Rseq_cv Zn' z).
  destruct (dicho_lb_cv x y P xley) as [z' Hz'] ;
  rewrite <- (cv_dicho _ _ _ _ _ xley Hz' Hz) ; assumption.
 assert (fz_eq : f z = 0).
  apply Rle_antisym.

  apply Rseq_negative_limit with (fun n => f (Zn' n)).
  intro n ; left ; rewrite <- cond_positivity_car' ; fold (P (Zn' n)) ;
  apply dicho_lb_car ; unfold P ; rewrite cond_positivity_car' ; apply O_in.

  eapply Rseq_cv_continuity_interval_compat ; [eapply dicho_interval_compat |
  intro ; apply dicho_steps_interval_compat | |] ; eassumption.

  apply Rseq_positive_limit with (fun n => f (Zn n)).
  intro n ; rewrite <- cond_positivity_car ; fold (P (Zn n)) ;
  apply dicho_up_car ; unfold P ; rewrite cond_positivity_car ;
  left ;  apply O_in.
  eapply Rseq_cv_continuity_interval_compat ; [eapply dicho_interval_compat |
  intro ; apply dicho_steps_interval_compat | |] ; eassumption.

  split ; [apply interval_open_interval | assumption].
   eapply dicho_interval_compat ; eassumption.
   intro Hfalse ; rewrite Hfalse in O_in ; apply (Rlt_irrefl 0) ;
   apply Rle_lt_trans with (f z) ; [right ; symmetry ; apply fz_eq | apply O_in].
   intro Hfalse ; rewrite Hfalse in O_in ; apply (Rlt_irrefl 0) ;
   apply Rlt_le_trans with (f z) ; [apply O_in | right ; apply fz_eq].
Qed.

Lemma IVT_open_interval : forall (f : R -> R) (x y : R) l,
  continuity_interval x y f -> x < y -> open_interval (f x) (f y) l ->
  { z : R | open_interval x y z /\ f z = l }.
Proof.
intros f x y l Hf Hxy Hl ;
 destruct IVT_open_interval_prelim with (f - (fun _ => l))%F x y as [z [z_in Hz]].
  apply continuity_in_minus, continuity_in_const ; assumption.
  assumption.
  clear - Hl; destruct Hl ; split ; unfold minus_fct ; lra.
 exists z ; split ; [assumption |].
  clear - Hz ; unfold minus_fct in * ; intuition.
Qed.

Lemma IVT_interval : forall (f : R -> R) (x y : R) l,
  continuity_interval x y f -> x <= y -> interval (f x) (f y) l ->
  {z : R | interval x y z /\ f z = l}.
Proof.
intros f x y l Hf xley [fxlel llefy] ;
 destruct (Rle_lt_or_eq_dec _ _ xley) as [xlty | xeqy].
 destruct (Rle_lt_or_eq_dec _ _ fxlel) as [fxltl | fxeql].
 destruct (Rle_lt_or_eq_dec _ _ llefy) as [lltfy | leqfy].
 destruct (IVT_open_interval _ _ _ l Hf xlty) as [z [z_in Hz]].
  split ; assumption.
  exists z ; split ; [apply open_interval_interval |] ; assumption.
  exists y ; split ; [apply interval_r |] ; auto.
  exists x ; split ; [apply interval_l |] ; auto.
  exists y ; subst ; split ; [apply interval_r | apply Rle_antisym] ; auto.
Qed.


(* SimpleType.v *)
(* Simply typed lambda calculus; theorems *)
(* 2014/10/22 by Yukiyoshi Kameyama *)

Require Export SfLib.
Require Import Ascii String.
Require Import SimpleTypeDef.

Theorem ex101 : [x \in T] |- x \in T.
Proof.
  Rvar.
Qed.

Theorem ex102 : [x \in T; y \in S] |- x \in T.
Proof.
  Rvar.
Qed.

Theorem ex103 : [x \in T; y \in S] |-  (x,y)   \in T * S.
Proof.
  Rpair.
  Rvar.
  Rvar.
Qed.

Theorem ex104 : [x \in T * S] |- left x \in T.
Proof.
  Rleft (S).
  Rvar.
Qed.

Theorem ex105 : [x \in T] |- (x,x) \in T * T.
Proof.
  Rpair.
  Rvar.
  Rvar.
Qed.

Theorem ex106 : [x \in T * S] |- (left x, (right x, left x)) \in T * (S * T).
Proof.
  Rpair.
    Rleft (S); Rvar.
    Rpair. Rright (T); Rvar.
          Rleft (S); Rvar.
Qed.

Theorem ex107 : [x \in (T * S) * U] |- (left (left x), (right (left x),right x)) \in T * (S * U).
Proof.
  Rpair.
    Rleft (S). Rleft (U). Rvar.
    Rpair.
      Rright (T). Rleft (U). Rvar.
      Rright (T * S). Rvar.
Qed.

Theorem ex108 : [x \in T * (S * U)]
|- ((left x, left (right x)), right (right x)) \in (T * S) * U.
Proof.
  Rpair.
  Rpair. Rleft (S * U). Rvar.
  Rleft(U). Rright(T). Rvar.
  Rright(S). Rright(T). Rvar.
Qed.

Theorem ex109 : [] |- \lambda (x \in T) x \in T -> T.
Proof.
  Rlambda.
  Rvar.
Qed.

Theorem ex110 : [] |- \lambda (x \in T) (\lambda (y \in T) x) \in T -> T -> T.
Proof.
  Rlambda.
  Rlambda.
  Rvar.
Qed.

Theorem ex111 : [] |- \lambda (x \in T) (\lambda (y \in S) x) \in T -> S -> T.
  Rlambda.
  Rlambda.
  Rvar.
Qed.

Theorem ex112 : [] |- \lambda (f \in T -> T -> S) (\lambda (x \in T)
((f @ x) @ x)) \in (T -> T -> S) -> (T -> S).
Proof.
  Rlambda.
  Rlambda.
  Rapply(T).
  Rapply(T).
  Rvar. Rvar. Rvar.
Qed.

Theorem ex113 : [] |-
  \lambda (f \in T -> S -> U) (
     \lambda (g \in T -> S) (
        \lambda (x \in T) (
          ((f @ x) @ (g @ x))
   )))
  \in
   (T -> S -> U) -> (T -> S) -> (T -> U).
Proof.
  Rlambda.
  Rlambda.
  Rlambda.
  Rapply(S).
  Rapply(T).
  Rvar.  Rvar.
  Rapply(T).
  Rvar. Rvar.
Qed.

Theorem ex114 : [] |- \lambda (x \in T * S) ( right x, left x) \in T * S -> S * T.
Proof.
  Rlambda.
  Rpair.
  Rright(T). Rvar.
  Rleft(S). Rvar.
Qed.

Theorem ex115 : [] |- \lambda (x \in T) (\lambda (f \in T -> S) (f @ x))
                \in T -> (T -> S) -> S.
Proof.
  Rlambda.
  Rlambda.
  Rapply(T). Rvar.
  Rvar.
Qed.

Theorem ex116 : [] |- \lambda (x \in T) (inl x) \in T -> T + S.
Proof.
  Rlambda.
  Rinl.
  Rvar.
Qed.

Theorem ex117 : [] |- \lambda (x \in T) (inr x) \in T -> S + T.
Proof.
  Rlambda.
  Rinr.
  Rvar.
Qed.

Theorem ex118 : [] |- \lambda (x \in T + T)
                      (case (x, (y \in T) y, (z \in T) z))
                   \in T + T -> T.
Proof.
  Rlambda.
  Rcase.
  Rvar.
  Rvar.
  Rvar.
Qed.

Theorem ex120 : [] |- \lambda (x \in T + (S + U))
                         (case(x, (y \in T) inl (inl y),
                                  (z \in S + U)
                                    (case(z, (u \in S) inl (inr u),
                                             (v \in U) inr(v)))))
                         \in (T + (S + U)) -> ((T + S) + U).
Proof.
  Rlambda.
  Rcase.
  Rvar.
  Rinl. Rinl. Rvar.
  Rcase.
  Rvar.
  Rinl. Rinr. Rvar.
  Rinr. Rvar.
Qed.

Theorem ex121 : [] |- \lambda (x \in T * (S + U)) (
                        case(right x,
                             (y \in S) inl (left x, y),
                             (z \in U) inr (left x, z)))
                  \in (T * (S + U)) -> ((T * S) + (T * U)).
Proof.
  Rlambda.
  Rcase.
  Rright(T). Rvar.
  Rinl. Rpair.
  Rleft(S + U). Rvar. Rvar.
  Rinr. Rpair.
  Rleft(S + U). Rvar. Rvar.
Qed.

Theorem ex122 : [] |-  (\lambda (x \in ((T * S) + (T * U)))
                          (case (x, (y \in T * S) (left y, inl (right y)),
                                    (z \in T * U) (left z, inr (right z)))))
                       \in ((T * S) + (T * U)) -> (T * (S + U)).
Proof.
  Rlambda.
  Rcase. Rvar.
  Rpair.
  Rleft(S). Rvar.
  Rinl. Rright(T). Rvar.
  Rpair.
  Rleft(U). Rvar.
  Rinr. Rright(T). Rvar.
Qed.

Theorem ex123 : [] |- \lambda (x \in (T + (S * U)))
                         (case (x, (y \in T) (inl(y), inl(y)),
                                   (z \in S * U) (inr(left(z)), inr(right(z)))))
                      \in (T + (S * U)) -> ((T + S) * (T + U)).
Proof.
   Rlambda.
   Rcase.  Rvar.
   Rpair.
   Rinl. Rvar.
   Rinl. Rvar.
   Rpair.
   Rinr. Rleft(U). Rvar.
   Rinr. Rright(S). Rvar.
Qed.

Theorem ex124 : [] |- \lambda (x \in (T+S) * (T+U))
                        (case(left(x), (y \in T) inl(y),
                                       (z \in S)
                                         (case (right(x),
                                                 (u \in T) inl(u),
                                                 (v \in U) inr(z, v)))))
                      \in ((T + S) * (T + U)) -> (T + (S * U)).
Proof.
  Rlambda.
  Rcase.
  Rleft(T + U). Rvar.
  Rinl. Rvar.
  Rcase.
  Rright(T + S). Rvar.
  Rinl. Rvar.
  Rinr. Rpair. Rvar. Rvar.
Qed.

Theorem ex127 : [] |- \lambda (x \in T * (T -> Empty))
                        (abort ( (right x) @ (left x)))
                      \in T * (T -> Empty) -> S.
Proof.
  Rlambda.
  Rabort.
  Rapply(T).
  Rright(T). Rvar.
  Rleft(T -> Empty). Rvar.
Qed.

Theorem ex128 : [] |- \lambda (x \in T)
                        (\lambda (f \in T -> U)
                           (f @ x))
                       \in T -> ((T -> U) -> U).
Proof.
  Rlambda.
  Rlambda.
  Rapply(T). Rvar.
  Rvar.
Qed.

Theorem ex129 : [] |- \lambda (f \in T -> S)
                         (\lambda (g \in S -> U)
                             (\lambda (x \in T)
                                  (g @ (f @ x))))
                      \in (T -> S) -> ((S -> U) -> (T -> U)).
Proof.
  Rlambda.
  Rlambda.
  Rlambda.
  Rapply(S). Rvar.
  Rapply(T). Rvar.
  Rvar.
Qed.

Theorem ex130 : [] |- \lambda (f \in ((T -> Empty) -> Empty) -> Empty)
                         (\lambda (x \in T)
                             (f @ (\lambda (g \in T -> Empty)
                                     (g @ x))))
                      \in (((T -> Empty) -> Empty) -> Empty) -> (T -> Empty).
Proof.
  Rlambda.
  Rlambda.
  Rapply((T -> Empty) -> Empty). Rvar.
  Rlambda.
  Rapply(T). Rvar.
  Rvar.
Qed.

Theorem ex133 : exists_term t, [] |- t \in T -> T.
Proof.
  Ex (\lambda (x \in T) x).
  Rlambda. Rvar.
Qed.

Theorem ex136 : exists_term t, [] |- t \in  T * Empty -> S * T.
Proof.
  Ex(\lambda(x \in T * Empty) (abort(right(x)), abort(right(x)))).
  Rlambda.
  Rpair.
  Rabort.
  Rright(T). Rvar.
  Rabort.
  Rright(T). Rvar.
Qed.

Theorem ex137 : exists_term t, [] |- t \in  (T -> S) -> (((T -> Empty) + S) -> Empty) -> Empty.
Proof.
  Ex(\lambda(f \in T -> S) (\lambda(g \in (T -> Empty) + S -> Empty) (g@inl(\lambda(t \in T)(g@(inr(f@t))))))).
  Rlambda.
  Rlambda.
  Rapply((T -> Empty) + S).
  Rvar.
  Rinl.
  Rlambda.
  Rapply((T -> Empty) + S).
  Rvar.
  Rinr.
  Rapply(T). Rvar. Rvar.
Qed.

(*case(x@x, (x \in T -> Empty)x, (x \in S)x) @ x*)

Theorem ex138 : exists_term t, [] |- t \in  ((T -> Empty) + S) -> T -> S.
Proof.
  Ex(\lambda (f \in  ((T -> Empty) + S)) (\lambda (g \in T) (case(f, (x \in T -> Empty)abort(x@g), (x \in S)x)))).
  Rlambda.
  Rlambda.
  Rcase.
  Rvar.
  Rabort.
  Rapply(T).
  Rvar. Rvar. Rvar.
Qed.

Theorem ex139 : exists_term t, [] |- t \in  (T -> S -> U) -> (T * S -> U).
Proof.
  Ex(\lambda (f \in T -> S -> U)(\lambda (g \in T*S) (f@(left(g))@(right(g))))).
  Rlambda.
  Rlambda.
  Rapply(S).
  Rapply(T). Rvar.
  Rleft(S). Rvar.
  Rright(T). Rvar.
Qed.

Theorem ex140 : exists_term t, [] |- t \in  (T * S -> U) -> (T -> S -> U).
Proof.
  Ex(\lambda(f \in T * S -> U)(\lambda(t \in T)(\lambda(s \in S)(f@(t, s))))).
  Rlambda.
  Rlambda.
  Rlambda.
  Rapply(T*S).
  Rvar.
  Rpair.
  Rvar. Rvar.
Qed.

Theorem ex141 : exists_term t, [] |- t \in  (T + S -> U) -> (T -> U) * (S -> U).
Proof.
  Ex(\lambda(f \in T + S -> U)(\lambda(t \in T)(f@inl(t)),  \lambda(s \in S)(f@inr(s)))).
  Rlambda.
  Rpair.
  Rlambda.
  Rapply(T+S). Rvar.
  Rinl. Rvar.
  Rlambda.
  Rapply(T+S).
  Rvar.
  Rinr. Rvar.
Qed.

Theorem ex142 : exists_term t, [] |- t \in  (T -> U) * (S -> U) -> (T + S -> U).
Proof.
  Ex(\lambda(f \in (T -> U) * (S -> U))(\lambda(g \in T + S)(case(g, (t \in T)((left(f))@t), (s \in S)((right(f))@s))))).
  Rlambda.
  Rlambda.
  Rcase. Rvar.
  Rapply(T).
  Rleft(S -> U).
  Rvar. Rvar.
  Rapply(S).
  Rright(T -> U).
  Rvar. Rvar.
Qed.

Theorem ex143 : exists_term t, [] |- t \in  (T -> S) -> (S -> U) -> (U -> S) -> (T -> S).
Proof.
  Ex(\lambda(f \in T -> S)(\lambda(g \in S -> U)(\lambda(h \in U -> S)f))).
  Rlambda.
  Rlambda.
  Rlambda.
  Rvar.
Qed.

Theorem ex144 : exists_term t, [] |- t \in  (T + S) -> (T -> U) -> (S -> U) -> U.
Proof.
  Ex(\lambda(f \in T + S)(\lambda(g \in T -> U)(\lambda(h \in S -> U)(case(f, (t \in T)(g@t), (s \in S)(h@s)))))).
  Rlambda.
  Rlambda.
  Rlambda.
  Rcase.
  Rvar.
  Rapply(T).
  Rvar. Rvar.
  Rapply(S).
  Rvar. Rvar.
Qed.

Theorem ex145 : exists_term t, [] |- t \in  ((T + (T -> Empty)) -> Empty) -> Empty.
Proof.
  Ex(\lambda(f \in (T + (T -> Empty)) -> Empty)(f@(inr( \lambda(t \in T)(f@inl(t)) )))).
  Rlambda.
  Rapply(T + (T -> Empty)).
  Rvar.
  Rinr.
  Rlambda.
  Rapply(T + (T -> Empty)). Rvar.
  Rinl. Rvar.
Qed.

Theorem ex146 : exists_term t, [] |- t \in ((((T -> Empty) -> Empty) -> T) -> Empty) -> Empty.
Proof.
  Ex(\lambda(f \in ((((T -> Empty) -> Empty) -> T) -> Empty))( f@( \lambda(g \in ((T -> Empty) -> Empty))(abort(g@(\lambda(t \in T)(f@(\lambda(g \in ((T -> Empty) -> Empty))t)))))))).
  Rlambda.
  Rapply((((T -> Empty) -> Empty) -> T)). Rvar.
  Rlambda.
  Rabort.
  Rapply(T -> Empty). Rvar.
  Rlambda.
  Rapply((((T -> Empty) -> Empty) -> T)). Rvar.
  Rlambda. Rvar.
Qed.

Theorem ex147 : exists_term t, [] |- t \in ((((T -> S) -> T) -> T) -> Empty) -> Empty.
Proof.
  Ex(\lambda(f \in ((((T -> S) -> T) -> T) -> Empty))(f@( \lambda(g \in (T -> S) -> T)(g@(\lambda(t \in T)(abort(f@(\lambda(g \in ((T -> S) -> T))t))) ) ) ) ) ).
  Rlambda.
  Rapply(((T -> S) -> T) -> T). Rvar.
  Rlambda.
  Rapply(T -> S). Rvar.
  Rlambda.
  Rabort.
  Rapply(((T -> S) -> T) -> T). Rvar.
  Rlambda. Rvar.
Qed.

Theorem ex148 : exists_term t, [] |- t \in ((T -> S) -> T) -> (T -> Empty) -> Empty.
Proof.
  Ex(\lambda(f \in ((T -> S) -> T))(\lambda(g \in T -> Empty)(g@(f@(\lambda(t \in T)(abort(g@t))))))).
  Rlambda.
  Rlambda.
  Rapply(T). Rvar.
  Rapply(T -> S). Rvar.
  Rlambda.
  Rabort.
  Rapply(T). Rvar. Rvar.
Qed.

Theorem ex149 : exists_term t, [] |- t \in (((T -> S) + (S -> T)) -> Empty) -> Empty.
Proof.
  Ex(\lambda(f \in ((T -> S) + (S -> T)) -> Empty)(f@(inl((\lambda(t \in T)(abort(f@(inr(\lambda(s \in S)t))))))))).
  Rlambda.
  Rapply((T -> S) + (S -> T)). Rvar.
  Rinl.
  Rlambda.
  Rabort.
  Rapply((T -> S) + (S -> T)). Rvar.
  Rinr.
  Rlambda. Rvar.
Qed.

Theorem ex150 : exists_term t, [] |- t \in  ((T -> S) -> U) -> ((S + (T -> Empty)) -> U).
Proof.
  Ex(\lambda(f \in (T -> S) -> U)(\lambda(g \in S + (T -> Empty))(f@(\lambda(t \in T)(case(g, (s \in S)s, (h \in T -> Empty)(abort(h@t)))))))).
  Rlambda.
  Rlambda.
  Rapply(T -> S).  Rvar.
  Rlambda.
  Rcase. Rvar. Rvar.
  Rabort.
  Rapply(T). Rvar. Rvar.
Qed.

Inspect 50.


Require Import FcEtt.tactics.
Require Export FcEtt.imports.
Require Import FcEtt.utils.
Require Export FcEtt.fset_facts.

Require Export FcEtt.ett_inf.
Require Export FcEtt.ett_ind.

Require Export FcEtt.beta.
Require Export FcEtt.ext_wf.
Require Import FcEtt.ett_path.
Require Import FcEtt.ext_weak.
Require Import FcEtt.ett_match.
Require Import FcEtt.ett_roleing.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

Generalizable All Variables.

Lemma Ctx_strengthen : forall G1 G2, Ctx (G2 ++ G1) -> Ctx G1.
  induction G2; [ | inversion 1]; simpl; auto.
Qed.

Lemma binds_to_PropWff: forall G0 c phi,
    Ctx G0 ->
    binds c (Co phi) G0 -> PropWff G0 phi.
Proof.
  induction G0; auto; try done.
  intros c phi H H0.
  destruct a.
  destruct s; auto; try done.
  - case H0; try done.
    move => h0.
    inversion H; subst.
    have:   PropWff ( G0) phi .
    apply (IHG0 c phi H4); eauto.
    move => h1.
    rewrite_env (nil ++ [(a, Tm A)] ++ G0).
    eapply PropWff_weakening; eauto.
  - destruct H0; subst.
    inversion H0; subst.
    inversion H; subst.
    rewrite_env (nil ++ [(c, Co phi)] ++ G0).
    eapply PropWff_weakening; eauto.
    rewrite_env (nil ++ [(a, Co phi0)] ++ G0).
    eapply PropWff_weakening; eauto.
    simpl.
    inversion H.
    eapply IHG0; eauto 2.
Qed.

Lemma binds_to_Typing : forall x A G, Ctx G -> binds x (Tm A) G -> Typing G A a_Star.
Proof.
  induction G; auto; try done.
  move=> CTX b.
  destruct a.
  destruct s; auto; try done.
  - inversion CTX. subst.
    case b; try done.
    move => h0.
    inversion h0; subst.
    rewrite_env (nil ++ [(x, Tm A)] ++ G).
    eapply Typing_weakening; eauto.
    move => h1.
    rewrite_env (nil ++ [(a, Tm A0)] ++ G).
    eapply Typing_weakening; eauto.
  - inversion CTX. subst.
    case b; try done.
    move=> h0.
    rewrite_env (nil ++ [(a, Co phi)] ++ G).
    eapply Typing_weakening; eauto.
Qed.

Lemma tm_subst_fresh_1 :
forall G a A a0 x s,
  Typing G a A -> Ctx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x A = A.
Proof.
  intros G a A a0 x s H H0.
  destruct s.
  - apply tm_subst_tm_tm_fresh_eq.
    inversion H0; subst; clear H0.
    show_fresh.
  - apply tm_subst_tm_tm_fresh_eq.
    inversion H0; subst; clear H0.
    show_fresh.
Qed.

(* The second premise is no longer needed. *)
Lemma tm_subst_co_fresh_1 :
forall G a A a0 c s,
  Typing G a A -> Ctx ((c ~ s) ++ G) -> co_subst_co_tm a0 c A = A.
Proof.
  intros G a A a0 x s H H0.
  move: (Typing_context_fv H) => ?. split_hyp.
  apply co_subst_co_tm_fresh_eq.
  fsetdec.
Qed.

Lemma tm_subst_fresh_2 :
forall G a A a0 x s,
  Typing G a A -> Ctx ((x ~ s) ++ G) -> tm_subst_tm_tm a0 x a = a.
Proof.
  intros G a A a0 x s H H0.
  apply tm_subst_tm_tm_fresh_eq.
  inversion H0; subst; auto;
  show_fresh.
Qed.

Lemma tm_subst_co_fresh_2 :
forall G A a0 c s,
  Typing G A a_Star -> Ctx ((c ~ s) ++ G) -> co_subst_co_tm a0 c A = A.
Proof.
  intros G A a0 x s H H0.
  move: (Typing_context_fv H) => ?. split_hyp.
  apply co_subst_co_tm_fresh_eq.
  fsetdec.
Qed.

Lemma co_subst_fresh :
forall G phi  a0 x s,
  PropWff G phi -> Ctx ((x ~ s) ++ G) -> tm_subst_tm_constraint a0 x phi = phi.
Proof.
  intros G phi  a0 x s H H0.
  apply tm_subst_tm_constraint_fresh_eq.
  move: (ProfWff_context_fv H) => ?. split_hyp.
  inversion H0; subst; auto.
Qed.

Lemma bind_map_tm_subst_tm_sort: forall c F A B T x a R,
    binds c (Co (Eq A B T R)) F ->
    binds c (Co (Eq (tm_subst_tm_tm a x A)
                    (tm_subst_tm_tm a x B) (tm_subst_tm_tm a x T) R)) (map (tm_subst_tm_sort a x) F).
Proof.
  induction F; try done.
  destruct a.
  destruct s; auto; try done.
  - intros A0 B T x a0 R0 H.
    right.
    (case H; try done) => h0.
    apply IHF; auto.
  - intros A B T x a0 R0 H.
    case H; auto.
    + inversion 1; subst.
      left; auto.
    + move => h0.
      right.
      apply IHF; auto.
Qed.

Lemma binds_map_4: forall x A F c0,
    binds x (Tm A) F ->
    binds x (Tm (co_subst_co_tm g_Triv c0 A)) (map (co_subst_co_sort g_Triv c0) F).
Proof.
  induction F; try done.
  intros c0 H.
  case H.
  move => h1.
  inversion h1; subst.
  simpl.
  fsetdec.
  move => h0.
  right.
  apply IHF; auto.
Qed.

Lemma binds_map_5: forall c A B T F c1 R,
    binds c (Co (Eq A B T R) ) F ->
    binds c (Co (Eq (co_subst_co_tm g_Triv c1 A) (co_subst_co_tm g_Triv c1 B) (co_subst_co_tm g_Triv c1 T) R) ) (map (co_subst_co_sort g_Triv c1) F).
Proof.
  induction F; try done.
  intros c1 R H.
  case H.
  move => h1; subst.
  simpl.
  fsetdec.
  move => h0.
  right.
  apply IHF; auto.
Qed.

Lemma tm_subst_tm_tm_dom_invariance: forall x a F, dom F = dom (map (tm_subst_tm_sort a x) F).
Proof.
  induction F; eauto; try fsetdec.
  destruct a0.
  simpl.
  rewrite IHF; auto.
Qed.

Lemma subst_rho: forall L G a A x y b rho
    (T : Typing G a A)
    (Neq: x <> y)
    (Fr: y `notin` fv_tm_tm_tm a)
    (Fr2: y `notin` L)
    (K : (forall x, x `notin` L -> RhoCheck rho x (open_tm_wrt_tm b (a_Var_f x)))),
    RhoCheck rho y  (tm_subst_tm_tm a x (open_tm_wrt_tm b (a_Var_f y))).
Proof.
  intros.
  RhoCheck_inversion y; eauto with lngen lc.
Qed.

(* Rewrite the context in to the appropriate form for the induction
   hypothesis (in the cases with binding).
   This rewriting is specific for substitution lemmas.
*)
Ltac rewrite_subst_context :=
  match goal with
  | [ |- context [( (?y ~ ?C (_ _ _ ?T)) ++ map ?sub ?F ++ ?G0)] ] =>
    rewrite_env (map sub ((y ~ (C T)) ++ F) ++ G0)
  | [ |- context [([(?y, ?C (_ _ _ ?T) ?R)] ++ map ?sub ?F ++ ?G0)] ] =>
    rewrite_env (map sub ((y ~ (C T R)) ++ F) ++ G0)
  | [ |- context [( (?y ~ ?C (?D (_ _ _ ?a) (_ _ _ ?b) (_ _ _ ?T) ?R))
                    ++ map ?sub ?F ++ ?G0)] ] =>
    rewrite_env (map sub ((y ~ (C (D a b T R))) ++ F) ++ G0)
  | [ |- context [([(?y, ?C (?D (_ _ _ ?a) (_ _ _ ?b) (_ _ _ ?T) ?R))]
                    ++ map ?sub ?F ++ ?G0)] ] =>
    rewrite_env (map sub ((y ~ (C (D a b T R))) ++ F) ++ G0)
  end.

(*
 These are constructors for the E judgements that
   - do not bind variables
   - are syntax directed
   - are not variables
 Therefore, they are safe to just use in the substitution lemmas
 below.
*)

Ltac eapply_E_subst :=
  first [ eapply E_Star     |
          eapply E_App      |
          eapply E_IApp     |
          eapply E_CApp     |
          eapply E_TApp     |
          eapply E_IsoConv  |
          eapply E_AppCong  |
          eapply E_IAppCong |
          eapply E_TAppCong |
          eapply E_CAppCong |
          eapply E_PiSnd    |
          eapply E_CPiSnd].

Lemma tm_subst_tm_tm_a_App : forall a0 x a nu b,
   tm_subst_tm_tm a0 x (a_App a nu b) = a_App (tm_subst_tm_tm a0 x a) nu (tm_subst_tm_tm a0 x b).
Proof. intros. simpl. auto. Qed.

Lemma tm_subst_tm_tm_apply_pattern_args : forall a0 x pattern_args5 b,
    (tm_subst_tm_tm a0 x (apply_pattern_args b pattern_args5)) =
    (apply_pattern_args (tm_subst_tm_tm a0 x b)
                        (List.map (tm_subst_tm_pattern_arg a0 x) pattern_args5)).
Proof.
  intros a0 x pa. induction pa; intros.
  simpl; auto.
  simpl.
  destruct a. simpl.
  rewrite IHpa. simpl. auto.
  simpl. rewrite IHpa. simpl. auto.
Qed.

Lemma BranchTyping_tm_subst :
      forall G0 n R b B b2 aa B2 B3 C (H : BranchTyping G0 n R b B b2 aa B2 B3 C),
      forall G a A, Typing G a A ->
               forall F x, G0 = (F ++ (x ~ (Tm A)) ++ G) ->
                      BranchTyping (map (tm_subst_tm_sort a x) F ++ G) n R
                                   (tm_subst_tm_tm a x b)
                                   (tm_subst_tm_tm a x B)
                                   (tm_subst_tm_tm a x b2)
                                   (List.map (tm_subst_tm_pattern_arg a x) aa)
                                   (tm_subst_tm_tm a x B2)
                                   (tm_subst_tm_tm a x B3)
                                   (tm_subst_tm_tm a x C).
Proof.
  induction 1; intros; subst; simpl.
  all: try solve [
    cbn; E_pick_fresh y;
    autofresh with y;
    rewrite_subst_context;
    happly H0;
      uha;
      (autorewrite with subst_open_var std using move=>//=);
      move=>//; try fsetdec_fast; eauto 2 with lc;
    case: (y == x) => //; intros; subst; exfalso; fsetdec_fast].

  - autorewrite with subst_open; eauto 3 with lc.
    have LC: lc_tm a0. eauto 3 with lc.
    rewrite tm_subst_tm_tm_apply_pattern_args.
    eapply BranchTyping_Base; eauto 4 using tm_subst_tm_tm_lc_tm.

  Unshelve.
  all: unfold one; try match goal with |- _ = _ => reflexivity end; ea.
Qed.

Lemma tm_substitution_mutual :
   (forall G0 b B (H : Typing G0 b B),
      forall G a A, Typing G a A ->
               forall F x, G0 = (F ++ (x ~ (Tm A)) ++ G) ->
                      Typing (map (tm_subst_tm_sort a x) F ++ G)
                             (tm_subst_tm_tm a x b)
                             (tm_subst_tm_tm a x B)) /\
    (forall G0 phi  (H : PropWff G0 phi),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ (Tm A)) ++ G) ->
                        PropWff (map (tm_subst_tm_sort a x) F ++ G)
                                (tm_subst_tm_constraint a x phi) ) /\
    (forall G0 D p1 p2  (H : Iso G0 D p1 p2 ),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ (Tm A)) ++ G) ->
                Iso (map (tm_subst_tm_sort a x) F ++ G) D
                    (tm_subst_tm_constraint a x p1)
                    (tm_subst_tm_constraint a x p2) ) /\
    (forall G0 D A B T R'' (H : DefEq G0 D A B T R''),
       forall G a A0, Typing G a A0 ->
                 forall F x, G0 = (F ++ (x ~ (Tm A0)) ++ G) ->
                        DefEq (map (tm_subst_tm_sort a x) F ++ G) D
                              (tm_subst_tm_tm a x A)
                              (tm_subst_tm_tm a x B) (tm_subst_tm_tm a x T) R'') /\
    (forall G0 (H : Ctx G0),
        forall G a A, Typing G a A ->
                 forall F x, G0 = (F ++ (x ~ (Tm A)) ++ G) ->
                        Ctx (map (tm_subst_tm_sort a x) F ++ G)).
Proof.
  ext_induction CON;
(*  eapply typing_wff_iso_defeq_mutual; *)
    intros; subst; simpl.
  all: try first [ E_pick_fresh y;
                   autorewrite with subst_open_var; eauto 2 with lc;
                   try rewrite_subst_context; eauto 3 |
                   autorewrite with subst_open; eauto 2 with lc ].
  all: try solve [econstructor; simpl in *; eauto 2].
  all: try eapply_E_subst.
  all: try solve [eapply subst_rho; eauto 2].
  all: try solve [eapply_first_hyp; eauto 2].
  all: try solve [eapply RolePath_subst; eauto 2 with lc].
  all: try solve [eapply DefEq_weaken_available; eauto 2].
  (* 16 *)
  - destruct (x == x0).
    + subst.
      assert (HA: Tm A = Tm A0). eapply binds_mid_eq; eauto.
      inversion HA. subst.
      assert (S : tm_subst_tm_tm a x0 A0 = A0). eapply tm_subst_fresh_1. eauto.
      apply Ctx_strengthen with (G2 := F). eauto.
      rewrite S.
      rewrite_env (nil ++ map (tm_subst_tm_sort a x0) F ++ G0).
      eapply Typing_weakening; eauto 2. simpl_env.
      apply (H _ _ A0); auto.
    + apply binds_remove_mid in b; auto.
      destruct (binds_app_1 _ _ _ _ _ b).
      (* after x *)
      eapply E_Var; eauto 2.
      eapply binds_app_2.
      assert (EQ : tm_subst_tm_sort a x0 (Tm A) = Tm (tm_subst_tm_tm a x0 A)). auto.
      rewrite <- EQ.
      eapply binds_map_2. auto.
      (* before x *)
      eapply E_Var; eauto 2.
      apply Ctx_strengthen in c.
      assert (EQ: tm_subst_tm_tm a x0 A = A). eapply tm_subst_fresh_1.
      eapply E_Var.
      eapply Ctx_strengthen. eauto. eauto. eauto.
      rewrite EQ.
      eauto.
  - (* conversion *)
    eapply E_Conv; try eapply DefEq_weaken_available; eauto 2.
  - (* constants *)
    have h0: Typing nil A a_Star by eauto using toplevel_closed_const.
    eapply E_Const. eauto 2.
    erewrite (tm_subst_fresh_2 _ h0); auto. eauto 2.
    erewrite (tm_subst_fresh_2 _ h0); eauto 2.
  - move: (toplevel_inversion b) => [X [G [B [h1 [h0 [h3 h4]]]]]].
    erewrite (tm_subst_fresh_2 _ t); auto.
    eapply E_Fam; eauto 2.
  - (* E_Case *)
    eapply CON;
      try solve [match goal with H : _ |- _ => eapply H; eauto 3 end].
    all: exactly 1 goal.
    move: BranchTyping_tm_subst.
    move/(_ _ _ _ _ _ (a_Fam F) []) => /=.
    by apply; try ea; try done.
  - (* E_Assn *)
    destruct (c == x).
    + subst.
      apply binds_mid_eq in b0; auto; try done.
    + apply binds_remove_mid in b0; auto.
      destruct (binds_app_1 _ _ _ _ _ b0).
      * apply (E_Assn _ D _ _ _ _ c); auto.
           by apply (H _ _ A0).
           have:  binds c (Co (Eq (tm_subst_tm_tm a0 x a) (tm_subst_tm_tm a0 x b) (tm_subst_tm_tm a0 x A) R)) (map (tm_subst_tm_sort a0 x) F); auto.
           apply bind_map_tm_subst_tm_sort; auto.
       * apply (E_Assn _ D _ _ _ _ c); auto.
           by apply (H _ _ A0).
         have: Ctx ([(x, Tm A0)] ++ G0) by apply (Ctx_strengthen _ F); auto.
         inversion 1; subst.
         have: PropWff G0 (Eq a b A R) by eapply binds_to_PropWff with (c:=c);  auto.
         inversion 1; subst.
         repeat rewrite tm_subst_tm_tm_fresh_eq; auto.
         all: show_fresh.
  - eapply E_Beta; eauto.
    eapply Beta_tm_subst; eauto 2 with lc.
  - autorewrite with open_subst.
    eauto. eauto using Typing_lc1.
  - eapply E_EqConv; eauto 2.
    eapply DefEq_weaken_available; eauto.
  - eapply CON; eauto 3;
      move: BranchTyping_tm_subst;
      move/(_ _ _ _ _ _ (a_Fam F) []);
      apply; try ea; try done.
  - eapply E_LeftRel with (b := tm_subst_tm_tm a0 x b)
                          (b':= tm_subst_tm_tm a0 x b'); eauto 2.
    move: (CasePath_subst_tm x c (Typing_lc H5).1) => h. eauto.
    move: (CasePath_subst_tm x c0 (Typing_lc H5).1) => h. eauto.
    autorewrite with open_subst; eauto 2 with lc.
    autorewrite with open_subst; eauto 2 with lc.
    eapply DefEq_weaken_available; eauto 2.
  - eapply E_LeftIrrel with (b := tm_subst_tm_tm a0 x b)
                          (b':= tm_subst_tm_tm a0 x b'); eauto 2.
    move: (CasePath_subst_tm x c (Typing_lc H5).1) => h. eauto.
    move: (CasePath_subst_tm x c0 (Typing_lc H5).1) => h. eauto.
    autorewrite with open_subst; eauto 2 with lc.
    eapply H3; eauto.
    autorewrite with open_subst; eauto 2 with lc.
    eapply DefEq_weaken_available; eauto 2.
  - eapply E_Right with (a := tm_subst_tm_tm a0 x a)
                        (a':= tm_subst_tm_tm a0 x a'); eauto 2.
    move: (CasePath_subst_tm x c (Typing_lc H5).1) => h. eauto.
    move: (CasePath_subst_tm x c0 (Typing_lc H5).1) => h. eauto.
    eapply H; eauto 2.
    eapply H1; eauto 2.
    autorewrite with open_subst; eauto 2 with lc.
    autorewrite with open_subst; eauto 2 with lc.
    eapply DefEq_weaken_available; eauto 2.
  - eapply E_CLeft; eauto 2.
    move: (CasePath_subst_tm x c (Typing_lc H3).1) => h. eauto.
    move: (CasePath_subst_tm x c0 (Typing_lc H3).1) => h. eauto.
    eapply H; eauto 2.
    eapply H0; eauto 2.
    eapply DefEq_weaken_available; eauto 2.
    replace g_Triv with (tm_subst_tm_co a0 x g_Triv).
    autorewrite with open_subst; eauto 2 with lc.
    auto.
  - destruct  F; try done.
  - induction F; try done.
    simpl; simpl in H2.
    inversion H2; subst; auto.
    destruct a0.
    destruct s.
    + simpl.
      eapply E_ConsTm; auto.
      * simpl in H2.
        inversion H2.
        apply (H _ _ _ H1); auto.
      * simpl in H0.
        inversion H2; subst; clear H2.
        apply (H0 _ _ _ H1); auto.
      * inversion H2; subst; clear H2; auto.
    + inversion H2.
  - inversion H2; subst; clear H2.
    induction F; try done.
    destruct a0.
    destruct s.
    + simpl; subst.
      inversion H4.
    + simpl; subst.
      apply E_ConsCo; auto.
      * apply (H _ _ _ H1); auto.
         inversion H4; auto.
      * inversion H4; subst; clear H4.
        apply (H0 _ _ A); auto.
      * inversion H4; subst; clear H4.
        auto.
   Unshelve. all: try exact Rep.
   all: eauto.
Qed.

Lemma Typing_tm_subst : forall G x A b B (H : Typing ((x ~ Tm A) ++ G) b B),
  forall a, Typing G a A ->
       Typing G (tm_subst_tm_tm a x b) (tm_subst_tm_tm a x B).
Proof.
  intros.
  pose K := @first _ _ _ _ _ tm_substitution_mutual _ b B H G a A H0 nil x.
  clearbody K. simpl in K.
  apply K. auto.
Qed.

Lemma co_subst_rho: forall L x y a rho
    (Neq: x <> y)
    (Fr2: y `notin` L)
    (K : (forall x, x `notin` L -> RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x)))),
    RhoCheck rho y  (co_subst_co_tm g_Triv x (open_tm_wrt_tm a (a_Var_f y))).
Proof.
  intros.
  RhoCheck_inversion y; eauto with lngen lc.
Qed.

Lemma co_subst_rho_g: forall L x y a rho g
    (Neq: x <> y)
    (Fr2: y `notin` L \u fv_tm_tm_co g)
    (LC: lc_co g)
    (K : (forall x, x `notin` L -> RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x)))),
    RhoCheck rho y  (co_subst_co_tm g x (open_tm_wrt_tm a (a_Var_f y))).
Proof.
  intros.
  RhoCheck_inversion y; eauto with lngen lc.
Qed.

Lemma co_subst_rho_g2: forall L x y a rho g
    (Neq: x <> y)
    (Fr2: y `notin` L \u fv_tm_tm_co g)
    (LC: lc_co g)
    (K : (forall x, x `notin` L -> RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x)))),
    RhoCheck rho y (open_tm_wrt_tm (co_subst_co_tm g x a) (a_Var_f y)).
Proof.
  intros.
  RhoCheck_inversion y; eauto with lngen lc.
  replace (a_Var_f y) with (co_subst_co_tm g x (a_Var_f y)).
  autorewrite with open_subst; eauto with lngen lc.
  simpl. auto.
Qed.

Lemma co_subst_co_tm_apply_pattern_args: `{
  co_subst_co_tm g c (apply_pattern_args b pat_args) =
  apply_pattern_args
    (co_subst_co_tm g c b)
    (List.map (co_subst_co_pattern_arg g c) pat_args)}.
Proof.
  intros; move: b.
  induction pat_args; try done; move=> b /=.
  match goal with |- ?T => match T with context ctx [match ?x with | _ => _ end] => destruct x end end.
  all: by rewrite -> IHpat_args.
Qed.

Lemma BranchTyping_co_subst :
      forall G0 n R b B b2 aa B2 B3 C (H : BranchTyping G0 n R b B b2 aa B2 B3 C),
      forall G D A1 A2 T R' F c g,
        G0 = (F ++ (c ~ Co (Eq A1 A2 T R') ) ++ G)
        -> DefEq G D A1 A2 T R'
        -> lc_co g
        -> BranchTyping (map (co_subst_co_sort g c) F ++ G) n R
                                   (co_subst_co_tm g c b)
                                   (co_subst_co_tm g c B)
                                   (co_subst_co_tm g c b2)
                                   (List.map (co_subst_co_pattern_arg g c) aa)
                                   (co_subst_co_tm g c B2)
                                   (co_subst_co_tm g c B3)
                                   (co_subst_co_tm g c C).
Proof.
  induction 1; intros; subst.

  - move: BranchTyping_Base => /=.
    rewrite co_subst_co_tm_apply_pattern_args.
    apply.
    all: try eapply co_subst_co_tm_lc_tm; try done.
    solve_uniq.
    move: co_subst_co_tm_open_tm_wrt_co.
    move/(_ _ _ g_Triv) => /= <- //=.
  - cbn; E_pick_fresh y;
    autofresh with y;
    rewrite_subst_context; auto.
    happly H0.
      (autorewrite with subst_open_var std using move=>//).
      (autorewrite with subst_open_var std using move=>//).
      auto.
      (autorewrite with subst_open_var std using move=>//).
      auto.
    Unshelve.
    all: try simpl_env.
    all: try reflexivity.
    all: eauto 1.
  - cbn; E_pick_fresh y;
    autofresh with y;
    rewrite_subst_context; auto.
    happly H0.
      (autorewrite with subst_open_var std using move=>//).
      (autorewrite with subst_open_var std using move=>//).
      auto.
      (autorewrite with subst_open_var std using move=>//).
      auto.
    Unshelve.
    all: try simpl_env.
    all: try reflexivity.
    all: eauto 1.
  - cbn; E_pick_fresh y;
    autofresh with y;
    rewrite_subst_context; auto.
    happly H0.
      (autorewrite with subst_open_var std using move=>//).
      (autorewrite with subst_open_var std using move=>//).
      auto.
      (autorewrite with subst_open_var std using move=>//).
      auto.
    Unshelve.
    all: try simpl_env.
    all: try reflexivity.
    all: eauto 1.
  - cbn; E_pick_fresh y;
    autofresh with y;
    rewrite_subst_context; auto.
    happly H0.
      (autorewrite with subst_open_var std using move=>//).
      (autorewrite with subst_open_var std using move=>//).
      unhide Fr. auto.
      auto.
      (autorewrite with subst_open_var std using move=>//).
      unhide Fr. auto.
      auto.
    Unshelve.
    all: try simpl_env.
    all: try reflexivity.
    all: eauto 1.
Qed.

Lemma co_substitution_mutual :
    (forall G0 b B (H : Typing G0 b B),
        forall G D A1 A2 T R' F c g,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T R') ) ++ G)
          -> DefEq G D A1 A2 T R'
          -> lc_co g
          -> Typing (map (co_subst_co_sort g c) F ++ G)
                   (co_subst_co_tm g c b) (co_subst_co_tm g c B)) /\
    (forall G0 phi  (H : PropWff G0 phi ),
        forall G D A1 A2 T R' F c g,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T R') ) ++ G)
          -> DefEq G D A1 A2 T R'
          -> lc_co g
          -> PropWff (map (co_subst_co_sort g c) F ++ G) (co_subst_co_constraint g c phi) ) /\
    (forall G0 D0 p1 p2  (H : Iso G0 D0 p1 p2 ),
          forall G D A1 A2 T R' F c g,
            G0 = (F ++ (c ~ Co (Eq A1 A2 T R') ) ++ G)
            -> DefEq G D A1 A2 T R'
            -> lc_co g
            -> Iso (map (co_subst_co_sort g c) F ++ G) (union D (remove c D0))
                    (co_subst_co_constraint g c p1)
                    (co_subst_co_constraint g c p2) ) /\
    (forall G0 D0 A B T R'' (H : DefEq G0 D0 A B T R''),
        forall G D F c A1 A2 T1 R' g,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T1 R') ) ++ G)
          -> DefEq G D A1 A2 T1 R'
          -> lc_co g
          -> DefEq (map (co_subst_co_sort g c) F ++ G) (union D (remove c D0))
                  (co_subst_co_tm g c A) (co_subst_co_tm g c B)
                  (co_subst_co_tm g c T) R'') /\
    (forall G0 (H : Ctx G0),
        forall G D F c A1 A2 T R' g,
          G0 = (F ++ (c ~ Co (Eq A1 A2 T R') ) ++ G)
          -> DefEq G D A1 A2 T R'
          -> lc_co g
          -> Ctx (map (co_subst_co_sort g c) F ++ G)).
Proof.
  ext_induction CON;
  (* adds an assumption to the context saying what branch we are in. *)
  (* apply typing_wff_iso_defeq_mutual; *)
  auto; intros; subst; simpl.
  all: try first [ E_pick_fresh y; autorewrite with subst_open_var; eauto 2 with lc;
                    try rewrite_subst_context; eauto 3
                  | autorewrite with subst_open; eauto 2 with lc ].
  all: try eapply_E_subst; eauto 2.
  all: try solve [eapply (@co_subst_rho_g L); eauto 2].
  all: try solve [eapply_first_hyp; eauto 2; auto].
  all: try solve [eapply RolePath_subst_co; eauto 2 with lc].
  all: try solve [eapply DefEq_weaken_available; eauto 2].

  - apply binds_app_1 in b.
    case:b; try done.
    + move => h0.
      apply E_Var; auto.
      * apply (H _ D _ _ A1 A2 T R'); auto.
      * apply binds_app_2.
        eapply binds_map_2 with (f:= (co_subst_co_sort g c0)) in h0.
        simpl in h0. auto.
    + intros b.
      apply binds_app_1 in b.
      case:b; try solve [move => h0; inversion h0; inversion H0].
      move => h0.
      rewrite co_subst_co_tm_fresh_eq.
      move: (Ctx_uniq c) => u. destruct_uniq.

      have TA: Typing G0 A a_Star. eauto using binds_to_Typing.
      move: (Typing_context_fv TA) => ?. split_hyp. auto.
      apply E_Var; auto.
        by apply (H _ D _ _ A1 A2 T R').
  - eapply E_Conv; eauto 3.
  - (* E_Const *)
    have h0: Typing nil A a_Star by eauto using toplevel_closed_const.
    eapply E_Const. eauto 2. erewrite tm_subst_co_fresh_2; eauto 2.
    erewrite tm_subst_co_fresh_2; eauto 2.
  - (* E_Fam *)
    move: (toplevel_inversion b) => [X [G [B [h1 [h0 [h3 h4]]]]]].
    erewrite (tm_subst_co_fresh_2 _ t); auto.
    eapply E_Fam; eauto 2.
  - (* E_Case *)
    eapply CON; try done;
      try solve [match goal with H : _ |- _ => eapply H; eauto 3 end].
      move: BranchTyping_co_subst => bt.
     happly bt.
     unshelve instantiate (1:= _); [refine (a_Fam _) | reflexivity].
     unshelve instantiate (1:= _); [refine ([]) | reflexivity].
  - eapply E_CPiFst; eauto 3.
    eapply H; eauto.
  -  destruct (binds_cases G0 F c _ c1 _ (Ctx_uniq c0) b0) as [ (bf & NE & Fr) | [(E1 & E2) | (bg & NE & Fr)]].
    + eapply E_Assn; eauto 3.
      apply binds_app_2.
      eapply binds_map_2 with (f := (co_subst_co_sort g c1)) in bf.
      simpl in bf.
      auto.
    + inversion E2. subst. clear E2.
      have: Ctx ([(c1, Co (Eq A1 A2 T1 R'))] ++ G0).
      apply (Ctx_strengthen _ F); auto.
      move => Hi2.
      inversion Hi2; subst; clear Hi2.
      inversion H6; subst; clear H6.
      repeat rewrite co_subst_co_tm_fresh_eq; eauto 2.
      all: try show_fresh. fsetdec. fsetdec.
      rewrite_env (nil ++(map (co_subst_co_sort g c1) F) ++ G0).
      eapply (fourth weaken_available_mutual).
      pose K := DefEq_weakening.
      apply (K _ _ _ _ _ _ H1); eauto 2.
      eapply H; eauto 2. auto.
    + have: Ctx ([(c1, Co (Eq A1 A2 T1 R'))] ++ G0). by apply (Ctx_strengthen _ F); auto.
      move => h2.
      have: Ctx G0 by eapply Ctx_strengthen; eauto. move => h3.
      have: PropWff G0 (Eq a b A R).
      eapply binds_to_PropWff; eauto 1. move => h4.
      inversion h4. subst. clear h4.
      have: c1 `notin` dom G0. inversion h2; auto.
      move => Fr1.
      repeat rewrite co_subst_co_tm_fresh_eq.
      all: try show_fresh. fsetdec. fsetdec.
      eapply E_Assn; eauto 1.
      eapply H; eauto 1.
      eapply binds_app_3; eauto 1.
      eauto.
  - eapply E_Beta; eauto 2.
    eapply Beta_co_subst; eauto.
  - autorewrite with open_subst.
    eauto 2.
    auto.
  - eapply E_PiFst; simpl in *; eauto 3.
  - eapply E_EqConv; eauto 2.
    eapply DefEq_weaken_available; eauto 1.
    eauto 2.
  - eapply E_IsoSnd; eauto 1.
    eapply H; eauto.
  - eapply CON; try done;
      try solve [match goal with H : _ |- _ => eapply H; eauto 3 end];
    move: BranchTyping_co_subst => bt;
    happly bt;
    only 1, 3: (unshelve instantiate (1:= _); [refine (a_Fam _) | reflexivity]);
    do 2 (only 1: unshelve instantiate (1:= _); [refine ([]) | reflexivity]).
  - eapply E_LeftRel with (b := co_subst_co_tm g c1 b) (b':= co_subst_co_tm g c1 b'); eauto 2.
    move: (CasePath_subst_co c1 c H7) => h. eauto.
    move: (CasePath_subst_co c1 c0 H7) => h. eauto.
    autorewrite with open_subst; eauto 2 with lc.
    autorewrite with open_subst; eauto 2 with lc.
    eapply DefEq_weaken_available; eauto 2.

  - eapply E_LeftIrrel with (b := co_subst_co_tm g c1 b)
                              (b':= co_subst_co_tm g c1 b'); eauto 2.
    move: (CasePath_subst_co c1 c H7) => h. eauto.
    move: (CasePath_subst_co c1 c0 H7) => h. eauto.
    autorewrite with open_subst; eauto 2 with lc.
    eapply H3; eauto.
    autorewrite with open_subst; eauto 2 with lc.
    eapply DefEq_weaken_available; eauto 2.
  - eapply E_Right with (a := co_subst_co_tm g c1 a)
                        (a':= co_subst_co_tm g c1 a'); eauto 2.
    move: (CasePath_subst_co c1 c H7) => h. eauto.
    move: (CasePath_subst_co c1 c0 H7) => h. eauto.
    simpl in H. eapply H; eauto 2.
    simpl in H1. eapply H1; eauto 2.
    autorewrite with open_subst; auto.
    simpl in H3. eapply H3; eauto 2.
    autorewrite with open_subst; auto.
    eapply DefEq_weaken_available; eauto 2.
  - eapply E_CLeft; eauto 2.
    move: (CasePath_subst_co c1 c H5) => h. eauto.
    move: (CasePath_subst_co c1 c0 H5) => h. eauto.
    eapply H; eauto 2.
    eapply H0; eauto 2.
    eapply DefEq_weaken_available; eauto 2.
    replace g_Triv with (co_subst_co_co g c1 g_Triv).
    autorewrite with open_subst; eauto 2 with lc.
    auto.
  - induction F; done.
  - induction F; try done.
    destruct a.
    destruct s; try inversion H1.
    + simpl.
      eapply E_ConsTm; auto.
      * simpl in H1.
        inversion H1.
        eapply (H _ D _ _ A1 A2 T R'); eauto.
      * simpl in H0.
        inversion H1; subst; clear H1.
        apply (H0 _ D A1 A2 T R' _ _); auto.
      * inversion H1; subst; clear H1.
        auto.
  - inversion H1; subst; clear H1.
    induction F; try done.
    + inversion H5; subst; clear H5; auto.
    + destruct a.
      destruct s; try inversion H5.
      simpl; subst.
      apply E_ConsCo; auto.
      * apply (H _ D _ _ A1 A2 T R'); auto.
      * inversion H5; subst; clear H5.
         apply (H0 G0 D A1 A2 T R' F c1); auto.

  Unshelve.
  all: unfold one; try match goal with |- _ = _ => reflexivity | |- DefEq _ _ _ _ _ _ => ea end; auto; ea.
Qed.

Lemma Typing_co_subst:
   forall G D c a1 a2 A R' b B (H : Typing (c ~ (Co (Eq a1 a2 A R')) ++ G) b B),
     DefEq G D a1 a2 A R' ->
     Typing G (co_subst_co_tm g_Triv c b) (co_subst_co_tm g_Triv c B).
Proof.
  intros.
  move: (first co_substitution_mutual) => ho.
  eapply ho with (F := nil); eauto.
  simpl; auto.
Qed.

(* -------------------- *)

Lemma Typing_swap : forall x1 x G a A B,
      x1 `notin` fv_tm_tm_tm a \u fv_tm_tm_tm B
    -> x `notin` dom G \u {{ x1 }}
    -> Typing ([(x1, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x1))
             (open_tm_wrt_tm B (a_Var_f x1))
    -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x))
             (open_tm_wrt_tm B (a_Var_f x)).
Proof.
  intros.
  assert (AC: Ctx ((x1 ~ Tm A) ++ G)).
  {apply ctx_wff_mutual in H1. assumption. }
  inversion AC; subst.
  assert (TV : Typing ([(x,Tm A)] ++ G) (a_Var_f x) A).
  { eapply E_Var; eauto 3.
    eapply E_ConsTm; eauto 2. }
  assert (CTX : Ctx ([(x1,Tm A)] ++ [(x, Tm A)] ++ G)).
  { eapply E_ConsTm; eauto 2.
  pose M1 := (Typing_weakening H6 [(x,Tm A)] nil G).
  simpl_env in M1; eapply M1; eauto.
  }
  pose K1 := Typing_weakening H1 [(x,Tm A)] [(x1, Tm A)] G eq_refl CTX;
               clearbody K1.
  pose K2 := Typing_tm_subst K1 TV.
  clearbody K2.
  repeat rewrite tm_subst_tm_tm_open_tm_wrt_tm in K2; auto.
  rewrite tm_subst_tm_tm_var in K2;
  repeat rewrite tm_subst_tm_tm_fresh_eq in K2.
  auto.
  eauto.
  eauto. Unshelve. constructor.
Qed.

Lemma DefEq_swap : forall x1 x G A1 D b1 b2 B R,
   x1 `notin` fv_tm_tm_tm b1 \u fv_tm_tm_tm b2 \u fv_tm_tm_tm B
  -> x `notin` dom G \u {{ x1 }}
  -> DefEq ([(x1, Tm A1)] ++ G) D
          (open_tm_wrt_tm b1 (a_Var_f x1)) (open_tm_wrt_tm b2 (a_Var_f x1))
          (open_tm_wrt_tm B (a_Var_f x1)) R
  -> DefEq ([(x, Tm A1)] ++ G) D
          (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x))
          (open_tm_wrt_tm B (a_Var_f x)) R.
Proof.
  intros.
  assert (AC: Ctx ((x1 ~ Tm A1) ++ G)). eauto.
  inversion AC; subst.
  assert (TV : Typing ([(x,Tm A1)] ++ G) (a_Var_f x) A1).
  { eapply E_Var; eauto 3.
    eapply E_ConsTm; eauto 2. }
  assert (CTX : Ctx ([(x1,Tm A1)] ++ [(x, Tm A1)] ++ G)).
  { eapply E_ConsTm; eauto 2.
  pose M1 := (Typing_weakening H6 [(x,Tm A1)] nil G).
  simpl_env in M1; eapply M1; eauto. }

  move: (DefEq_weakening H1 [(x,Tm A1)] [(x1, Tm A1)] G eq_refl CTX) => K1.
  move: (fourth tm_substitution_mutual _ _ _ _ _ _ K1 _ _ _ TV nil _ eq_refl) => K2.
  simpl_env in K2.
  rewrite -tm_subst_tm_tm_intro in K2; auto.
  rewrite -tm_subst_tm_tm_intro in K2; auto.
  rewrite -tm_subst_tm_tm_intro in K2; auto.
  Unshelve. all: auto.
Qed.

Ltac co_subst_hyp :=
  match goal with
  | [a0 : Typing _ (a_UAbs ?rho ?A1 ?b) _  |-
          Typing _ (a_UAbs ?rho (_ ?A1) (_ ?b)) _ ] =>
      eapply (first co_substitution_mutual _ _ _ a0); eauto
  | [a0 :  Typing _ (a_Pi ?rho ?A1 ?B1) _ |-
           Typing _ (a_Pi ?rho (_ ?A1) (_ ?B1)) _  ] =>
      eapply (first co_substitution_mutual _ _ _ a0); eauto
  | [a0 : Typing _ (a_UCAbs ?phi ?B) _  |- Typing _ (a_UCAbs (_ ?phi) (_ ?B)) _ ] =>
      eapply (first co_substitution_mutual _ _ _ a0); eauto
  | [a0 : Typing _ (a_CPi ?phi ?B) _ |- Typing _ (a_CPi (_ ?phi) (_ ?B)) _ ] =>
    eapply (first co_substitution_mutual _ _ _ a0); eauto
  | [ a0 : Typing _ (a_App ?a1 ?rho ?a2) _ |-
           Typing _ (a_App (_ ?a1) ?rho (_ ?a2)) _ ] =>
    eapply (first co_substitution_mutual _ _ _ a0); eauto
  | [ a0 : Typing _ (a_CApp ?a1 ?g2) _ |- Typing _ (a_CApp (_ ?a1) (_ ?g2)) _ ] =>
    eapply (first co_substitution_mutual _ _ _ a0); eauto
  | [a0 : DefEq _  _  (a_CPi ?phi1 ?B1) (a_CPi ?phi2 ?B2) _  _ |-
     DefEq _ _  (a_CPi (_ ?phi1) _) (a_CPi (_ ?phi2) _) _ _  ] =>
    eapply DefEq_weaken_available;
    eapply (fourth co_substitution_mutual _ _ _ _ _ a0);
    eauto
  | [a0 : PropWff _ (Eq ?a ?b ?A ?R) |- PropWff _ (Eq (_ ?a) (_ ?b) (_ ?A) ?R) ] =>
    eapply (second co_substitution_mutual _ _ a0); eauto
  | [ a0 : Typing _ ?a _ |- Typing _ (_ ?a) _ ] =>
    eapply (first co_substitution_mutual _ _ _ a0); eauto
  | [a0 : DefEq _ _ ?a _ _ _ |- DefEq _ _ (_ ?a) _ _ _ ] =>
      eapply DefEq_weaken_available;
      eapply (fourth co_substitution_mutual _ _ _ _ _ a0);
      eauto
  end.

Ltac prepare_env :=
  match goal with
    | [ |- context[ (?x' ~ (?S (?sub ?a1 ?x ?A))) ++ map (?tm_subst_tm_sort ?a1 ?x) ?F ++ ?G ] ] =>
    rewrite app_assoc;
    replace (x' ~ (S (sub a1 x A)) ++  map (co_subst_co_sort a1 x) F) with
    (map (co_subst_co_sort a1 x) (x' ~ S A ++ F)); eauto 2 using map_app
    | [ |- context[ (?x' ~ (?S (Eq (?sub ?a) (?sub ?b) (?sub ?A) ?R))) ++ map (?tm_subst_tm_sort ?a1 ?x) ?F ++ ?G ] ] =>
    rewrite app_assoc;
    replace (x' ~ (S (Eq (sub a) (sub b) (sub A) R)) ++  map (co_subst_co_sort a1 x) F) with
    (map (co_subst_co_sort a1 x) (x' ~ S (Eq a b A R) ++ F)); eauto 2 using map_app

  end.

(* The co_swap version needs a special version of the
   substitution lemma. *)

Lemma co_substitution_mutual2 :
    (forall G0 b B, Typing G0 b B -> True) /\
    (forall G0 phi, PropWff G0 phi -> True) /\
    (forall G0 D0 p1 p2 (H : Iso G0 D0 p1 p2),
        forall D G g A1 A2 A3 R F c, G0 = (F ++ (c ~ Co (Eq A1 A2 A3 R)) ++ G)
                              -> DefEq G D A1 A2 A3 R
                              -> lc_co g
                              -> c `notin` D0
                              -> Iso (map (co_subst_co_sort g c) F ++ G)
                                       D0
                                       (co_subst_co_constraint g c p1)
                                       (co_subst_co_constraint g c p2)) /\
    (forall G0 D0 a b A R1 (H : DefEq G0 D0 a b A R1),
        forall G D g F c A1 A2 A3 R, G0 = (F ++ (c ~ Co (Eq A1 A2 A3 R)) ++ G)
                              -> DefEq G D A1 A2 A3 R
                              -> lc_co g
                              -> c `notin` D0
                              -> DefEq (map (co_subst_co_sort g c) F ++ G) D0
                                         (co_subst_co_tm g c a)
                                         (co_subst_co_tm g c b)
                                         (co_subst_co_tm g c A) R1) /\
    (forall G0, Ctx G0 -> True).
Proof.
  ext_induction CON;
  (* adds an assumption to the context saying what branch we are in. *)
  (* apply typing_wff_iso_defeq_mutual; *)
  intros; subst; auto.

  all: simpl co_subst_co_tm in *;
       simpl co_subst_co_co in *;
       simpl co_subst_co_constraint in *.

  all: match goal with
         [H1 : DefEq ?G0 ?D ?A1 ?A2 ?A3 ?R |- _ ] =>
         move: (DefEq_lc H1) => [? [? ?]] end.

  all: try (E_pick_fresh x'; eauto 2; try (have neq: c <> x' by fsetdec_fast)).

  all: (* rho check *)
      try (apply (@co_subst_rho_g2 L); auto).

  all: (* substitution dance for the body *)
       try (autorewrite with subst_open_var; auto;
            rewrite_body;
            autorewrite with subst_open; auto;
            try (simpl; case: (x' == c) => [?|//]; by subst)).

  all: try (prepare_env; repeat autorewrite with subst_open_var => //;
       eauto using app_assoc).

  all: try (autorewrite with open_subst; eauto 2;
            eapply DefEq_weaken_available; eauto 2).

  all: try co_subst_hyp.

  all: try (autorewrite with subst_open; auto).

  all: try solve [eapply CON; eauto 2; try co_subst_hyp].

  - simpl; simpl in H.
    apply binds_app_1 in b0.
    case:b0; try done.
    + move => h0.
      * eapply E_Assn; eauto 2.
        eapply (fifth co_substitution_mutual); eauto.
        apply binds_app_2.
        apply binds_map with (f:= co_subst_co_sort g c1) in h0; eauto.
    + move => h0.
      destruct (eq_dec c c1); first subst c1. done.
      destruct (binds_app_1 _ c _ _ _ h0).
      pose K := ( binds_one_1 _ _ _ _ _ H0). done.
      eapply E_Assn; eauto 2.
      eapply (fifth co_substitution_mutual); eauto 1.
      assert (c1 `notin` dom G0).
      eapply fresh_mid_tail. eapply Ctx_uniq. eauto 1.
      assert (PropWff G0 (Eq a b A R)).
      eapply binds_to_PropWff; eauto 1.
      eapply Ctx_strengthen.
      eapply Ctx_strengthen. eauto 2.
      inversion H5. subst.
      move: (Typing_context_fv H10) => ?.
      move: (Typing_context_fv H12) => ?.
      split_hyp.
      rewrite co_subst_co_tm_fresh_eq; auto. fsetdec.
      apply binds_app_3; eauto.
      rewrite co_subst_co_tm_fresh_eq.
      fsetdec.
      rewrite co_subst_co_tm_fresh_eq.
      fsetdec.
      auto.
  - eapply E_Beta; try co_subst_hyp; eauto.
    eapply Beta_co_subst; auto.
  - eapply E_TAppCong; eauto 2.
    eapply RolePath_subst_co; eauto.
    eapply RolePath_subst_co; eauto.
    autorewrite with open_subst.
    co_subst_hyp.
    auto.
  - eapply (first co_substitution_mutual _ _ _ t); eauto.
  - eapply (first co_substitution_mutual _ _ _ t0); eauto.
  - eapply (second co_substitution_mutual _ _ p); eauto.
  - eapply E_CAppCong; eauto 2.
    autorewrite with open_subst.
    eapply DefEq_weaken_available.
    eapply (fourth co_substitution_mutual _ _ _ _ _ _ d0); eauto.
  - simpl. eapply CON; eauto 2.
    eapply DefEq_weaken_available.
    eapply (fourth co_substitution_mutual _ _ _ _ _ _ d0); eauto.
    eapply DefEq_weaken_available.
    eapply (fourth co_substitution_mutual _ _ _ _ _ _ d1); eauto.
  - eapply CON; eauto 2.
    eapply DefEq_weaken_available.
    eapply (fourth co_substitution_mutual _ _ _ _ _ _ d0); eauto.
    co_subst_hyp.
  - eapply CON; eauto 2.
    replace nil with (List.map (co_subst_co_pattern_arg g c) nil); auto.
    replace (a_Fam F) with (co_subst_co_tm g c (a_Fam F)); try auto.
    eapply BranchTyping_co_subst; eauto 2.
    replace nil with (List.map (co_subst_co_pattern_arg g c) nil); auto.
    replace (a_Fam F) with (co_subst_co_tm g c (a_Fam F)); try auto.
    eapply BranchTyping_co_subst; eauto 2.
    replace (a_Fam F) with (co_subst_co_tm g c (a_Fam F)); try auto.
    co_subst_hyp.
  - eapply CON; eauto 2.
    eapply (CasePath_subst_co _ c); auto.
    eapply (CasePath_subst_co _ c0); auto.
    all: try co_subst_hyp.
    all: fold co_subst_co_tm.
    autorewrite with open_subst; auto.
    eapply H3; eauto 2.
    replace a_Star with (co_subst_co_tm g c1 a_Star).
    autorewrite with open_subst; auto.
    eapply DefEq_weaken_available.
    eapply (fourth co_substitution_mutual _ _ _ _ _ _ d0); eauto.
    auto.
  - eapply CON; eauto 2.
    eapply (CasePath_subst_co _ c); auto.
    eapply (CasePath_subst_co _ c0); auto.
    all: try co_subst_hyp.
    eapply (first co_substitution_mutual _ _ _ t0); eauto.
    eapply (first co_substitution_mutual _ _ _ t2); eauto.
    autorewrite with open_subst; auto.
    eapply H3; eauto 2.
    eapply DefEq_weaken_available.
    autorewrite with open_subst; auto.
    replace a_Star with (co_subst_co_tm g c1 a_Star).
    eapply (fourth co_substitution_mutual _ _ _ _ _ _ d0); eauto.
    reflexivity.
  - eapply CON; eauto 2.
    eapply (CasePath_subst_co _ c); auto.
    eapply (CasePath_subst_co _ c0); auto.
    all: try co_subst_hyp.
    all: fold co_subst_co_tm.
    autorewrite with open_subst; auto.
    eapply H3; eauto 2.
    eapply DefEq_weaken_available.
    autorewrite with open_subst; auto.
    replace a_Star with (co_subst_co_tm g c1 a_Star).
    eapply (fourth co_substitution_mutual _ _ _ _ _ _ d0); eauto.
    reflexivity.
  - eapply CON; eauto 2.
    eapply (CasePath_subst_co _ c); auto.
    eapply (CasePath_subst_co _ c0); auto.
    all: try co_subst_hyp.
    all: fold co_subst_co_tm.
    eapply DefEq_weaken_available.
    eapply (fourth co_substitution_mutual _ _ _ _ _ _ d); eauto.
    replace (open_tm_wrt_co (co_subst_co_tm g c1 B) g_Triv) with
        (co_subst_co_tm g c1 (open_tm_wrt_co B g_Triv)).
    eapply H2; eauto 2.
    autorewrite with subst_open. simpl. auto. auto.
Unshelve.
  all: try eauto 1.
Qed.

Lemma DefEq_swap_co : forall x1 x G phi D b1 b2 B R,
   x1 `notin` fv_co_co_tm b1 \u fv_co_co_tm b2 \u fv_co_co_tm B \u dom G \u D
  -> x `notin` dom G \u {{ x1 }}
  -> DefEq ([(x1, Co phi)] ++ G) D
          (open_tm_wrt_co b1 (g_Var_f x1)) (open_tm_wrt_co b2 (g_Var_f x1))
          (open_tm_wrt_co B (g_Var_f x1)) R
  -> DefEq ([(x, Co phi)] ++ G) D
          (open_tm_wrt_co b1 (g_Var_f x)) (open_tm_wrt_co b2 (g_Var_f x))
          (open_tm_wrt_co B (g_Var_f x)) R.
Proof.
  intros.

  destruct phi as [a0 b0 A0 R0].
  assert (AC: Ctx ((x ~ Co (Eq a0 b0 A0 R0) ++ G))).
  move: (DefEq_Ctx H1) => h0. inversion h0. eauto.
  inversion AC; subst.

  assert (TV : DefEq ([(x,Co (Eq a0 b0 A0 R0))] ++ G)
                   (dom ([(x,Co (Eq a0 b0 A0 R0))] ++ G)) a0 b0 A0 R0).
  { eapply E_Assn; eauto 3.
    simpl. auto. }
  assert (CTX : Ctx ([(x1,Co (Eq a0 b0 A0 R0))] ++ [(x, Co (Eq a0 b0 A0 R0))] ++ G)).
  { eapply E_ConsCo; eauto 2.
  with PropWff do ltac:(fun h =>
    pose M1 := (PropWff_weakening h [(x,Co (Eq a0 b0 A0 R0))] nil G)).
  simpl_env in M1; eapply M1; eauto. }

  move: (DefEq_weakening H1 [(x,Co (Eq a0 b0 A0 R0))]
                            [(x1, Co (Eq a0 b0 A0 R0))] G eq_refl CTX) => K1.
  move: (fourth co_substitution_mutual2 _ _ _ _ _ _ K1
                ([(x,Co (Eq a0 b0 A0 R0))] ++ G) _ (g_Var_f x)
                nil x1 _ _ _ _  eq_refl TV ltac:(auto)) => K2.
  simpl_env in K2.
  rewrite -co_subst_co_tm_intro in K2; auto.
  rewrite -co_subst_co_tm_intro in K2; auto.
  rewrite -co_subst_co_tm_intro in K2; auto.
Qed.

Lemma BranchTyping_swap : forall x1 x G a b A A1 B C C' Apps args,
      x1 `notin` fv_tm_tm_tm a \u fv_tm_tm_tm b \u fv_tm_tm_tm A1 \u dom G
                  \u fv_tm_tm_tm C' \u fv_tm_tm_tm B \u fv_tm_tm_tm C
    -> Typing G A a_Star
    -> x `notin` dom G \u {{ x1 }}
    -> BranchTyping ([(x1, Tm A)] ++ G) Apps Nom a A1 b
                   args
                   (open_tm_wrt_tm B (a_Var_f x1))
                   (open_tm_wrt_tm C (a_Var_f x1))
                   C'
    -> BranchTyping ([(x, Tm A)] ++ G) Apps Nom a A1 b
                   (List.map (tm_subst_tm_pattern_arg (a_Var_f x) x1) args)
                   (open_tm_wrt_tm B (a_Var_f x))
                   (open_tm_wrt_tm C (a_Var_f x))
                   C'.
Proof.
  intros.
  assert (AC: Ctx ((x1 ~ Tm A) ++ G)). constructor; eauto.
  inversion AC; subst.
  assert (TV : Typing ([(x,Tm A)] ++ G) (a_Var_f x) A).
  { eapply E_Var; eauto 3.
    eapply E_ConsTm; eauto 2. }
  assert (CTX : Ctx ([(x1,Tm A)] ++ [(x, Tm A)] ++ G)).
  { eapply E_ConsTm; eauto 2.
  with (Typing G A a_Star) do ltac:(fun h =>
    pose M1 := (Typing_weakening h [(x,Tm A)] nil G)).
  simpl_env in M1; eapply M1; eauto. }

  with BranchTyping do ltac:(fun h =>
     move: (BranchTyping_weakening h [(x,Tm A)] [(x1, Tm A)] G eq_refl (Ctx_uniq CTX)) => K1).
  move: (BranchTyping_tm_subst K1 TV nil x1 eq_refl) => K2.
  simpl_env in K2.
  rewrite (tm_subst_tm_tm_fresh_eq a) in K2; auto.
  rewrite (tm_subst_tm_tm_fresh_eq A1) in K2; auto.
  rewrite (tm_subst_tm_tm_fresh_eq b) in K2; auto.

  rewrite -tm_subst_tm_tm_intro in K2; auto.
  rewrite -tm_subst_tm_tm_intro in K2; auto.
  rewrite (tm_subst_tm_tm_fresh_eq C') in K2; auto.
  Unshelve. all: try exact Rep.
Qed.

Lemma BranchTyping_swap_co : forall x1 x G a b A1 B C C' Apps args phi,
      x1 `notin` fv_co_co_tm a \u fv_co_co_tm b \u fv_co_co_tm A1 \u dom G
                  \u fv_co_co_tm C' \u fv_co_co_tm B \u fv_co_co_tm C
    -> PropWff G phi
    -> x `notin` dom G \u {{ x1 }}
    -> BranchTyping ([(x1, Co phi)] ++ G) Apps Nom a A1 b
                   args
                   (open_tm_wrt_co B (g_Var_f x1))
                   (open_tm_wrt_co C (g_Var_f x1))
                   C'
    -> BranchTyping ([(x, Co phi)] ++ G) Apps Nom a A1 b
                   (List.map (co_subst_co_pattern_arg (g_Var_f x) x1) args)
                   (open_tm_wrt_co B (g_Var_f x))
                   (open_tm_wrt_co C (g_Var_f x))
                   C'.
Proof.
  intros.
  destruct phi as [a0 b0 A0 R0].
  assert (AC: Ctx ((x ~ Co (Eq a0 b0 A0 R0) ++ G))). constructor; eauto.
  inversion AC; subst.

  assert (TV : DefEq ([(x,Co (Eq a0 b0 A0 R0))] ++ G)
                   (dom ([(x,Co (Eq a0 b0 A0 R0))] ++ G)) a0 b0 A0 R0).
  { eapply E_Assn; eauto 3.
    simpl. auto. }
  assert (CTX : Ctx ([(x1,Co (Eq a0 b0 A0 R0))] ++ [(x, Co (Eq a0 b0 A0 R0))] ++ G)).
  { eapply E_ConsCo; eauto 2.
  with PropWff do ltac:(fun h =>
    pose M1 := (PropWff_weakening h [(x,Co (Eq a0 b0 A0 R0))] nil G)).
  simpl_env in M1; eapply M1; eauto. }

  with BranchTyping do ltac:(fun h =>
     move: (BranchTyping_weakening h [(x,Co (Eq a0 b0 A0 R0))] [(x1, Co (Eq a0 b0 A0 R0))] G eq_refl (Ctx_uniq CTX)) => K1).
  move: (BranchTyping_co_subst K1) => K2.
  move: (@K2 ([(x,Co (Eq a0 b0 A0 R0))] ++ G)
              (dom ([(x,Co (Eq a0 b0 A0 R0))] ++ G)) a0 b0 A0 R0 nil x1 (g_Var_f x)) => K3.

  move: (K3 eq_refl TV ltac:(auto)) => K4.
  rewrite (co_subst_co_tm_fresh_eq a) in K4; auto.
  rewrite (co_subst_co_tm_fresh_eq A1) in K4; auto.
  rewrite (co_subst_co_tm_fresh_eq b) in K4; auto.
  rewrite -co_subst_co_tm_intro in K4; auto.
  rewrite -co_subst_co_tm_intro in K4; auto.
  rewrite (co_subst_co_tm_fresh_eq C') in K4; auto.
Qed.

Lemma tm_subst_tm_pattern_args_fresh_eq : forall args x a,
  x `notin` fv_tm_tm_pattern_args args
  → List.map (tm_subst_tm_pattern_arg a x) args = args.
Proof.
  induction args. simpl; auto.
  intros. simpl in *.
  f_equal; auto.
  destruct a; simpl in *.
  rewrite tm_subst_tm_tm_fresh_eq; auto.
  rewrite tm_subst_tm_co_fresh_eq; auto.
Qed.

Lemma co_subst_co_pattern_args_fresh_eq : forall args x a,
  x `notin` fv_co_co_pattern_args args
  → List.map (co_subst_co_pattern_arg a x) args = args.
Proof.
  induction args. simpl; auto.
  intros. simpl in *.
  f_equal; auto.
  destruct a; simpl in *.
  rewrite co_subst_co_tm_fresh_eq; auto.
  rewrite co_subst_co_co_fresh_eq; auto.
Qed.

Lemma  BranchTyping_PiRole_exists : forall x,
   `{
      BranchTyping (x ~ Tm A ++ G) Apps5 Nom a A1 b
                 (pattern_args5 ++ one (p_Tm (Role R) (a_Var_f x)))
                 (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm C (a_Var_f x)) C'
    -> x `notin` fv_tm_tm_tm A \u dom G \u fv_tm_tm_tm a \u fv_tm_tm_tm A1
             \u fv_tm_tm_tm b \u fv_tm_tm_pattern_args pattern_args5
             \u fv_tm_tm_tm B \u fv_tm_tm_tm C \u fv_tm_tm_tm C'
    -> Typing G A a_Star
    -> BranchTyping G (A_cons (A_Tm (Role R)) Apps5) Nom a A1 b pattern_args5
                      (a_Pi Rel A B) (a_Pi Rel A C) C' }.
Proof.
  intros.
  pick fresh y and apply BranchTyping_PiRole; auto.
  replace (pattern_args5 ++ one (p_Tm (Role R) (a_Var_f y))) with
        (List.map (tm_subst_tm_pattern_arg (a_Var_f y) x)
                  (pattern_args5 ++ one (p_Tm (Role R) (a_Var_f x)))).
  eapply BranchTyping_swap; auto.
  rewrite map_app.
  simpl.
  case h: (x == x); try done.
  f_equal.
  rewrite tm_subst_tm_pattern_args_fresh_eq; auto.
Qed.

Lemma BranchTyping_PiRel_exists : forall x,
   `{ BranchTyping (x ~ Tm A ++ G) Apps5 Nom a A1 b
                 (pattern_args5 ++ one (p_Tm (Rho Rel) (a_Var_f x)))
                 (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm C (a_Var_f x)) C'
   -> x `notin` fv_tm_tm_tm A \u dom G \u fv_tm_tm_tm a \u fv_tm_tm_tm A1
             \u fv_tm_tm_tm b \u fv_tm_tm_pattern_args pattern_args5
             \u fv_tm_tm_tm B \u fv_tm_tm_tm C \u fv_tm_tm_tm C'
   -> Typing G A a_Star
   -> BranchTyping G (A_cons (A_Tm (Rho Rel)) Apps5) Nom a A1 b pattern_args5
    (a_Pi Rel A B) (a_Pi Rel A C) C'}.
Proof.
  intros.
  pick fresh y and apply BranchTyping_PiRel; auto.
  replace (pattern_args5 ++ one (p_Tm (Rho Rel) (a_Var_f y))) with
        (List.map (tm_subst_tm_pattern_arg (a_Var_f y) x)
                  (pattern_args5 ++ one (p_Tm (Rho Rel) (a_Var_f x)))).
  eapply BranchTyping_swap; auto.
  rewrite map_app.
  simpl.
  case h: (x == x); try done.
  f_equal.
  rewrite tm_subst_tm_pattern_args_fresh_eq; auto.
Qed.

Lemma BranchTyping_PiIrrel_exists: forall x,
  `{  BranchTyping (x ~ Tm A ++ G) Apps5 Nom a A1 b
                 (pattern_args5 ++ one (p_Tm (Rho Irrel) a_Bullet))
                 (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm C (a_Var_f x)) C'
  -> x `notin` fv_tm_tm_tm A \u dom G \u fv_tm_tm_tm A1 \u fv_tm_tm_tm a
             \u fv_tm_tm_tm b \u fv_tm_tm_pattern_args pattern_args5
             \u fv_tm_tm_tm B \u fv_tm_tm_tm C \u fv_tm_tm_tm C'
    -> Typing G A a_Star
    -> BranchTyping G (A_cons (A_Tm (Rho Irrel)) Apps5) Nom a A1 b pattern_args5
    (a_Pi Irrel A B) (a_Pi Irrel A C) C' }.
Proof.
 intros.
  pick fresh y and apply BranchTyping_PiIrrel; auto.
  replace (pattern_args5 ++ one (p_Tm (Rho Irrel) a_Bullet)) with
        (List.map (tm_subst_tm_pattern_arg (a_Var_f y) x)
                  (pattern_args5 ++ one (p_Tm (Rho Irrel) a_Bullet))).
  eapply BranchTyping_swap; auto.
  rewrite map_app.
  simpl.
  case h: (x == x); try done.
  f_equal.
  rewrite tm_subst_tm_pattern_args_fresh_eq; auto.
Qed.

Lemma BranchTyping_CPi_exists : forall c,
    `{ BranchTyping (c ~ Co phi ++ G) Apps5 Nom a A
                    b (pattern_args5 ++ one (p_Co g_Triv))
                    (open_tm_wrt_co B (g_Var_f c))
                    (open_tm_wrt_co C (g_Var_f c)) C'
     -> c `notin`
           union (fv_co_co_tm a)
            (union (fv_co_co_tm b)
               (union (fv_co_co_tm A)
                  (union (dom G)
                     (union (fv_co_co_tm C') (union (fv_co_co_tm B)
                                               (union (fv_co_co_pattern_args pattern_args5)     (fv_co_co_tm C)))))))
     -> PropWff G phi
     -> BranchTyping G (A_cons A_Co Apps5) Nom a A b pattern_args5
        (a_CPi phi B) (a_CPi phi C) C'}.
Proof.
  intros.
  pick fresh y and apply BranchTyping_CPi; auto.
  replace (pattern_args5 ++ one (p_Co g_Triv)) with
        (List.map (co_subst_co_pattern_arg (g_Var_f y) c)
                  (pattern_args5 ++ one (p_Co g_Triv))).
  eapply BranchTyping_swap_co; auto.
  rewrite map_app.
  simpl.
  rewrite co_subst_co_pattern_args_fresh_eq; auto.
Qed.

(* -------------------- *)

Lemma E_Pi_exists : forall x (G : context) (rho : relflag) (A B : tm),
      x `notin` dom G \u fv_tm_tm_tm B
      -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm B (a_Var_f x)) a_Star
      -> Typing G A a_Star
      -> Typing G (a_Pi rho A B) a_Star.
Proof.
  intros.
  pick fresh y and apply E_Pi; auto.
  replace a_Star with (open_tm_wrt_tm a_Star (a_Var_f y)); auto.
  eapply Typing_swap; eauto.
Qed.

Lemma E_Abs_exists :  forall x (G : context) (rho : relflag) (a A B : tm),
    x `notin` fv_tm_tm_tm a \u fv_tm_tm_tm B
    -> Typing ([(x, Tm A)] ++ G) (open_tm_wrt_tm a (a_Var_f x))
                 (open_tm_wrt_tm B (a_Var_f x))
    -> Typing G A a_Star
    -> RhoCheck rho x (open_tm_wrt_tm a (a_Var_f x))
    -> Typing G (a_UAbs rho a) (a_Pi rho A B).
Proof.
  intros.
  pick fresh y and apply E_Abs; eauto 2.
  eapply (@Typing_swap x); eauto.
  eapply rho_swap with (x := x); eauto.
Qed.


Require Export Base.

Class Galois (A A' : Type) : Type :=  γ : A -> ℘ A'.
Arguments γ : simpl never.
Hint Unfold γ : soundness.

Ltac gamma_destruct := repeat
  match goal with
  | x : γ _  _ |- _ => inv x
  end.
Hint Extern 0 (γ _ _) => progress gamma_destruct : soundness.

Definition gamma_bot (A A' : Type) `{Galois A A'} : (A+⊥) → A' → Prop :=
  λ a : A+⊥, match a with
             | Bot => λ _, False
             | NotBot x => λ y, γ x y
             end.

Instance galois_bot : ∀ (A A' : Type),
  Galois A A' → Galois (A+⊥) A' := gamma_bot.

Definition gamma_top (A A' : Type) `{Galois A A'} : (A+⊤) → ℘ A' :=
  λ a : A+⊤, match a with
             | Top => λ _, True
             | NotTop x => λ y, γ x y
             end.
Instance galois_top : ∀  (A A' : Type), Galois A A' → Galois (A+⊤) A' :=
  gamma_top.

Definition gamma_fun {A A' B B' : Type} {GA : Galois A A'} {GB : Galois B B'}
  : (A → B) → (A' → B') → Prop := λ (f : A → B), λ (g : A' → B'),
    ∀ (a : A) (a' : A'), γ a a' → γ (f a) (g a').
Arguments gamma_fun A A' {B B'} {GA GB}.

Instance galois_fun : ∀ (A A' : Type) {B B' : Type},
  Galois A A' →
  Galois B B' →
  Galois (A → B) (A' → B') := gamma_fun.
Hint Unfold galois_fun gamma_fun : soundness.

Instance galois_unit : Galois unit unit := λ _, λ _, True.
Hint Unfold galois_unit : soundness.

Inductive gamma_pairs {A A' B B' : Type} {GA : Galois A A'} {GB : Galois B B'}
: prod A B → prod A' B' → Prop :=
    | gamma_pairs_cons : ∀ p q,
        γ (fst p) (fst q) → γ (snd p) (snd q) → gamma_pairs p q.
Arguments gamma_pairs A A' B B' {GA GB}.
Hint Constructors gamma_pairs : soundness.

Instance galois_pairs : ∀ A A' B B' : Type,
  Galois A A' →
  Galois B B' →
  Galois (A*B)%type (A'*B')%type := gamma_pairs.
Hint Unfold galois_pairs : soundness.

Lemma fst_sound : ∀ (A A' : Type) {GA : Galois A A'} {B B' : Type} {GB : Galois B B'}
  (p : A*B) (q : A'*B'),
  γ p q →
  γ (fst p) (fst q).
Proof.
  intros. destruct p eqn:Hp, q eqn:Hq; simpl. inversion H. subst.
  simpl in *. assumption.
Qed.

Corollary snd_sound : ∀ (A A' : Type) {GA : Galois A A'} {B B' : Type} {GB : Galois B B'}
  (p : A*B) (q : A'*B'),
  γ p q →
  γ (snd p) (snd q).
Proof.
  intros. destruct p, q; simpl. inversion H. subst. simpl in *. assumption.
Qed.

Definition gamma_sum {A A' B B'} {GA : Galois A A'} {GB : Galois B B'} :
    (A+B) → ℘ (A'+B') := λ s, λ s',
      match s, s' with
      | inl x, inl y => γ x y
      | inr x, inr y => γ x y
      | _, _ => False
      end.
Arguments gamma_sum A A' B B' {GA GB}.

Instance galois_sum : ∀ (A A' B B' : Type),
  Galois A A' →
  Galois B B' →
  Galois (A+B) (A'+B') := gamma_sum.

Definition gamma_identity {A A'} {GA : Galois A A'} (ia : Identity A)
                            (ia' : Identity A') : Prop :=
    match ia, ia' with
    | identity a, identity a' => γ a a'
    end.
Arguments gamma_identity A A' {GA} ia ia'.

Instance galois_identity : ∀ (A A' : Type),
  Galois A A' →
  Galois (Identity A) (Identity A') :=
    gamma_identity.

Class extract_op (A B : Type) : Type := extract : A → B.

Class extract_op_sound {A B B' : Type} {GB : Galois B B'}
  (EO : extract_op A B) (EO' : extract_op A B') : Prop :=
  extract_sound :  ∀ a, γ (extract a) (extract a).
Hint Resolve extract_sound : soundness.

Instance extract_nat : extract_op nat nat := id.
Instance extract_bool : extract_op bool bool := id.

Instance extract_sum {A B C D : Type}
  (EA : extract_op A C) (EB : extract_op B D) : extract_op (A+B) (C+D) :=
    λ v,
      match v with
      | inl x => inl (extract x)
      | inr x => inr (extract x)
      end.

Instance extract_sum_sound {A B C C' D D'}
  {GC : Galois C C'} {GD : Galois D D'}
  {EA : extract_op A C} {EA' : extract_op A C'}
  {EB : extract_op B D} {EB' : extract_op B D'} :
  extract_op_sound EA EA' → extract_op_sound EB EB' →
  extract_op_sound (extract_sum EA EB) (extract_sum EA' EB').
Proof.
  intros EAS EBS.
  intro p; destruct p; apply EAS + apply EBS.
Qed.
Hint Resolve extract_sum_sound : soundness.

Instance extract_top {A B : Type}
  (EA : extract_op A B) : extract_op A (B+⊤) := λ a, NotTop (extract a).

Instance extract_top_sound {A B B'} {GB : Galois B B'}
  {EA : extract_op A B} {EA' : extract_op A B'} :
  extract_op_sound EA EA' →
  extract_op_sound (extract_top EA) EA'.
Proof. intro EAS; apply EAS. Qed.
Hint Resolve extract_top_sound : soundness.


(** * RIS.nominalsetoid : Nominal sets up-to equivalence. *)

Require Import tools atoms PeanoNat Nat bijection.

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

(** * Definitions *)
Section s.
  (** We fix a decidable set of atoms. *)
  Context {atom : Set}{A : Atom atom}.

  (** We use the notation [π ⊙ x] for the group action of a nominal setoid, and [⌈x⌉] for its support. *)
  Class ActionSetoid (X : Set) := actoid : perm -> X -> X.
  Infix " ⊙ " := actoid (at level 50).
  Class SupportSetoid {A : Atom atom} (X : Set) := suppoid : X -> list atom.
  Notation " ⌈ x ⌉ " := (suppoid x).

  (** A nominal setoid is a set [X] equipped with a relation [≃], an action [⊙] and a support function [⌈_⌉] satisfying the following axioms: *)
  Class NominalSetoid (X : Set) (equiv : SemEquiv X) (act : ActionSetoid X)
        (supp : SupportSetoid X) :=
    {
      (** [≃] is an equivalence relation; *)
      eq_equivalence :> Equivalence sequiv;
     (** equivalent elements have equivalent support : if [x≃y], then [a∈⌈x⌉ <-> a∈⌈y⌉]; *)
      eq_support :> Proper (sequiv ==> (@equivalent atom)) suppoid;
      (** the action in compatible with the equivalence relation ; *)
      eq_act_proper π :> Proper (sequiv ==> sequiv) (actoid π);
      (** the remaining axioms are the same as for nominal sets, except that equality of elements in [X] has been substituted with [≃]. *)
      action_invariant_eq : forall (x : X) π, (π ∙ ⌈x⌉ = ⌈x⌉) -> (π ⊙ x) ≃ x;
      support_action_eq : forall x π, ⌈π ⊙ x⌉ ≈ π∙⌈x⌉;
      action_compose_eq : forall x π π', π ⊙ (π' ⊙ x) ≃ (π++π') ⊙ x
    }.

  (** The following observations are straightforward to check directly from the axioms we just listed. *)
  Remark actoid_pinv_p {X : Set} `{NominalSetoid X}:
    forall π x, π∗ ⊙ (π ⊙ x) ≃ x.
  Proof.
    intros;rewrite action_compose_eq;apply action_invariant_eq.
    rewrite perm_pinv_p_eq_nil,act_nil;reflexivity.
  Qed.

  Remark actoid_p_pinv {X : Set} `{NominalSetoid X}:
    forall π x, π ⊙ (π∗ ⊙ x) ≃ x.
  Proof.
    intros;rewrite action_compose_eq;apply action_invariant_eq.
    rewrite perm_p_pinv_eq_nil,act_nil;reflexivity.
  Qed.

  (** Permutations that are equivalent as functions yield the same action (even if they are syntactically different): if for every atom [a] we have [π ∙ a = π' ∙ a] and if [x≃y], then [π⊙x≃π'⊙y]. *)
  Global Instance eq_act {X : Set} `{NominalSetoid X} :
    Proper (sequiv ==> sequiv ==> sequiv) actoid.
  Proof.
    intros π π' Eπ x y <- ;clear y.
    transitivity (π'⊙(π'∗ ⊙ (π ⊙ x))).
    - rewrite actoid_p_pinv;reflexivity.
    - apply eq_act_proper.
      rewrite action_compose_eq;apply action_invariant_eq.
      rewrite <- action_compose.
      rewrite Eπ,act_pinv_p;reflexivity.
  Qed.

  Lemma minimal_support_eq {X: Set} `{NominalSetoid X} l x :
    (forall π, (forall a, a ∈ l -> π ∙ a = a) -> π ⊙ x ≃ x) -> ⌈x⌉ ⊆ l.
  Proof.
    intros s a Ia.
    case_in a l;[tauto|exfalso].
    destruct (exists_fresh (a::l++⌈x⌉)) as (b&hb).
    simpl_In in hb.
    assert (E: [(a,b)]⊙x≃x).
    - apply s;intros c Ic.
      apply elements_inv_act_atom;simpl.
      intros [->|[->|F]];tauto.
    - pose proof (support_action_eq x [(a,b)]) as E'.
      rewrite E in E';revert Ia.
      rewrite E',In_act_lists.
      unfold act,act_atom;simpl;simpl_beq.
      tauto.
  Qed.

  Remark ActionSetoid_ext_In {X:Set} `{NominalSetoid X}:
    forall π π' x, (forall a, a ∈ ⌈x⌉ -> π ∙ a = π' ∙ a) -> π ⊙ x ≃ π' ⊙ x.
  Proof.
    intros p q x h.
    cut (x ≃ q∗ ⊙ (p ⊙ x)).
    - intros e ;rewrite e at 2;rewrite actoid_p_pinv;reflexivity.
    - symmetry;rewrite action_compose_eq.
      apply action_invariant_eq,map_eq_id.
      intros a Ia;rewrite <- action_compose,h,act_pinv_p;reflexivity||assumption.
  Qed.

End s.

(* begin hide *)
Infix " ⊙ " := actoid (at level 50).
Notation " ⌈ x ⌉ " := (suppoid x).
(* Arguments NominalSetoid : clear implicits. *)
Arguments NominalSetoid {atom} A X {equiv act supp}.
Arguments ActionSetoid _ A X : clear implicits.
Arguments SupportSetoid _ A X : clear implicits.
(* end hide *)

(** * Lifting the structure to lists *)
Section list.
  (** Let us fix a nominal setoid [S] over a set of atoms [Atom]. *)
  Context {atom : Set}{A: Atom atom}.
  Context {S : Set} {eqS : SemEquiv S} {actS : ActionSetoid _ A S}
          {suppS : SupportSetoid _ A S}.
  Context {N: NominalSetoid A S}.

  (** We define the action of [π] on a list by apply [π] pointwise. *)
  Global Instance actoid_lists : ActionSetoid _ A (list S):=
    fun π l => map (fun x => π⊙x) l.

  (* begin hide *)
  Remark actoid_lists_app π (l m : list S) : π⊙(l++m) = π⊙l++π⊙m.
  Proof. apply map_app. Qed.

  Remark actoid_lists_cons π (a :S) l : π⊙(a::l) = π⊙a::π⊙l.
  Proof. reflexivity. Qed.

  Remark actoid_lists_length π (l : list S) : ⎢π⊙l⎥ = ⎢l⎥.
  Proof. apply map_length. Qed.
  (* end hide *)

  (** To compute the support of a list, we compute the support of each element, take the union of those, and remove duplicates. *)
  Global Instance SupportSetoidList : SupportSetoid _ A (list S) :=
    fun l => {{flat_map suppoid l}}.

  (** Two lists are equivalent if they have the same length, and if their elements are pointwise equivalent. For instance if [l=l1...ln] and [m=m1...mn], then [l≃m] if and only if [forall 1<=i<=n, li≃mi]. *)
  Fixpoint semeq_list (l1 l2 : list S) :=
    match (l1,l2) with
    | ([],[]) => True
    | (a::l1,b::l2) => (a≃b) /\ semeq_list l1 l2
    | (_::_,[]) | ([],_::_) => False
    end.

  Instance SemEquiv_listS : SemEquiv (list S) :=  semeq_list.

  (* begin hide *)
  Global Instance cons_sequiv : Proper (sequiv ==> sequiv ==> sequiv) cons.
  Proof.
    intros x y E l m E'.
    unfold sequiv,SemEquiv_listS in *;simpl;tauto.
  Qed.
  Global Instance app_sequiv : Proper (sequiv ==> sequiv ==> sequiv) (@app S).
  Proof.
    intros x y E l m E'.
    unfold sequiv,SemEquiv_listS in *.
    revert y E;induction x as [|a x];intros [|b y];simpl;try tauto.
    intros (h1&h2);split;[tauto|apply IHx,h2].
  Qed.
  Global Instance length_sequiv : Proper (sequiv ==> eq) (@length S).
  Proof.
    intros x y E.
    unfold sequiv,SemEquiv_listS in *.
    revert y E;induction x as [|a x];intros [|b y];simpl;try tauto.
    intros (h1&h2);rewrite (IHx y);reflexivity||assumption.
  Qed.
  (* end hide *)

  (** It is a simple matter to check that the operations we have defined indeed define a nominal setoid structure over [list S]. *)
  Global Instance NominalSetoid_list : NominalSetoid A (list S).
  Proof.
    split.
    - unfold sequiv,SemEquiv_listS;split.
      + intros l;induction l as [|a l];simpl.
        * tauto.
        * split;[reflexivity|assumption].
      + intros l1;induction l1 as [|a l1];intros [|b l2];simpl;try tauto.
        intros (->&h);intuition.
      + intros l1;induction l1 as [|a l1];intros [|b l2] [|c l3];simpl;try tauto.
        intros (->&h1) (->&h2);split;[reflexivity|].
        apply (IHl1 l2 l3);assumption.
    - unfold sequiv,SemEquiv_listS;intros l1;induction l1 as [|a l1];intros [|b l2];simpl;
        try tauto||reflexivity.
      intros (e&h);apply IHl1 in h;revert h.
      unfold suppoid,SupportSetoidList;simpl.
      repeat rewrite undup_equivalent;intros ->.
      rewrite (eq_support e);reflexivity.
    - intros π l1;unfold sequiv,SemEquiv_listS;induction l1 as [|a l1];intros [|b l2];simpl;
        try tauto.
      intros (->&e);split;[reflexivity|].
      apply IHl1,e.
    - unfold sequiv,SemEquiv_listS;unfold suppoid,SupportSetoidList in *;simpl.
      intros x p h; unfold actoid,actoid_lists in *.
      unfold act,act_lists in h;rewrite <- map_undup_id in h.
      induction x as [|x l];auto.
      + reflexivity.
      + revert h;simpl;rewrite map_app;intro E;apply length_app in E as (E1&E2).
        * split;[|apply IHl,E2].
          apply action_invariant_eq,E1.
        * apply map_length.
    - unfold act,act_lists,actoid,actoid_lists,suppoid,SupportSetoidList,sequiv,SemEquiv_listS in *.
      intros x p;symmetry;simpl in *.
      rewrite map_undup_inj;eauto using perm_inj.
      repeat rewrite flat_map_concat_map.
      rewrite concat_map,map_map,map_map,undup_equivalent,undup_equivalent.
      intros a;repeat rewrite <- flat_map_concat_map,in_flat_map.
      setoid_rewrite support_action_eq;unfold act at 2,act_lists;tauto.
    - intros;unfold actoid,actoid_lists.
      rewrite map_map.
      unfold sequiv,SemEquiv_listS;induction x as [|a x];simpl;[tauto|split;[|apply IHx]].
      apply action_compose_eq.
  Qed.

  (* begin hide *)
  Remark suppoid_cons b w : ⌈b::w⌉ ≈ ⌈b⌉ ++ ⌈w⌉.
  Proof.
    intro a;unfold suppoid,SupportSetoidList.
    repeat rewrite undup_equivalent.
    simpl;simpl_In;tauto.
  Qed.
  Remark suppoid_app w1 w2 : ⌈w1++w2⌉ ≈ ⌈w1⌉ ++ ⌈w2⌉.
  Proof.
    intro a;unfold suppoid,SupportSetoidList.
    repeat rewrite undup_equivalent.
    rewrite flat_map_concat_map,map_app,concat_app,<-flat_map_concat_map,<-flat_map_concat_map.
    reflexivity.
  Qed.
  (* end hide *)

End list.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^251 - 9
Base: 41 + 5/6
***)

Definition curve : CurveParameters :=
  {|
    sz := 6%nat;
    base := 41 + 5/6;
    bitwidth := 64;
    s := 2^251;
    c := [(1, 9)];
    carry_chains := Some [seq 0 (pred 6); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.