Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal2.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (y:lst):@eq natural (Succ (len (append y x))) (len (append y (Cons n x))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal2_theorem0_40_lem/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) (y:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x y.
QuickChick collect_data.
Success.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require Export geometry_tools_lemmas.
Require Export general_tactics.
Require Import List.

Inductive AVars : Type :=
  | PVar : Point -> AVars
  | FVar : F -> AVars.

Inductive AP : Type :=
  | APvar : nat -> AP.

Inductive AF : Type :=
  | AS : nat -> nat -> nat -> AF
  | AD : nat -> nat -> AF
  | AFvar : nat -> AF
  | AF0 : AF
  | AF1 : AF
  | AFplus : AF -> AF -> AF
  | AFmult : AF -> AF -> AF
  | AFopp : AF -> AF
  | AFinv : AF -> AF.

(* Checks if var is in lvar *)

Ltac List_mem var lvar :=
  match constr:(lvar) with
  | nil => constr:(false)
  | cons ?X1 ?X2 =>
      match constr:(X1 = var) with
      | (?X1 = ?X1) => constr:(true)
      | _ => List_mem var X2
      end
  end.

(* Build the list of variables  *)

Ltac build_var_point_list_aux lvar point :=
     let res := List_mem (PVar point) lvar in
      match constr:(res) with
      | true => lvar
      | false => constr:(cons (PVar point) lvar)
      end.

Ltac build_var_list_aux lvar trm :=
  match constr:(trm) with
  | F0 => lvar
  | F1 => lvar
  | (Fplus ?X1 ?X2) =>
      let l2 := build_var_list_aux lvar X2 in
      build_var_list_aux  l2 X1
  | (Fmult ?X1 ?X2) =>
      let l2 := build_var_list_aux  lvar X2 in
      build_var_list_aux l2 X1
  | (Fopp ?X1) => build_var_list_aux lvar X1
  | (Finv ?X1) => build_var_list_aux lvar X1
  | (S ?X1 ?X2 ?X3) =>
  let l1 := build_var_point_list_aux lvar X3 in
  let l2 := build_var_point_list_aux l1 X2 in
  build_var_point_list_aux l2 X1
  | (DSeg ?X1 ?X2) =>
  let l1 := build_var_point_list_aux lvar X2 in
  build_var_point_list_aux l1 X1
  | (?X1 = ?X2) =>
  let l2 := build_var_point_list_aux lvar X2 in
  build_var_point_list_aux l2 X1

  | ?X1 =>
    let res := List_mem (FVar X1) lvar in
      match constr:(res) with
      | true => lvar
      | false => constr:(cons (FVar X1) lvar)
      end
  end.

Ltac build_var_list trm :=
  build_var_list_aux (@nil AVars) trm.

Ltac List_assoc elt lst :=
  match constr:(lst) with
  | nil => fail
  | (cons (@pairT AVars nat ?X1 ?X2) ?X3) =>
      match constr:(elt = X1) with
      | (?X1 = ?X1) => constr:(X2)
      | _ => List_assoc elt X3
      end
  end.

Ltac number_aux lvar cpt :=
  match constr:(lvar) with
  | nil => constr:(@nil (prodT AVars nat))
  | cons ?X2 ?X3 =>
      let l2 := number_aux X3 (Datatypes.S cpt) in
      constr:(cons (@pairT  AVars nat X2 cpt) l2)
  end.

Ltac number lvar := number_aux lvar (Datatypes.O).

Ltac build_numbered_var_list trm := let lvar := build_var_list trm in
                             number lvar.

Definition list_assoc_inv :=
  (fix list_assoc_inv_rec (A:Type) (B:Set)
                     (eq_dec:forall e1 e2:B, {e1 = e2} + {e1 <> e2})
                     (lst:list (prodT A B)) {struct lst} :
   B -> A -> A :=
     fun (key:B) (default:A) =>
       match lst with
       | nil => default
       | cons (pairT v e) l =>
           match eq_dec e key with
           | left _ => v
           | right _ => list_assoc_inv_rec A B eq_dec l key default
           end
       end).

(* Interpretation *)
Parameter SomeValue :AVars.
Parameter SomePoint :Point.

Definition interp_AP_to_Point (lvar:list (prodT AVars nat)) (e:nat) : Point :=
 match(list_assoc_inv  AVars nat eq_nat_dec lvar e SomeValue) with
    | PVar p => p
    | _ => SomePoint
  end
.

Fixpoint interp_AF_to_F (lvar:list (prodT AVars nat)) (e:AF) {struct e} : F :=
  match e with
  | AF0 => F0
  | AF1 => F1
  | AS e1 e2 e3 => let idx1 := (interp_AP_to_Point lvar e1) in
S idx1 (interp_AP_to_Point lvar e2) (interp_AP_to_Point lvar e3)
  | AD e1 e2 => DSeg (interp_AP_to_Point lvar e1) (interp_AP_to_Point lvar e2)
  | AFplus e1 e2 => Fplus (interp_AF_to_F lvar e1) (interp_AF_to_F lvar e2)
  | AFmult e1 e2 => Fmult (interp_AF_to_F lvar e1) (interp_AF_to_F lvar e2)
  | AFopp e => Fopp (interp_AF_to_F lvar e)
  | AFinv e => Finv (interp_AF_to_F lvar e)
  | AFvar n =>
  match(list_assoc_inv  AVars nat eq_nat_dec lvar n SomeValue) with
    | FVar f => f
    | _ => F0
  end
  end.

(* Metaification *)

Ltac interp_A lvar trm :=
  match constr:(trm) with
  | F0 => constr:(AF0)
  | F1 => constr:(AF1)
  | (Fplus ?X1 ?X2) =>
      let e1 := interp_A lvar X1 with e2 := interp_A lvar X2 in
      constr:(AFplus e1 e2)
  | (Fmult ?X1 ?X2) =>
      let e1 := interp_A lvar X1 with e2 := interp_A lvar X2 in
      constr:(AFmult e1 e2)
  | (Fopp ?X1) =>
      let e := interp_A lvar X1 in
      constr:(AFopp e)
  | (Finv ?X1) =>
      let e := interp_A lvar X1 in
      constr:(AFinv e)
 | (S ?X1 ?X2 ?X3) =>
   let idx1 := List_assoc (PVar X1) lvar with
   idx2 := List_assoc (PVar X2) lvar with
   idx3 := List_assoc (PVar X3) lvar in
   constr:(AS idx1 idx2 idx3)
 | (DSeg ?X1 ?X2) =>
  let idx1 := List_assoc (PVar X1) lvar with
  idx2 := List_assoc (PVar X2) lvar in
  constr:(AD idx1 idx2)
 | ?X1 => let idx := List_assoc (FVar X1) lvar in
           constr:(AFvar idx)
  end.

Fixpoint nateq (n m:nat) {struct m} : bool :=
  match n, m with
  | O, O => true
  | Datatypes.S n', Datatypes.S m' => nateq n' m'
  | _, _ => false
  end.

Lemma nateq_prop : forall n m:nat, (Is_true (nateq n m))-> n=m.
Proof.
 simple induction n; simple induction m; intros; try contradiction.
  trivial.
  unfold Is_true in H1.
  rewrite (H n1 H1).
  trivial.
Qed.

Fixpoint simplif (e:AF) {struct e} : AF :=
  match e with
   | AFplus e1 e2 =>
   let s1 := (simplif e1) in
   let s2 := (simplif e2) in
   match s1 with
     AF0 => s2
     |_ => match s2 with
        AF0 => s1
        |_ =>  AFplus s1 s2
        end
     end
   | AFmult e1 e2 =>
    let s1 := (simplif e1) in
    let s2 := (simplif e2) in
    match s1 with
      AF0 => AF0
      |AF1 => s2
      |_ => match s2 with
        AF0 => AF0
        |AF1 => s1
        |_ =>  AFmult s1 s2
        end
    end
  | AFopp e =>
    let s := (simplif e) in
    match s with
       AF0 => AF0
       | AFopp e1 => e1
       | _ => AFopp s
    end
  | AS e1 e2 e3 => if (nateq e1 e2) then AF0 else
  (if (nateq e1 e3) then AF0 else (if (nateq e2 e3) then AF0 else e))
  | AD e1 e2 => if (nateq e1 e2) then AF0 else e
  | _ => e
end.

Lemma simplif_correct :
forall (e:AF) (lvar:list (prodT AVars nat)),
   interp_AF_to_F lvar (simplif e) =
   interp_AF_to_F lvar e.
Proof.
intros.
induction e;trivial;simpl interp_AF_to_F at 2.
simpl.
assert (T:=(nateq_prop n n0)).
destruct (nateq n n0).
replace n with n0.
replace (S (interp_AP_to_Point lvar n0) (interp_AP_to_Point lvar n0)
  (interp_AP_to_Point lvar n1)) with 0;auto;apply trivial_col1.
symmetry;apply T;unfold Is_true;auto.
assert (T2:=(nateq_prop n n1)).
destruct (nateq n n1).
replace n with n1.
replace (S (interp_AP_to_Point lvar n1) (interp_AP_to_Point lvar n0)
  (interp_AP_to_Point lvar n1)) with 0;auto;apply trivial_col3.
symmetry;apply T2;unfold Is_true;auto.
assert (T3:=(nateq_prop n0 n1)).
destruct (nateq n0 n1).
replace n0 with n1.
replace (S (interp_AP_to_Point lvar n) (interp_AP_to_Point lvar n1)
  (interp_AP_to_Point lvar n1)) with 0;auto;apply trivial_col2.
symmetry;apply T3;unfold Is_true;auto.
simpl;auto.
simpl.
assert (T:=(nateq_prop n n0)).
destruct (nateq n n0).
replace n with n0.
apply nuldirseg.
symmetry;apply T;unfold Is_true;auto.
simpl;auto.
rewrite <- IHe1;rewrite <- IHe2;simpl simplif at 1;destruct (simplif e1);destruct (simplif e2);trivial;simpl;ring.
rewrite <- IHe1;rewrite <- IHe2;simpl simplif at 1;destruct (simplif e1);destruct (simplif e2);trivial;simpl;ring.
rewrite <- IHe;simpl simplif at 1;destruct (simplif e);trivial;simpl;ring.
Qed.

Ltac simplif_term exp :=
  let lvar := build_numbered_var_list exp in
  let trm := interp_A lvar exp in
  let trm2 :=constr:(interp_AF_to_F lvar (simplif trm)) in
 (replace exp with trm2 in *;[simpl|rewrite simplif_correct;trivial]).

Ltac Rbasic_simpl := match goal with
_:_ |- ?X1 = ?X2 => simplif_term X1;simplif_term X2;unfold interp_AP_to_Point;simpl
end.

Fixpoint natle (n m:nat) {struct m} : bool :=
  match n, m with
  | O, O => true
  | O, Datatypes.S n' => true
  | Datatypes.S n', Datatypes.S m' => natle n' m'
  | _, _ => false
  end.

Fixpoint uniformize_areas (e:AF) {struct e} : AF :=
match e with
  | AFplus e1 e2 =>
    let s1 := (uniformize_areas e1) in
    let s2 := (uniformize_areas e2) in
    AFplus s1 s2
  | AFmult e1 e2 =>
    let s1 := (uniformize_areas e1) in
    let s2 := (uniformize_areas e2) in
    AFmult s1 s2
  | AFopp e1 =>
    let s1 := (uniformize_areas e1) in
    AFopp s1
  | AFinv e1 =>
    let s1 := (uniformize_areas e1) in
    AFinv s1
  | AS e1 e2 e3 => if (natle e1 e2) then
                                 (if (natle e2 e3) then (AS e1 e2 e3) else
                                            (if (natle e1 e3)  then  (AFopp (AS e1 e3 e2)) else (AS e3 e1 e2)))
                               else (if (natle e2 e3) then
						(if (natle e1 e3) then (AFopp (AS e2 e1 e3)) else (AS e2 e3 e1))
					else (AFopp (AS e3 e2 e1)))
  | AD e1 e2 => if (natle e1 e2) then (AD e1 e2) else  (AFopp (AD e2 e1))
  | _ => e
end.

Lemma uniformize_areas_correct :
forall (e:AF) (lvar:list (prodT AVars nat)),
   interp_AF_to_F lvar (uniformize_areas e) =
   interp_AF_to_F lvar e.
intros.
induction e;trivial;simpl interp_AF_to_F at 2.
simpl;case (natle n n0);case (natle n0 n1);case (natle n n1);simpl;Geometry.
simpl;case (natle n n0);simpl;symmetry;Geometry.
rewrite <- IHe1;rewrite <- IHe2;simpl uniformize_areas at 1;destruct (uniformize_areas e1);destruct (uniformize_areas e2);trivial;ring.
rewrite <- IHe1;rewrite <- IHe2;simpl uniformize_areas at 1;destruct (uniformize_areas e1);destruct (uniformize_areas e2);trivial;ring.
rewrite <- IHe;simpl uniformize_areas at 1;destruct (uniformize_areas e);trivial;ring.
rewrite <- IHe;simpl uniformize_areas at 1;destruct (uniformize_areas e);trivial;ring.
Qed.

Ltac generalize_all :=
   repeat match goal with
          H:_ |- _ => revert H
end.

Ltac uniformize_term exp lvar :=
  let trm := interp_A lvar exp in
  let trm2 :=constr:(interp_AF_to_F lvar (uniformize_areas trm)) in
(replace exp with trm2;[idtac|rewrite uniformize_areas_correct;trivial]).

(* This is a metaification to collect the list of all points *)

Inductive formula : Type :=
  | f_imp : formula -> formula -> formula (* binary constructor *)
  | f_const : Prop -> formula (* contructor for constants *).

Inductive formula2 : Type :=
  | f_imp2 : formula2 -> formula2 -> formula2 (* binary constructor *)
  | f_neq : AF -> AF -> formula2
  | f_eq : AF -> AF -> formula2.

Fixpoint uniformize_areas_formula2 (e:formula2) {struct e} : formula2 :=
match e with
  | f_imp2 e1 e2 =>
    let s1 := (uniformize_areas_formula2 e1) in
    let s2 := (uniformize_areas_formula2 e2) in
    f_imp2 s1 s2
  | f_neq e1 e2 =>
    let s1 := (uniformize_areas e1) in
    let s2 := (uniformize_areas e2) in
    f_neq s1 s2
  | f_eq e1 e2 =>
    let s1 := (uniformize_areas e1) in
    let s2 := (uniformize_areas e2) in
    f_eq s1 s2
end.

Fixpoint interp_formula2_to_prop (lvar:list (prodT AVars nat)) (e:formula2) {struct e} : Prop :=
  match e with
  | f_imp2 e1 e2 =>
        let s1 := interp_formula2_to_prop lvar e1 in
        let s2 := interp_formula2_to_prop lvar e2 in
      s1 -> s2
  | f_neq e1 e2 =>
        let s1 := interp_AF_to_F lvar e1 in
        let s2 := interp_AF_to_F lvar e2 in
        s1 <> s2
 | f_eq e1 e2 =>
        let s1 := interp_AF_to_F lvar e1 in
        let s2 := interp_AF_to_F lvar e2 in
        s1 = s2
end.

Lemma uniformize_areas_formula2_correct_gen :
forall (e:formula2) (lvar:list (prodT AVars nat)),
   interp_formula2_to_prop lvar (uniformize_areas_formula2 e) <->
   interp_formula2_to_prop lvar e.
Proof.
intros.
induction e;simpl interp_formula2_to_prop;
repeat rewrite uniformize_areas_correct ;intuition.
Qed.

Lemma uniformize_areas_formula2_correct :
forall (e:formula2) (lvar:list (prodT AVars nat)),
   interp_formula2_to_prop lvar (uniformize_areas_formula2 e) ->
   interp_formula2_to_prop lvar e.
Proof.
intros.
assert
(   interp_formula2_to_prop lvar (uniformize_areas_formula2 e) <->
   interp_formula2_to_prop lvar e).
apply uniformize_areas_formula2_correct_gen.
intuition.
Qed.

Definition implies := fun A B :Prop => A->B.
Definition neqF := fun A B : F => A<>B.
Definition eqF := fun A B : F => A=B.

Fixpoint interp_f (f: formula) : Prop :=
   match f with
   | f_imp f1 f2 => implies (interp_f f1) (interp_f f2)
   | f_const c => c
   end.

Ltac put_implies :=
 repeat
 match goal with
  _:_ |- context [?X1 -> ?X2] => replace (X1 -> X2) with (implies X1 X2);[idtac|auto]
end.

Ltac put_eq_neqF :=
 repeat
 match goal with
  _:_ |- context [?X1 <> ?X2] => replace (X1 <> X2) with (neqF X1 X2);[idtac|auto]
  |H:context [?X1 <> ?X2] |- _ => replace (X1 <> X2) with (neqF X1 X2) in H;[idtac|auto]
  |_:_ |- context [?X1 = ?X2] => replace (X1 = X2) with (eqF X1 X2);[idtac|auto]
  |H:context [?X1 = ?X2] |- _ => replace (X1 = X2) with (eqF X1 X2) in H;[idtac|auto]

end.

Ltac generalize_all_eq :=
   repeat match goal with
   H: context [?X1 = ?X2] |- _=> revert H
end.

Ltac generalize_all_eq_neqF :=
   repeat match goal with
   H: context [eqF ?X1 ?X2] |- _=> revert H
   | H: context [neqF ?X1 ?X2] |- _=> revert H
 end.

Ltac interp_formula2 lvar trm :=
match constr:(trm) with
  | (implies ?X1 ?X2) =>
      let e1 := interp_formula2 lvar X1 in
      let e2 := interp_formula2 lvar X2 in
      constr:(f_imp2 e1 e2)
 | (eqF ?X1 ?X2) =>
      let e1 := interp_A lvar X1 in
      let e2 := interp_A lvar X2 in
      constr:(f_eq e1 e2)
 | (neqF ?X1 ?X2) =>
     let e1 := interp_A lvar X1 in
     let e2 := interp_A lvar X2 in
     constr:(f_neq e1 e2)
end.

Ltac interp_formula2_goal lvar :=
 match goal with
 _:_ |- ?X1 => interp_formula2 lvar X1
end.

Ltac uniformize_formula2_goal lvar :=
  let trm := interp_formula2_goal lvar in
  let trm2 :=constr:(interp_formula2_to_prop lvar (uniformize_areas_formula2 trm)) in
  let id := fresh in (
assert (id:(trm2-> interp_formula2_to_prop lvar trm));
[apply uniformize_areas_formula2_correct|idtac];
simpl in id;
(* voir problème de changement de nom d'hypothèse
vm_compute in id; *)
unfold interp_AP_to_Point in id;simpl in id;unfold implies;
apply id;clear id
).
(*
Ltac uniformize_formula2_goal lvar :=
  match goal with
 _:_ |- ?X1 => uniformize_formula2 X1 lvar
end.
*)
Ltac prepare_goal2 lvar := generalize_all_eq_neqF;put_implies;interp_formula2_goal lvar.

Ltac quote_interp_f :=
  let rec aux c :=
    match c with
    | implies ?A ?B =>
      let a := aux A in
      let b := aux B in
      constr:(f_imp a b)
    | c => constr:(f_const c)
    end in
  match goal with
  |- ?G =>
    let g := aux G in
    change (interp_f g)
  end.

Ltac prepare_goal := generalize_all_eq;put_implies;quote_interp_f.
Ltac un_prepare_goal := simpl;unfold implies;intros.

Ltac build_var_list_eq varlist x :=
 match constr:(x) with
     	?X2=?X3 =>
           let l1 := build_var_list_aux varlist X2 in
   	   let l2 := build_var_list_aux l1 X3 in
           constr:(l2)
       | ?X2<>?X3 =>
          let l1 := build_var_list_aux varlist X2 in
          let l2 := build_var_list_aux l1 X3 in
          constr:(l2)
   | _ => varlist
end.

Ltac union_vars_aux varlist trm :=
  match constr:(trm) with
   | interp_f ?X1 => union_vars_aux varlist X1
   | f_imp ?X1 ?X2 =>
        let lvar1 := union_vars_aux varlist X1 in
        let lvar2 := union_vars_aux lvar1 X2 in
        constr:(lvar2)
   | f_const ?X1 => build_var_list_eq varlist X1
 end.

Ltac union_vars trm :=  union_vars_aux (@nil AVars) trm .

Ltac compute_vars_of_the_goal :=
  match goal with
  _:_ |- ?X1 =>
        let lvar := union_vars X1 in
        let varlist := number lvar in
       varlist
end.

Ltac uniformize_quantities varlist trm :=
  match constr:(trm) with
   | interp_f ?X1 => uniformize_quantities varlist X1
   | f_imp ?X1 ?X2 => uniformize_quantities varlist X1;uniformize_quantities varlist X2
   | f_const ?X1 =>
                (match constr:(X1) with
                    ?X1 = ?X2 => uniformize_term X1 varlist;uniformize_term X2 varlist
                  | ?X1 <> ?X2 => uniformize_term X1 varlist;uniformize_term X2 varlist
                    |_ => idtac
                   end)
   end.

Ltac uniformize_quantities_of_the_goal varlist :=
 match goal with
  _:_ |- ?XG => uniformize_quantities varlist  XG
end.

Ltac uniformize_quantities_of_all varlist :=
 repeat
  match goal with
	  _:_ |- context [?X1 = ?X2] => progress uniformize_term X1 varlist
          |_:_ |- context [?X1 = ?X2] => progress uniformize_term X2 varlist
	  |H: context [?X1 <> ?X2] |- _ => progress uniformize_term X1 varlist
          |H: context [?X1 <> ?X2] |- _ => progress uniformize_term X2 varlist
	  |H: context [?X1 = ?X2] |- _ => progress uniformize_term X1 varlist
	  |H: context [?X1 = ?X2] |- _ => progress uniformize_term X2 varlist
end.
(*
Ltac Runiformize_signed_areas :=
  unfold Fminus, Fdiv in *;
  prepare_goal;
  let varlist := compute_vars_of_the_goal in
 (repeat (progress uniformize_quantities_of_the_goal varlist);un_prepare_goal).
*)
(*
  (uniformize_quantities_of_the_goal varlist;
   unfold interp_AP_to_Point;simpl;
   un_prepare_goal
   ). *)

Ltac Runiformize_signed_areas :=
  unfold Fminus, Fdiv in *;
  prepare_goal;
  let varlist := compute_vars_of_the_goal in
  (un_prepare_goal; put_eq_neqF;generalize_all_eq_neqF;put_implies;
    uniformize_formula2_goal varlist;intros).


Require Import Raft.
Require Import CommonDefinitions.
Require Import TraceUtil.

Section OutputGreatestId.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Section inner.

  Variables client id : nat.

  Definition greatest_id_for_client (net : network) : Prop :=
    forall id',
      id < id' ->
      before_func (has_key client id) (has_key client id') (applied_entries (nwState net)).

  End inner.

  Class output_greatest_id_interface : Prop :=
    {
      output_greatest_id :
        forall client id failed net tr,
          step_f_star step_f_init (failed, net) tr ->
          key_in_output_trace client id tr ->
          greatest_id_for_client client id net
    }.
End OutputGreatestId.


(** * The category of semisimplicial sets *)
Require Import Types.
Require Import Category.Core Functor.Core.
Require Import Category.Morphisms.
Require Import Category.Dual FunctorCategory.Core.
Require Import SetCategory.Core.
Require Import SimplicialSets.
Require Import Category.Sigma.OnMorphisms Category.Subcategory.Wide.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope category_scope.

Module Export Core.
  Section semisimplicial_sets.
    Context `{Funext}.
    (** Quoting David Spivak:

        Consider the subcategory of [Δ] with the same objects (wide)
        but only injective morphisms.  If we call that [Γ] (which is
        nonstandard), then semi-simplicial sets (also a non-standard
        term) (sic) are [Fun(Γᵒᵖ, Set)]. Define the obvious inclusion
        [Γ -> Δ], which we will use to make simplicial sets without
        having to worry about "degneracies". *)

    Definition semisimplex_category : PreCategory
      := wide simplex_category
              (@IsMonomorphism _)
              _ _ _.

    Definition semisimplicial_inclusion_functor : semisimplex_category -> simplex_category
      := pr1_mor.

    Definition semisimplicial_category (C : PreCategory) : PreCategory
      := semisimplex_category^op -> C.

    Definition semisimplicial_set := semisimplicial_category set_cat.
    Definition semisimplicial_prop := semisimplicial_category prop_cat.
  End semisimplicial_sets.

  Notation semisimplicial_of obj := (semisimplicial_category (cat_of obj)).
End Core.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e235m15_9limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


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

(***
Modulus : 2^480 - 2^240 - 1
Base: 26 + 2/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 18%nat;
    base := 26 + 2/3;
    bitwidth := 32;
    s := 2^480;
    c := [(1, 1); (2^240, 1)];
    carry_chains := Some [[8; 17]; [9; 0; 10; 1; 11; 2; 12; 3; 13; 4; 14; 5; 15; 6; 16; 7; 17; 8]; [9; 0]]%nat;

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

    goldilocks := Some true;
    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.


(* Virtual Memory Model *)

Require Import iris_c.clang.lang.
Require Import iris_c.clang.logic.

Definition option_addr_to_val (opt_a: option addr) : val :=
  match opt_a with
    | Some a => Vptr a
    | None => Vnull
  end.

Structure page_table `{clangG Σ} :=  {
  (* -- operations -- *)
  insert_pt : ident;
  delete_pt : ident;
  lookup_pt : ident;
  (* -- predicates -- *)
  is_page_table: gmap int8 addr → iProp Σ;
  (* -- operation specs -- *)
  insert_pt_spec i l m Φ ls:
    is_page_table m ∗ (is_page_table (<[ i := l ]> m) -∗ Φ Vvoid)
    ⊢ WP (Ecall Tvoid insert_pt
                (Evalue (Vpair (Vint8 i) (Vpair (Vptr l) Vvoid))), ls) {{ Φ }};
  delete_pt_spec i m Φ (ks: stack * env):
    is_page_table m ∗ (is_page_table (delete i m) -∗ Φ Vvoid)
    ⊢ WP (Ecall Tvoid delete_pt (Evalue (Vpair (Vint8 i) Vvoid)), ks) {{ Φ }};
  lookup_pt_spec i m Φ ks:
    is_page_table m ∗ (is_page_table m -∗ Φ (option_addr_to_val (m !! i)))
    ⊢ WP (Ecall (Tptr Tvoid) lookup_pt (Evalue (Vpair (Vint8 i) Vvoid)), ks) {{ Φ }}
}.

Arguments insert_pt {_ _} _.
Arguments delete_pt {_ _} _.
Arguments lookup_pt {_ _} _.
Arguments insert_pt_spec {_ _} _ _ _ _ _ _.
Arguments delete_pt_spec {_ _} _ _ _ _ _.
Arguments lookup_pt_spec {_ _} _ _ _ _ _.
Arguments is_page_table {_ _} _ _.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e291m19_11limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e489m21_20limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Export poly.

Theorem double_injective_FAILED: forall n m,
     double n = double m ->
     n = m.
Proof.
  intros n m. induction n as [| n'].
  Case "n = O". simpl. intros eq. destruct m as [| m'].
    SCase "m = O". reflexivity.
    SCase "m = S m'". inversion eq.
  Case "n = S n'". intros eq. destruct m as [| m'].
    SCase "m = O". inversion eq.
    SCase "m = S m'".
      assert (n' = m') as H.
      SSCase "Proof of assertion".
      (* Here we are stuck.  We need the assertion in order to
         rewrite the final goal (subgoal 2 at this point) to an
         identity.  But the induction hypothesis, IHn', does
         not give us n' = m' -- there is an extra S in the
         way -- so the assertion is not provable. *)
      Admitted.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas32_2e413m21_16limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import F.
Require Import names.
Require Import subst.

Lemma weakening_typing : forall G1 G2 G3 t T,
  (G1++G3) :> t ; T ->
  Ok (G1++G2++G3) ->
  (G1 ++ G2 ++ G3) :> t ; T.
Proof. admit. Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Q R Z : Universe, ((wd_ A C /\ (wd_ P Q /\ (wd_ C D /\ (wd_ R C /\ (wd_ A B /\ (wd_ P R /\ (wd_ Q C /\ (wd_ P C /\ (wd_ Z C /\ (col_ C P R /\ (col_ P R Q /\ col_ C R Z))))))))))) -> col_ P Q C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Raft.
Require Import RaftRefinementInterface.

Section LogsLeaderLogs.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition logs_leaderLogs (net : network) : Prop :=
    forall h e,
      In e (log (snd (nwState net h))) ->
      exists leader ll es,
        In (eTerm e, ll) (leaderLogs (fst (nwState net leader))) /\
        removeAfterIndex (log (snd (nwState net h))) (eIndex e) = es ++ ll /\
        (forall e', In e' es -> eTerm e' = eTerm e).

  Definition logs_leaderLogs_nw net :=
    forall p t n pli plt es ci e,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      In e es ->
      exists leader ll es' ll',
        In (eTerm e, ll) (leaderLogs (fst (nwState net leader))) /\
        Prefix ll' ll /\
        removeAfterIndex es (eIndex e) = es' ++ ll' /\
        (forall e', In e' es' -> eTerm e' = eTerm e) /\
        ((plt = eTerm e /\ pli > maxIndex ll)  \/
         (exists e, In e ll /\ eIndex e = pli /\ eTerm e = plt /\ (ll' <> [] \/
                                                             pli = maxIndex ll)) \/
         plt = 0 /\ pli = 0 /\ ll' = ll).

  Class logs_leaderLogs_interface : Prop :=
    {
      logs_leaderLogs_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          logs_leaderLogs net;
      logs_leaderLogs_nw_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          logs_leaderLogs_nw net
    }.
End LogsLeaderLogs.


(**
----
_This file is part of_

----
*** A Formal Definition of JML in Coq #
# and its Application to Runtime Assertion Checking
Ph.D. Thesis by Hermann Lehner
----
Online available at #jmlcoq.info#

Authors:
  - Hermann Lehner
  - David Pichardie (Bicolano)
  - Andreas Kaegi (Syntax Rewritings, Implementation of ADTs)

Copyright 2011 Hermann Lehner

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

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

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

----
*)

From Coq Require Export Sumbool.
From Coq Require Import List.

Definition bool_eq (b1 b2:bool) :=
  if b1 then b2
  else if b2 then false else true.

Lemma bool_eq_spec : forall b1 b2, if bool_eq b1 b2 then b1 = b2 else b1 <> b2.
Proof. destruct b1;destruct b2;simpl;trivial;intro;discriminate. Qed.

Section EqBool_Dec.

 Variable A:Type.
 Variable Aeq : A -> A -> bool.
 Variable Aeq_spec : forall x y, if Aeq x y then x = y else x <> y.

 Lemma Aeq_dec : forall (x y:A), x = y \/ x <> y.
 Proof.
  intros x y;generalize (Aeq_spec x y);destruct (Aeq x y);auto.
 Qed.

 Lemma Aeq_eq : forall x, Aeq x x = true.
 Proof.
  intros;generalize (Aeq_spec x x);destruct (Aeq x x);intros;trivial.
  elim H;trivial.
 Qed.

 Lemma Aeq_diff : forall x y, x <> y -> Aeq x y = false.
 Proof.
  intros x y H;generalize (Aeq_spec x y);destruct (Aeq x y);intros;trivial.
  elim H;trivial.
  Qed.

 Lemma Aeq_Dec : forall x y:A, {x=y}+{x<>y}.
 Proof.
   intros. induction (sumbool_of_bool (Aeq x y)).
   apply left. assert (h:= (Aeq_spec x y)); rewrite a in h; assumption.
   apply right. assert (h:= (Aeq_spec x y)); rewrite b in h; assumption.
 Qed.

 Section EqBool_Prod.
  Variable B:Set.
  Variable Beq : B -> B -> bool.
  Variable Beq_spec : forall x y, if Beq x y then x = y else x <> y.

  Definition prod_eq (x y:A*B) :=
   let (x1,x2) := x in
   let (y1,y2) := y in
   if Aeq x1 y1 then Beq x2 y2 else false.

  Lemma prod_eq_spec : forall x y, if prod_eq x y then x = y else x <> y.
  Proof.
     intros (x1,x2) (y1,y2); simpl;generalize (Aeq_spec x1 y1);destruct (Aeq x1 y1);intros;subst.
     generalize (Beq_spec x2 y2);destruct (Beq x2 y2);intros;subst;trivial.
     intro H1;injection H1;auto.
     intro H1;injection H1;auto.
  Qed.

 End EqBool_Prod.

 Section EqOption.
   Definition opt_eq (x y: option A) :=
     match x, y with
     | Some x, Some y => Aeq x y
     | None, None => true
     | _, _ => false
     end.

  Lemma opt_eq_spec : forall o1 o2, if opt_eq o1 o2 then o1 = o2 else o1 <> o2.
  Proof.
   intros [a1|] [a2|];simpl;trivial;try (intro H;discriminate H;fail).
   generalize (Aeq_spec a1 a2);destruct (Aeq a1 a2);intros;subst;trivial.
   intro H1;injection H1;auto.
  Qed.

 End EqOption.

 Section EqList.

  Fixpoint list_eq (x y:list A) {struct x} : bool :=
    match x, y with
    | a1::x, a2::y => if Aeq a1 a2 then list_eq x y else false
    | nil, nil => true
    | _, _ => false
    end.

  Lemma list_eq_spec : forall l1 l2, if list_eq l1 l2 then l1 = l2 else l1 <> l2.
  Proof.
   induction l1;destruct l2;simpl;intros;trivial;try (intro;discriminate;fail).
   generalize (Aeq_spec a a0);destruct (Aeq a a0);intros;subst;trivial.
   generalize (IHl1 l2);destruct (list_eq l1 l2);intros;subst;trivial.
   intro H1;injection H1;auto.
   intro H1;injection H1;auto.
  Qed.

 End EqList.
End EqBool_Dec.


(* Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Unique Solutions. *)

Require Import UniDB.Spec.Core.
Require Import UniDB.Spec.Subst.

(******************************************************************************)

Instance iUpUnit : Up unit := fun _ _ => tt.
Instance iIdmUnit : Idm unit := tt.
Instance iCompUnit : Comp unit := fun _ _ => tt.

Instance iUpHomUnit : UpHom unit.
Proof. constructor; intro ξ; destruct ξ; reflexivity. Qed.
Instance iUpIdmUnit : UpIdm unit.
Proof. constructor; reflexivity. Qed.

Instance iLkUnit {T : Type} `{Vr T} : Lk T unit := fun _ i => vr T i.
Instance iLkIdmUnit {T : Type} `{Vr T} : LkIdm T unit.
Proof. constructor. Qed.
Instance iLkRenUnit {T : Type} `{Vr T} : LkRen T unit.
Proof. constructor. Qed.
Instance iLkUpUnit {T : Type} `{WkVr T} : LkUp T unit.
Proof. now apply make_lkup_inst_ren. Qed.

Class TrIdmUnit (T : Type) {vrT : Vr T} (X : Type) {trTX : Tr T X} :=
  tr_idm_unit : ∀ (x : X), tr T X unit x tt = x.

(******************************************************************************)


(** * Miscellaneous Well-Foundedness Facts *)
Require Import Coq.Setoids.Setoid Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat Coq.Classes.Morphisms Coq.Init.Wf.
Require Import Coq.Lists.SetoidList.
Require Export Crypto.Util.FixCoqMistakes.
Require Coq.Arith.EqNat.

Local Set Implicit Arguments.
Local Unset Uniform Inductive Parameters.

Scheme Induction for Acc Sort Prop.
Scheme Induction for Acc Sort Set.
Scheme Induction for Acc Sort Type.

Section wf.
  Section wrap_wf.
    Context {A R} (Rwf : @well_founded A R).

    Definition lt_wf_idx_step
               (lt_wf_idx : nat -> well_founded R)
               (n : nat)
      : well_founded R.
    Proof.
      destruct n.
      { clear -Rwf; apply Rwf. }
      { constructor; intros; apply lt_wf_idx; assumption. }
    Defined.

    Fixpoint lt_wf_idx (n : nat) : well_founded R
      := lt_wf_idx_step (@lt_wf_idx) n.
  End wrap_wf.

  Section rel_hetero.
    Local Notation "R ==> S"
      := (@respectful_hetero _ _ _ _ R (fun _ _ => S))
         : signature_scope.
    Local Notation Proper S R
      := (S%signature R R) (only parsing).

    Context {A A'}
            (RA : A -> A' -> Prop)
            (P : A -> Type) (P' : A' -> Type)
            (RP : forall a a', RA a a' -> P a -> P' a' -> Prop)
            {R : relation A} {R' : relation A'}
            (HR : (RA ==> RA ==> Basics.impl)%signature R R')
            (Rwf : well_founded R) (Rwf' : well_founded R')
            (F : forall x, (forall y, R y x -> P y) -> P x)
            (F' : forall x, (forall y, R' y x -> P' y) -> P' x)
            (HF : forall a a' (r : RA a a')
                         (f := (fun (y : A) (_ : R y a) => Fix Rwf P F y))
                         (f' := (fun (y' : A') (_ : R' y' a') => Fix Rwf' P' F' y'))
                         (Hf : forall y y' (ry : RA y y') (r : R y a) (r' : R' y' a'),
                             RP _ _ ry (f y r) (f' y' r')),
                RP a a' r (F a f) (F' a' f'))
            (F_ext : forall x f g,
                (forall y p, f y p = g y p) -> F x f = F x g)
            (F'_ext : forall x f g,
                (forall y p, f y p = g y p) -> F' x f = F' x g).

    Lemma Fix_Proper_hetero
          {a a'}
          (Ha : RA a a')
      : @RP a a' Ha (Fix Rwf P F a) (Fix Rwf' P'  F' a').
    Proof.
      revert a' Ha.
      induction (Rwf a) as [a Hlt IHwf].
      intros a' Ha.
      rewrite (Fix_eq Rwf), (Fix_eq Rwf') by assumption.
      apply HF; intros.
      apply IHwf; assumption.
    Qed.
  End rel_hetero.

  Global Instance well_founded_subrelation {A}
    : Proper (flip subrelation ==> impl) (@well_founded A).
  Proof.
    intros R R' HR Rwf a.
    induction (Rwf a) as [a Ra R'a].
    constructor; intros y Hy.
    apply R'a, HR, Hy.
  Defined.

  Fixpoint no_wf_cycle_helper {A} {R : relation A} x y
           (H0 : R x y) (H1 : R y x) (wf : Acc R x)
    : False
    := match wf with
       | Acc_intro f => @no_wf_cycle_helper A R y x H1 H0 (f _ H1)
       end.

  Global Instance no_wf_cycle {A R} (Rwf : @well_founded A R) : Asymmetric R.
  Proof.
    intros x y H0 H1.
    specialize (Rwf x).
    eapply no_wf_cycle_helper; [ .. | eassumption ]; eassumption.
  Qed.

  Inductive RT_closure {A} (R : relation A) : relation A :=
  | cinject {x y} : R x y -> RT_closure R x y
  | crefl {x} : RT_closure R x x
  | ctrans {x y z} : RT_closure R x y -> RT_closure R y z -> RT_closure R x z.

  Fixpoint Acc_subrelation {A} (R1 R2 : relation A) (v : A) (Hacc : Acc R1 v)
        (HR : forall x y, RT_closure R2 y v -> R2 x y -> R1 x y) {struct Hacc}
    : Acc R2 v.
  Proof.
    destruct Hacc as [Hacc].
    constructor.
    intros y Hy.
    specialize (fun pf => @Acc_subrelation A R1 R2 y (Hacc y pf)).
    specialize (@Acc_subrelation (HR _ _ (@crefl _ _ _) Hy)).
    apply Acc_subrelation; clear -HR Hy.
    intros x y' Hxy Hr2.
    apply HR; clear HR; [ | assumption ].
    clear -Hy Hxy.
    eapply ctrans; [ eassumption | eapply cinject; eassumption ].
  Defined.

  Section wf_acc_of.
    Context A (RA : relation A).

    Definition well_founded_acc_relation_of
              B (f : B -> A) (fA : forall b, Acc RA (f b))
      : relation B
      := fun b0 b1 => match fA b1 with
                      | Acc_intro fAb1 => exists pf,
                                          fAb1 (f b0) pf = fA b0
                      end.

    Lemma well_founded_well_founded_acc_relation_of B f fA
      : well_founded (@well_founded_acc_relation_of B f fA).
    Proof.
      intro b.
      constructor.
      unfold well_founded_acc_relation_of.
      generalize (fA b).
      generalize (f b).
      lazymatch goal with
      | [ |- forall a' wf', @?P a' wf' ]
        => apply (@Acc_ind_dep A RA P)
      end.
      intros a Ha IH y [pf Hy].
      constructor.
      intros z Hz.
      specialize (IH (f y) pf z).
      apply IH; clear IH.
      destruct Hy.
      apply Hz.
    Defined.

    Fixpoint Acc_RA_of B (f : B -> A) b (ac : Acc RA (f b))
      : Acc (fun x y => RA (f x) (f y)) b.
    Proof.
      refine match ac with
             | Acc_intro fg => Acc_intro _ (fun y Ry => @Acc_RA_of _ _ _ (fg _ _))
             end.
      assumption.
    Defined.

    Lemma well_founded_RA_of B (f : B -> A) (wf_A : well_founded RA)
      : well_founded (fun x y => RA (f x) (f y)).
    Proof.
      intro a.
      apply Acc_RA_of, wf_A.
    Defined.
  End wf_acc_of.

  Section wf_acc_of_option.
    Context A (RA : relation A).

    Definition well_founded_acc_relation_of_opt
              B (f : B -> option A) (fA : forall b, match f b with
                                                    | Some fb => Acc RA fb
                                                    | None => True
                                                    end)
      : relation B
      := fun b0 b1
         => match f b1 as fb1 return match fb1 with
                                     | Some fb => Acc RA fb
                                     | None => True
                                     end -> _
            with
            | Some fb1
              => fun fAb
                 => match fAb with
                    | Acc_intro fAb1
                      => match f b0 as fb0 return match fb0 with
                                                  | Some fb => Acc RA fb
                                                  | None => True
                                                  end -> _
                         with
                         | Some fb0
                           => fun fAb0 => exists pf,
                                  fAb1 fb0 pf = fAb0
                         | None => fun _ => False
                         end (fA b0)
                    end
            | None => fun _ => False
            end (fA b1).

    Lemma well_founded_well_founded_acc_relation_of_opt B f fA
      : well_founded (@well_founded_acc_relation_of_opt B f fA).
    Proof.
      intro b.
      constructor.
      unfold well_founded_acc_relation_of_opt.
      generalize (fA b).
      generalize (f b).
      intros [fb|].
      { revert fb.
        lazymatch goal with
        | [ |- forall a' wf', @?P a' wf' ]
          => apply (@Acc_ind_dep A RA P)
        end.
        intros a Ha IH y.
        constructor.
        generalize dependent (fA y).
        destruct (f y) as [fy|] eqn:Hfy.
        { intros y0 [pf Hy].
          intros z Hz.
          specialize (IH fy pf z).
          apply IH; clear IH.
          destruct Hy.
          apply Hz. }
        { intros ? []. } }
      { intros ?? []. }
    Defined.

    Fixpoint Acc_RA_of_opt B (f : B -> option A) b v (Heq : f b = Some v)
             (ac : Acc RA v) {struct ac}
      : Acc (fun x y => match f x, f y with
                        | Some fx, Some fy => RA fx fy
                        | _, _ => False
                        end) b.
    Proof.
      destruct ac as [fg].
      constructor.
      intros y Ry.
      specialize (fun v H Rv => Acc_RA_of_opt B f y v H (fg _ Rv)); clear fg.
      destruct (f y) as [fy|] eqn:Hfy.
      { specialize (Acc_RA_of_opt _ eq_refl).
        destruct (f b) as [fb|] eqn:Hfb.
        { inversion Heq; clear Heq; subst.
          specialize (Acc_RA_of_opt Ry).
          assumption. }
        { destruct Ry. } }
      { destruct Ry. }
    Defined.

    Lemma well_founded_RA_of_opt B (f : B -> option A) (wf_A : well_founded RA)
      : well_founded (fun x y => match f x, f y with
                                 | Some fx, Some fy => RA fx fy
                                 | _, _ => False
                                 end).
    Proof.
      intro a.
      destruct (f a) eqn:H.
      { eapply Acc_RA_of_opt, wf_A; eassumption. }
      { constructor.
        intro y.
        destruct (f y); [ rewrite H | ]; intros []. }
    Defined.
  End wf_acc_of_option.

  Section wf_prodA.
    Context A B (eqA RA : relation A) (RB : relation B).

    Definition prod_relationA : relation (A * B)
      := fun ab a'b' =>
           RA (fst ab) (fst a'b') \/ (eqA (fst a'b') (fst ab) /\ RB (snd ab) (snd a'b')).

    Context (prod_relationA_Proper
             : forall b'', Proper (eqA ==> impl) (fun a => Acc prod_relationA (a, b''))).

    Global Instance prod_relationA_Proper_from_Equivalence
          (RA_Proper : Proper (eq ==> eqA ==> flip impl) RA)
          (eqA_Proper : Proper (eqA ==> eq ==> flip impl) eqA)
      : forall b'', Proper (eqA ==> impl) (fun a => Acc prod_relationA (a, b'')).
    Proof.
      intros b'' a b H wf.
      revert dependent b.
      destruct wf as [f].
      constructor.
      intros y Hlt; apply f.
      unfold prod_relationA in Hlt |- *; simpl in *.
      destruct Hlt as [Hlt|[Hlt0 Hlt1]]; [ left | right; split; try assumption ].
      { eapply RA_Proper; [ reflexivity | exact H | exact Hlt ]. }
      { eapply eqA_Proper; [ exact H | reflexivity | exact Hlt0 ]. }
    Defined.

    Section step.
      Context (well_founded_prod_relationA_helper
               : forall a b (wf_A : Acc RA a) (wf_B : well_founded RB),
                  Acc prod_relationA (a, b)).

      Definition well_founded_prod_relationA_helper_step
                 a b
                 (wf_A : Acc RA a) (wf_B : well_founded RB)
                 (wf_B_rec : forall (fa : forall y : A, RA y a -> Acc RA y) b' (wf_B' : Acc RB b'), Acc prod_relationA (a, b'))
        : Acc prod_relationA (a, b)
        := match wf_A with
           | Acc_intro fa => @wf_B_rec fa b (wf_B b)
           end.
      Definition wf_B_rec_step
                 (wf_B : well_founded RB)
                 a (fa : forall y : A, RA y a -> Acc RA y)
                 (wf_B_rec : forall b' (wf_B' : Acc RB b'), Acc prod_relationA (a, b'))
                 b' (wf_B' : Acc RB b')
        :  Acc prod_relationA (a, b').
      Proof.
        refine (Acc_intro _ _).
        intros [a'' b''] [pf'|[pfa pfb]].
        { refine (@well_founded_prod_relationA_helper
                    _ _
                    (fa _ pf')
                    wf_B). }
        { refine match wf_B' with
                 | Acc_intro fb => @prod_relationA_Proper
                                     _ _ _ pfa
                                     (@wf_B_rec _ (fb _ pfb))
                 end. }
      Defined.
    End step.

    Fixpoint well_founded_prod_relationA_helper
             a b
             (wf_A : Acc RA a) (wf_B : well_founded RB) {struct wf_A}
      : Acc prod_relationA (a, b)
      := @well_founded_prod_relationA_helper_step
           a b wf_A wf_B
           (fun fa
            => fix wf_B_rec b' (wf_B' : Acc RB b') : Acc prod_relationA (a, b')
            := @wf_B_rec_step
                 (@well_founded_prod_relationA_helper)
                 wf_B
                 a fa (@wf_B_rec)
                 b' wf_B').

    Definition well_founded_prod_relationA : well_founded RA -> well_founded RB -> well_founded prod_relationA.
    Proof.
      intros wf_A wf_B [a b]; hnf in *.
      apply well_founded_prod_relationA_helper; auto.
    Defined.
  End wf_prodA.

  Section wf_prod.
    Context A B (RA : relation A) (RB : relation B).

    Definition prod_relation : relation (A * B)
      := Eval cbv [prod_relationA] in prod_relationA eq RA RB.

    Definition well_founded_prod_relation : well_founded RA -> well_founded RB -> well_founded prod_relation.
    Proof.
      apply well_founded_prod_relationA.
      intros b'' a b H H'.
      induction H.
      exact H'.
    Defined.
  End wf_prod.

  Section wf_sig.
    Context A B (RA : relation A) (RB : forall a : A, relation (B a)).

    Definition sigT_relation : relation (sigT B)
      := fun ab a'b' =>
           RA (projT1 ab) (projT1 a'b') \/ (exists pf : projT1 a'b' = projT1 ab, RB (projT2 ab)
                                                                                (eq_rect _ B (projT2 a'b') _ pf)).

    Fixpoint well_founded_sigT_relation_helper
             a b
             (wf_A : Acc RA a) (wf_B : forall a, well_founded (@RB a)) {struct wf_A}
    : Acc sigT_relation (existT _ a b).
    Proof.
      refine match wf_A with
               | Acc_intro fa => (fix wf_B_rec b' (wf_B' : Acc (@RB a) b') : Acc sigT_relation (existT _ a b')
                                  := Acc_intro
                                       _
                                       (fun ab =>
                                          match ab as ab return sigT_relation ab (existT _ a b') -> Acc sigT_relation ab with
                                            | existT a'' b'' =>
                                              fun pf =>
                                                match pf with
                                                  | or_introl pf'
                                                    => @well_founded_sigT_relation_helper
                                                         _ _
                                                         (fa _ pf')
                                                         wf_B
                                                  | or_intror (ex_intro pfa pfb)
                                                    => match wf_B' with
                                                         | Acc_intro fb
                                                           => _(*eq_rect
                                                            _
                                                            (fun a'' => Acc sigT_relation (existT B a'' _(*b''*)))
                                                            (wf_B_rec _ (fb _ _(*pfb*)))
                                                            _
                                                            pfa*)
                                                       end
                                                end
                                          end)
                                 ) b (wf_B a b)
             end;
      simpl in *.
      destruct pfa; simpl in *.
      exact (wf_B_rec _ (fb _ pfb)).
    Defined.

    Definition well_founded_sigT_relation : well_founded RA
                                            -> (forall a, well_founded (@RB a))
                                            -> well_founded sigT_relation.
    Proof.
      intros wf_A wf_B [a b]; hnf in *.
      apply well_founded_sigT_relation_helper; auto.
    Defined.
  End wf_sig.

  Section wf_projT1.
    Context A (B : A -> Type) (R : relation A).

    Definition projT1_relation : relation (sigT B)
      := fun ab a'b' =>
           R (projT1 ab) (projT1 a'b').

    Definition well_founded_projT1_relation : well_founded R -> well_founded projT1_relation.
    Proof.
      intros wf [a b]; hnf in *.
      induction (wf a) as [a H IH].
      constructor.
      intros y r.
      specialize (IH _ r (projT2 y)).
      destruct y.
      exact IH.
    Defined.
  End wf_projT1.

  Section wf_iterated_prod_ofA.
    Context A (eqA R : relation A) (Rwf : well_founded R)
            (RA_Proper : Proper (eq ==> eqA ==> flip impl) R)
            (eqA_Proper : Proper (eqA ==> eq ==> flip impl) eqA).

    Fixpoint iterated_prod (n : nat) : Type
      := match n with
         | 0 => unit
         | S n' => A * iterated_prod n'
         end%type.

    Fixpoint iterated_prod_relationA {n} : relation (iterated_prod n)
      := match n return relation (iterated_prod n) with
         | 0 => fun _ _ => False
         | S n' => prod_relationA eqA R (@iterated_prod_relationA n')
         end.

    Fixpoint nat_eq_transfer (P : nat -> Type) (n m : nat) : P n -> (P m) + (EqNat.beq_nat n m = false)
      := match n, m return P n -> (P m) + (EqNat.beq_nat n m = false) with
         | 0, 0 => fun x => inl x
         | S n', S m' => @nat_eq_transfer (fun v => P (S v)) n' m'
         | _, _ => fun _ => inr eq_refl
         end.

    Fixpoint nat_eq_transfer_refl (P : nat -> Type) (n : nat) : forall v : P n, nat_eq_transfer P n n v = inl v
      := match n return forall v : P n, nat_eq_transfer P n n v = inl v with
         | 0 => fun v => eq_refl
         | S n' => @nat_eq_transfer_refl (fun k => P (S k)) n'
         end.

    Fixpoint nat_eq_transfer_neq (P : nat -> Type) (n m : nat)
      : forall v : P n, (if EqNat.beq_nat n m as b return ((P m) + (b = false)) -> Prop
                         then fun _ => True
                         else fun v => v = inr eq_refl)
                          (nat_eq_transfer P n m v)
      := match n, m return forall v : P n, (if EqNat.beq_nat n m as b return ((P m) + (b = false)) -> Prop
                                            then fun _ => True
                                            else fun v => v = inr eq_refl)
                                             (nat_eq_transfer P n m v)
         with
         | 0, 0 => fun _ => I
         | S n', S m' => @nat_eq_transfer_neq (fun v => P (S v)) n' m'
         | _, _ => fun _ => eq_refl
         end.

    Definition iterated_prod_relationA_of
               B (sz : B -> nat) (f : forall b, iterated_prod (sz b))
      : relation B
      := fun x y => match nat_eq_transfer _ (sz x) (sz y) (f x) with
                    | inl fx => iterated_prod_relationA fx (f y)
                    | inr _ => False
                    end.

    Definition iterated_prod_relationA_of_opt
               B (sz : nat) (f : B -> option (iterated_prod sz))
      : relation B
      := fun x y => match f x, f y with
                    | Some fx, Some fy => iterated_prod_relationA fx fy
                    | _, _ => False
                    end.

    Lemma well_founded_iterated_prod_relationA {n} : well_founded (@iterated_prod_relationA n).
    Proof.
      induction n as [|n IHn]; simpl.
      { constructor; intros ? []. }
      { apply well_founded_prod_relationA; try exact _; assumption. }
    Defined.

    Lemma well_founded_iterated_prod_relationA_of_opt {B n f} : well_founded (@iterated_prod_relationA_of_opt B n f).
    Proof.
      unfold iterated_prod_relationA_of_opt.
      apply well_founded_RA_of_opt, well_founded_iterated_prod_relationA.
    Defined.

    Local Ltac handle_nat_eq_transfer
      := repeat lazymatch goal with
                | [ |- forall n0 n1, @?P n0 n1 ]
                  => let n0' := fresh "n" in
                     let n1' := fresh "n" in
                     let H := fresh in
                     let H' := fresh in
                     intros n0' n1';
                     destruct (@nat_eq_transfer (P n0') n0' n1') as [H|H];
                     [ clear n1'; revert n0'
                     | apply H
                     | lazymatch goal with
                       | [ |- context[@nat_eq_transfer iterated_prod n1' n0' _] ]
                         => pose proof (@nat_eq_transfer_neq iterated_prod n1' n0') as H';
                            cbv beta in *;
                            generalize dependent (nat_eq_transfer iterated_prod n1' n0');
                            let Heq := fresh in
                            destruct (EqNat.beq_nat n1' n0') eqn:Heq;
                            [ apply EqNat.beq_nat_true_iff in Heq; subst; rewrite <- EqNat.beq_nat_refl in H;
                              exfalso; clear -H; congruence
                            | ]
                       | [ |- context[@nat_eq_transfer iterated_prod n0' n1' _] ]
                         => pose proof (@nat_eq_transfer_neq iterated_prod n0' n1') as H';
                            cbv beta in *;
                            generalize dependent (nat_eq_transfer iterated_prod n0' n1');
                            rewrite H
                       end
                     ]
                end;
         repeat match goal with
                | _ => reflexivity
                | [ H : False |- _ ] => exfalso; exact H
                | [ H : forall v, _ = inr _ |- _ ] => rewrite H
                | _ => intro
                end.

    Lemma RT_closure_same_size B (sz : B -> nat) (f : forall b, iterated_prod (sz b))
          a b
          (H : RT_closure (iterated_prod_relationA_of sz f) a b)
      : sz a = sz b.
    Proof.
      induction H as [x y H | | ].
      { unfold iterated_prod_relationA_of in *.
        generalize dependent (f x).
        generalize dependent (f y).
        generalize dependent (sz x).
        generalize dependent (sz y).
        handle_nat_eq_transfer. }
      { reflexivity. }
      { etransitivity; eassumption. }
    Defined.

    Lemma well_founded_iterated_prod_relationA_of
          B (sz : B -> nat) (f : forall b, iterated_prod (sz b))
      : well_founded (@iterated_prod_relationA_of B sz f).
    Proof.
      intro b.
      pose proof (@well_founded_RA_of_opt (iterated_prod (sz b)) iterated_prod_relationA B) as wf.
      specialize (wf (fun b' => match nat_eq_transfer _ (sz b') (sz b) (f b') with
                                | inl v => Some v
                                | inr _ => None
                                end)).
      specialize (wf well_founded_iterated_prod_relationA).
      eapply Acc_subrelation; [ eapply wf | clear wf ].
      intros x y H.
      apply RT_closure_same_size in H.
      unfold iterated_prod_relationA_of.
      generalize dependent (f b).
      generalize dependent (f x).
      generalize dependent (f y).
      generalize dependent (sz y).
      intros ??; subst.
      clear y.
      generalize dependent (sz b).
      generalize dependent (sz x).
      clear.
      handle_nat_eq_transfer.
      rewrite !nat_eq_transfer_refl in *.
      assumption.
    Defined.
  End wf_iterated_prod_ofA.

  Section wf_iterated_prod_of.
    Context A (R : relation A) (Rwf : well_founded R).

    Definition iterated_prod_relation {n} : relation (iterated_prod A n)
      := iterated_prod_relationA eq R.

    Definition iterated_prod_relation_of
      : forall B (sz : B -> nat) (f : forall b, iterated_prod A (sz b)),
        relation B
      := iterated_prod_relationA_of eq R.

    Definition iterated_prod_relation_of_opt
      : forall B (sz : nat) (f : B -> option (iterated_prod A sz)),
        relation B
      := iterated_prod_relationA_of_opt eq R.

    Lemma well_founded_iterated_prod_relation {n} : well_founded (@iterated_prod_relation n).
    Proof.
      apply well_founded_iterated_prod_relationA; try exact _; assumption.
    Defined.

    Lemma well_founded_iterated_prod_relation_of_opt {B n f} : well_founded (@iterated_prod_relation_of_opt B n f).
    Proof.
      apply well_founded_iterated_prod_relationA_of_opt; try exact _; assumption.
    Defined.

    Lemma well_founded_iterated_prod_relation_of
          B (sz : B -> nat) (f : forall b, iterated_prod A (sz b))
      : well_founded (@iterated_prod_relation_of B sz f).
    Proof.
      apply well_founded_iterated_prod_relationA_of; try exact _; assumption.
    Defined.
  End wf_iterated_prod_of.

  Section wf_functionsA.
    Context A (eqA R : relation A)
            (R_Proper : Proper (eq ==> eqA ==> flip impl) R)
            (R_Proper2 : Proper (eq ==> eqA ==> impl) R)
            (eqA_Proper : Proper (eqA ==> eq ==> flip impl) eqA)
            (eqA_Proper2 : Proper (eq ==> eqA ==> flip impl) eqA)
            (eqA_Symmetric : Symmetric eqA).

    Local Infix "<" := R.
    Local Notation "x <= y" := (eqA x y \/ x < y).

    Context (bot : A) (bot_bot : forall a, bot <= a)
            (Rwf : well_founded R)
            (B C : Type)
            (eqv : relation B)
            {Heqv : Reflexive eqv}
            (F : C -> (B -> A))
            (F_Proper : forall a b k k', eqv k' k -> eqA (F a k) (F b k) -> eqA (F a k') (F b k')).

    Definition is_finite_forA' (ls : list B) (f : B -> A)
      := forall x, ~SetoidList.InA eqv x ls -> eqA (f x) bot.

    Definition is_finite_forA (ls : list B) (c : C) := is_finite_forA' ls (F c).

    Definition function_relationA : relation (B -> A)
      := fun f g => (forall x, f x <= g x)
                    /\ exists x, ~(eqA (f x) (g x)).

    Definition iterated_prod_of_function_for (ls : list B) (f : B -> A)
      : iterated_prod A (List.length ls)
      := list_rect (fun ls => iterated_prod A (List.length ls))
                   tt
                   (fun x _ v => (f x, v))
                   ls.

    Global Instance is_finite_forA'_Proper_fr
      : Proper (eq ==> function_relationA ==> flip impl) is_finite_forA'.
    Proof.
      unfold is_finite_forA', function_relationA.
      intros ls g ?; subst g.
      intros f g [Hle Hne] Hfin x Hnin.
      specialize (Hle x); specialize (Hfin x Hnin).
      destruct Hle as [Heq|Hlt]; [ rewrite Heq; assumption | ].
      specialize (bot_bot (f x)).
      destruct bot_bot as [Heq|Hlt']; [ symmetry; assumption | ].
      rewrite Hfin in Hlt.
      clear -Hlt Hlt' Rwf.
      exfalso; eapply no_wf_cycle; eassumption.
    Qed.

    Global Instance is_finite_forA_Proper_fr
      : Proper (eq ==> (fun x y => function_relationA (F x) (F y)) ==> flip impl) is_finite_forA.
    Proof.
      unfold is_finite_forA.
      intros ??????.
      eapply is_finite_forA'_Proper_fr; eassumption.
    Qed.

    Global Instance is_finite_forA'_Proper_frc
      : Proper (eq ==> RT_closure function_relationA ==> flip impl) is_finite_forA'.
    Proof.
      intros ls ls' ? f g H Hfin.
      induction H as [ ?? H | | ].
      { eapply is_finite_forA'_Proper_fr; eassumption. }
      { subst; assumption. }
      { subst; eauto with nocore. }
    Qed.

    Global Instance is_finite_forA_Proper_frc
      : Proper (eq ==> (fun x y => RT_closure function_relationA (F x) (F y)) ==> flip impl) is_finite_forA.
    Proof.
      unfold is_finite_forA.
      intros ??????.
      eapply is_finite_forA'_Proper_frc; eassumption.
    Qed.

    Global Instance is_finite_forA_Proper_frc'
      : Proper (eq ==> RT_closure (fun x y => function_relationA (F x) (F y)) ==> flip impl) is_finite_forA.
    Proof.
      intros ls ls' ? f g H Hfin.
      induction H as [ ?? H | | ].
      { eapply is_finite_forA_Proper_fr; eassumption. }
      { subst; assumption. }
      { subst; eauto with nocore. }
    Qed.

    Lemma function_subrelationA ls c (H : is_finite_forA ls c)
      : forall x y : C,
        RT_closure (fun x0 y0 : C => function_relationA (F x0) (F y0)) y c ->
        function_relationA (F x) (F y) ->
        (fun x0 y0 : C =>
           iterated_prod_relationA_of eqA R (fun _ : B -> A => length ls)
                                      (iterated_prod_of_function_for ls) (F x0) (F y0)) x y.
    Proof.
      intros g h Hhf Hgh; cbv beta.
      assert (Hfinh : is_finite_forA ls h) by (rewrite Hhf; assumption).
      assert (Hfing : is_finite_forA ls g) by (unfold is_finite_forA; rewrite Hgh; assumption).
      unfold iterated_prod_relationA_of, function_relationA, iterated_prod_of_function_for in *.
      rewrite nat_eq_transfer_refl.
      destruct Hgh as [Hle Hne].
      destruct Hne as [b Hne].
      assert (Hin : ~~SetoidList.InA eqv b ls).
      { intro Hnin.
        rewrite Hfinh in Hne by assumption.
        eauto with nocore. }
      rewrite SetoidList.InA_alt in Hin.
      move ls at bottom.
      clear H Hfinh Hfing.
      induction ls as [|x xs IHxs];
        [
        | destruct (Hle x) as [Heqx|Hlex];
          [ right; split;
            [ | apply IHxs; clear IHxs ]
          | left ] ];
        simpl; unfold prod_relationA; simpl in *;
          repeat match goal with
                 | _ => congruence
                 | _ => tauto
                 | [ H : ex _ |- _ ] => destruct H
                 | [ H : and _ _ |- _ ] => destruct H
                 | [ H : or _ _ |- _ ] => destruct H
                 | _ => progress subst
                 | _ => progress eauto
                 | _ => solve [ exfalso; eauto ]
                 | [ H : ~~(exists x, _ /\ False) |- _ ]
                   => exfalso; apply H; clear
                 | _ => intro
                 | [ |- and _ _ ] => split
                 | [ H : ~~_ |- False ] => apply H; clear H
                 end.
    Qed.

    Definition function_relationA_of_Acc ls (c : C) (H : is_finite_forA ls c)
      : Acc (fun x y => function_relationA (F x) (F y)) c.
    Proof.
      pose proof (@well_founded_RA_of
                    _ _ _ F
                    (@well_founded_iterated_prod_relationA_of
                       _ eqA R Rwf _ _ _ (fun _ => List.length ls) (iterated_prod_of_function_for ls))
                    c)
        as wf.
      eapply Acc_subrelation; [ eexact wf | ].
      apply function_subrelationA; assumption.
    Defined.
  End wf_functionsA.

  Section wf_functions.
    Context A (R : relation A).

    Local Infix "<" := R.
    Local Notation "x <= y" := (x = y \/ x < y).

    Context (bot : A) (bot_bot : forall a, bot <= a)
            (Rwf : well_founded R)
            {B : Type}.

    Definition function_relation : relation (B -> A)
      := @function_relationA A eq R B.

    Definition is_finite_for (ls : list B) (f : B -> A)
      := forall x, ~List.In x ls -> f x = bot.

    Lemma is_finite_for_iff ls f
      : is_finite_for ls f <-> @is_finite_forA A eq bot B (B -> A) eq (fun f => f) ls f.
    Proof.
      unfold is_finite_for, is_finite_forA, is_finite_forA'.
      setoid_rewrite InA_alt.
      split; intros H x H'; apply H; intro H''; apply H'.
      { eexists; split; [ reflexivity | assumption ]. }
      { destruct H'' as [? [? ?]]; subst; assumption. }
    Qed.

    Definition function_relation_Acc ls (f : B -> A) (H : is_finite_for ls f)
      : Acc function_relation f.
    Proof.
      rewrite is_finite_for_iff in H.
      apply function_relationA_of_Acc with (bot := bot) (eqv := eq) (ls := ls);
        try exact _; try assumption.
      intros; subst; assumption.
    Defined.
  End wf_functions.
End wf.


(* Distributed under the terms of the MIT license. *)
From MetaCoq.Template Require Import utils All.
From MetaCoq.Translations Require Import translation_utils.
Require Import ssreflect.
(* Import BasicAst. *)

Reserved Notation "'tsl_ty_param'".

Definition tsl_name n :=
  match n with
  | nAnon => nAnon
  | nNamed n => nNamed (tsl_ident n)
  end.

(* Definition mkApps t us := *)
(*   match t with *)
(*   | tApp f args => tApp f (args ++ us) *)
(*   | _ => tApp t us *)
(*   end. *)
Definition mkApps t us := tApp t us. (* meanwhile *)
Definition mkApp t u := mkApps t [u].

Definition default_term := tRel 0.

Definition up := lift 1 0.

Fixpoint tsl_rec0 (E : tsl_table) (t : term) {struct t} : term :=
  match t with
  | tRel k => tRel (2*k+1)
  | tEvar k ts => tEvar k (map (tsl_rec0 E) ts)
  | tCast t c a => tCast (tsl_rec0 E t) c (tsl_rec0 E a)
  | tProd na A B => tProd na (tsl_rec0 E A)
                  (tProd (tsl_name na) (mkApp (up (tsl_rec1 E A)) (tRel 0))
                         (tsl_rec0 E B))
  | tLambda na A t => tLambda na (tsl_rec0 E A)
                    (tLambda (tsl_name na) (mkApp (up (tsl_rec1 E A)) (tRel 0))
                             (tsl_rec0 E t))
  | tLetIn na A t u => tLetIn na (tsl_rec0 E A) (tsl_rec0 E t)
                     (tLetIn (tsl_name na) (mkApp (up (tsl_rec1 E A)) (tRel 0)) (up (tsl_rec1 E t))
                             (tsl_rec0 E u))

  | tApp t us => let u' := List.fold_right (fun v l => tsl_rec0 E v :: tsl_rec1 E v :: l) [] us in
                mkApps (tsl_rec0 E t) u'

  | tCase ik t u br => tCase ik (tsl_rec0 E t) (tsl_rec0 E u)
                            (map (fun x => (fst x, tsl_rec0 E (snd x))) br)
  | tProj p t => tProj p (tsl_rec0 E t)
  (* | tFix : mfixpoint term -> nat -> term *)
  (* | tCoFix : mfixpoint term -> nat -> term *)
  | _ => t
  end
with tsl_rec1 (E : tsl_table) (t : term) {struct t} : term :=
  match t with
  | tRel k => tRel (2 * k)
  | tSort s => tLambda (nNamed "A") (tSort s) (tProd nAnon (tRel 0) (tSort s))

  | tProd na A B => let A0 := tsl_rec0 E A in
                   let A1 := tsl_rec1 E A in
                   let B0 := tsl_rec0 E B in
                   let B1 := tsl_rec1 E B in
                   let ΠAB0 := tProd na A0 (tProd (tsl_name na) (mkApp (up A1) (tRel 0)) B0) in
                   tLambda (nNamed "f") ΠAB0
                           (tProd na (up A0) (tProd (tsl_name na) (subst_app (lift0 2 A1) [tRel 0])
                                                    (subst_app (lift 1 2 B1)
                                                               [tApp (tRel 2) [tRel 1; tRel 0]])))

  | tLambda na A t => let A0 := tsl_rec0 E A in
                     let A1 := tsl_rec1 E A in
                     tLambda na A0 (tLambda (tsl_name na) (subst_app (up A1) [tRel 0]) (tsl_rec1 E t))

  | tApp t us => let u' := List.fold_right (fun v l => tsl_rec0 E v :: tsl_rec1 E v :: l) [] us in
                mkApps (tsl_rec1 E t) u'

  | tLetIn na t A u => let t0 := tsl_rec0 E t in
                      let t1 := tsl_rec1 E t in
                      let A0 := tsl_rec0 E A in
                      let A1 := tsl_rec1 E A in
                      let u0 := tsl_rec0 E u in
                      let u1 := tsl_rec1 E u in
                      tLetIn na t0 A0 (tLetIn (tsl_name na) (up t1) (subst_app (up A1) [tRel 0]) u1)

  | tCast t c A => let t0 := tsl_rec0 E t in
                  let t1 := tsl_rec1 E t in
                  let A0 := tsl_rec0 E A in
                  let A1 := tsl_rec1 E A in
                  tCast t1 c (mkApps A1 [tCast t0 c A0]) (* apply_subst ? *)

  | tConst s univs =>
    match lookup_tsl_table E (ConstRef s) with
    | Some t => t
    | None => default_term
    end
  | tInd i univs =>
    match lookup_tsl_table E (IndRef i) with
    | Some t => t
    | None => default_term
    end
  | tConstruct i n univs =>
    match lookup_tsl_table E (ConstructRef i n) with
    | Some t => t
    | None => default_term
    end

  | _ => todo ""
  end.

MetaCoq Run (tm <- tmQuote (forall A, A -> A) ;;
                     let tm' := tsl_rec1 [] tm in
                     tmUnquote tm' >>= tmPrint).

MetaCoq Run (tm <- tmQuote (fun A (x : A) => x) ;;
                     let tm' := tsl_rec0 [] tm in
                     tmUnquote tm' >>= tmPrint).

MetaCoq Run (tm <- tmQuote (fun A (x : A) => x) ;;
                     let tm' := tsl_rec1 [] tm in
                     tmUnquote tm' >>= tmPrint).

Goal ((fun f : forall (A : Type) (Aᵗ : A -> Type) (H : A), Aᵗ H -> A =>
    forall (A : Type) (Aᵗ : A -> Type) (H : A) (H0 : Aᵗ H), Aᵗ (f A Aᵗ H H0)) (fun (A : Type) (Aᵗ : A -> Type) (x : A) (_ : Aᵗ x) => x)
       = (forall (A : Type) (Aᵗ : A -> Type) (x : A), Aᵗ x -> Aᵗ x)).
reflexivity.
Defined.

MetaCoq Quote Definition tm := ((fun A (x:A) => x) (Type -> Type) (fun x => x)).

Unset MetaCoq Strict Unquote Universe Mode.

MetaCoq Run (let tm' := tsl_rec1 [] tm in
                     print_nf tm' ;;
                     tmUnquote tm' >>= tmPrint).

Fixpoint fold_left_i_aux {A B} (f : A -> nat -> B -> A) (n0 : nat) (l : list B)
         (a0 : A) {struct l} : A
  := match l with
     | [] => a0
     | b :: l => fold_left_i_aux f (S n0) l (f a0 n0 b)
     end.
Definition fold_left_i {A B} f := @fold_left_i_aux A B f 0.

Fixpoint monad_map_i_aux {M} {H : Monad M} {A B} (f : nat -> A -> M B) (n0 : nat) (l : list A) : M (list B)
  := match l with
     | [] => ret []
     | x :: l => x' <- (f n0 x) ;;
                l' <- (monad_map_i_aux f (S n0) l) ;;
                ret (x' :: l')
     end.

Definition monad_map_i {M H A B} f := @monad_map_i_aux M H A B f 0.

(* could be defined with Id monad *)
Fixpoint map_i_aux {A B} (f : nat -> A -> B) (n0 : nat) (l : list A) : list B
  := match l with
     | [] => []
     | x :: l => (f n0 x) :: (map_i_aux f (S n0) l)
     end.

Definition map_i {A B} f := @map_i_aux A B f 0.

Definition tsl_mind_body (E : tsl_table)
           (id : ident) (mind : mutual_inductive_body)
  : tsl_table * list mutual_inductive_body.
  refine (_, [{| ind_npars := 2 * mind.(ind_npars);
                 ind_bodies := _ |}]).
  - refine (let id' := tsl_ident id in (* should be kn ? *)
            fold_left_i (fun E i ind => _ :: _ ++ E) mind.(ind_bodies) []).
    + (* ind *)
      exact (IndRef (mkInd id i), tInd (mkInd id' i) []).
    + (* ctors *)
      refine (fold_left_i (fun E k _ => _ :: E) ind.(ind_ctors) []).
      exact (ConstructRef (mkInd id i) k, tConstruct (mkInd id' i) k []).
  - refine (map_i _ mind.(ind_bodies)).
    intros i ind.
    refine {| ind_name := tsl_ident ind.(ind_name);
              ind_type := _;
              ind_kelim := ind.(ind_kelim);
              ind_ctors := _;
              ind_projs := [] |}. (* todo *)
    + (* arity  *)
      refine (let ar := subst_app (tsl_rec1 E ind.(ind_type))
                             [tInd (mkInd id i) []] in
              ar).
    + (* constructors *)
      refine (map_i _ ind.(ind_ctors)).
      intros k ((name, typ), nargs).
      refine (tsl_ident name, _, 2 * nargs).
      refine (subst_app _ [tConstruct (mkInd id i) k []]).
      refine (fold_left_i (fun t0 i u  => t0 {S i := u}) _ (tsl_rec1 E typ)).
      (* [I_n-1; ... I_0] *)
      refine (List.rev (map_i (fun i _ => tInd (mkInd id i) [])
                              mind.(ind_bodies))).
Defined.

(* Instance param3 : Translation *)
(*   := {| tsl_id := tsl_ident ; *)
(*         tsl_tm := fun ΣE => tsl_term fuel (fst ΣE) (snd ΣE) [] ; *)
(*         tsl_ty := fun ΣE => tsl_ty_param fuel (fst ΣE) (snd ΣE) [] ; *)
(*         tsl_ind := todo |}. *)

Definition tTranslate (ΣE : tsl_context) (id : ident)
  : TemplateMonad (option tsl_context) :=
  gr <- tmLocate id ;;
  id' <- tmEval all (tsl_ident id) ;;
  let E := snd ΣE in
  match gr with
  | ConstructRef ind _ => tmPrint "todo tTranslate" ;; ret None
  | IndRef (mkInd kn n) =>
      d <- tmQuoteInductive id ;;
      let d' := tsl_mind_body E id d in
      d' <- tmEval lazy d' ;;
      tmPrint d' ;;
      let entries := map mind_body_to_entry (snd d') in
      (* print_nf entries ;; *)
      monad_fold_left (fun _ e => tmMkInductive true e) entries tt ;;
      let decl := InductiveDecl kn d in
      print_nf  (id ^ " has been translated as " ^ id') ;;
      ret (Some (decl :: fst ΣE, E ++ snd ΣE))

  | ConstRef kn =>
    e <- tmQuoteConstant kn true ;;
    print_nf ("toto1" ^ id) ;;
    match e with
    | ParameterEntry _ => print_nf (id ^ "is an axiom, not a definition") ;;
                         ret None
    | DefinitionEntry {| definition_entry_type := A;
                         definition_entry_body := t |} =>
      print_nf ("toto2 " ^ id) ;;
      (* tmPrint t ;; *)
      t0 <- tmEval lazy (tsl_rec0 E t) ;;
      t1 <- tmEval lazy (tsl_rec1 E t) ;;
      A1 <- tmEval lazy (tsl_rec1 E A) ;;
      print_nf ("toto4 " ^ id) ;;
      tmMkDefinition id' t1 ;;
      print_nf ("toto5 " ^ id) ;;
      let decl := {| cst_universes := [];
                     cst_type := A; cst_body := Some t |} in
      let Σ' := ConstantDecl kn decl :: (fst ΣE) in
      let E' := (ConstRef kn, tConst id' []) :: (snd ΣE) in
      print_nf  (id ^ " has been translated as " ^ id') ;;
      tmEval all (Some (Σ', E'))
    end
  end.

Definition Ty := Type.
Definition TyTy := Ty -> Type.
MetaCoq Run (ΣE <- tTranslate ([],[]) "Ty" ;;
                     let ΣE := option_get todo ΣE in
                        (* print_nf ΣE). *)
                     tTranslate ΣE "TyTy" >>= tmPrint).

(* MetaCoq Run (ΣE <- tTranslate ([],[]) "nat" ;; *)
(*                      let ΣE := option_get todo ΣE in *)
(*                         (* print_nf ΣE). *) *)
(*                      tTranslate ΣE "t" >>= tmPrint). *)

Fail MetaCoq Run (tTranslate ([],[]) "nat").

Definition map_context_decl (f : term -> term) (decl : context_decl): context_decl
  := {| decl_name := decl.(decl_name);
        decl_body := option_map f decl.(decl_body); decl_type := f decl.(decl_type) |}.

Notation " Γ ,, d " := (d :: Γ) (at level 20, d at next level, only parsing).

Fixpoint tsl_ctx (E : tsl_table) (Γ : context) : context :=
  match Γ with
  | [] => []
  (* | Γ ,, {| decl_name := n; decl_body := None; decl_type := A |} => *)
  (*   tsl_ctx E Γ ,, vass n (tsl_rec0 0 A) ,, vass (tsl_name n) (mkApp (lift0 1 (tsl_rec1 E 0 A)) (tRel 0)) *)
  | Γ ,, decl => let n := decl.(decl_name) in
                let x := decl.(decl_body) in
                let A := decl.(decl_type) in
    tsl_ctx E Γ ,, Build_context_decl n (omap (tsl_rec0 0) x) (tsl_rec0 0 A)
                ,, Build_context_decl (tsl_name n) (omap (lift 1 0 \o tsl_rec1 E 0) x) (mkApps (lift0 1 (tsl_rec1 E 0 A)) [tRel 0])
  end.

Delimit Scope term_scope with term.

Notation "#| Γ |" := (List.length Γ) (at level 0, Γ at level 99, format "#| Γ |") : term_scope.

Lemma tsl_ctx_length E (Γ : context) : #|tsl_ctx E Γ| = 2 * #|Γ|%term.
Proof.
  induction Γ.
  reflexivity.
  destruct a, decl_body; simpl;
  by rewrite IHΓ mulnS.
Qed.

(* Fixpoint removefirst_n {A} (n : nat) (l : list A) : list A := *)
(*   match n with *)
(*   | O => l *)
(*   | S n => match l with *)
(*           | [] => [] *)
(*           | a :: l => removefirst_n n l *)
(*           end *)
(*   end. *)

Notation "( x ; y )" := (exist _ x y).

(* Lemma tsl_ctx_safe_nth fuel Σ E Γ *)
(*   : forall Γ', tsl_ctx fuel Σ E Γ = Success Γ' -> forall n p, exists p', *)
(*         map_context_decl (tsl_ty fuel Σ E (removefirst_n (S n) Γ)) *)
(*                          (safe_nth Γ (n; p)) *)
(*         = Success (safe_nth Γ' (n; p')). *)
(*   intros Γ' H n p. cbn beta in *. *)
(*   revert Γ Γ' H p. *)
(*   induction n; intros Γ Γ' H p; *)
(*     (destruct Γ as [|A Γ]; [inversion p|]). *)
(*   - cbn -[map_context_decl]. *)
(*     rewrite tsl_ctx_cons in H. *)
(*     remember (map_context_decl (tsl_term fuel Σ E Γ) A).  *)
(*     destruct t; [|discriminate]. *)
(*     remember (tsl_ctx fuel Σ E Γ).  *)
(*     destruct t; [|discriminate]. *)
(*     cbn in H. inversion H; clear H. *)
(*     clear p H1. *)
(*     unshelve econstructor. apply le_n_S, le_0_n. *)
(*     reflexivity. *)
(*   - cbn -[map_context_decl]. *)
(*     rewrite tsl_ctx_cons in H. *)
(*     remember (map_context_decl (tsl_term fuel Σ E Γ) A).  *)
(*     destruct t; [|discriminate]. *)
(*     remember (tsl_ctx fuel Σ E Γ).  *)
(*     destruct t; [|discriminate]. *)
(*     cbn in H. inversion H; clear H. *)
(*     symmetry in Heqt0. *)
(*     set (Typing.safe_nth_obligation_2 context_decl (A :: Γ) (S n; p) A Γ eq_refl n eq_refl). *)
(*     specialize (IHn Γ c0 Heqt0 l). *)
(*     destruct IHn. *)

(*     unshelve econstructor. *)
(*     cbn. rewrite <- (tsl_ctx_length fuel Σ E Γ _ Heqt0). exact p. *)
(*     etransitivity. exact π2. cbn. *)
(*     apply f_equal, f_equal, f_equal. *)
(*     apply le_irr. *)
(* Defined. *)
(* Admitted. *)

(* (* todo inductives *) *)
(* Definition global_ctx_correct (Σ : global_context) (E : tsl_context) *)
(*   := forall id T, lookup_constant_type Σ id = Checked T *)
(*                 -> exists fuel t' T', lookup_tsl_ctx E (ConstRef id) = Some t' /\ *)
(*                            tsl_term fuel Σ E [] T = Success _ T' /\ *)
(*                            squash (Σ ;;; [] |-- t' : T'). *)

Definition tsl_table_correct (Σ : global_context) (E : tsl_table) : Type := todo.
(*   := forall id t' T, *)
(*     lookup_tsl_table E (ConstRef id) = Some t' -> *)
(*     lookup_constant_type Σ id = Checked T -> *)
(*     exists fuel T', ((tsl_ty fuel Σ E [] T = Success T') *)
(*       * (Σ ;;; [] |--  t' : T'))%type. *)

Lemma LmapE : @List.map = @seq.map.
reflexivity.
Qed.

Lemma lebE (m n : nat) : (Nat.leb m n) = (m <= n).
Admitted.

Lemma term_eqP : Equality.axiom eq_term.
Admitted.

Definition term_eqMixin := EqMixin term_eqP.
Canonical termT_eqype := EqType term term_eqMixin.

Lemma tsl_rec0_lift m n t :
  tsl_rec0 m (lift n m t) = lift (2 * n) m (tsl_rec0 m t).
Proof.
elim/term_forall_list_ind : t m n => //=; rewrite ?plusE.
- move=> n m k.
  rewrite lebE.
  case: leqP => /= mn; rewrite lebE plusE.
  rewrite !ifT ?mulnDr ?addnA //.
    admit.
    admit.
  by rewrite leqNgt mn.
- admit.
- by move=> t IHt c t0 IHt0 m n; rewrite IHt IHt0.
- by move=> n0 t -IHt t0 IHt0 m n /=; rewrite IHt addn1 IHt0.
- by move=> n t IHt t0 IHt0 m n0; rewrite IHt addn1 IHt0.
- by move=> n t IHt t0 IHt0 t1 IHt1 m n0; rewrite !addn1 IHt IHt0 IHt1.
- move=> t IHt l IHl m n; rewrite IHt.
  rewrite LmapE.
  rewrite -!map_comp.
  congr (tApp _ _).
  apply/eq_in_map => i /=.
  admit.
- move=> p t IHt t0 IHt0 l IHl m n.
  rewrite IHt IHt0.
  admit.
- by move=> s t IHt m n; rewrite IHt.
- admit.
- admit.
Admitted.

Lemma lift_mkApps n k t us
  : lift n k (mkApps t us) = mkApps (lift n k t) (map (lift n k) us).
Proof.
  (* destruct t; try reflexivity. *)
  (* cbn. destruct (Nat.leb k n0); try reflexivity. *)
  (* cbn. by rewrite -map_cat.  *)
done.
Qed.

Arguments subst_app : simpl nomatch.

Lemma tsl_rec1_lift E n t :
  (* tsl_rec1 E 0 (lift n m t) = lift (2 * n) (2 * m) (tsl_rec1 E 0 t). *)
  tsl_rec1 E 0 (lift0 n t) = lift0 (2 * n) (tsl_rec1 E 0 t).
Proof.
elim/term_forall_list_ind : t n => //; rewrite ?plusE.
- move=> n k.
  (* rewrite !lebE fun_if /= leq_mul2l /=. *)
  (* by have [] := leqP m n => //=; *) by rewrite /= mulnDr.
- admit.
- admit.
- admit.
- move=> t IHt c t0 IHt0 n /=; rewrite IHt IHt0 ?lift_mkApps.
  congr (tCast _ _ (mkApps _ _)).
  by rewrite !tsl_rec0_lift.
- move=> n t IHt t0 IHt0 n0.
  rewrite /=.
  rewrite !IHt.
  rewrite !tsl_rec0_lift.
(*   rewrite lift_simpl. *)
(*   rewrite IHt addn1 IHt0. *)
(* - by move=> n t IHt t0 IHt0 m n0; rewrite IHt addn1 IHt0. *)
(* - by move=> n t IHt t0 IHt0 t1 IHt1 m n0; rewrite !addn1 IHt IHt0 IHt1. *)
(* - move=> t IHt l IHl m n; rewrite IHt. *)
(*   rewrite LmapE. *)
(*   rewrite -!map_comp. *)
(*   congr (tApp _ _). *)
(*   apply/eq_in_map => i /=. *)
(*   admit. *)
(* - move=> p t IHt t0 IHt0 l IHl m n. *)
(*   rewrite IHt IHt0. *)
(*   admit. *)
(* - by move=> s t IHt m n; rewrite IHt. *)
(* - admit. *)
(* - admit. *)
Admitted.

(* Admitted. *)

(* Lemma tsl_rec0_lift n t *)
(*   : tsl_rec0 0 (lift0 n t) = lift0 n (tsl_rec0 0 t). *)
(* Admitted. *)

(* Lemma tsl_ty_lift fuel Σ E Γ n (p : n <= #|Γ|) t *)
(*   : tsl_ty fuel Σ E Γ (lift0 n t) = *)
(*     (t' <- tsl_ty fuel Σ E (removefirst_n n Γ) t ;; ret (lift0 n t')). *)
(* Admitted. *)

(* Lemma tsl_S_fuel {fuel Σ E Γ t t'} *)
(*   : tsl_term fuel Σ E Γ t = Success t' -> tsl_term (S fuel) Σ E Γ t = Success t'. *)
(* Admitted. *)

Record hidden T := Hidden {show : T}.
Arguments show : simpl never.
Notation "'hidden" := (show _ (Hidden _ _)).
Lemma hide T (t : T) : t = show T (Hidden T t).
Proof. by []. Qed.

(* From mathcomp Require Import ssrnat. *)

Arguments safe_nth : simpl nomatch.

Lemma eq_safe_nth T (l : list T) n n' p p' : n = n' ->
  safe_nth l (n; p) = safe_nth l (n'; p') :> T.
Proof.
move=> eq_n; case: _ / eq_n in p p' *.
elim: l => [|x l IHl] in n p p' *.
  by inversion p.
by case: n => [//|n] in p p' *; apply: IHl.
Qed.

    Lemma tsl_rec0_decl_type (Γ : context) (n : nat) (isdecl : (n < #|Γ|%term)%coq_nat) (E : tsl_table) (isdecl' : (2 * n + 1 < #|tsl_ctx E Γ|%term)%coq_nat)
      : tsl_rec0 0 (decl_type (safe_nth Γ (n; isdecl))) =
        decl_type (safe_nth (tsl_ctx E Γ) (2 * n + 1; isdecl')).
    Proof.
      elim: Γ => [|a Γ IHΓ] in n isdecl isdecl' *.
        by inversion isdecl.
      simpl.
      case: n => [//|n] in isdecl isdecl' *.
      rewrite addn1 /= in isdecl' *.
      rewrite IHΓ addn1 //.
        apply/leP; move/leP : isdecl'.
        by rewrite !mul2n doubleS.
      move=> isdecl''.
      congr (decl_type _); apply: eq_safe_nth.
      by rewrite plusE addn0 mul2n -addnn addnS.
    Qed.

Lemma tsl_rec1_decl_type (Γ : context) (n : nat) (E : tsl_table) p p'
  (Γ' := tsl_ctx E Γ) :
  mkApps (lift0 1 (decl_type (safe_nth Γ' ((2 * n); p)))) [tRel 0] =
  decl_type (safe_nth Γ' (2 * n; p')).
Proof.
subst Γ'; elim: Γ => [|a Γ IHΓ] in n p p' *.
  by inversion p.
(* simpl. *)
(* case: n => [|n] //= in p p' *. *)

(* rewrite /=. *)
(* rewrite addn1 /= in p' *. *)
(* rewrite IHΓ addn1 //. *)
(*   apply/leP; move/leP : p'. *)
(*   by rewrite !mul2n doubleS. *)
(* move=> p''. *)
(* congr (decl_type _); apply: eq_safe_nth. *)
(* by rewrite plusE addn0 mul2n -addnn addnS. *)
(*     Qed. *)

Admitted.

    (* Lemma tsl_rec1_decl_type (Γ : context) (n : nat) (isdecl : (n < #|Γ|%term)%coq_nat) (E : tsl_table) (isdecl' : (2 * n + 1 < #|tsl_ctx E Γ|%term)%coq_nat) *)
    (*   : tsl_rec1 E (decl_type (safe_nth Γ (n; isdecl))) = *)
    (*     decl_type (safe_nth (tsl_ctx E Γ) (2 * n + 1; isdecl')). *)

Lemma tsl_correct Σ Γ t T (H : Σ ;;; Γ |-- t : T)
  : forall E, tsl_table_correct Σ E ->
    let Γ' := tsl_ctx E Γ in
    let t0 := tsl_rec0 0 t in
    let t1 := tsl_rec1 E 0 t in
    let T0 := tsl_rec0 0 T in
    let T1 := tsl_rec1 E 0 T in
    Σ ;;; Γ' |-- t0 : T0 /\ Σ ;;; Γ' |-- t1 : mkApps T1 [t0].
Proof.
elim/typing_ind: H => {Γ t T} Γ.
- move=> n isdecl E X Γ' /=.
  rewrite tsl_rec0_lift mulnS add2n (tsl_rec0_decl_type _ _ _ E).
  rewrite tsl_ctx_length.
     apply/leP.
       by rewrite addn1 mul2n -doubleS -mul2n leq_mul2l; apply/leP.
  rewrite !addn1; move=> isdecl'.
  split; first exact: type_Rel.
  have := type_Rel Σ Γ' (2 * n) _.

  evar (l : (2 * n < #|Γ'|%term)%coq_nat).
  move=> /(_ l).
  rewrite -tsl_rec1_decl_type /=.
  admit.
  (* rewrite simpl_lift_rec; do ?easy. *)
  (* by rewrite plusE addn0 addn1. *)

- admit.
- admit.
- admit.
- admit.
- admit.
- rewrite /= => t l t' t'' tt' IHt' spine E ΣE_correct; rewrite /mkApps; split.
    apply: type_App.
      have [] := IHt' _ ΣE_correct.
        by move=> t0_ty ?; exact: t0_ty.
    admit.
  apply: type_App.
    have [] := IHt' _ ΣE_correct.
    by move=> ? t1_ty; exact: t1_ty.
  admit.

    rewrite /Γ' => isdecl'; clear.
    case: Γ isdecl isdecl'.

Require Import Vector.
(* MetaCoq Run (ΣE <- tTranslate ([],[]) "nat" ;; *)