(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr  &all    2006                     *)
(*************************************************************)

Require Import Tactic.
(*Load phi.*)
Require Import CAD_types.
Require Import Utils.
Require Import Setoid.
Require Import ZArith.
Require Import Even.
Require Import Pol_ring.
(*Require Import phi.*)
Require Import Mylist.

(*Notation  ZCoef:=Pol.*)
Notation  pol:= Pol.
Notation add :=Pol_add.
Notation "a !* x" := (Pol_mul_Rat  x a )(at level 40, left associativity).

Add New Ring PolRing : PRth Abstract.
Add New Ring CoefRing : cRth Abstract.

Section ListAux.

Variable A: Set.
Theorem length_app:
 forall (l1 l2 : list A),  length (app l1  l2) = (length l1 + length l2)%nat.
intros l1; elim l1; simpl; auto.
Qed.

End ListAux.

(* lists of Pols pairwise PolEq equal*)
Inductive Pol_list_equiv:(list Pol) -> (list Pol) ->Prop :=
|Nil_equiv : Pol_list_equiv (@nil Pol) (@nil Pol)
|Cons_equiv : forall a1 a2 l1 l2, a1!=a2 -> Pol_list_equiv l1 l2 ->
(Pol_list_equiv (a1::l1) (a2::l2)).

Infix "*=" := Pol_list_equiv (at level 70, no associativity).

Lemma Pol_list_equiv_refl : forall l, l *=l.
Proof.
intro l;induction l;constructor;trivial;reflexivity.
Qed.

Lemma Pol_list_equiv_sym : forall l1 l2,
l1 *= l2 -> l2 *=l1.
Proof.
intros l1 ;induction l1;intro l2;induction l2;intro H;inversion H;constructor;
[apply PolEq_sym;trivial|apply IHl1;trivial].
Qed.

Lemma Pol_list_equiv_trans1 : forall l1 l2,
l1*=l2 -> forall l3, l2 *= l3 -> l1 *= l3.
Proof.
intro l1;induction l1;intro l2;destruct l2;intros Heq12 l3 Heq23.
inversion Heq23;trivial.
inversion Heq12.
inversion Heq23;trivial.
inversion_clear Heq23.
constructor;inversion_clear Heq12.
apply PolEq_trans with p;trivial.
apply IHl1 with l2;trivial.
Qed.

Lemma Pol_list_equiv_trans:forall l1 l2 l3,
l1*=l2 -> l2 *= l3 -> l1 *= l3.
Proof.
intros;apply Pol_list_equiv_trans1 with l2;assumption.
Qed.

Add Relation (list Pol) Pol_list_equiv
reflexivity proved by Pol_list_equiv_refl
symmetry proved by Pol_list_equiv_sym
transitivity proved  by Pol_list_equiv_trans
as Pol_list_relation.

Add Morphism (@app Pol) with signature
 Pol_list_equiv ==> Pol_list_equiv ==> Pol_list_equiv as app_morph.
Proof.
intros l1 l2;induction 1;intros m1 m2;induction 1;
simpl;try constructor;trivial.
apply IHPol_list_equiv;constructor.
apply IHPol_list_equiv;constructor;trivial.
Qed.

Lemma Pol_list_equiv_length : forall l m, l *= m -> length l = length m.
Proof.
intros l m;induction 1;simpl;trivial;auto with arith.
Qed.

(*Transparent phi.*)

Ltac toto := match goal with |- context [if ?X then _ else _ ] => case X end.

(*
Add Morphism phi  with signature (@eq nat) ==>(@eq nat) ==> Pol_Eq ==> Pol_Eq  as phi_Morphism.
intros d n P Q;unfold phi;case (le_gt_dec (d+2)n); intros.
Proof.
reflexivity.
case n;simpl.
reflexivity.
intros;case n0; trivial.
intros;toto;
intros;simpl;
rewrite H;setoid ring.
Show Script.
Qed.
*)

Section det.
Variable phi : nat -> nat -> Pol -> Pol.

(*
Notation scal:=(fun x y =>Pol_mul_Rat y x).
*)
Definition scal(x:Coef)(y:Pol):= Pol_mul_Rat y x.
(*Notation add := Pol_add.*)

Hypothesis phi_m: forall deg n a b c d,
 phi deg n (add (scal a b) (scal c  d)) != a !* phi deg n b + c !* phi deg n d.

Fixpoint rec_det (f: Pol -> Pol) (rec: list Pol -> Pol)  (l1 l2: list pol)  {struct l1}: Pol :=
  match l1 with
    nil =>  P0
  | a:: l3 => f a * rec (app l2 l3)  - rec_det f  rec  l3 (app l2 (a::nil))
  end.

Variable deg:nat.

Fixpoint det_aux (n: nat) (l: list Pol) {struct n}: Pol :=
  match n with
    O => P1
  | S n1 => rec_det (phi deg n) (det_aux n1) l nil
  end.

Definition det l :=  det_aux(length l) l.

Theorem rec_det_m: forall f rec a b c d l1 l2,
  (forall a b c d l, (1 + length l = length l1 + length l2)%nat ->
    rec ((add (scal a b) (scal c d)):: l) != a !* rec (b :: l) + c !* rec (d :: l)) ->
  rec_det f rec l1 ((add (scal a b) (scal c d)):: l2)  != a !* rec_det f rec l1 (b :: l2) + c !* rec_det f rec  l1 (d :: l2).
intros f rec a b c d l1 l2; generalize l2; elim l1; simpl; clear l1 l2.
(*intros;Pcsimpl;setoid ring.*)
intros;Pcsimpl;setoid ring.

intros a1 l3 Rec l2 H.
repeat (rewrite Rec||rewrite H);try rewrite length_app;try omega.
intros;rewrite H.
rewrite H0;simpl;omega.
setoid ring.
repeat rewrite Pscal_Pmul_l.
setoid ring.
Qed.

Theorem det_aux_m: forall n a b c d l,
  (n= 1 + length l)%nat ->  det_aux n (((add (scal a b) (scal c d))) :: l) != a !* det_aux n (b :: l) + c !* det_aux n (d :: l).

intros n; elim n; simpl; auto.
intros; discriminate.
intros n1 Rec  a b c d l H; injection H; clear H; intros H.
generalize (phi_m  deg (S n1)); intro Hphi.
repeat (rewrite Rec || rewrite Hphi|| rewrite rec_det_m); auto; repeat rewrite Pscal_Pmul_l.
intros a1 b1 c1 d1 l1;simpl.
rewrite plus_0_r;intros H1; rewrite Rec.
rewrite H; auto.
reflexivity.
setoid ring.
Qed.

Theorem det_m0: forall a b c d l, det ((add (scal a b) (scal c d)) :: l) != a !* det (b :: l) + c !* det (d :: l).
intros; unfold det; rewrite det_aux_m; auto.
simpl length.
case ( even_odd_dec (S (length l)));intro;try rewrite det_aux_m;
auto;setoid ring.
Qed.

Theorem rec_det_r: forall f rec a b  l1 l2 l3,
  (forall a b l'1 l'2, (1 + length l'1 + length l'2 = length l1 + length l2 + length l3)%nat ->
               rec (app l'2( a :: b :: l'1)) != -  rec (app l'2 ( b :: a :: l'1))) ->
  rec_det f rec l1 (app l2 ( a :: b :: l3)) != - rec_det f rec l1 (app l2 (b :: a :: l3)).
intros f rec a b l1; elim l1; simpl; auto; clear l1.
intros;constructor.
setoid ring.

intros a1 l1 Rec l2 l3 H.
assert (tmp: forall a b l4, ( app (app l2 ( a :: b :: l3))  l4) = ((app l2 (a :: b :: (app l3  l4))))).
intros; rewrite app_ass; auto.
repeat rewrite tmp; simpl.
rewrite H; auto with arith.
rewrite length_app; simpl;
rewrite <- (plus_comm (length l3));auto with arith.
rewrite Rec.
 intros a2 b1 l'1 l'2; rewrite length_app; simpl.
rewrite (fun x => plus_comm x 1).
intros H1; apply H.
rewrite H1; auto with zarith.
setoid ring.
Qed.

Theorem rec_det_t: forall f rec a b  l1 l2 l3,
  (forall a b  l'1 l'2 , (1 + length l'1 + length l'2 = length l1 + length l2 + length l3)%nat ->
rec (app l'2 (a :: b :: l'1)) != -  rec (app l'2 ( b :: a :: l'1))) ->
  rec_det f rec (app l1 (a :: b :: l2)) l3 != - rec_det f rec (app l1 (b :: a :: l2)) l3.
intros f rec a b l1; elim l1; simpl; auto; clear l1.
intros l2 l3 H.
repeat rewrite app_ass; simpl.
rewrite rec_det_r; auto.
intros a0 b0 l'1 l'2; simpl; rewrite plus_0_r.
intros H1; apply H; auto.
setoid ring.
intros a1 l1 Rec l2 l3 H.
assert (tmp: forall a b l4, (app (app l2(  a :: b :: l3))  l4) = ((app l2  (a :: b :: (app l3  l4))))).
intros; rewrite app_ass; auto.
repeat rewrite <- app_ass; rewrite H.
rewrite length_app; auto with zarith.
rewrite Rec.
intros a2 b1 l'1 l'2; rewrite length_app; simpl.
rewrite (fun x => plus_comm x 1).
intros H1; apply H.
rewrite H1; auto with zarith.
setoid ring.
Qed.

Theorem det_aux_t0: forall n a b  l1 l2, (n = 2 + length l1 + length l2)%nat  ->
    det_aux n (app l1  (a :: b :: l2))!= - det_aux n (app l1   (b :: a :: l2)).
intros n; elim n; simpl; auto.
intros; discriminate.
intros n1 Rec a b l1 l2 H.
rewrite rec_det_t; auto.
intros a2 b1 l'1 l'2; simpl; rewrite plus_0_r.
intros H1; rewrite <- H1 in H; clear H1.
rewrite Rec; auto.

injection H; intros; rewrite plus_comm; auto.
setoid ring.
setoid ring.
Qed.

Theorem det_aux_t: forall n a b  l1 l2 l3, (n = 2 + length l1 + length l2 + length l3)%nat  ->
    det_aux n (app l1 (app  (a :: l2)  (b :: l3))) != - det_aux n (app l1 (app   (b :: l2) ( a :: l3))).
intros n a b l1 l2; generalize a b l1; elim l2; clear a b l1 l2; simpl; auto.
intros a b l1 l2; rewrite plus_0_r; intros H1; apply det_aux_t0; auto.
intros a1 l2 Rec a2 b1 l1 l3 H.
rewrite (@det_aux_t0 n a2 a1 l1 (app l2 (b1::l3))).
rewrite length_app; simpl; auto with zarith.
assert (h1: det_aux n (app l1 (b1 :: a1 :: app l2 (a2 :: l3))) !=
- det_aux n (app l1 (a1 :: b1 :: app l2 (a2 :: l3))));
[apply det_aux_t0 with (b := a1)| rewrite h1].
rewrite length_app; simpl; auto with zarith.

generalize (Rec a2 b1 (app l1 ( a1 ::   nil)) l3); repeat rewrite app_ass; simpl.
intros H1;rewrite H1 ; auto.

rewrite length_app; simpl; auto with zarith.
setoid ring.
Qed.

Theorem det_t: forall a b l1 l2 l3, det (app l1 (app  (a :: l2)  (b :: l3))) !=
- det (app l1 (app   (b :: l2)  (a :: l3))).
intros; unfold det.
repeat rewrite length_app;simpl length.
case ( even_odd_dec ( length l1 + (S (length l2) + S (length l3))));intro;
repeat (rewrite <- det_aux_t; auto;try omega; try setoid ring).
Qed.

Theorem det_m: forall a b c d l1 l2,
    det (app l1  (add (scal a b) (scal c d):: l2)) != a !* det (app l1 ( b :: l2))  + c !* det ( app l1  (d :: l2)).
intros a b c d l1 l2; case l1.
simpl; apply det_m0 .
intros a1 l3.
generalize (det_t a1 (add (scal a b) (scal c d))   nil l3 l2); simpl; intros tmp; rewrite tmp; clear tmp.
rewrite det_m0.
generalize (det_t b a1   nil l3 l2); simpl; intros tmp; rewrite tmp; clear tmp.
generalize (det_t d a1   nil l3 l2); simpl; intros tmp; rewrite tmp; clear tmp.
repeat rewrite Pscal_Pmul_l;setoid ring.
Qed.

Theorem det_zero: forall a l1 l2 l3, det (app l1 (app  (a :: l2)  (a :: l3))) != P0.
intros a l1 l2 l3.
case (Pmul_integral (P1+P1) (det (app l1 (app  (a :: l2) (a :: l3))))); auto.
assert (tmp: forall x, (P1 + P1)* x != x + x).
intros;setoid ring.
rewrite tmp; clear tmp.
assert (det (app l1 (app (a :: l2) (a :: l3))) + det (app l1 (app (a :: l2) (a :: l3))) !=
det (app l1 (app (a :: l2) (a :: l3))) + - det (app l1 (app (a :: l2) (a :: l3)))).
apply Padd_ext; [setoid ring| apply det_t].
rewrite H;setoid ring.
intros; absurd (P1 + P1 != P0 );auto; apply P2_diff_P0.
Qed.

Definition  even_odd_dec : forall n, {even n} + {odd n}.
induction n.
auto with arith.
elim IHn; auto with arith.
Defined.

Theorem rec_det_diag: forall f rec l1 l2 a1 a2,
  (forall a, In a l1 -> f a != P0) -> f a2 != P0 ->
   rec_det f rec (app l1  (a1::a2::nil)) l2 != match even_odd_dec (length l1) with
      left _ => (f a1) * rec (app l2 (app l1 (a2::nil)))
    | right _ => - (f a1) * rec (app l2 (app l1 ( a2::nil))) end.
intros f rec l1 l2 a1 a2; generalize l2; elim l1; clear l1 l2.
intros l2 H1 H2.
simpl.
Pcsimpl.
rewrite H2;rewrite Psub_def;setoid ring.
intros a l3 Rec l2 H1 H2;simpl rec_det.
rewrite Rec; auto with datatypes zarith.
rewrite (H1 a); auto with datatypes zarith.
rewrite app_ass;simpl length.
case (even_odd_dec (length l3));intros.
case(even_odd_dec (S (length l3))).
intros.
inversion e0.
absurd (even (length l3));auto.
red;intros;apply (not_even_and_odd (length l3));auto.
intros;simpl;setoid ring.
case(even_odd_dec (S (length l3)));intros.
simpl;setoid ring.
inversion o0.
absurd (even(length l3));auto.
red;intros;apply (not_even_and_odd (length l3));auto.
Qed.

Theorem list_last_element:
  forall (A: Set) (l : list A),
  l = nil \/ exists l1, exists a1, l = (app l1 (a1 :: nil)).
intros A l; elim l; simpl; auto.
intros a1 l1 [HH | (l2, (a2, HH))]; auto; right.
exists l1; exists a1; rewrite HH; auto.
exists (a1::l2); exists a2; rewrite HH; auto.
Qed.

Theorem nth_app_l: forall (A: Set) a n (l1 l2: list A), (n < length l1)%nat -> nth n (app l1  l2) a = nth n l1 a.
intros A a n l1; generalize n; elim l1; clear n l1.
simpl; intros n l2 H;contradict H; auto with arith.
intros a1 l1 Rec n l2; case n; simpl; auto.
intros n1 H; apply Rec; auto with arith.
Qed.

Theorem nth_app_r: forall (A: Set) a n (l1 l2: list A), (length l1 <= n)%nat -> nth n (app l1 l2) a = nth (n - length l1) l2 a.
intros A a n l1; generalize n; elim l1; clear n l1.
simpl; intros n l2 H; eq_tac; auto with zarith.
intros a1 l1 Rec n l2; case n; simpl.
intros H; contradict H; auto with arith.
intros n1 H; apply Rec; auto with arith.
Qed.

Theorem in_nth_inv: forall (A: Set) (a: A) l p, (In a l) -> exists i, (i < length l)%nat /\  a = nth i l p.
intros A a l p; elim l; simpl; clear l.
intros tmp; case tmp.
intros a1 l1 Rec1 [HH1 | HH1].
exists 0%nat; auto with arith.
case Rec1; auto.
intros i (Hi1, Hi2).
exists (S i); auto with arith.
Qed.

Definition Zpolpower_nat (i:nat):= match (even_odd_dec i) with
   left _ => Pc c1
   | right _ => - (Pc c1) end.

Opaque phi.

Theorem det_aux_diag: forall l a n p,
  (forall i:nat, (1 < i)%nat -> (i <= n)%nat -> phi deg  i a != P0) ->
  (forall (i j:nat), (j < i)%nat  -> (i < n)%nat -> phi deg (S (S i)) (nth j l p) != P0) ->
  (forall i:nat, (i < n)%nat -> (i < length l )%nat -> phi deg (S (S i)) (nth i l p) != (Zpolpower_nat  i))->
  (length l + 1 = n)%nat -> det_aux n (app l  (a :: nil)) != phi deg 1 a.
intros l a n p; generalize l; elim n;simpl;clear l n.
intros l _ _ _ H1; rewrite plus_comm in H1; discriminate.
intros n Rec l H0 H2 H3 H4.
case (list_last_element _ l); intros H5.
rewrite H5; simpl.
replace n with 0%nat;simpl.
Pcsimpl.
(*rewrite Pol_sub_c0;rewrite Pmul_Rat_c1;setoid ring.*)
apply eq_add_S.
rewrite <- H4; rewrite H5; simpl; auto.
case H5; clear H5; intros l2 (a1, H5).
subst l.
assert (Eq0: n = (S (pred n))).
generalize H4; rewrite length_app; repeat (rewrite plus_comm; simpl); auto.
case n; simpl; auto with zarith.
assert (Eq1: pred n = (length l2)).
apply eq_add_S; apply eq_add_S.
rewrite <- Eq0; rewrite <- H4; rewrite length_app; repeat (rewrite plus_comm; simpl); auto.
rewrite app_ass;simpl.
rewrite rec_det_diag; simpl; auto with zarith.

intros a2 HH.
case (in_nth_inv _ a2 l2 p); auto.
intros i (Hi1, Hi2).
rewrite Eq0.
replace a2 with (nth i (app l2 ( a1 :: nil)) p).
apply H2; auto with arith.
rewrite Eq1; auto.
rewrite nth_app_l; auto with arith.
case (even_odd_dec (length l2));intros.

rewrite Rec; auto.

intros i j HH HH1.
rewrite <- (H2 i j); auto with arith.
rewrite  (@f_equal3 _ _ _ _ phi deg deg (S(S i)) (S(S i)) (nth j l2 p) (nth j (app l2 (a1 :: nil)) p)); auto.
setoid ring.
apply sym_equal; apply nth_app_l.
apply lt_le_trans with (1 := HH).
rewrite <- Eq1; clear Eq1; rewrite Eq0 in HH1; auto with arith.

intros i HH HH1; rewrite <- H3; auto.
rewrite length_app; simpl; auto with arith.
rewrite  (@f_equal3 _ _ _ _ phi deg deg (S(S i)) (S(S i)) (nth i l2 p) (nth i (app l2 (a1 :: nil)) p)); auto.
setoid ring.
apply sym_equal; apply nth_app_l; auto.
apply eq_add_S; auto with arith.
rewrite <- H4; rewrite length_app; repeat (rewrite plus_comm; simpl); auto.

rewrite Eq0.
replace a1 with (nth (pred n) (app l2 (a1 :: nil)) p).
rewrite H3; auto with zarith.
rewrite Eq1.
unfold Zpolpower_nat.
case (even_odd_dec (length l2));intros.
apply Pmul_1_l.
elim  (not_even_and_odd (length l2));trivial.
rewrite nth_app_r.
rewrite Eq1; rewrite <- minus_n_n; auto.
rewrite Eq1; auto with arith.

rewrite Rec; auto.

intros i j HH HH1.
rewrite <- (H2 i j); auto with arith.
rewrite  (@f_equal3 _ _ _ _ phi deg deg (S(S i)) (S(S i)) (nth j l2 p) (nth j (app l2 (a1 :: nil)) p)); auto.
setoid ring.

apply sym_equal; apply nth_app_l.
apply lt_le_trans with (1 := HH).
rewrite <- Eq1; clear Eq1; rewrite Eq0 in HH1; auto with arith.

intros i HH HH1; rewrite <- H3; auto.
rewrite length_app; simpl; auto with arith.
rewrite  (@f_equal3 _ _ _ _ phi deg deg (S(S i)) (S(S i)) (nth i l2 p) (nth i (app l2 (a1 :: nil)) p)); auto.
setoid ring.
apply sym_equal; apply nth_app_l; auto.
apply eq_add_S; auto with arith.
rewrite <- H4; rewrite length_app; repeat (rewrite plus_comm; simpl); auto.

rewrite Eq0.
replace a1 with (nth (pred n) (app l2 (a1 :: nil)) p).
rewrite H3; auto with zarith.
rewrite Eq1.
unfold Zpolpower_nat.
case (even_odd_dec (length l2));intros.
elim  (not_even_and_odd (length l2));trivial.
setoid ring.
rewrite nth_app_r.
rewrite Eq1; rewrite <- minus_n_n; auto.
rewrite Eq1; auto with arith.
Qed.

Theorem det_diag: forall l a p,
  (forall i, (1 < i)%nat -> (i <= length l + 1)%nat -> phi  deg i a != P0)->
  (forall i j, (j < i)%nat-> (i < length l + 1)%nat -> phi deg (S (S i)) (nth j l p) != P0)->
  (forall i, (i < length l )%nat-> phi deg (S (S i)) (nth i l p) != (Zpolpower_nat i))->
   det (app l ( a :: nil)) != phi deg 1 a.
intros l a p H2 H3 H4.
unfold det; rewrite length_app.
apply det_aux_diag with p; simpl; auto with arith.
Qed.

(*
Ltac list_blast := simpl;try (repeat rewrite app_ass);try (repeat rewrite app_comm_cons);
try (repeat rewrite app_ass);simpl;try reflexivity.

Lemma nth_app_cons : forall A n l1 l2 a b,
length l1 = n -> @nth A n (app l1 (a::l2)) b = a.
Proof.
intro A;induction n;intros l1 l2 a b Defn.
replace l1 with (@nil A);[reflexivity|destruct l1].
trivial.
discriminate.
destruct l1;simpl.
discriminate.
apply IHn.
simpl in Defn;auto with arith.
Qed.

Ltac falso := apply False_ind;omega.

Theorem det_aux_trig: forall k1 k2 l1 l2  n p c,
  length l1 = k1 -> length l2 = k2 -> (k1 + k2)%nat = n ->
  (forall i:nat, (1 < i)%nat -> (i <= k1)%nat ->
    forall j, j < k2 -> phi deg  i (nth j l2 p) != P0) ->

  (forall (i j:nat), (j < i)%nat  -> (i < k1)%nat ->
    phi deg (S (S i)) (nth j l1 p) != P0) ->

  (forall i:nat, (i < n)%nat -> (i < length l1 )%nat ->
    phi deg (S (S i)) (nth i l1 p) != c)->
  det_aux n (app l1 l2) != (Pol_pow c (N_of_nat k1))*(det_aux n l2).
Proof.
intro k1;elim k1.
intros k2 l1 l2 n p c H1 H2 H3.
destruct l1.
simpl in H3.
subst k2;clear H1.
intros H4 H5 H6.
simpl.
setoid ring.
simpl in H1;discriminate.
intros n Rec k2 l1 l2 n0 p c H1 H2 H3 H4 H5 H6.
case (list_last_element _ l1).
intro H7.
subst l1.
discriminate.
intro H7.
case H7.
clear H7;intros l3 (a1,H7).
subst l1.
replace (app (app l3 (a1 :: nil)) l2) with (app l3 (a1::l2)) by list_blast.
assert (l3_length : length l3 = n) by
(rewrite length_app in H1;simpl in H1;omega).
rewrite (Rec (S k2) l3 (a1::l2) n0 p c);trivial.
simpl;omega.
omega.
intros i H7 H8 j H9.
destruct j.
simpl.
replace a1 with (nth (length l3) (app l3 (a1::nil)) p).
destruct i;try destruct i;try falso.
apply H5.

Goal forall n, forall l:list nat, length l = S n -> False.
intros;case(list_last_element _ l).
intro H1.
subst l.
subst l1.
simpl.

intros l a n p.
generalize l.
 elim n.
simpl.
clear l n.
intros l _ _ _ H1.
rewrite plus_comm in H1; discriminate.
clear l n.
intros n Rec l H0 H2 H3 H4.
case (list_last_element _ l).
 intros H5.
rewrite H5; simpl.
replace n with 0%nat;simpl.
Pcsimpl.
(*rewrite Pol_sub_c0;rewrite Pmul_Rat_c1;setoid ring.*)
apply eq_add_S.
rewrite <- H4; rewrite H5; simpl; auto.
intro H5.
case H5.
 clear H5; intros l2 (a1, H5).
subst l.
assert (Eq0: n = (S (pred n))).
generalize H4; rewrite length_app; repeat (rewrite plus_comm; simpl); auto.
case n; simpl; auto with zarith.
assert (Eq1: pred n = (length l2)).
apply eq_add_S; apply eq_add_S.
rewrite <- Eq0; rewrite <- H4; rewrite length_app; repeat (rewrite plus_comm; simpl); auto.
rewrite app_ass;simpl.
rewrite rec_det_diag; simpl; auto with zarith.

intros a2 HH.
case (in_nth_inv _ a2 l2 p); auto.
intros i (Hi1, Hi2).
rewrite Eq0.
replace a2 with (nth i (app l2 ( a1 :: nil)) p).
apply H2; auto with arith.
rewrite Eq1; auto.
rewrite nth_app_l; auto with arith.
case (even_odd_dec (length l2));intros.

rewrite Rec; auto.

intros i j HH HH1.
rewrite <- (H2 i j); auto with arith.
rewrite  (@f_equal3 _ _ _ _ phi deg deg (S(S i)) (S(S i)) (nth j l2 p) (nth j (app l2 (a1 :: nil)) p)); auto.
setoid ring.
apply sym_equal; apply nth_app_l.
apply lt_le_trans with (1 := HH).
rewrite <- Eq1; clear Eq1; rewrite Eq0 in HH1; auto with arith.

intros i HH HH1; rewrite <- H3; auto.
rewrite length_app; simpl; auto with arith.
rewrite  (@f_equal3 _ _ _ _ phi deg deg (S(S i)) (S(S i)) (nth i l2 p) (nth i (app l2 (a1 :: nil)) p)); auto.
setoid ring.
apply sym_equal; apply nth_app_l; auto.
apply eq_add_S; auto with arith.
rewrite <- H4; rewrite length_app; repeat (rewrite plus_comm; simpl); auto.

rewrite Eq0.
replace a1 with (nth (pred n) (app l2 (a1 :: nil)) p).
rewrite H3; auto with zarith.
rewrite Eq1.
unfold Zpolpower_nat.
case (even_odd_dec (length l2));intros.
apply Pmul_1_l.
elim  (not_even_and_odd (length l2));trivial.
rewrite nth_app_r.
rewrite Eq1; rewrite <- minus_n_n; auto.
rewrite Eq1; auto with arith.

rewrite Rec; auto.

intros i j HH HH1.
rewrite <- (H2 i j); auto with arith.
rewrite  (@f_equal3 _ _ _ _ phi deg deg (S(S i)) (S(S i)) (nth j l2 p) (nth j (app l2 (a1 :: nil)) p)); auto.
setoid ring.

apply sym_equal; apply nth_app_l.
apply lt_le_trans with (1 := HH).
rewrite <- Eq1; clear Eq1; rewrite Eq0 in HH1; auto with arith.

intros i HH HH1; rewrite <- H3; auto.
rewrite length_app; simpl; auto with arith.
rewrite  (@f_equal3 _ _ _ _ phi deg deg (S(S i)) (S(S i)) (nth i l2 p) (nth i (app l2 (a1 :: nil)) p)); auto.
setoid ring.
apply sym_equal; apply nth_app_l; auto.
apply eq_add_S; auto with arith.
rewrite <- H4; rewrite length_app; repeat (rewrite plus_comm; simpl); auto.

rewrite Eq0.
replace a1 with (nth (pred n) (app l2 (a1 :: nil)) p).
rewrite H3; auto with zarith.
rewrite Eq1.
unfold Zpolpower_nat.
case (even_odd_dec (length l2));intros.
elim  (not_even_and_odd (length l2));trivial.
setoid ring.
rewrite nth_app_r.
rewrite Eq1; rewrite <- minus_n_n; auto.
rewrite Eq1; auto with arith.
Qed.
*)

Theorem rec_det_morph : forall f rec  l1 l1',
 l1 *= l1' ->  forall l2 l2' , l2 *= l2' ->
(forall l1 l1' , l1*=l1' -> rec l1 != rec l1' ) ->
(forall a b, a != b -> f a != f b) ->
rec_det f rec l1 l2 != rec_det f rec l1' l2'.
Proof.
intros f rec l1 l1'.
induction 1; intros m2 m2';induction 1;simpl;intros.
reflexivity.
reflexivity.
rewrite (H2 _ _ H).
rewrite (H1 _ _ H0).
rewrite (IHPol_list_equiv (a1::nil) (a2::nil));
try constructor;trivial.
constructor.
reflexivity.

rewrite (H4 a1 a2 H).
rewrite (H3 (a0::(app l0 l1)) (a3::(app l3 l2)));[constructor;trivial|idtac].
rewrite H2;rewrite H0;reflexivity.
rewrite (IHPol_list_equiv (a0::app l0 (a1 :: nil)) (a3 :: app l3 (a2 :: nil)));trivial.
 constructor;trivial.
apply app_morph;trivial.
constructor;trivial.
constructor.
reflexivity.
Qed.

Add Morphism phi  with signature (@eq nat) ==>(@eq nat) ==> Pol_Eq ==> Pol_Eq as phi_Morphism.
Admitted.
(*
intros d n P Q;unfold phi;case (le_gt_dec (d+2)n); intros.
Proof.
reflexivity.
case n;simpl.
reflexivity.
intros;case n0; trivial.
intros;toto;
intros;simpl;
rewrite H;setoid ring.
Show Script.
Qed.
*)

Theorem det_aux_morph : forall n, (forall l1 l2, l1 *= l2 ->  det_aux n l1 != det_aux n l2).
Proof.
induction n;intros l1 l2 H;induction H;simpl;try reflexivity.
apply Psub_comp.
rewrite H.
rewrite (IHn l1 l2 H0).
reflexivity.
apply rec_det_morph;try assumption.
constructor;[assumption|constructor].
intros a b Hab;rewrite Hab;reflexivity.
Qed.

Add Morphism det with signature Pol_list_equiv ==> Pol_Eq as det_morph.
Proof.
intros l1 l2 H.
unfold det.
rewrite (Pol_list_equiv_length l1 l2 H).
apply det_aux_morph;assumption.
Qed.

Theorem det_sum_simpl : forall l1 l2 l3 a b c,
det (app l1 (app (((b + (c !* a)))::l2) (a::l3))) != det (app l1 (app (b::l2) (a::l3))).
Proof.
intros.
rewrite <- (app_comm_cons l2 (a::l3) (b+( c !* a))).
assert (G: app l1 (b +(scal  c a) :: app l2 (a :: l3)) *= app l1 (((scal c1 b) + (scal c a)) :: app l2 (a :: l3))).
apply app_morph.
reflexivity.
constructor.
2:reflexivity.
unfold scal;Pcsimpl.
rewrite G.
rewrite det_m.
Pcsimpl.
repeat rewrite app_comm_cons.
rewrite det_zero.
Pcsimpl;setoid ring.
Qed.

Theorem det_scal : forall l1 l2 a c,
det (app l1 ((c !* a) :: l2)) != c !* (det (app l1 (a::l2))).
Proof.
intros l1 l2 a c.
transitivity  (det (app l1 (((c !* a) + (c0 !* P1)) :: l2))).
apply det_morph;apply app_morph.
reflexivity.
constructor.
unfold scal;Pcsimpl;setoid ring.
reflexivity.
fold (scal c a).
fold (scal c(det (app l1 (a :: l2)))).
fold (scal c0 P1).
rewrite det_m.
unfold scal;Pcsimpl;setoid ring.
Qed.

End det.


(* Context Conversion  *)

From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq Require Import Ast utils Typing.
From Translation
Require Import util Sorts SAst SLiftSubst Equality SCommon Conversion ITyping
               ITypingInversions ITypingLemmata.
Import ListNotations.

Section ContextConversion.

Context `{Sort_notion : Sorts.notion}.

Inductive ctxconv : scontext -> scontext -> Type :=
| ctxconv_nil : ctxconv [] []
| ctxconv_cons Γ Δ A B:
    ctxconv Γ Δ ->
    A ≡ B ->
    ctxconv (Γ,, A) (Δ,, B).

Derive Signature for ctxconv.

Fact ctxconv_refl :
  forall {Γ}, ctxconv Γ Γ.
Proof.
  intros Γ. induction Γ.
  - constructor.
  - constructor.
    + assumption.
    + apply conv_refl.
Defined.

Fact ctxconv_length :
  forall {Γ Δ},
    ctxconv Γ Δ ->
    #|Γ| = #|Δ|.
Proof.
  intros Γ Δ h. induction h.
  - reflexivity.
  - cbn. f_equal. assumption.
Defined.

End ContextConversion.

Ltac lift_sort :=
  match goal with
  | |- _ ;;; _ |-i lift ?n ?k ?t : ?S => change S with (lift n k S)
  | |- _ ;;; _ |-i ?t { ?n := ?u } : ?S => change S with (S {n := u})
  | |- sSort ?s ≡ lift ?n ?k ?t =>
    change (sSort s) with (lift n k (sSort s))
  | |- sSort ?s ≡ ?t{ ?n := ?u } =>
    change (sSort s) with ((sSort s){ n := u })
  | |- lift ?n ?k ?t ≡ sSort ?s =>
    change (sSort s) with (lift n k (sSort s))
  | |- ?t{ ?n := ?u } ≡ sSort ?s =>
    change (sSort s) with ((sSort s){ n := u })
  end.

Section ctxconv.

  Context `{Sort_notion : Sorts.notion}.

  Fact safe_nth_conv :
    forall {Γ Δ},
      ctxconv Γ Δ ->
      forall n is1 is2,
        safe_nth Γ (exist _ n is1) ≡ safe_nth Δ (exist _ n is2).
  Proof.
    intros Γ Δ h. induction h ; intros n is1 is2.
    - cbn. bang.
    - destruct n.
      + cbn. assumption.
      + cbn. apply IHh.
  Defined.

  Inductive ctxctx Σ : scontext -> scontext -> Prop :=
  | ctxctx_nil : ctxctx Σ [] []
  | ctxctx_cons Γ Δ A B :
      ctxctx Σ Γ Δ ->
      isType Σ Δ A ->
      ctxctx Σ (Γ,, A) (Δ,, B).

  Fact ctxctx_type :
    forall {Σ Γ Δ n} isdecl,
      type_glob Σ ->
      wf Σ Γ ->
      wf Σ Δ ->
      ctxctx Σ Γ Δ ->
      isType Σ Δ (lift0 (S n) (safe_nth Γ (exist _ n isdecl))).
  Proof.
    intros Σ Γ Δ n isdecl hg w1 w2 hc.
    revert n isdecl w1 w2.
    induction hc ; intros n isdecl w1 w2.
    - cbn. bang.
    - destruct n.
      + cbn.
        destruct H.
        dependent destruction w2.
        eexists. lift_sort.
        eapply typing_lift01 ; eassumption.
      + cbn.
        dependent destruction w1.
        dependent destruction w2.
        match goal with
        | |- context [ exist _ _ ?isdecl ] =>
          set (is' := isdecl)
        end.
        destruct (IHhc _ is' w1 w2).
        eexists.
        replace (S (S n)) with (1 + (S n))%nat by mylia.
        rewrite <- liftP3 with (k := 0) by mylia.
        lift_sort. eapply typing_lift01 ; eassumption.
  Defined.

  Ltac tih type_ctxconv' :=
    lazymatch goal with
    | |- _ ;;; (?Δ,, ?A),, ?B |-i _ : _ =>
      eapply type_ctxconv' ; [
        eassumption
      | assumption
      | econstructor ; [
          econstructor ; [ assumption | tih type_ctxconv' ]
        | idtac
        ]
      | econstructor ; [
          econstructor ; [ assumption | eexists ; tih type_ctxconv' ]
        | idtac
        ]
      | econstructor ; [
          econstructor ; [ assumption | apply conv_refl ]
        | apply conv_refl
        ]
      ]
    | |- _ ;;; ?Δ,, ?A |-i _ : _ =>
      eapply type_ctxconv' ; [
        eassumption
      | assumption
      | econstructor ; [ assumption | tih type_ctxconv' ]
      | econstructor ; [ assumption | eexists ; tih type_ctxconv' ]
      | econstructor ; [ assumption | apply conv_refl ]
      ]
    | |- _ ;;; _ |-i _ : _ =>
      eapply type_ctxconv' ; eassumption
    | _ => fail "Not applicable tih"
    end.

  Ltac ih :=
    lazymatch goal with
    | type_ctxconv' :
        forall (Σ : sglobal_context) (Γ Δ : scontext) (t A : sterm),
          Σ;;; Γ |-i t : A ->
          type_glob Σ ->
          wf Σ Δ ->
          ctxctx Σ Γ Δ ->
          ctxconv Γ Δ ->
          Σ;;; Δ |-i t : A
      |- _ => tih type_ctxconv'
    | _ => fail "Cannot find type_ctxconv'"
    end.

  Fixpoint type_ctxconv' {Σ Γ Δ t A} (ht : Σ ;;; Γ |-i t : A) {struct ht} :
    type_glob Σ ->
    wf Σ Δ ->
    ctxctx Σ Γ Δ ->
    ctxconv Γ Δ ->
    Σ ;;; Δ |-i t : A.
  Proof.
    intros hg hw hcc hc. destruct ht.
    all: try (econstructor ; ih).
    - destruct (ctxctx_type isdecl hg H hw hcc).
      eapply type_conv.
      + econstructor. assumption.
      + eassumption.
      + apply lift_conv. apply conv_sym. apply safe_nth_conv. assumption.
    - econstructor. assumption.
    - econstructor.
      + lift_sort. eapply typing_lift01 ; try eassumption ; ih.
      + eapply typing_lift01 ; try eassumption ; ih.
      + refine (type_Rel _ _ _ _ _) ; [| cbn ; mylia ].
        econstructor ; try eassumption. ih.
    - eexists. econstructor.
      + lift_sort. eapply typing_lift01 ; try eassumption ; ih.
      + eapply typing_lift01 ; try eassumption ; ih.
      + refine (type_Rel _ _ _ _ _) ; [| cbn ; mylia ].
        econstructor ; try eassumption. ih.
    - eapply type_HeqTrans with (B0 := B) ; ih.
    - econstructor ; try ih.
      eapply type_ctxconv'.
      + eassumption.
      + assumption.
      + econstructor ; try assumption.
        econstructor ; ih.
      + econstructor ; try assumption.
        eexists ; econstructor ; ih.
      + econstructor ; try assumption.
        apply conv_refl.
    - econstructor ; try ih.
      + eapply type_ctxconv'.
        * eassumption.
        * assumption.
        * econstructor ; try assumption.
          econstructor ; ih.
        * econstructor ; try assumption.
          eexists ; econstructor ; ih.
        * econstructor ; try assumption.
          apply conv_refl.
      + eapply type_ctxconv'.
        * eassumption.
        * assumption.
        * econstructor ; try assumption.
          econstructor ; ih.
        * econstructor ; try assumption.
          eexists ; econstructor ; ih.
        * econstructor ; try assumption.
          apply conv_refl.
    - econstructor ; try ih.
      eapply type_ctxconv'.
      + eassumption.
      + assumption.
      + econstructor ; try assumption.
        econstructor ; ih.
      + econstructor ; try assumption.
        eexists ; econstructor ; ih.
      + econstructor ; try assumption.
        apply conv_refl.
    - econstructor ; try ih.
      eapply type_ctxconv'.
      + eassumption.
      + assumption.
      + econstructor ; try assumption.
        econstructor ; ih.
      + econstructor ; try assumption.
        eexists ; econstructor ; ih.
      + econstructor ; try assumption.
        apply conv_refl.
    - econstructor ; try ih.
      eapply type_ctxconv'.
      + eassumption.
      + assumption.
      + econstructor ; try assumption.
        econstructor ; ih.
      + econstructor ; try assumption.
        eexists ; econstructor ; ih.
      + econstructor ; try assumption.
        apply conv_refl.
    - econstructor ; try ih.
      eapply type_ctxconv'.
      + eassumption.
      + assumption.
      + econstructor ; try assumption.
        econstructor ; ih.
      + econstructor ; try assumption.
        eexists ; econstructor ; ih.
      + econstructor ; try assumption.
        apply conv_refl.
    - econstructor ; try ih.
      eapply type_ctxconv'.
      + eassumption.
      + assumption.
      + econstructor ; try assumption.
        econstructor ; ih.
      + econstructor ; try assumption.
        eexists ; econstructor ; ih.
      + econstructor ; try assumption.
        apply conv_refl.
    - eapply type_ProjT2 with (A3 := A1) ; ih.
    - eapply type_Ax.
      + assumption.
      + assumption.
    - econstructor.
      + ih.
      + ih.
      + assumption.

    Unshelve. rewrite <- ctxconv_length by eassumption. assumption.
  Qed.

  Lemma type_ctxconv {Σ Γ Δ t A} (ht : Σ ;;; Γ |-i t : A) :
    type_glob Σ ->
    wf Σ Δ ->
    ctxconv Γ Δ ->
    Σ ;;; Δ |-i t : A.
  Proof.
    intros hg hw hc.
    eapply type_ctxconv' ; try eassumption.
    assert (w1 : wf Σ Γ).
    { eapply typing_wf. eassumption. }
    clear t A ht. revert hw.
    induction hc ; intro w2.
    - constructor.
    - dependent destruction w1.
      dependent destruction w2.
      econstructor.
      + eapply IHhc ; assumption.
      + eexists. eapply type_ctxconv' ; try eassumption.
        eapply IHhc ; assumption.
  Qed.

End ctxconv.


Require Import Coq.Classes.DecidableClass.
Require Import Coq.Lists.List.
Require Import Coq.Bool.Bool.
Require Import SquiggleEq.export.
Require Import SquiggleEq.UsefulTypes.
Require Import SquiggleEq.list.
Require Import SquiggleEq.LibTactics.
Require Import SquiggleEq.tactics.
Require Import SquiggleEq.AssociationList.
Require Import ExtLib.Structures.Monads.
Require Import templateCoqMisc.
Require Import Template.Template.
Require Import Template.Ast.

Require Import paramDirect.

Require Import Program.
Open Scope program_scope.

(* Reserved Notation " A ↪ B " (at level 80). *)

Lemma NoDupSinleton {A:Type} (a:A): NoDup [a].
Proof using.
  repeat constructor.
  simpl. tauto.
Qed.
(* Move to templateCoqMisc. change it to 5 or more *)
Definition varCycleLen := 3.

(* TODO: preproc : unflatten all applications to binary *)
(* similar to PTS.Beta. need to take one step *)
Inductive red (substf: list V -> STerm -> Substitution -> STerm):
  ((*outerBVars*)list V) -> STerm -> STerm -> Prop :=
| beta : forall outerBvars x A Sa b arg,
  red substf outerBvars (mkApp (mkLamS x A Sa b) [arg])  (substf outerBvars b [(x,arg)])
| congruence :
    forall outerBvars n o lbt1 lbt2,
    n < length (lbt1) (* reduction happens only in the nth bterm *)
    -> length lbt1 = length lbt2
    -> (forall m, m<>n -> selectbt lbt1 m = selectbt lbt2 m)
    -> let b1 := (selectbt lbt1 n) in let b2 := (selectbt lbt2 n) in
       get_vars b1= get_vars b2
    -> red substf (get_vars b1 ++ outerBvars) (get_nt b1) (get_nt b2)
    -> red substf outerBvars (oterm o lbt1)  (oterm o lbt2).
(* clause for alpha equality? *)
Require Import Coq.Relations.Relation_Operators.

Definition redS := red bcSubst.
(** for the correctness of translate on [tl] and [tr], we need to assume that
 [outerBvars] includes the free vars of [tl] and [tr]. No such assumption is needed here *)
Lemma redPreservesBC: forall (outerBvars:list V) (tl tr : STerm),
    redS outerBvars tl tr -> checkBC outerBvars tl = true -> checkBC outerBvars tr = true.
Proof using.
  intros ? ? ? Hred.
  induction Hred.
Local Opaque decide.
- simpl.
  rewrite decide_true by (try constructor).
  rewrite decide_true by disjoint_reasoning.
  rewrite decide_true by (try apply NoDupSinleton).
  intros Hr. fold V in x.
  ring_simplify in Hr.
  repeat rewrite andb_true in Hr.
  repeat rewrite Decidable_spec in Hr.
  repnd. apply bcSubstBetaPreservesBC with (o:=CApply 1).
  simpl.
  setoid_rewrite decide_true;
    try apply NoDupSinleton; try constructor; try disjoint_reasoningv2.
  ring_simplify. repeat rewrite andb_true.
  tauto.
- simpl. do 2 rewrite ball_map_true.
  intros Hl ? Hin. pose proof Hin as Hsel.
  apply in_selectbt in Hsel. exrepnd. subst.
  rename n0 into m.
  destruct (decideP (m=n));
    [subst | rewrite <- H1 by assumption; apply Hl; apply selectbt_in; congruence].
  pose proof Hsel1 as Hsel2.
  rewrite <- H0 in Hsel2.
  eapply selectbt_in in Hsel2.
  specialize (Hl  _ Hsel2).
  destruct (selectbt lbt1 n) as [lv1 tl].
  destruct (selectbt lbt2 n) as [lv tr].  simpl in *. subst.
  repeat rewrite andb_true in *. repnd. dands; auto.
Qed.

Definition defEqS   (outerBVars:list V) :   STerm -> STerm -> Prop :=
clos_refl_sym_trans _ (redS outerBVars).

(* Infix  "≡" := defEq (at level 80). *)

(* (free_vars (tvmap vprime t)) = map vprime (free_vars t) *)

(* Lemma 2.1 in Lasson.
Unlike in Certicoq, here we are talking about reduction, which
can happen even under binders. So, we don't have the luxury
of only talking about closed terms. So alpha equality is inevitable in later lemmas.
In this lemma, by ensuring that freshVars commutes with vprime, we may be
able to get it with strict equality
*)

Require Import Psatz.

Local Opaque BinNat.N.add .

Lemma vPrimeNeqV : forall v,  v <> vprime v.
Proof.
  intros ? Heq. apply (f_equal fst) in Heq.
  simpl in Heq. lia.
Qed.

Lemma vRelNeqV : forall v,  v <> vrel v.
Proof.
  intros ? Heq. apply (f_equal fst) in Heq.
  simpl in Heq. lia.
Qed.

Lemma vRelNeqVPrime : forall (v:V), vprime v <> vrel v.
Proof.
  intros ? Heq. apply (f_equal fst) in Heq.
  simpl in Heq. lia.
Qed.

Require Import NArith.

(** Move to templateCoqMisc *)
Definition vBase (v: V) : N :=
  let vn := fst v in
  (vn - (N.modulo vn varCycleLen))%N.

Lemma vBaseId v :
  varClass v = userVar -> vBase v = fst v.
Proof using.
  intros Heq.
  destruct v; simpl in *.
  apply (f_equal (@proj1_sig _ _ )) in Heq. unfold vBase.
  simpl in *. setoid_rewrite Heq. lia.
Qed.

Lemma vBasePrime v :
  varClass v = userVar -> vBase (vprime v) = fst v.
Proof using.
  intros Heq.
  destruct v; simpl in *.
  apply (f_equal (@proj1_sig _ _ )) in Heq. unfold vBase.
  simpl in *. rewrite N.add_mod by (compute;lia).
  setoid_rewrite Heq. unfold varCycleLen.
  change ((1 mod 3 + 0) mod 3) with 1.
  lia.
Qed.

Lemma vBaseRel v :
  varClass v = userVar -> vBase (vrel v) = fst v.
Proof using.
  intros Heq.
  destruct v; simpl in *.
  apply (f_equal (@proj1_sig _ _ )) in Heq. unfold vBase.
  simpl in *. rewrite N.add_mod by (compute;lia).
  setoid_rewrite Heq. unfold varCycleLen.
  change ((2 mod 3 + 0) mod 3) with 2.
  lia.
Qed.

Hint Rewrite (fun v => not_eq_beq_var_false _ _ (vPrimeNeqV v)) : Param.
Hint Rewrite (fun v => not_eq_beq_var_false _ _ (vRelNeqVPrime v)) : Param.
Hint Rewrite (fun v => not_eq_beq_var_false _ _ (vRelNeqV v)) : Param.

Require Import NArith.

Definition varClass1 (v:V) : N := proj1_sig (varClass v).

Lemma varClassVPrime : forall v, varClass1 (vprime v) =
  (1+ varClass1 v) mod varCycleLen.
Proof using.
  intros. unfold varClass1. simpl.
  rewrite N.add_mod;[| lia].
  refl.
Qed.

Lemma varClassVRel : forall v, varClass1 (vrel v) =
  (2+ varClass1 v) mod varCycleLen.
Proof using.
  intros. unfold varClass1. simpl.
  rewrite N.add_mod;[| lia].
  refl.
Qed.

Hint Rewrite varClassVPrime varClassVRel : Param.

Lemma varClassNotEq : forall v1 v2,
     (varClass1 v1 <> varClass1 v2) -> beq_var v1 v2 = false.
Proof.
  intros ? ? Heq.
  apply not_eq_beq_var_false.
  congruence.
Qed.

Hint Resolve vRelNeqVPrime vRelNeqV vPrimeNeqV : Param.

Lemma decideFalse P `{Decidable P} : ~P -> decide P = false.
Proof.
apply Decidable_sound_alt.
Qed.

Lemma nameMapAppInj s :
injective_fun (nameMap (fun x : ident => String.append x s)).
(** append is injective at the first argument *)
Admitted. (** very confident about this *)

(** unconditional, even though we use vrel only userVars *)
Lemma vRelInjective : injective_fun vrel.
Proof using.
  intros v1 v2 Heq.
  destruct v1, v2.
  unfold vrel in *.
  simpl in *.
  inverts Heq.
  f_equal; [lia|].
  unfold nameMap.
  apply nameMapAppInj in H1.
  assumption.
Qed.

(** unconditional, even though we use vrel only userVars *)
Lemma vPrimeInjective : injective_fun vprime.
Proof using.
  intros v1 v2 Heq.
  destruct v1, v2.
  unfold vrel in *.
  simpl in *.
  inverts Heq.
  f_equal; [lia|].
  apply nameMapAppInj in H1.
  assumption.
Qed.

Lemma vRelInjective2 v1 v2 : v1 <> v2 ->
  vrel v1 <> vrel v2.
Proof using.
  intros Heq.
  intros Hc.
  apply vRelInjective in Hc. contradiction.
Qed.

Hint Rewrite varClassVPrime: Param.
Hint Rewrite varClassVRel: Param.

Hint Resolve vPrimeInjective : injective_fun.
Hint Resolve vRelInjective : injective_fun.
Local Transparent BinNat.N.add .

Ltac hideRHS rhs :=
match goal with
  [ |- _ = ?r] => set (rhs:= r)
  end.

  Local Opaque vprime.
  Local Opaque vrel.

(* use parametricity? *)
Lemma substAuxPrimeCommute: forall (t: STerm) (sub:Substitution),
(* NO need to assume that vars in a and b and the var x have class 0 *)
tprime (ssubst_aux t sub) =
ssubst_aux (tprime t) (ALMap vprime tprime sub).
Proof using.
  induction t using NTerm_better_ind; intro.
- simpl. unfold sub_find. rewrite ALFindMap by eauto with injective_fun.
  dALFind ss; setoid_rewrite <- Heqss; refl.
- simpl. unfold tprime, tvmap. simpl. f_equal. repeat rewrite map_map.
  apply eq_maps.
  intros b Hin. destruct b.
  specialize (H _ _ Hin). unfold compose. simpl. f_equal.
  unfold sub_filter. rewrite ALEndoMapFilterCommute by eauto with injective_fun.
  apply H.
Qed.

Corollary substAuxPrimeCommute1 : forall (A B: STerm) (x:V),
 (* NO need to assume that vars in a and b and the var x have class 0 *)
tprime (ssubst_aux A [(x,B)]) =
ssubst_aux (tprime A) [(vprime x,tprime B)].
Proof using.
  intros. rewrite substAuxPrimeCommute. refl.
Qed.

(* can use parametricity instead, once we deal with universe-polymorpic types such as NTerm *)
Lemma fvarsPrimeCommute t:
free_vars (tprime t) =
map vprime (free_vars t).
Proof using.
  induction t using NTerm_better_ind;[refl|].
  simpl. rewrite flat_map_map,  map_flat_map.
  apply eq_flat_maps.
  intros b Hin. destruct b. unfold compose. simpl.
  specialize (H _ _ Hin). setoid_rewrite H.
  unfold remove_nvars.
  erewrite <- map_diff_commute by eauto with injective_fun.
  refl.
Qed.

Lemma ifThenElseMap {A B:Type} (f: A->B) (b:bool) (t e : A):
  f (if b then t else e) = if b then (f t) else (f e).
Proof using.
  destruct b; auto.
Qed.

Lemma translateFvars ienv (t:STerm) :
subset
  (free_vars (translate true ienv t))
  (flat_map vAllRelated (free_vars t)).
Proof using.
Admitted. (** confident about this. note that it is unconditional, and it says [subset] not [eq_set]*)

(* generalize vAllRelated as a function that returns disjoint lists on different inputs *)
Lemma vAllRelatedFlatDisjFst lva lvb:
varsOfClass (lva ++ lvb) userVar
-> disjoint (map fst lva) (map fst lvb)
-> disjoint (flat_map vAllRelated lva) (flat_map vAllRelated lvb).
Proof using.
  intros Hvc Hd.
  apply disjoint_map with (f:= vBase).
  apply  varsOfClassApp in Hvc.
  destruct Hvc as [Hvca Hvcb].
  do 2 rewrite map_flat_map.
  unfold vAllRelated, compose. simpl.
  setoid_rewrite flat_map_fapp with (f:= fun x => [vBase x]).
  setoid_rewrite flat_map_fapp with (f:= fun x => [vBase (vprime x)]).
(*  let rec tac l :=
      match l with
        | ?h::?tl =>
        setoid_rewrite eqset_flat_maps at ltac:h;
          [| intros  ? ?;
                     try rewrite vBaseId;
                     try rewrite vBasePrime;
                     try rewrite vBaseRel;
                     [apply eq_set_refl | eauto]]; tac tl
        | _ => idtac "nil"
       end in tac ([1]). *)
  setoid_rewrite eqset_flat_maps at 1.
    Focus 2.
    intros  ? ?. rewrite vBaseId; [apply eq_set_refl | eauto].
  setoid_rewrite eqset_flat_maps at 2.
    Focus 2.
    intros  ? ?. rewrite vBasePrime; [apply eq_set_refl | eauto].
  setoid_rewrite eqset_flat_maps at 3.
    Focus 2.
    intros  ? ?. rewrite vBaseRel; [apply eq_set_refl | eauto].
  setoid_rewrite eqset_flat_maps at 4.
    Focus 2.
    intros  ? ?. rewrite vBaseId; [apply eq_set_refl | eauto].
  setoid_rewrite eqset_flat_maps at 5.
    Focus 2.
    intros  ? ?. rewrite vBasePrime; [apply eq_set_refl | eauto].
  setoid_rewrite eqset_flat_maps at 6.
    Focus 2.
    intros  ? ?. rewrite vBaseRel; [apply eq_set_refl | eauto].
    repeat rewrite flat_map_single.
    disjoint_reasoningv.
Qed.

(* generalize vAllRelated as a function that returns disjoint lists on different inputs *)
  Lemma vAllRelatedFlatDisj lva lvb:
 varsOfClass (lva ++ lvb) userVar
 -> disjoint lva lvb
 -> disjoint (flat_map vAllRelated lva) (flat_map vAllRelated lvb).
 Proof using.
   intros Hvc Hd. unfold disjoint.
   setoid_rewrite in_flat_map.
   unfold disjoint in Hd.
   apply  varsOfClassApp in Hvc.
   destruct Hvc as [Hvca Hvcb].
   intros ? H1ex. destruct H1ex as [v1  H1ex].
   destruct H1ex.
   intros H2ex. destruct H2ex as [v2  H2ex].
   destruct H2ex.
   unfold vAllRelated in *.
   repeat (in_reasoning); subst; try contradiction; eauto with Param.
   firstorder.
 - apply Hvcb in H1. apply (f_equal (@proj1_sig _ _ )) in H1.
   setoid_rewrite varClassVPrime in H1.
   apply Hvca in H. apply (f_equal (@proj1_sig _ _ )) in H.
   setoid_rewrite H in H1. compute in H1. lia.
 - apply Hvcb in H1. apply (f_equal (@proj1_sig _ _ )) in H1.
   setoid_rewrite varClassVRel in H1.
   apply Hvca in H. apply (f_equal (@proj1_sig _ _ )) in H.
   setoid_rewrite H in H1. compute in H1. lia.
 - apply Hvcb in H1. apply (f_equal (@proj1_sig _ _ )) in H1.
   apply Hvca in H. apply (f_equal (@proj1_sig _ _ )) in H.
   setoid_rewrite varClassVPrime in H.
   setoid_rewrite H1 in H. compute in H. lia.
 - apply vPrimeInjective in H2.  subst. firstorder.
 - apply (f_equal varClass1) in H2.
   autorewrite with Param in H2.
   unfold varClass1 in H2.
   setoid_rewrite (Hvca _ H) in H2.
   setoid_rewrite (Hvcb _ H1) in H2.
   compute in H2. lia.
 - apply Hvcb in H1. apply (f_equal (@proj1_sig _ _ )) in H1.
   apply Hvca in H. apply (f_equal (@proj1_sig _ _ )) in H.
   setoid_rewrite varClassVRel in H.
   setoid_rewrite H1 in H. compute in H. lia.
 - apply (f_equal varClass1) in H2.
   autorewrite with Param in H2.
   unfold varClass1 in H2.
   setoid_rewrite (Hvca _ H) in H2.
   setoid_rewrite (Hvcb _ H1) in H2.
   compute in H2. lia.
 - apply vRelInjective in H2.  subst. firstorder.
 Qed.

Lemma translateFvarsDisj ienv (t:STerm) lv:
varsOfClass (free_vars t  ++ lv) userVar
-> disjoint (free_vars t ) lv
-> disjoint (free_vars (translate true ienv t)) (flat_map vAllRelated lv).
Proof using.
  intros Hvc Hd.
  eapply subset_disjoint;[apply translateFvars|].
  apply vAllRelatedFlatDisj; auto.
Qed.

Fixpoint mkAppUnFlattened (f: STerm) (args: list STerm) : STerm :=
  match args with
  | [] => f
  | h::tl => mkAppUnFlattened (mkAppNoCheck f [h]) tl
  end.

(* beta reduction in mkApp was only for efficiency and we dont consider
  that in the proof *)
Lemma mkAppNoBeta : mkAppBeta = mkAppNoCheck. Admitted.

Local Opaque castIfNeeded mkAppBeta.

(* this comes up again and again *)
Lemma vDisjointUserVar (la lb: list V) :
  varsOfClass la userVar
  -> varsOfClass lb userVar
  -> disjoint la (map vprime lb ++ map vrel lb).
Proof using.
  intros Ha Hb.
  disjoint_reasoning; intros ? Hin Hc; apply in_map_iff in Hc; exrepnd;
    try apply Ha in Hin; try apply Hb in Hin; subst;
      try apply Ha in Hc1; try apply Hb in Hc1;
        apply (f_equal (@proj1_sig _ _ )) in Hc1;
        apply (f_equal (@proj1_sig _ _ )) in Hin;
        try setoid_rewrite varClassVPrime in Hin;
        try setoid_rewrite varClassVRel in Hin;
        rewrite N.add_mod in Hin by (unfold varCycleLen; lia);
        setoid_rewrite Hc1 in Hin; inverts Hin.
Qed.

Lemma vDisjointPrimeUserVar (la lb: list V) :
  varsOfClass la userVar
  -> varsOfClass lb userVar
  -> disjoint (map vprime la) (lb ++ map vrel lb).
Proof using.
  intros Ha Hb.
  pose proof (vDisjointUserVar _ _ Hb Ha).
  repeat disjoint_reasoning2.
  clear H H0.
  intros ? Hin Hinc.
  apply in_map_iff in Hin.
  apply in_map_iff in Hinc.
  exrepnd. subst.
  apply (f_equal varClass1) in Hinc0.
  apply Ha in Hin1.
  apply Hb in Hinc1.
  apply (f_equal (@proj1_sig _ _ )) in Hinc1.
  apply (f_equal (@proj1_sig _ _ )) in Hin1.
  rewrite varClassVPrime in Hinc0.
  rewrite varClassVRel in Hinc0.
  setoid_rewrite Hin1 in Hinc0.
  setoid_rewrite Hinc1 in Hinc0.
  invertsn Hinc0.
Qed.

Lemma vDisjointTPrimeUserVar (t:STerm) (lb: list V) :
  varsOfClass (free_vars t) userVar
  -> varsOfClass lb userVar
  -> disjoint (free_vars (tprime t)) (lb ++ map vrel lb).
Proof using.
  rewrite fvarsPrimeCommute.
  apply vDisjointPrimeUserVar.
Qed.

Lemma ssubst_trim (t:STerm) x b1 b2 b3:
  varsOfClass (free_vars t) userVar
  -> varsOfClass [x] userVar
  -> ssubst_aux t [(x, b1); (vprime x, b2); (vrel x, b3)] = ssubst_aux t [(x, b1)].
Proof using.
  intros H1v H2v.
  rewrite <- ssubst_aux_sub_filter2 with (l:= [vprime x; vrel x]);
    [| apply vDisjointUserVar with (lb:=[x]); assumption].
  simpl.
  do 2 rewrite deq_refl.
  do 3 rewrite decideFalse by eauto with Param.
  refl.
Qed.

Lemma ssubst_trim_prime (t:STerm) x b1 b2 b3:
varsOfClass (free_vars t) userVar
-> varsOfClass [x] userVar
-> ssubst_aux (tprime t) [(x, b1); (vprime x, b2); (vrel x, b3)] =
ssubst_aux (tprime t) [(vprime x, b2)].
Proof using.
  intros H1v H2v.
  rewrite <- ssubst_aux_sub_filter2 with (l:= [x; vrel x]);
    [|rewrite fvarsPrimeCommute;  apply vDisjointPrimeUserVar with (lb:=[x]); assumption].
  simpl.
  do 2 rewrite deq_refl.
  do 3 rewrite decideFalse by eauto with Param. refl.
Qed.

Require Import Morphisms.

(*
Ltac procVc Hvc :=
  simpl in Hvc;
  rewrite all_vars_ot in Hvc;
  simpl in Hvc;
  do 2 rewrite allvars_bterm in Hvc;
  rewrite app_nil_l in Hvc;
  unfold all_vars in Hvc;
  autorewrite with list in Hvc;
  rewrite cons_as_app in Hvc;
  rwsimpl Hvc.
 *)

(*
(* for this to work, replace mkAppBeta with mkApp in lambda case of translate  *)
Lemma translateSubstCommute ienv : forall (A B: STerm) (x:V),
    (* A must have been preprocessed with change_bvars_alpha *)
disjoint (bound_vars B) (bound_vars A) (* A will be alpha renamed before substitution to ensure this *)
-> checkBC (free_vars B ++ (remove_nvars [x]  (free_vars A))) B = true
-> checkBC (free_vars A ++ free_vars B) A = true
-> varsOfClass (x::(all_vars A (* ++ all_vars B*) )) userVar
->
let tr := translate true ienv in
tr (ssubst_aux A [(x,B)])
= (ssubst_aux (tr A) [(x,B); (vprime x, tprime B); (vrel x, tr B)]).
Proof.
  simpl.
  induction A as [| o lbt Hind]  using NTerm_better_ind ;
    intros B x Hdis H1bc H2bc Hvc;[|destruct o]; try refl;
    [ | | | | | | | | | |].
(* variable *)
- hideRHS rhs.
  simpl.
  rewrite beq_deq.
  cases_if as hd; subst.
  + simpl. unfold rhs. simpl.
    rewrite <- beq_var_refl.
    autorewrite with Param. refl.
  + simpl. unfold rhs. clear rhs.
    unfold all_vars in Hvc. simpl in *.
    unfold varsOfClass, lforall in Hvc.
    simpl in *; dLin_hyp.
    let tac:=
      autorewrite with Param;
      unfold varClass1;
      try setoid_rewrite Hyp; try setoid_rewrite Hyp0;
      compute; congruence in
    do 2 rewrite varClassNotEq by tac.
    rewrite not_eq_beq_var_false; auto;[].
    apply vRelInjective2. assumption.

- (* Lambda *)
  Local Opaque transLam.
  simpl. destruct lbt as [| b  lbt]; simpl; [refl|].
  let tac := try reflexivity in destructbtdeep2 b tac.
  rename bnt into lamTyp.
  (* process each BTerm before going to the next *)
  destruct lbt as [| b2  lbt]; [refl |].
  let tac := try reflexivity in destructbtdeep2 b2 tac.
  rename b2lv1 into lamVar.
  rename b2nt into lamBody.
  Local Opaque sub_filter.
  destruct lbt; [ |refl].
  Local Opaque decide.
  simpl in *.
  repeat rewrite app_nil_r in H1bc.
  repeat rewrite app_nil_r in H2bc.
  rewrite decide_true in H2bc;[| disjoint_reasoningv].
  ring_simplify in H2bc.
  fold V in lamVar.
  repeat rewrite andb_true in H2bc. repnd.
  rewrite Decidable_spec in H2bc.
  rwsimpl Hdis. rwsimpl Hdup. rwsimpl Hvc.
  fold V in lamVar.  repnd.
  clear Hvc4 Hvc2. unfold singleton in *.
  rewrite sub_filter_nil_r.
Abort.
 *)

Lemma checkBCLamAux (lamVar x:V) (lamBody lamTyp B: STerm ):
  disjoint (bound_vars B) [lamVar]
  -> (checkBC (free_vars B ++ remove x (free_vars lamTyp ++ remove lamVar (free_vars lamBody))) B =
         true)
  -> (checkBC (free_vars B ++ remove x (free_vars lamBody)) B = true).
Proof using.
   intros Hdis H2nd.
   apply (fst (checkBCStrengthen [lamVar])) in H2nd;[| assumption].
      revert H2nd. apply (fst checkBCSubset).
      rewrite remove_app.
      setoid_rewrite eqset_app_comm at 4.
      do 2 rewrite app_assoc.
      apply subset_app_r.
      setoid_rewrite eqset_app_comm at 3.
      do 1 rewrite <- app_assoc.
      apply subsetvAppLR;[eauto|].
      rewrite remove_comm. apply removeConsCancel.
Qed.

(* used in the lambda case and the pi case *)
Lemma transLamSubstCommute:
forall (ienv : indEnv) (argSort : option sort) (lamTyp : STerm) (lamVar : V) (lamBody : STerm),
  (
forall (nt : STerm) (lv : list (N * name)),
         bterm [] lamTyp = bterm lv nt \/ bterm [lamVar] lamBody = bterm lv nt \/ False ->
         forall (B : STerm) (x : V),
         disjoint (bound_vars B) (bound_vars nt) ->
         checkBC (free_vars B ++ remove x (free_vars nt)) B = true ->
         checkBC (free_vars nt ++ free_vars B) nt = true ->
         varsOfClass (x :: all_vars nt) userVar ->
         translate true ienv (ssubst_aux nt [(x, B)]) =
         ssubst_aux (translate true ienv nt)
           [(x, B); (vprime x, tprime B); (vrel x, translate true ienv B)] )
  ->
  forall (B : STerm) (x : V),
  disjoint (bound_vars B) (bound_vars lamTyp ++ lamVar :: bound_vars lamBody) ->
  checkBC ((free_vars lamTyp ++ remove lamVar (free_vars lamBody)) ++ free_vars B) lamTyp =
          true ->
  checkBC (lamVar :: (free_vars lamTyp ++ remove lamVar (free_vars lamBody)) ++ free_vars B)
            lamBody = true ->
checkBC (free_vars B ++ remove x (free_vars lamTyp ++ remove lamVar (free_vars lamBody))) B =
true ->
  disjoint [lamVar] ((free_vars lamTyp ++ remove lamVar (free_vars lamBody)) ++ free_vars B) ->
  varsOfClass [x] userVar ->
  varsOfClass (all_vars lamTyp) userVar ->
  varsOfClass [lamVar] userVar ->
  varsOfClass (all_vars lamBody) userVar ->
  transLam true (translate true ienv) (lamVar, (ssubst_aux lamTyp [(x, B)], argSort))
    (translate true ienv (ssubst_aux lamBody (sub_filter [(x, B)] [lamVar]))) =
  ssubst_aux
    (transLam true (translate true ienv) (lamVar, (lamTyp, argSort)) (translate true ienv lamBody))
    [(x, B ); (vprime x, tprime B); (vrel x, translate true ienv B)].
Proof using.
  intros ? ? ? ? ? Hind ? ? H2d H1nd H3nd H2nd H1d H1vc H2vc H3vc H4vc.
  hideRHS rhs. simpl.
  Local Opaque ssubst_bterm_aux.
  unfold rhs. clear rhs. simpl.
  Local Transparent ssubst_bterm_aux.
  simpl ssubst_bterm_aux at 1.
  unfold all_vars in *. rwsimpl H2vc. rwsimpl H4vc.
  rwsimpl Hvc.
  rewrite ssubst_trim by tauto.
  Local Opaque  ssubst_bterm_aux.
  symmetry.
  simpl in *. repeat rewrite app_nil_r in *.
  do 2 progress f_equal.
  Local Transparent ssubst_bterm_aux.
  Local Opaque ssubst_aux sub_filter.
  simpl.
  do 2 progress f_equal. simpl.
  Local Transparent ssubst_aux.
  simpl ssubst_aux at 1. rewrite sub_filter_nil_r.
  rewrite <- ssubst_aux_sub_filter2
  with
    (l:=[x; vrel x])
      (sub:= (sub_filter [(x, B); (vprime x, tprime B); (vrel x, translate true ienv B)] [lamVar]));
     [ |apply vDisjointTPrimeUserVar with (lb := [x]); tauto].
  rewrite sub_filter_swap.
  rewrite sub_filter_nil_r.
  Local Transparent sub_filter. simpl sub_filter at 1.
  Local Opaque sub_filter.
  do 2 rewrite deq_refl. symmetry.
  symmetry. do 3 rewrite decideFalse by eauto with Param.
  rename H3vc into Hvclv.
  rename H1vc into Hvcxb.
  pose proof (vDisjointPrimeUserVar _ _ Hvcxb Hvclv) as Hdiss.
  rewrite disjoint_app_r in Hdiss. apply proj1 in Hdiss.
  rewrite sub_filter_disjoint1 by assumption.
  clear Hdiss.
  rewrite <- substAuxPrimeCommute1.
  do 5 progress f_equal.
  (* the type of the (vrel lamVar) and the body lamBody remain.
     the type of lamVar and (tprime lamTyp) are already taken care of *)
  simpl.
  rewrite decide_decideP.
  destructDecideP.
  + clear Hind. (* ssubst gets filtered out. so no Hind needed *)
    subst. Local Transparent sub_filter. simpl.
    do 1 rewrite deq_refl.
    do 2 rewrite decideFalse by eauto with Param. simpl.
    do 1 rewrite deq_refl.
    do 1 rewrite decideFalse by eauto with Param.
    simpl.
    do 1 rewrite deq_refl.

    (* get the second BTerm [translate lamBody] to match up *)
    do 2 rewrite ssubst_aux_nil.

    do 4 f_equal. symmetry.

    (* now we only have [translate lamTyp] to worry about.
       In the RHS subst (after translate), we have a subst of length 1 (only for [vrel x]):
       the first 2 items have been filtered out.
       In the translation, [translate lamTyp] is in the scope of the binders
       [x:lamType] and [(vprime x):tprime lamType]. So those get filtered out in the RHS
       substitution. That's why no shadowing.

       We don't (can't) use the induction hypothesis.
       Indeed, it was filtered out in the first step after +.

       In the next branch (+), we will have a substitution of length 3 and use the induction
       hypothesis.*)
    rewrite ssubst_aux_trivial_disj;[| simpl; noRepDis2].
    rewrite ssubst_aux_trivial_disj;[refl|].
    rewrite mkAppNoBeta. simpl.
    disjoint_reasoningv2; try apply disjoint_neq_iff;
      try apply vRelNeqVPrime;
      try apply vRelNeqV.
    Local Transparent castIfNeeded.
    unfold castIfNeeded, projTyRel. rename H1d1 into H1d2.
    assert (disjoint (free_vars (translate true ienv lamTyp)) [vrel x]).
      apply disjoint_sym in H1d2.
      apply translateFvarsDisj with (ienv:=ienv) in H1d2;
        [unfold vAllRelated in H1d2; simpl in H1d2; noRepDis2 |].
      rwsimplC. dands; eauto with SquiggleEq.
    case_if; rwsimplC; unfold id in *; auto.
    disjoint_reasoningv2; auto.
    * pose proof (vDisjointUserVar _ _ H2vc0 Hvcxb).
      simpl in *. disjoint_reasoningv2.
    * pose proof (vDisjointTPrimeUserVar _ _ H2vc0 Hvcxb).
      simpl in *. disjoint_reasoningv2.

  +   (* here, substitution for [x] actually happens *)
    pose proof n as Hd. apply disjoint_neq_iff in Hd.
    apply vAllRelatedFlatDisj in Hd; [| rwsimplC; eauto with SquiggleEq; fail].
    simpl in Hd.
    rewrite sub_filter_disjoint1 with (lf := [lamVar]) (* start from innermost filter *)
      by (simpl; disjoint_reasoningv2).
    rewrite sub_filter_disjoint1 with (lf := [vprime lamVar]) (* start from innermost filter *)
      by (simpl; disjoint_reasoningv2).
    rewrite sub_filter_disjoint1 with (lf := [vrel lamVar]) (* start from innermost filter *)
      by (simpl; disjoint_reasoningv2).
    assert (checkBC (free_vars B ++ remove x (free_vars lamTyp)) B = true).
      revert H2nd. apply (fst checkBCSubset).
      rewrite remove_app. rewrite app_assoc. apply subset_app_r. eauto; fail.
    assert (checkBC (free_vars B ++ remove x (free_vars lamBody)) B = true).
      revert H2nd. apply checkBCLamAux. disjoint_reasoningv2.
    assert (checkBC (free_vars lamBody ++ free_vars B) lamBody = true).
      revert H3nd. apply (fst checkBCSubset).
      rewrite cons_as_app. rewrite app_assoc.
      apply subsetvAppLR;[| reflexivity].
      rewrite eqset_app_comm.
      rewrite <- app_assoc.
      apply subset_app_l.
      rewrite eqset_app_comm.
      apply removeConsCancel.
    assert (checkBC (free_vars lamTyp ++ free_vars B) lamTyp = true).
      revert H1nd. apply (fst checkBCSubset).
      apply subsetvAppLR;[| reflexivity].
      apply subset_app_r. reflexivity.

    disjoint_reasoningv2.
(*    setoid_rewrite (disjoint_remove_nvars_l  [lamVar]) in H1d5.
    setoid_rewrite remove_nvars_nop  in H1d5;[| disjoint_reasoningv2]. *)
    rewrite <- Hind with (lv := [lamVar]); auto; try disjoint_reasoningv2;
      [ |  rwsimplC; dands; eauto with SquiggleEq].
    do 2 progress f_equal.
    symmetry.

    (* Unlike the previous bullet (+), here we need to use the induction hypothesis
       for [translate lamTyp]. See the last comment in the above bullet.
       Unlike the subgoal there, here the substitution in RHS has length 3.
     *)
    rewrite mkAppNoBeta. simpl. unfold mkAppNoCheck. simpl.
    do 6 (rewrite not_eq_beq_var_false; [ | noRepDis2]).
    do 3 (progress f_equal).
    Ltac tac Hind := (apply Hind with (lv:=[]); auto;
        try (disjoint_reasoningv2); try (rewrite cons_as_app; rwsimplC; eauto with SquiggleEq)).
    Ltac tacOld Hind := (apply Hind with (lv:=[]); auto;
                         [disjoint_reasoningv2| rewrite cons_as_app; rwsimplC; eauto with SquiggleEq]).
    cases_if;
      [
        simpl; unfold projTyRel, mkConstApp, mkApp, mkAppNoCheck;
        simpl; do 4 (progress f_equal);
        [  | f_equal | do 2 progress f_equal; tac Hind]
      | unfold id; tac Hind
      ];
    symmetry;[ apply ssubst_trim| rewrite ssubst_trim_prime]; auto.
    rewrite substAuxPrimeCommute1. refl.
Qed.

Ltac revertAll :=
  repeat match goal with
   | [H:_ |- _] => revert H
   end.
Ltac eqList :=
    repeat match goal with
             [|- cons _ _ = cons _ _] => f_equal
                                         end.

(**
Note that in the LHS, [translate] is called on [(ssubst_aux A [(x,B)])], which
may have duplicate bound variables, even though [A] has unique bound variables.
Consider [A:= x x] and [B:= \y.y].

In the paper, we said that [translate] assumes that the input has unique boundvars.
That would make the LHS illegitimate.
We do need some condition: see examples/capture.v where a form of repeated boundvars
causes capture.
Perhaps we need a weaker condition: Barendredgt convention seems to suffice for this proof.
Why not make the weakest condition that suffices?

Then, if we prove that [translate] preserves alpha equality for terms only containing
uservars and in barendredgt convention, we'll be done.
beta does not preserve BC. so the subst function used in red will
need to take [B], which is already in BC and rename
it ti [B'] such that its bvars to be disjoint from [all_vars A]. [B'] is also in BC.
(this is kinda what would happen if we did the substitution A[B/x] in DB world and converted back to named)
in LHS, we will have [B']. In RHS, we will have something alpha equal to [translate B]
such that its bvars are disjoint from [all_vars (translate A)].
But, [translate B] is alpha equal to [translate B']. after rewriting, we can invoke this lemma

(We could instead precompose [translate] with a function to make boundvars [NoDup].
But then we would have to reason about alpha equality in the proof below.
[translate] does not unconditionally
respect alpha equality, as examples/capture.v shows. so we cannot "rewrite" after the proof)

When proving preservation of reduction, we will get in trouble because [NoDup].
*)

(* for this to work, replace mkAppBeta with mkApp in lambda case of translate  *)
Lemma translateSubstCommute ienv : forall (A B: STerm) (x:V),
    (* A must have been preprocessed with change_bvars_alpha *)
disjoint (bound_vars B) (bound_vars A) (* A will be alpha renamed before substitution to ensure this *)
-> checkBC (free_vars B ++ (remove_nvars [x]  (free_vars A))) B = true
-> checkBC (free_vars A ++ free_vars B) A = true
-> varsOfClass (x::(all_vars A (* ++ all_vars B*) )) userVar
->
let tr := translate true ienv in
tr (ssubst_aux A [(x,B)])
= (ssubst_aux (tr A) [(x,B); (vprime x, tprime B); (vrel x, tr B)]).
(* currently, nothing prevents the translation of A from picking bvars that free in B. tr A
 only looks at A and is free to pick anything that is not free on parts of A that it looks at.
 unless we have all free vars of B free in all subterms of A (impossible), there can be
a problem if we allow the translation to keep picking arbitrary bound vars. All the bvars
in the translation
must be obtained by a function of the input. Then we may also be able to obtain many free
theorems by parametricity. Seems we need 5 class. Or use a combinator for Pi. But then we need
to tackle universe issues *)
Proof.
  simpl.
  induction A as [| o lbt Hind]  using NTerm_better_ind ;
    intros B x Hdis H1bc H2bc Hvc;[|destruct o]; try refl;
    [ | | | | | | | | | |].
(* variable *)
- hideRHS rhs.
  simpl.
  rewrite beq_deq.
  cases_if as hd; subst.
  + simpl. unfold rhs. simpl.
    rewrite <- beq_var_refl.
    autorewrite with Param. refl.
  + simpl. unfold rhs. clear rhs.
    unfold all_vars in Hvc. simpl in *.
    unfold varsOfClass, lforall in Hvc.
    simpl in *; dLin_hyp.
    let tac:=
      autorewrite with Param;
      unfold varClass1;
      try setoid_rewrite Hyp; try setoid_rewrite Hyp0;
      compute; congruence in
    do 2 rewrite varClassNotEq by tac.
    rewrite not_eq_beq_var_false; auto;[].
    apply vRelInjective2. assumption.

- (* Lambda *)
  Local Opaque transLam.
  simpl. destruct lbt as [| b  lbt]; simpl; [refl|].
  let tac := try reflexivity in destructbtdeep2 b tac.
  rename bnt into lamTyp.
  (* process each BTerm before going to the next *)
  destruct lbt as [| b2  lbt]; [refl |].
  let tac := try reflexivity in destructbtdeep2 b2 tac.
  rename b2lv1 into lamVar.
  rename b2nt into lamBody.
  Local Opaque sub_filter.
  destruct lbt; [ |refl].
  Local Opaque decide.
  simpl in *.
  repeat rewrite app_nil_r in H1bc.
  repeat rewrite app_nil_r in H2bc.
  rewrite decide_true in H2bc;[| disjoint_reasoningv].
  ring_simplify in H2bc.
  fold V in lamVar.
  repeat rewrite andb_true in H2bc. repnd.
  rewrite Decidable_spec in H2bc.
  rwsimpl Hdis. rwsimpl Hdup. rwsimpl Hvc.
  fold V in lamVar.  repnd.
  clear Hvc4 Hvc2. unfold singleton in *.
  rewrite sub_filter_nil_r.
  eapply transLamSubstCommute; eauto.
- (* Pi *)
  Local Opaque transLam.
  simpl. destruct lbt as [| b  lbt]; simpl; [refl|].
  let tac := try reflexivity in destructbtdeep2 b tac.
  rename bnt into piVarType.
  (* process each BTerm before going to the next *)
  destruct lbt as [| b2  lbt]; [refl |].
  let tac := try reflexivity in destructbtdeep2 b2 tac.
  rename b2lv1 into piVar.
  rename b2nt into piRangeType.
  simpl in *.
  destruct lbt; [ |refl].
  rwsimpl Hdis. rwsimpl Hdup. rwsimpl Hvc.
  unfold all_vars in Hvc. rwsimpl Hvc.
  fold V in piVar.  repnd.
  repnd.
  repeat match goal with
  [H: varsOfClass [] _ |- _ ] => clear H
  end.
  unfold singleton in *.
  repeat rewrite sub_filter_nil_r.

  (* so far, same as that of the lambda case, except for different naming *)
  unfold mkPiRNew.
  simpl in *.
  repeat rewrite app_nil_r in H1bc.
  repeat rewrite app_nil_r in H2bc.
  rewrite decide_true in H2bc;[| disjoint_reasoningv].
  ring_simplify in H2bc.
  repeat rewrite andb_true in H2bc. repnd.
  rewrite Decidable_spec in H2bc.

  (* The 2 cases generated by the destruct below are very different.
    In the None (anyrel) case, we manually make the lambdas.
     (Initially, I used a combinator, but ran into universe issues)
    In the Some (isorel case), we make make a constant (combinator) applied to arguments:
     in this case we know that the domain and the codomain are in Set/Prop:
    We have disabled forall T:Type: True : Prop. *)
  Local Transparent sub_filter.
  assert (checkBC (free_vars B ++ remove x (free_vars piVarType)) B = true).
    revert H1bc. apply checkBCSubset. rewrite remove_app.
    rewrite  app_assoc.
    apply subset_app_r. reflexivity.
  assert (checkBC (free_vars piVarType ++ free_vars B) piVarType = true).
    revert H2bc3.
    apply checkBCSubset. apply subsetvAppLR;[| reflexivity].
    apply subset_app_r. reflexivity.
  destruct (needGoodnessPi true argsort bodySort).
  + simpl. unfold mkAppNoCheck, tvmap. simpl.
    repeat rewrite sub_filter_nil_r. simpl. f_equal.
    let rwTac := (clear Hind; repeat rewrite decideFalse by eauto with Param;
                   rewrite ssubst_aux_nil, ssubst_aux_trivial_disj;[refl|];
                   try (apply vDisjointTPrimeUserVar with (lb:=[x]); assumption);
                     try (apply vDisjointUserVar with (lb:=[x]); assumption)) in
    eqList; f_equal; symmetry;
      [ apply ssubst_trim
      | rewrite ssubst_trim_prime by auto; rewrite substAuxPrimeCommute1 | | | | ]; auto;
        symmetry;
        [ eapply Hind; eauto; [disjoint_reasoningv2| unfold all_vars; rwsimplC;
          eauto with SquiggleEq; fail]
        | f_equal; eqList; f_equal; symmetry; [apply ssubst_trim; assumption|]
        | f_equal; eqList; f_equal; symmetry;
          [rewrite ssubst_trim_prime by assumption;symmetry; apply substAuxPrimeCommute1 |]
        | eapply transLamSubstCommute; eauto; [|]; unfold all_vars; rwsimplC;
          eauto with SquiggleEq ];[|];
      simpl;
    rewrite (@decide_decideP (piVar=x) _);
    destructDecideP; subst; repeat rewrite deq_refl;
      [rwTac | | rwTac |]; simpl; [|];
    rename n into Hd;
    apply disjoint_neq_iff in Hd;
    (apply vAllRelatedFlatDisj in Hd; [| rwsimplC; eauto with SquiggleEq; fail]);
    simpl in Hd; repeat rewrite decideFalse by
        (apply disjoint_neq_iff;simpl; disjoint_reasoningv2);
    [apply ssubst_trim; auto |]; [].
    rewrite ssubst_trim_prime by assumption.
    symmetry. apply substAuxPrimeCommute1.
    Local Transparent decide.
  + (* no extra proofs because this Pi Type is in a higher universe. This part
      is same as the AnyRel translation *)
    admit.
- (* sort *)
  simpl. destruct lbt; [ | refl]. simpl map. cbv iota.
  rewrite ssubst_aux_trivial_disj;[refl | simpl; disjoint_reasoningv2].
  (* exactly same proof for all terms that take no lbt *)
- (* cast *) admit. (* not in the core calculus *)
- (* constant in the environment . also not a part of the core *)
  simpl. destruct lbt; [ | refl]. simpl map. cbv iota.
  rewrite ssubst_aux_trivial_disj;[refl | simpl; disjoint_reasoningv2].
- (* constructor constant in the env : note: it does not contain the constructor's args:
    need wo apply it explicitly. Thus, this case is exactly like the constant case:
    this is just a technicality that the kernel uses a different tag for the constructor
    constants*)
  simpl. destruct lbt; [ | refl]. simpl map. cbv iota.
  rewrite ssubst_aux_trivial_disj;[refl | simpl; disjoint_reasoningv2].
- (* inductive constant in the env : note: it does not contain the inductives's args:
    need wo apply it explicitly. Thus, this case is exactly like the constant case:
    this is just a technicality that the kernel uses a different tag for the constructor
    constants*)
  simpl. destruct lbt; [ | refl]. simpl map. cbv iota.
  rewrite ssubst_aux_trivial_disj;[refl | simpl; disjoint_reasoningv2].
- (* Fix : this will be complicated *) admit.
- (* app *)
  Local Transparent sub_filter.
  simpl.
  (** We assume the Coq produces only well formed applications, with each app having only 1 arg.
     We can put a preprocessing phase to nest in cases of multiple args*)
  assert (map num_bvars lbt = [ 0; 0 ]%nat) as Hwf by admit.
  destruct lbt as [| f lbt]; [reflexivity | ]. simpl.
  let tac := invertsn Hwf in destructbtdeep2 f tac.
  simpl.
  destruct lbt as [| a lbt]; inverts Hwf as Ha Hwf.
  destruct lbt as [|]; [ | invertsn Hwf].
  let tac := invertsn Ha in destructbtdeep2 a tac.
  Local Opaque decide.
  simpl in *. unfold all_vars in Hvc. simpl in Hvc.
  autorewrite with list in *.
  rewrite cons_as_app in Hvc.
  rwsimpl Hvc. clear Hwf. repnd.
  do 2 (rewrite decide_true in H2bc;[| disjoint_reasoningv2]).
  ring_simplify in H2bc. repeat rewrite  andb_true in H2bc. repnd.
  disjoint_reasoningv2.
  assert (checkBC (free_vars B ++ remove x (free_vars fnt)) B =true).
    revert H1bc. apply checkBCSubset. rewrite remove_app.
    rewrite  app_assoc.
    apply subset_app_r. reflexivity.
  assert ( checkBC (free_vars fnt ++ free_vars B) fnt = true).
    revert H2bc0.
    apply checkBCSubset. apply subsetvAppLR;[| reflexivity].
    apply subset_app_r. reflexivity.
  assert (checkBC (free_vars B ++ remove x (free_vars ant)) B =true).
    revert H1bc. apply checkBCSubset. rewrite remove_app.
    apply subsetvAppLR; [reflexivity|]. apply subset_app_l. reflexivity.
  assert ( checkBC (free_vars ant ++ free_vars B) ant = true).
    revert H2bc.
    apply checkBCSubset. rewrite <- app_assoc.
    apply subset_app_l. reflexivity.

  rewrite mkAppNoBeta. unfold mkApp, mkAppNoCheck. simpl.
  clear Hvc0.
   let tac := (progress f_equal) in
   let htac :=
      apply Hind with (lv:=[]); auto;
        try (disjoint_reasoningv2); try (rewrite cons_as_app; rwsimplC; eauto with SquiggleEq) in
            do 3 tac;[ htac | do 1 tac| do 2 tac;[ | tac; htac ] ];[ | ]; symmetry;
          [ apply ssubst_trim; assumption | ].
  rewrite ssubst_trim_prime by assumption.
  symmetry. apply substAuxPrimeCommute1.
- (* match : this will be complicated *) admit.
Fail idtac.
Admitted.

Ltac GCVC := repeat match goal with
                      [ h: varsOfClass [] _ |- _ ] => clear h
                                                       end.

Definition goodInput (outerBvars : list V) (t:STerm) : Prop :=
  (varsOfClass (all_vars t) userVar) /\ (checkBC outerBvars t = true).

Lemma translatePreservesBC ienv (a: STerm) :
  goodInput (free_vars a) a  ->  checkBC (flat_map vAllRelated (free_vars a)) (translate true ienv a) = true.
Proof using.
  intros Hb.  rename a into t.
  induction t as [| o lbt Hind]  using NTerm_better_ind;
    [|destruct o]; try refl;
      [ | | | | | | | | |].
- (* Lambda *)
  Local Opaque transLam.
  simpl. destruct lbt as [| b  lbt]; simpl; [refl|].
  let tac := try reflexivity in destructbtdeep2 b tac.
  rename bnt into lamTyp.
  (* process each BTerm before going to the next *)
  destruct lbt as [| b2  lbt]; [refl |].
  let tac := try reflexivity in destructbtdeep2 b2 tac.
  rename b2lv1 into lamVar.
  rename b2nt into lamBody.
  Local Opaque sub_filter.
  destruct lbt; [ |refl].
  Local Opaque decide.
  simpl in *.
  repeat rewrite app_nil_r in Hb.
  repeat rewrite app_nil_r.
  unfold goodInput in Hb.
  simpl in Hb. fold V in lamVar.
  repeat rewrite andb_true in Hb. repnd. GC.
  clear Hb5. pose proof Hb0 as Hbb. unfold all_vars in Hbb. rwsimpl Hbb.
  repnd.
  setoid_rewrite all_vars_ot in Hb0. simpl in Hb0. rewrite app_nil_r in Hb0.
  rwsimpl Hb0. rename Hb0 into Huv. repnd. GCVC. unfold singleton in *. GC.
  rewrite Decidable_spec in Hb2.
  unfold all_vars in *.
  rwsimpl Huv0.
  rwsimpl Huv. repnd. GC. pose proof Hb2 as Hbr.
  apply vAllRelatedFlatDisj in Hb2;[| rwsimplC]; dands; auto;[| eauto with SquiggleEq].
  Local Transparent transLam.
  unfold transLam.
  simpl in *.
  repeat (rewrite decide_true;
      (try apply NoDupSinleton; try constructor; try disjoint_reasoningv2));
    try (apply disjoint_neq_iff; eauto with Param; fail);[].
  ring_simplify. repeat rewrite andb_true. dands;[| | | ].
  + setoid_rewrite flat_map_fcons. rewrite map_id. rewrite eqset_app_comm.
    pose proof Hb6 as Hclt.
    revert Hb6.
    apply checkBCStrengthen. simpl.
    apply checkBCdisjoint in Hclt.
    rewrite flat_map_fcons. rewrite flat_map_single.
    apply vDisjointUserVar; auto. rwsimplC. dands; auto.
  + (* similar  to above. there is an extra, [lamVar]. but it cannot appear in [tprime lamTyp] because
       of classes *) admit.
  + (* despite Hb6:  checkBC (free_vars lamTyp ++ remove lamVar (free_vars lamBody)) lamTyp ,
       [bound_vars lamTyp] may have [lamVar].
       ([free_vars lamTyp] cannot have [lamVar], because of Hbr0).

      Thus, ([bound_vars (translate lamTyp)] may have [vAllRelated lamVar], which violates the BC condition,
      because (translate lamTyp) is in scope of [lamVar] and [vprime lamVar] (but not [vrel lamVar]).

*) admit.
  + rewrite flat_map_app. rewrite cons_as_app. setoid_rewrite cons_as_app at 3.
    setoid_rewrite cons_as_app at 5.
    repeat rewrite app_assoc.
    apply checkBCStrengthen.
    * apply disjoint_app_r. dands.
      (* disjoint (bound_vars (translate true ienv lamBody))
    (([vrel lamVar] ++ [vprime lamVar]) ++ [lamVar]) *)
      (* because the input was in BC*) admit.

      (* bvars of lamBody cannot include free_vars of lamTyp, by defn of checkBC*) admit.
    * eapply checkBCSubset;[| apply Hind with (lv:=[lamVar])];
        [ apply flat_map_monotone
        | cpx; fail
        | split; unfold all_vars; rwsimplC; try split; auto];
        [| revert Hb4; apply checkBCSubset].

Abort.
(** there is a much more elegant proof of this *)
Lemma translateRespectsAlpha ienv (a b: STerm) :
  goodInput (free_vars a) a -> goodInput (free_vars b) b -> alpha_eq a b -> alpha_eq (translate true ienv a) (translate true ienv b).
Proof using.
  intros H1g H2g Hal.
  induction Hal as [|op lbt lbt2 Hlen Hbt];[refl| destruct op].
(* Lambda *)
- Local Opaque transLam.
  simpl.
  destruct lbt as [| b  lbt]; simpl; simpl in Hlen;
    dlist_len lbt2; [  refl|]. rename lbt0 into b2.
  let tac := try reflexivity in destructbtdeep2 b tac.
  rename bnt into lamTyp.
  (* process each BTerm before going to the next *)
(*  destruct lbt as [| b2  lbt]; [refl |].
  let tac := try reflexivity in destructbtdeep2 b2 tac.
  rename b2lv1 into lamVar.
  rename b2nt into lamBody.
  Local Opaque sub_filter.
  destruct lbt; [ |refl].
  Local Opaque decide.
  simpl in *.

  *)
Admitted.

(* delete *)
Ltac add_changebvar_spec4 cb Hn:=
match goal with
| [ |- context[@change_bvars_alpha ?a1 ?a2 ?a3 ?a4 ?a5 ?a6 ?lv ?nt] ] =>
   pose proof (@change_bvars_alpha_spec2 a1 a2 a3  a5 a4 _ a6 nt lv) as Hn;
    remember (@change_bvars_alpha a1 a2 a3 a4 a5 a6 lv nt) as cb
| [ |- context[@change_bvars_alphabt ?a1 ?a2 ?a3 ?a4 ?a5 ?a6 ?lv ?nt] ] =>
  pose proof (@change_bvars_alphabt_spec2 a1 a2 a3  a5 a4 _ a6 lv nt) as Hn;
    remember (@change_bvars_alphabt a1 a2 a3 a4 a5 a6 lv nt) as cb
end.

Lemma translate_bcsubst_commute ienv (outerBvars : list V) : forall (A B: STerm) (x:V),
    let lam := bterm [x] A in
    let apT := (oterm (CApply 1) [lam ; bterm [] B]) in
subset (free_vars apT) outerBvars
-> checkBC outerBvars apT =true
-> varsOfClass (x::(all_vars A (* ++ all_vars B*) )) userVar
-> let tr := translate true ienv in
  alpha_eq
    (tr (bcSubst outerBvars A [(x,B)]))
    ((bcSubst (flat_map vAllRelated outerBvars) (tr A) [(x,B); (vprime x, tprime B); (vrel x, tr B)])).
Proof.
  simpl.
  intros ? ? ? Hs Hbc Hvc.
  simpl in Hbc.
  setoid_rewrite decide_true in Hbc at 2;[| disjoint_reasoningv].
  ring_simplify in Hbc.
  repeat rewrite andb_true in Hbc.
  repnd.
  unfold bcSubst.
  add_changebvar_spec4 Ap Hn. clear HeqAp.
  add_changebvar_spec4 Atp Htn. clear HeqAtp.
  simpl in *.
  rewrite app_nil_r in *.
  repnd.
  pose proof Hn2 as Hal.
  rewrite cons_as_app in Hvc. rwsimpl Hvc. repnd.
  pose proof Hvc as Hvcb.
  unfold all_vars in Hvcb. rwsimpl Hvcb. repnd.
  clear Hvc0. unfold singleton in *.
  assert ( subset (free_vars A) (x :: outerBvars)) as H1s.
    eapply subset_trans.
    apply removeConsCancel with (r:=x). apply subset_cons2.
    eapply subset_trans;[| apply Hs].
    apply subset_app_r. reflexivity.

  apply (translateRespectsAlpha ienv) in Hal.
  Focus 2.
    split; [assumption|].
    revert Hbc3. apply (fst checkBCSubset). apply H1s.

  Focus 2.
    split; [admit (*  varsOfClass (all_vars Ap) userVar *)|].
    revert Hn0. apply (fst checkBCSubset).
    rewrite cons_as_app. rewrite app_assoc.
    apply subset_app_r. rewrite <- Hn2. apply H1s.

  (*rewrite Htn in Hn.*)
  symmetry.
  rewrite <- ssubst_ssubst_aux;[| simpl].
  Focus 2.
    (* vars RHS are a subset of (flat_map vAllRelated (free_vars B))
     because  (bound_vars Atp) only has vars of class [userVar], it suffices to
     replace the RHS merely with (free_vars B)
    *)
     revert Htn1. revert Hs.  (* now these should be enough *) rewrite app_nil_r.
  (*
  subset (remove x (free_vars A) ++ free_vars B) outerBvars ->
  disjoint
    (x
     :: vprime x
        :: vrel x
           :: flat_map vAllRelated outerBvars ++
              bound_vars B ++ bound_vars (tprime B) ++ bound_vars (translate true ienv B))
    (bound_vars Atp) ->
  disjoint (bound_vars Atp)
    (free_vars B ++ free_vars (tprime B) ++ free_vars (translate true ienv B))
*)
    admit.

  rewrite Htn2 in Hal.
  rewrite Hal.
  symmetry.

  rewrite translateSubstCommute;
    [ | disjoint_reasoningv2 | | | (*  varsOfClass (x :: all_vars Ap) userVar *) admit] .
  Focus 2.
    revert Hbc1. apply (fst checkBCSubset).
    rewrite eqset_app_comm. simpl. rewrite <- Hn2. assumption.

  Focus 2.
    revert Hn0. apply (fst checkBCSubset). rewrite cons_as_app. rewrite app_assoc.
    apply subset_app_r. rewrite <- Hn2. apply subset_app.
    split;[apply H1s|].
    apply subset_app_l. eapply subset_trans;[| apply Hs]. apply subset_app_l. reflexivity.

  rewrite  ssubst_ssubst_aux;[refl| simpl]. rewrite app_nil_r.

(*
disjoint (bound_vars (translate true ienv Ap))
    (free_vars B ++ free_vars (tprime B) ++ free_vars (translate true ienv B)
 true because [Ap] avoides [outerBvars] and  [outerBvars] includes [free_vars B]
*)
Abort.

(** this is refutable, hence only a temporary hack.
  In the end, replace [mkAppBeta] witn [mkAppUnFlattened ]in [translate] *)
Lemma mkAppSimpl : mkAppBeta = mkAppUnFlattened. Admitted.

Lemma mkAppCongrLeft sf (outerBvars: list V) (FL FR arg :STerm)  :
  red sf outerBvars FL FR
  -> red sf outerBvars (mkApp FL [arg]) (mkApp FR [arg]).
Proof using.
  intros Hr.
  apply congruence with (n:=0%nat); simpl; auto.
  intros m Hneq. destruct m; simpl; auto. lia.
Qed.

Inductive clos_refl_sym_trans (R : Relation_Definitions.relation STerm)
  : Relation_Definitions.relation STerm :=
    rst_step : forall x y : STerm, R x y -> clos_refl_sym_trans R x y
  | rst_refl : forall x y: STerm, alpha_eq x y -> clos_refl_sym_trans R x y
  | rst_sym : forall x y : STerm, clos_refl_sym_trans R x y -> clos_refl_sym_trans R y x
  | rst_trans : forall x y z : STerm,
                clos_refl_sym_trans R x y ->
                clos_refl_sym_trans R y z -> clos_refl_sym_trans R x z.

(* target language, where we dont have to worry about shadowing *)
Definition defEqT :   STerm -> STerm -> Prop :=
clos_refl_sym_trans (red (fun _ => ssubst) []).

Lemma translateRedCommute ienv : forall (A B: STerm) outerBvars,
(* subset (free_vars A) outerBVars -> checkBC outerBVars A = true*)
 redS outerBvars A B
(* 3 beta reductions *)
-> defEqT (translate true ienv A) (translate true ienv B).
Proof using.
  intros ? ? ? Hred. induction Hred.
- simpl. Local Transparent transLam. unfold transLam. simpl.
  rewrite  mkAppSimpl. simpl.

  eapply rst_trans;
   [apply rst_step; apply mkAppCongrLeft; apply mkAppCongrLeft;apply beta|].
  eapply rst_trans.

  simpl. apply rst_step. apply mkAppCongrLeft.
  Fail apply beta. (* the lambda bterm needs to be visible. need another version of ssubst that doesn't
    do unnecessary renamings as much as possible *)
  (* blows up. because bcSubst has to go over mkLam before [beta] can unify.
     Solutions:
      1) make change_bvar_alphabt skip renaming if not necessary. here the variable [vprime x]
         already satisfies the desired specs. [vprime x] is not [x]. It is not in [outerBvars]
         because of the hypothesis [check outerBvars A= true]. It is not in
         [flat_map bound_vars [arg]] because its class is different.
--->  2) use normal safe substitution (ssubst) in the conclusion. the BC stuff is only needed
         BEFORE the translation.
         Make another version of subst that delays renaming even more (deeper), until it actually
         hits a bterm with a problematic bound variable.
      3) In the target, use a reduction rule that directly does beta for 3 apps and 3 lams
   *)
(*   [apply rst_step; apply mkAppCongrLeft;apply beta|]. *)
Abort.

Lemma translateDefnEqCommute ienv : forall (A B: STerm) outerBvars,
(* preconditions *)
defEqS outerBvars A B
-> defEqT (translate true ienv A) (translate true ienv B).
Abort.

(* define the typing relation. primitive rules for the terms denoting SigT and SigT_rect,
eq and eq_rect2 (dependent version)
Also define subtyping? subtyping comes before typing?
*)

(* pick out a core language that excludes inductives – only covers Lasson;s
first translation *)
Inductive inSrcLanuage : STerm -> Prop :=.

(* abstraction theorem for the translation of terms satisfying inSrcLanuage.
The desination uses full typing rules.
https://onedrive.live.com/edit.aspx/Documents/Postdoc?cid=946e75b47b19a3b5&id=documents&wd=target%28parametricity%2Fpapers%2Flogic%2Fproof.one%7C4AAB4EEB-90BF-4FC7-BBB1-7C61980BE1EB%2F%29
onenote:https://d.docs.live.net/946e75b47b19a3b5/Documents/Postdoc/parametricity/papers/logic/proof.one#section-id={4AAB4EEB-90BF-4FC7-BBB1-7C61980BE1EB}&end
*)


Require Import VST.floyd.proofauto.
Require Import onepile.
Require Import spec_stdlib.
Require Import PileModel.

Record OnePileAPD := {
  onepile: option (list Z) -> globals -> mpred
}.

Local Open Scope assert.

Section OnepileASI.
Variable M: MallocFreeAPD.
Variable ONEPILE:OnePileAPD.

Definition Onepile_init_spec :=
 DECLARE _Onepile_init
 WITH gv: globals
 PRE [ ]
    PROP() PARAMS () GLOBALS (gv) SEP(onepile ONEPILE None gv; mem_mgr M gv)
 POST[ tvoid ]
    PROP() LOCAL() SEP(onepile ONEPILE (Some nil) gv; mem_mgr M gv).

Definition Onepile_add_spec :=
 DECLARE _Onepile_add
 WITH n: Z, sigma: list Z, gv: globals
 PRE [ tint ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (Vint (Int.repr n)) GLOBALS (gv)
    SEP(onepile ONEPILE (Some sigma) gv; mem_mgr M gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(onepile ONEPILE (Some (n::sigma)) gv; mem_mgr M gv).

Definition Onepile_count_spec :=
 DECLARE _Onepile_count
 WITH sigma: list Z, gv: globals
 PRE [  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS () GLOBALS (gv)
    SEP(onepile ONEPILE (Some sigma) gv)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(onepile ONEPILE (Some sigma) gv).

Definition OnepileASI:funspecs := [ Onepile_init_spec; Onepile_add_spec; Onepile_count_spec].

End OnepileASI.