From iris.algebra Require Export frac auth.
From iris.algebra Require Export updates local_updates.
From iris.algebra Require Import proofmode_classes.

Definition frac_authR (A : cmraT) : cmraT :=
  authR (optionUR (prodR fracR A)).
Definition frac_authUR (A : cmraT) : ucmraT :=
  authUR (optionUR (prodR fracR A)).

Definition frac_auth_auth {A : cmraT} (x : A) : frac_authR A :=
  ● (Some (1%Qp,x)).
Definition frac_auth_frag {A : cmraT} (q : frac) (x : A) : frac_authR A :=
  ◯ (Some (q,x)).

Typeclasses Opaque frac_auth_auth frac_auth_frag.

Instance: Params (@frac_auth_auth) 1.
Instance: Params (@frac_auth_frag) 2.

Notation "●! a" := (frac_auth_auth a) (at level 10).
Notation "◯!{ q } a" := (frac_auth_frag q a) (at level 10, format "◯!{ q }  a").
Notation "◯! a" := (frac_auth_frag 1 a) (at level 10).

Section frac_auth.
  Context {A : cmraT}.
  Implicit Types a b : A.

  Global Instance frac_auth_auth_ne : NonExpansive (@frac_auth_auth A).
  Proof. solve_proper. Qed.
  Global Instance frac_auth_auth_proper : Proper ((≡) ==> (≡)) (@frac_auth_auth A).
  Proof. solve_proper. Qed.
  Global Instance frac_auth_frag_ne q : NonExpansive (@frac_auth_frag A q).
  Proof. solve_proper. Qed.
  Global Instance frac_auth_frag_proper q : Proper ((≡) ==> (≡)) (@frac_auth_frag A q).
  Proof. solve_proper. Qed.

  Global Instance frac_auth_auth_discrete a : Discrete a → Discrete (●! a).
  Proof. intros; apply Auth_discrete; apply _. Qed.
  Global Instance frac_auth_frag_discrete a : Discrete a → Discrete (◯! a).
  Proof. intros; apply Auth_discrete, Some_discrete; apply _. Qed.

  Lemma frac_auth_validN n a : ✓{n} a → ✓{n} (●! a ⋅ ◯! a).
  Proof. done. Qed.
  Lemma frac_auth_valid a : ✓ a → ✓ (●! a ⋅ ◯! a).
  Proof. done. Qed.

  Lemma frac_auth_agreeN n a b : ✓{n} (●! a ⋅ ◯! b) → a ≡{n}≡ b.
  Proof.
    rewrite auth_validN_eq /= => -[Hincl Hvalid].
    by move: Hincl=> /Some_includedN_exclusive /(_ Hvalid ) [??].
  Qed.
  Lemma frac_auth_agree a b : ✓ (●! a ⋅ ◯! b) → a ≡ b.
  Proof.
    intros. apply equiv_dist=> n. by apply frac_auth_agreeN, cmra_valid_validN.
  Qed.
  Lemma frac_auth_agreeL `{!LeibnizEquiv A} a b : ✓ (●! a ⋅ ◯! b) → a = b.
  Proof. intros. by apply leibniz_equiv, frac_auth_agree. Qed.

  Lemma frac_auth_includedN n q a b : ✓{n} (●! a ⋅ ◯!{q} b) → Some b ≼{n} Some a.
  Proof. by rewrite auth_validN_eq /= => -[/Some_pair_includedN [_ ?] _]. Qed.
  Lemma frac_auth_included `{CmraDiscrete A} q a b :
    ✓ (●! a ⋅ ◯!{q} b) → Some b ≼ Some a.
  Proof. by rewrite auth_valid_discrete /= => -[/Some_pair_included [_ ?] _]. Qed.
  Lemma frac_auth_includedN_total `{CmraTotal A} n q a b :
    ✓{n} (●! a ⋅ ◯!{q} b) → b ≼{n} a.
  Proof. intros. by eapply Some_includedN_total, frac_auth_includedN. Qed.
  Lemma frac_auth_included_total `{CmraDiscrete A, CmraTotal A} q a b :
    ✓ (●! a ⋅ ◯!{q} b) → b ≼ a.
  Proof. intros. by eapply Some_included_total, frac_auth_included. Qed.

  Lemma frac_auth_auth_validN n a : ✓{n} (●! a) ↔ ✓{n} a.
  Proof.
    split; [by intros [_ [??]]|].
    by repeat split; simpl; auto using ucmra_unit_leastN.
  Qed.
  Lemma frac_auth_auth_valid a : ✓ (●! a) ↔ ✓ a.
  Proof. rewrite !cmra_valid_validN. by setoid_rewrite frac_auth_auth_validN. Qed.

  Lemma frac_auth_frag_validN n q a : ✓{n} (◯!{q} a) ↔ ✓{n} q ∧ ✓{n} a.
  Proof. done. Qed.
  Lemma frac_auth_frag_valid q a : ✓ (◯!{q} a) ↔ ✓ q ∧ ✓ a.
  Proof. done. Qed.

  Lemma frac_auth_frag_op q1 q2 a1 a2 : ◯!{q1+q2} (a1 ⋅ a2) ≡ ◯!{q1} a1 ⋅ ◯!{q2} a2.
  Proof. done. Qed.

  Lemma frac_auth_frag_validN_op_1_l n q a b : ✓{n} (◯!{1} a ⋅ ◯!{q} b) → False.
  Proof. rewrite -frac_auth_frag_op frac_auth_frag_validN=> -[/exclusiveN_l []]. Qed.
  Lemma frac_auth_frag_valid_op_1_l q a b : ✓ (◯!{1} a ⋅ ◯!{q} b) → False.
  Proof. rewrite -frac_auth_frag_op frac_auth_frag_valid=> -[/exclusive_l []]. Qed.

  Global Instance is_op_frac_auth (q q1 q2 : frac) (a a1 a2 : A) :
    IsOp q q1 q2 → IsOp a a1 a2 → IsOp' (◯!{q} a) (◯!{q1} a1) (◯!{q2} a2).
  Proof. by rewrite /IsOp' /IsOp=> /leibniz_equiv_iff -> ->. Qed.

  Global Instance is_op_frac_auth_core_id (q q1 q2 : frac) (a  : A) :
    CoreId a → IsOp q q1 q2 → IsOp' (◯!{q} a) (◯!{q1} a) (◯!{q2} a).
  Proof.
    rewrite /IsOp' /IsOp=> ? /leibniz_equiv_iff ->.
    by rewrite -frac_auth_frag_op -core_id_dup.
  Qed.

  Lemma frac_auth_update q a b a' b' :
    (a,b) ~l~> (a',b') → ●! a ⋅ ◯!{q} b ~~> ●! a' ⋅ ◯!{q} b'.
  Proof.
    intros. by apply auth_update, option_local_update, prod_local_update_2.
  Qed.

  Lemma frac_auth_update_1 a b a' : ✓ a' → ●! a ⋅ ◯! b ~~> ●! a' ⋅ ◯! a'.
  Proof.
    intros. by apply auth_update, option_local_update, exclusive_local_update.
  Qed.
End frac_auth.


From iris.bi Require Import bi.
From iris.proofmode Require Export classes.
From iris.prelude Require Import options.
Import bi.

Section modalities.
  Context {PROP : bi}.

  Lemma modality_persistently_mixin :
    modality_mixin (@bi_persistently PROP) MIEnvId MIEnvClear.
  Proof.
    split; simpl; eauto using equiv_entails_1_2, persistently_intro,
      persistently_mono, persistently_sep_2 with typeclass_instances.
  Qed.
  Definition modality_persistently :=
    Modality _ modality_persistently_mixin.

  Lemma modality_affinely_mixin :
    modality_mixin (@bi_affinely PROP) MIEnvId (MIEnvForall Affine).
  Proof.
    split; simpl; eauto using equiv_entails_1_2, affinely_intro, affinely_mono,
      affinely_sep_2 with typeclass_instances.
  Qed.
  Definition modality_affinely :=
    Modality _ modality_affinely_mixin.

  Lemma modality_intuitionistically_mixin :
    modality_mixin (@bi_intuitionistically PROP) MIEnvId MIEnvIsEmpty.
  Proof.
    split; simpl; eauto using equiv_entails_1_2, intuitionistically_emp,
      affinely_mono, persistently_mono, intuitionistically_idemp,
      intuitionistically_sep_2 with typeclass_instances.
  Qed.
  Definition modality_intuitionistically :=
    Modality _ modality_intuitionistically_mixin.

  Lemma modality_embed_mixin `{BiEmbed PROP PROP'} :
    modality_mixin (@embed PROP PROP' _)
      (MIEnvTransform IntoEmbed) (MIEnvTransform IntoEmbed).
  Proof.
    split; simpl; split_and?;
      eauto using equiv_entails_1_2, embed_emp_2, embed_sep, embed_and.
    - intros P Q. rewrite /IntoEmbed=> ->. by rewrite embed_intuitionistically_2.
    - by intros P Q ->.
  Qed.
  Definition modality_embed `{BiEmbed PROP PROP'} :=
    Modality _ modality_embed_mixin.

  Lemma modality_plainly_mixin `{BiPlainly PROP} :
    modality_mixin (@plainly PROP _) (MIEnvForall Plain) MIEnvClear.
  Proof.
    split; simpl; split_and?; eauto using equiv_entails_1_2, plainly_intro,
      plainly_mono, plainly_and, plainly_sep_2 with typeclass_instances.
  Qed.
  Definition modality_plainly `{BiPlainly PROP} :=
    Modality _ modality_plainly_mixin.

  Lemma modality_laterN_mixin n :
    modality_mixin (@bi_laterN PROP n)
      (MIEnvTransform (MaybeIntoLaterN false n)) (MIEnvTransform (MaybeIntoLaterN false n)).
  Proof.
    split; simpl; split_and?; eauto using equiv_entails_1_2, laterN_intro,
      laterN_mono, laterN_and, laterN_sep with typeclass_instances.
    rewrite /MaybeIntoLaterN=> P Q ->. by rewrite laterN_intuitionistically_2.
  Qed.
  Definition modality_laterN n :=
    Modality _ (modality_laterN_mixin n).
End modalities.


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 NArith.
Require Import Coq.Program.Program.
Open Scope program_scope.
Require Import Coq.Init.Nat.
Require Import SquiggleEq.varInterface.
Require Import SquiggleEq.varImplDummyPair.

Notation AnyRel := false (only parsing).
Notation IsoRel := true (only parsing).

Require Import ExtLib.Data.String.
Definition constTransName (n:ident) : ident :=
  String.append (mapDots "_" n) "_pmtcty_RR".

Definition indTransName (n:inductive) : ident :=
match n with
| mkInd s n => String.append (constTransName s) (nat2string10 n)
end.

Definition propAuxName (n: ident) : ident :=
  String.append n "_prop".

(* TODO: use in indProp.translateIndProp *)
Definition propIndRInd (ind: inductive) : inductive :=
  let (_ ,indIndex) :=  ind in
  let indRName := (indTransName ind) in
  let indRNameAux2 := propAuxName indRName in
  (mkInd indRNameAux2 indIndex).

Definition constrTransName (n:inductive) (nc: nat) : ident :=
String.append (indTransName n) (String.append "_constr_" (nat2string10 nc)).

Definition constrTransTotName (n:inductive) (nc: nat) : ident :=
String.append (constrTransName n nc) "_tot".

Definition constrInvName (cn:ident)  : ident :=
String.append cn "_inv".

(* not iso *)
Definition constrInvFullName (n:inductive) (nc: nat)  : ident :=
constrInvName (constrTransName n nc).

(*
Definition sigtPolyRect@{i j} (A : Type@{i}) (P : A -> Type@{i}) (P0 : {x : A & P x} -> Type@{j})
  (f : forall (x : A) (p : P x), P0 (existT P x p)) (s : {x : A & P x}) :=
             let (x, x0) as s0 return (P0 s0) := s in f x x0.
*)

Module IndTrans.

Record ConstructorInfo : Set := {
  index : nat; (* index of this constructor *)
  args_R : list (TranslatedArg.T Arg);
(*  argsPrimes : list Arg;
  args_RR : list Arg; *)
  retTyp : STerm;
(*  retTypIndices : list STerm; *)
  retTypIndices_R : list (TranslatedArg.T STerm);
  (* retTypIndicesPacket : STerm  packaged as a sigma *)
}.

  Record IndInfo :=
  {
    numParams : nat;
    tind : inductive;
    constrInfo_R :  list ConstructorInfo;
    indArgs_R : list (TranslatedArg.T Arg);
    retSort : STerm;
    retSort_R : STerm;
    castedArgs_R : list STerm; (* these include indices as well, althoug only params are casted *)
  }.

  Definition indAppR (i: IndInfo) : STerm :=
    mkConstApp (indTransName (tind i)) (castedArgs_R i).

  Definition indApp (i: IndInfo) : STerm :=
    mkIndApp (tind i) (map (vterm ∘ fst ∘ TranslatedArg.arg) (indArgs_R i)).

  Definition argsLen (ci: IndTrans.ConstructorInfo) : nat :=
    (length (args_R ci)).

  Definition matchOpid (i: IndInfo) : CoqOpid :=
      let cargsLens : list nat := (map IndTrans.argsLen  (constrInfo_R i)) in
      (CCase ((tind i), (numParams i)) cargsLens) None.

  Definition indIndices_R (i: IndInfo) : list (TranslatedArg.T Arg) :=
    skipn (numParams i) (indArgs_R i).

  Definition indParams_R (i: IndInfo) : list (TranslatedArg.T Arg) :=
    firstn (numParams i) (indArgs_R i).

    Definition castedParams_R (i: IndInfo) : list STerm :=
    firstn (3*(numParams i)) ( castedArgs_R i).

  (* because these are not translated, it doesn't matter whether we pick this or
    the casted params*)
  Definition indParams (i: IndInfo) : list (Arg) :=
    map TranslatedArg.arg (indParams_R i).

      (* because these are not translated, it doesn't matter whether we pick this or
    the casted params*)
  Definition indIndices (i: IndInfo) : list (Arg) :=
    map TranslatedArg.arg (indIndices_R i).

    Definition sigIndApp (i: IndInfo) : STerm :=
    let indIndices := mrs (indIndices i) in
    mkSigL indIndices (indApp i).

Definition args (ci: IndTrans.ConstructorInfo) : list Arg :=
  map TranslatedArg.arg  (args_R ci).

Definition thisConstructor (i: IndInfo) (ci: ConstructorInfo) : STerm :=
  let params := indParams i in
  let c11 := mkApp (mkConstr (tind i) (index ci)) (map (vterm∘fst) params) in
  mkApp c11 (map (vterm∘fst∘TranslatedArg.arg) (args_R ci)).

Definition constrInvApp (i: IndInfo) (ci: ConstructorInfo) :
  (STerm (*need to append indIndices_RR with cretIndices1/2 substed in. most
     of the constructions of matches already compute this *)
   ):=
  let cInvName := constrInvFullName (tind i) (index ci) in (* not iso *)
  let cargsAndPrimes := flat_map (fun p =>
                                    [TranslatedArg.arg p;
                                       TranslatedArg.argPrime p]) (args_R ci) in
  let cargsRR := map TranslatedArg.argRel (args_R ci) in
  (mkConstApp cInvName ((castedParams_R i)++(map (vterm ∘ fst) cargsAndPrimes))
   ).

Definition argPrimes (ci: IndTrans.ConstructorInfo) : list Arg:=
map TranslatedArg.argPrime  (args_R ci).

Definition argRR (ci: IndTrans.ConstructorInfo) : list Arg :=
map TranslatedArg.argRel  (args_R ci).

Definition indices (ci: IndTrans.ConstructorInfo) : list STerm :=
map TranslatedArg.arg  (retTypIndices_R ci).

Definition indicesPrimes (ci: IndTrans.ConstructorInfo) : list STerm :=
map TranslatedArg.argPrime (retTypIndices_R ci).

Definition indicesRR (ci: IndTrans.ConstructorInfo) : list STerm :=
map TranslatedArg.argRel  (retTypIndices_R ci).

Definition constrBvars (c: ConstructorInfo) : list V :=
  map fst (args c).

  Definition indBVars (i: IndInfo) : list V :=
    let allConsrVars : list V:= flat_map constrBvars (constrInfo_R i) in
    let indVars := map (fst ∘ TranslatedArg.arg) (indArgs_R i) in
    allConsrVars++indVars.

End IndTrans.

(* can be Prop for set *)
Definition translateSort (s:sort) : sort :=
match s with
| sType _ => s
| _ => sProp
end.
(*
Definition mkTyRel (T1 T2 sort: term) : term :=
  T1 ↪ T2 ↪ sort.
Definition projTyRel (T1 T2 T_R: term) : term := T_R.
*)

Require Import Trecord.
Require Import common.

(* inline it? *)
Definition mkTyRel (T1 T2 sort: STerm) : STerm :=
  mkConstApp "ReflParam.Trecord.BestRel" [T1; T2].

(* inline it? *)
Definition projTyRel (T1 T2 T_R: STerm) : STerm :=
mkConstApp "ReflParam.Trecord.BestR" [T1; T2; T_R].

(*
Fixpoint hasSortSetOrProp (t:STerm) : bool :=
match t with
| mkCast t _ (mkSort sSet) => true
| mkCast t _ (mkSort sProp) => true
(* this should not be needed. Fix template-coq cast branch to insert casts
when params are converted to lambdas *)
| mkPi x A B => andb (hasSortSetOrProp A) (hasSortSetOrProp B) (* ignoring impred prop *)
(* TODO: ensure that App and inductives is casted in Coq *)
(* Todo : handle Fix (look at the types in the body*)
| _ => false
end.

*)

Require Import PiTypeR.

(*
Using this can cause universe inconsistencies. Using its quote is like using
a notation and does not add universe constraints
Definition PiABType@{i it j jt}
  (A1 A2 :Type@{i}) (A_R: A1 -> A2 -> Type@{it})
  (B1: A1 -> Type@{j})
  (B2: A2 -> Type@{j})
  (B_R: forall a1 a2,  A_R a1 a2 ->  (B1 a1) -> (B2 a2) -> Type@{jt})
  := (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : A_R a1 a2), B_R a1 a2 p (f1 a1) (f2 a2)).
*)

Definition PiABType (Asp Bsp:bool) (a1:V)
  (A1 A2 A_R B1 B2 B_R : STerm) : STerm :=
let allVars := flat_map all_vars ([A1; A2; B1; B2; A_R; B_R]) in
let f1 : V := freshUserVar (a1::allVars) "ff" in
let a2 := vprime a1 in
let ar := vrel a1 in
let f2 := vprime f1 in
let A_R := if Asp then projTyRel A1 A2 A_R else A_R in
let B_R := mkAppBetaUnsafe B_R [vterm a1; vterm a2; vterm ar] in
let B_R := if Bsp then projTyRel (mkAppBeta B1 [vterm a1]) (mkAppBeta B2 [vterm a2])
     B_R else B_R in
mkLamL [(f1, mkPi a1 A1 (mkAppBeta B1 [vterm a1])) ; (f2, mkPi a2 A2 (mkAppBeta B2 [vterm a2]))]
       (mkPiL [(a1,A1); (a2,A2) ; (ar, mkAppBeta A_R [vterm a1; vterm a2])]
(* dont change the app below to mkAppBeta -- that would complicate the function
remove removePiRHeadArg, which
   is to get B_R from the translation of [forall a, B]. Because of the termination check issues,
   we can often not directly translate B, as the recursive function to extract [B] confuses the termination checker *)
   (mkApp B_R [mkApp (vterm f1) [vterm a1]; mkApp (vterm f2) [vterm a2]])).

(* to be used when flattening must not be done *)
Definition appExtract (t:STerm) : (STerm * list STerm):=
  match t with
  | vterm _ => (t,[])
  | oterm (CApply _) (b::lb) => (get_nt b, map get_nt lb)
  | oterm _ _ => (t,[])
   end.
(* not in use anymore *)
Definition removePiRHeadArg (t:STerm) : STerm :=
  let (t,_) := getNHeadLams 2 t in
  let (t,_) := (getNHeadPis 3 t) in
  fst (appExtract t).

(*
Definition getPiConst (Asp Bsp : bool) :=
match (Asp, Bsp) with
(* true means lower universe (sp stands for Set or Prop) *)
| (false, false) => "PiABType" (* not used *)
| (false, true) => "PiATypeBSet" (* not used *)
| (true, false) => "PiASetBType" (* not used *)
| (true, true) => "ReflParam.PiTypeR.PiGoodSet"
end.
Run TemplateProgram (printTermSq "PiABType").
 *)

Definition getPiConst (Bsort : sort) :=
match Bsort with
| sSet => "ReflParam.PiTypeR.PiGoodSet"
| sProp => "ReflParam.PiTypeR.PiGoodProp"
| _ => "errrorrConst"
end.

Definition getPiGoodnessLevel (Bsort : sort) : ident :=
match Bsort with
| sSet => "ReflParam.Trecord.allProps"
| sProp => "ReflParam.Trecord.onlyTotal"
| _ => "errrorrGoodLvl"
end.

Definition getPiDownCastOp (Bsort : sort) : STerm  -> STerm :=
match Bsort with
| sSet => id
| sProp => fun t => mkConstApp "Trecord.cast_Good_onlyTotal" [t]
| _ => id
end.

(* TODO: simplify this. just return the final STerm. the first two elems of the pair are
not needed anymore *)
Definition mkPiR (isoMode: bool) (needToProjectRel : option sort -> bool)
           (Asp Bsp : option sort) :
  ((STerm->STerm) * option ident *(forall (a: V) (A1 A2 A_R  B1 B2 B_R: STerm), STerm)) :=
  let PiABType := PiABType (needToProjectRel Asp) (needToProjectRel Bsp) in
  if (negb isoMode) then (id, None, PiABType) else
match (Asp, Bsp) with
(*if RHS is Prop, then the result is in Prop, and the abstraction theorem would
need goodness which this doesn't provide. If A:=Prop, this works. Try
to characterize such cases.

Come up with a concrete couterexample.
(Regardless, because if A is of a higher univ, we don't have goodness for it
and then we have no combinator we can use)
T:Type
A:=T
B:= fun a:T => A

  *)
| (None, _) => (id, None ,PiABType)
| (_, None) => (id, None ,PiABType)
| (Some _, Some Bsort) =>
  (getPiDownCastOp Bsort, Some (getPiGoodnessLevel Bsort)
   ,fun _ (A1 A2 A_R  B1 B2 B_R: STerm) =>mkApp (mkConst (getPiConst Bsort))
                                             [A1; A2; A_R ; B1; B2; B_R])
end.

(* return Bsp iff a goodness record is needed *)
Definition needGoodnessPi (isoMode: bool) (Asp Bsp : option sort): option sort :=
if (negb isoMode) then None else
match (Asp, Bsp) with
(*if RHS is Prop, then the result is in Prop, and the abstraction theorem would
need goodness which this doesn't provide. If A:=Prop, this works. Try
to characterize such cases.

Come up with a concrete couterexample.
(Regardless, because if A is of a higher univ, we don't have goodness for it
and then we have no combinator we can use)
T:Type
A:=T
B:= fun a:T => A

  *)
| (None, _) => None (* B could be some but it doesnt matter as the overall univ would be higher *)
| (_, None) => None
| (Some _, Some Bsort) => Bsp
end.

Definition mkPiRNew (isoMode: bool) (needToProjectRel : option sort -> bool)
           (Asp Bsp : option sort) :
  ((forall (a: V) (A1 A2 A_R  B1 B2 B_R: STerm), STerm)) :=
  match needGoodnessPi isoMode Asp Bsp with
  | None  => PiABType (needToProjectRel Asp) (needToProjectRel Bsp)
  | Some Bsort =>
fun _ (A1 A2 A_R  B1 B2 B_R: STerm) =>mkApp (mkConst (getPiConst Bsort))
                                         [A1; A2; A_R ; B1; B2; B_R]
  end.

Lemma mkPiRNewCorrect (isoMode: bool) (needToProjectRel : option sort -> bool)
      (Asp Bsp : option sort) :
  mkPiRNew isoMode needToProjectRel Asp Bsp
  = snd (mkPiR isoMode needToProjectRel Asp Bsp).
Proof using.
  unfold mkPiRNew, mkPiR, needGoodnessPi. destruct isoMode; simpl;[| refl].
  destruct Asp; destruct Bsp; refl.
Qed.

Definition appArgTranslate translate (b:@BTerm (N*name) CoqOpid) : list STerm :=
  let t := get_nt b in
  let t2 := tvmap vprime t in
  let tR := translate t in
  [t; t2; tR].

Definition mkTyRelOld T1 T2 TS :=
  let v1 := (6, nAnon) in (* safe to use 0,3 ? *)
  let v2 := (9, nAnon) in
  mkPiL [(v1,T1); (v2,T2)] TS.

(*
Remove casts around tind.
TODO: additional work needed for nested inductives.
Fixpoint removeCastsAroundInd (tind: inductive) (t:STerm) : (STerm) :=
match t with
| mkPi x A B
  => mkPi x A (removeCastsAroundInd tind B) (* strict positivity => tind cannot appear in A *)
| mkCast tc _ (mkSort sProp)
| mkCast tc _ (mkSort sSet) =>
    let (f, args) := flattenApp tc [] in
    match f with
    | mkConstInd tin  => if (decide (getIndName tind = getIndName tin)) then tc else t
    | mkPi x A B => tc (* must ensure that this argument is recursive *)
    | _ => t
    end
| t => t
end.
*)

(* while translating an inductive, we don't yet have its goodness. So, we remove the flags
that signal the need for creation and projection of goodness props.
The callee must ensure that this argument is recursive -- the last item in the Pi type is the inductive type
being translated. *)
Fixpoint removeIndRelProps (*_: inductive*) (t:STerm) : (STerm) :=
match t with
| mkPiS x A Sa B Sb
  => mkPiS x A (* strict positivity => tind cannot appear in A *) Sa (removeIndRelProps B) None
| t => t
end.

Import STermVarInstances.
Definition isoModeId (id:ident) := String.append id "_iso".

Definition indGoodTransName (n:inductive) : ident :=
  String.append (indTransName n) "_good".

Definition indIndicesTransName (n:inductive) : ident :=
String.append (indTransName n) "_indices".

Definition indIndicesIrrelTransName (n:inductive) : ident :=
String.append (indTransName n) "_indices_irr".

Definition indIndicesConstrTransName (i:ident) : ident :=
String.append i "c".

Definition indIndicesConstrTransNameFull (n:inductive) : ident :=
indIndicesConstrTransName (indIndicesTransName n).

Definition indTransTotName (iff b21: bool)(n:inductive) : ident :=
  let tot := if iff then "iff" else "tot" in
  let s21 := if b21 then "21" else "12" in
  (String.append (indTransName n) (String.append tot s21)).

Definition indTransOneName (b21: bool)(n:inductive) : ident :=
  let tot := "one" in
  let s21 := if b21 then "21" else "12" in
  (String.append (indTransName n) (String.append tot s21)).

Require Import SquiggleEq.AssociationList.

Definition mindNumParams (t:simple_mutual_ind STerm SBTerm) :nat :=
length (fst t).

(* Move to templateCoqMisc?
In the constructor types in t, vars representing the inductive being defined
(now already defined) need to be replaces with the corresponding term (of the form mkInd _)
by which they are referred to after the definition.
 *)
Definition substMutIndMap {T:Set} (f: SBTerm -> list STerm -> list Arg -> T)
           (id:ident) (t: simple_mutual_ind STerm SBTerm)
:list (inductive* simple_one_ind STerm T) :=
    let (params,ones) := t  in
    let numInds := (length ones) in
    let is := List.seq 0 numInds in
    let inds := map (fun n => mkInd id n) is in
    let indsT := map (fun n => mkConstInd n) inds in
    let numParams := (length params) in
    (* Fix: for robustness agains variable implementation, use FreshVars?*)
    let lp := getParamAsVars numParams ones in
    let onesS := map (mapTermSimpleOneInd
       (@Datatypes.id STerm)
       (fun b: SBTerm => f b indsT lp)) ones in
       combine inds onesS.

Definition substMutInd
           (id:ident) (t: simple_mutual_ind STerm SBTerm)
  :list (inductive* simple_one_ind STerm STerm) :=
  substMutIndMap (fun b is ps => apply_bterm b (is++(map (vterm∘fst)ps))) id t.

Definition ondIndType {ConstrType:Set} (t: simple_one_ind STerm ConstrType) : STerm :=
  let '(_,typ,_) := t in typ.

Definition indTypes (id:ident)
           (t: simple_mutual_ind STerm SBTerm) : list (inductive * STerm):=
  let (_,ones) := t  in
  let oneTypes := map ondIndType ones in
  let oneTypesN := numberElems oneTypes in
  map (fun (p:(nat*STerm)) => let (n,typ) := p in (mkInd id n, typ)) oneTypesN.

Definition substMutIndNoParams
           (id:ident) (t: simple_mutual_ind STerm SBTerm)
  :list (inductive* simple_one_ind STerm SBTerm) :=
  substMutIndMap (fun b is _ => apply_bterm_partial b is) id t.

Definition substMutIndParamsAsPi
           (id:ident) (t: simple_mutual_ind STerm SBTerm)
  :list (inductive * simple_one_ind STerm STerm) :=
  substMutIndMap (fun b is ps =>
    mkPiL (map removeSortInfo ps) (apply_bterm b (is++(map (vterm∘fst) ps)))
    ) id t.

Definition mutAllConstructors
           (id:ident) (t: simple_mutual_ind STerm SBTerm) : list (ident * STerm) :=
  flat_map (fun p:(inductive * simple_one_ind STerm STerm) => let (i,one) := p in
    let numberedConstructors := numberElems (map snd (snd one)) in
    map (fun pc => (constrTransName i (fst pc),snd pc)) numberedConstructors
    ) (substMutIndParamsAsPi id t).

Definition substIndConstsWithVars (id:ident) (numInds : nat)

(indTransName : inductive -> ident)
  : list (ident*V) :=
    let is := List.seq 0 numInds in
    let inds := map (fun n => mkInd id n) is in
    let indRNames := map indTransName inds in
    (* Fix: for robustness agains variable implementation, use FreshVars?*)
    let indRVars : list V := combine (seq (N.add 3) 0 numInds) (map nNamed indRNames) in
    combine indRNames (indRVars).

(** to be used when we don't yet know how to produce a subterm *)
Axiom F: False.
Definition fiat (T:Type) : T := @False_rect T F.

(* somehow False_rect doesn't work while unquoting *)

Definition indEnv:  Type := AssocList ident (simple_mutual_ind STerm SBTerm).

(* return numParams as well? may be needed for generating Fix F = F (Fix F)*)
Definition lookUpInd (ienv: indEnv) (ind : inductive) : (simple_one_ind STerm SBTerm)*nat :=
  match ind with
  | mkInd id n =>
    let omind := ALFind ienv id in
    let dummy :=  (ind, dummyInd) in
    (match omind with
      | Some mind =>
        let mindS := substMutIndNoParams id mind in
        (snd (nth n mindS dummy), length (fst mind))
      | None=> (dummyInd, O)
    end)
  end.

Definition isIndProp (ienv: indEnv) (ind : inductive) : bool :=
  let (id,n) := ind in
  let omind := ALFind ienv id in
  match omind with
  | Some mind =>
    let type := nth n (map ondIndType (snd mind)) (mkUnknown "index out of range") in
    let (ret, _) := getHeadPIs type in
    match ret with
    | mkSort sProp => true
    |  _ => false
    end
  | None=> false (* impossible *)
  end.

Section trans.
Variable piff:bool.
(* already removed
Let removeHeadCast := if piff then removeHeadCast else id.
*)
Definition needSpecialTyRel := if piff
then
  (fun os =>
    match os with
  | Some s => isPropOrSet s
  | None => false
  end
  )
else (fun _ => false).

Let isoModeId  := if piff then isoModeId else id.
Let indTransName s := (isoModeId ( indTransName s)).

(* TODO : use fixDefSq *)
Definition mkFixCache
           (p: list (fixDef V STerm)) : fixCache :=
  fixDefSq bterm p.

(* TODO:  use the mkFixcache above.
 indTransName depends on mode*)
Definition mutIndToMutFixAux {TExtra:Type}
(tone : forall (numParams:nat)(tind : inductive*(simple_one_ind STerm STerm)),
  (list Arg) * (fixDef True STerm)* list TExtra)
(id:ident) (t: simple_mutual_ind STerm SBTerm) (i:nat)
  : STerm * list TExtra :=
    let onesS := substMutInd id t in
    let numInds := length onesS in
    let numParams := length (fst t) in
    let trAndDefs := map (tone numParams) onesS in
    let tr: list ((list Arg) *fixDef True STerm) := map fst trAndDefs in
    let lamArgs := match tr with
                   | (la,_)::_ => la
                   | _ => []
                   end in
    let tr := map snd tr in
    let extraDefs := flat_map snd trAndDefs in
    let lamArgs := mrs lamArgs in
    let constMap := substIndConstsWithVars id numInds indTransName in
    let indRVars := map snd constMap in
    let constMap := map (fun p => (fst p, mkLamL lamArgs ((vterm ∘ snd) p))) constMap in
    (* TODO : use one of the combinators *)
    let o: CoqOpid := (CFix numInds (map (@structArg True STerm) tr) [] i) in
    let bodies := (map ((bterm indRVars)∘(substConstants constMap)∘(@fbody True STerm)) tr) in
    let f := mkLamL (lamArgs) (oterm o (bodies++(map ((bterm [])∘ fst ∘(@ftype True STerm)) tr))) in
    (f , extraDefs).

Definition mutIndToMutFix
(tone : forall (numParams:nat)(tind : inductive*(simple_one_ind STerm STerm)),
    (list Arg) *  (fixDef True STerm))
(id:ident) (t: simple_mutual_ind STerm SBTerm) (i:nat)
  : STerm:=
fst (@mutIndToMutFixAux True (fun np i => (tone np i,[])) id t i).

Let constrTransName ind cnum := (isoModeId (constrTransName ind cnum)).
Let constrInvFullName ind cnum := (isoModeId (constrInvFullName ind cnum)).
Let projTyRel := if piff then projTyRel else (fun _ _ t=> t).
Let mkTyRel := if piff then mkTyRel else mkTyRelOld.

(* Let indTransName := if piff then indGoodTransName else indTransName. *)

(** AR is of type BestRel A1 A2 or A1 -> A2 -> Type. project out the relation
in the former case.
Definition maybeProjRel (A1 A2 AR : STerm) :=
   if (hasSortSetOrProp A) then
           (fun t => projTyRel A1 A2 AR)
      else AR.
*)

(* TODO : rename to projectifIneeded *)
Definition castIfNeeded  (A : (STerm * option sort)) (Aprime AR : STerm)
  : STerm :=
  let (A, Sa) := A in
  let f := if (needSpecialTyRel Sa) then
           (fun t => projTyRel A Aprime t)
      else id in
  f AR.

(*
Definition transLamAux (translate : STerm -> STerm)
           (A : (STerm * option sort)) : ((STerm * STerm)*STerm) :=
  let (A1, Sa) := A in
  let A2 := tvmap vprime A1 in
  (A1, A2, castIfNeeded A A2 (translate A1)).
 *)

Definition transLam (translate : STerm -> STerm) (nma : Arg) b :=
  let (nm,A1s) := nma in
  let A1 := fst A1s in
  let A2 := tprime A1 in
  let AR := castIfNeeded A1s  A2 (translate A1) in
  mkLamL [(nm, A1);
            (vprime nm, A2);
            (vrel nm, mkAppBeta AR [vterm nm; vterm (vprime nm)])]
         b.

Definition getConstrRetIndices
  (numParams: nat)
    (fretType : forall (cargs: list Arg) (cretType : STerm), STerm)
    (ctype : STerm)
    : list STerm :=
  let (constrRetTyp, constrArgs) := getHeadPIs ctype in
  let thisConstrRetTyp : STerm := fretType constrArgs constrRetTyp in
  let (_,cRetTypArgs) := flattenApp thisConstrRetTyp [] in
  skipn numParams cRetTypArgs.

(* take the variables denoting constructor arguments in the original match branch
lambda and get the full constructor and the indices in its return type *)
Definition matchProcessConstructors
           (np: nat)
           (tind: inductive)
           (discTParams  : list STerm) (bnc : (list V)*(nat*SBTerm)) :
  (STerm * list STerm) :=
  let (bargs, thisConstrTyp) := bnc in
  let bargs : list STerm := map (vterm) bargs in
  let (thisConstrNum, thisConstrTyp) := thisConstrTyp in
  (* let restArgs := skipn ncargs args in *)
  let thisConstrTyp : STerm := apply_bterm thisConstrTyp discTParams in
  let substCRetType  constrArgs constrRetTyp : STerm :=
    ssubst_aux constrRetTyp
     (combine (map fst constrArgs) bargs) in
  let thisConstr := mkConstr tind thisConstrNum in
  let thisConstrFull := mkApp thisConstr (discTParams++bargs) in
  (thisConstrFull, getConstrRetIndices np substCRetType thisConstrTyp).

(* write a function that gets only the first x headLams *)
Definition transMatchBranchInner (discTypParamsR : list STerm)
           (*translate: STerm -> STerm*) (*np: nat*)
           (*tind: inductive*)
           (retTypLamPartiallyApplied : list STerm -> STerm)
           (bnc : (option ident)*((STerm * list Arg)*(STerm * list STerm))) : STerm :=
  let (constrInv, bnc) := bnc in
  let (brn, thisConstrInfo) := bnc in
  let (thisConstrFull, thisConstrRetTypIndices) := thisConstrInfo in
  let retTyp := retTypLamPartiallyApplied
                  (map tprime (snoc thisConstrRetTypIndices thisConstrFull)) in
  let (ret, args) := brn in (* assuming there are no letins *)
  let cargs := map removeSortInfo args in
  let cargs2 := (filter_mod3 cargs 1) in
  let (cargs_R (*R*), cargsAndPrimes) := separate_Rs cargs in
  let cargsAndPrimes := map (vterm ∘ fst) cargsAndPrimes in
  let (retTypBody,pargs) := getHeadPIs retTyp in
  let ret :=
    match constrInv with (* in the branches where the constructors dont match, this is None *)
    | Some constrInv =>
        let f : STerm := mkLamL cargs_R ret in
        mkConstApp constrInv (discTypParamsR++cargsAndPrimes
                                            (* indIndices_R with 1s and 2s substituted *)
                                            ++(map (vterm ∘ fst) pargs)
          ++[headPisToLams retTyp;f])
    | None =>
         let sigt : V := last (map fst pargs) dummyVar in
        falseRectSq retTypBody (vterm sigt)
    end
    in
  mkLamL cargs2 (mkLamL (map removeSortInfo pargs) ret).

Definition transMatchBranch (discTypParamsR : list STerm) (o: CoqOpid) (np: nat)
           (tind: inductive)
           (allBnc : list ((STerm * list Arg)*(STerm * list STerm)))
           (retTypLam : STerm) (retArgs1: list (V*STerm))
           (disc2: STerm)
           (bnc: nat* ((STerm * list Arg)*(STerm * list STerm))) : STerm
            :=
  let (thisConstrIndex, bnc) := bnc in
  let (brn, thisConstrInfo) := bnc in
  let (b_R, cargs) := brn in
  let (thisConstrFull, thisConstrRetTypIndices) := thisConstrInfo in
  let retArgs2 := map primeArgsOld retArgs1 in
  let cargs := map removeSortInfo (filter_mod3 cargs 0) in
  (* let restArgs := skipn ncargs args in *)
  let oneRetArgs1 := (snoc thisConstrRetTypIndices thisConstrFull) in
  let goodConstrb := (boolNthTrue (length allBnc) thisConstrIndex) in
  let constrInvName := constrInvFullName tind thisConstrIndex in
  let goodConstrb :=
    map (fun b:bool => if b then Some constrInvName else None) goodConstrb in
  let allBnc := combine goodConstrb allBnc in
  let brs :=
      (* this must be AppBeta because we need to analyse the simplified result *)
      let retTypLamPartial args2 := mkAppBeta retTypLam (merge oneRetArgs1 args2) in
      map (transMatchBranchInner discTypParamsR retTypLamPartial) allBnc in
  let matchRetTyp :=
    mkApp retTypLam (merge oneRetArgs1 (map (vterm∘fst) retArgs2)) in
  let matchRetTyp := mkLamL retArgs2 matchRetTyp in
  mkLamL cargs
    (oterm o ((bterm [] matchRetTyp):: (bterm [] disc2)::(map (bterm []) brs))).

(* see matchR.vappend2_RR for some concrete intuition on why the translation is the way it is,
e.g., why the type of the discriminee is needed. This function was written after
playing with those examples. *)
Definition transMatch (translate: STerm -> STerm) (ienv: indEnv) (tind: inductive)
           (rsort: option sort) (* we know it is Set or Type *)
           (numIndParams: nat) (lNumCArgs : list nat) (retTyp disc discTyp : STerm)
           (branches : list SBTerm) : STerm :=
  let o := (CCase (tind, numIndParams) lNumCArgs None) in
  let (_, retArgs) := getHeadLams retTyp in (* this is a lambda, encoding  as _  in _ return _  with*)
  let lastVar :=
      let vars := map fst retArgs in
      last vars dummyVar in
  let mt := oterm o ((bterm [] retTyp):: (bterm [] (vterm lastVar))
                                      :: (bterm [] discTyp)::(branches)) in
  let discInner := tvmap vprime disc in
  let retTyp_R := translate (* in false mode?*) retTyp in
  let (retTypLeaf, rargs) := getHeadLams retTyp in (* FIX: this was already done above. reuse that *)
  (* FIX: the word retTyp is used both for the leaf and thw whole term including lambdas *)
  let (retTyp_R, retArgs_R) :=
      let nrargs := length rargs in
      getNHeadLams (3*nrargs) retTyp_R in
  let (arg_Rs (*rename to arg_RRs *), argsAndPrimes) := separate_Rs retArgs_R in
  (* contains lastVar *)

  let retTyp_R := mkApp (castIfNeeded (retTypLeaf,rsort) (tprime retTypLeaf) retTyp_R)
                        [mt; tvmap vprime mt] in
  let retTyp_R := mkPiL (map removeSortInfo arg_Rs) retTyp_R in
  (* let binding this monster can reduce bloat, but to letbind,
      we need to compute its type. *)
  let retTypLam : STerm := mkLamL (map removeSortInfo argsAndPrimes) retTyp_R in
  let (_,discTypArgs) := flattenApp discTyp [] in
  let discTypIndices := skipn numIndParams discTypArgs in
  let discTypParams := firstn numIndParams discTypArgs in
  let (_, discTypArgsR) := flattenApp (translate discTyp) [] in
  let discTypParamsR := (firstn (3*numIndParams) discTypArgsR) in
  let discTypIndicesR :=
      fst (separate_Rs (skipn (3*numIndParams) discTypArgsR)) in
  (* Warning! if this list of constructors has no elements,
     there will be no branches in the produced translation *)
  let constrTyps : list SBTerm := map snd ((snd ∘ fst) (lookUpInd ienv tind)) in
  let branches_R  := map (translate ∘ get_nt) branches in
  let branches_RN := (combine lNumCArgs branches_R) in
  let branches_R := map (fun p => getNHeadLams (3*fst p) (snd p)) branches_RN in
  let branches_RArgs := map (fun p => map fst (filter_mod3 (snd p) 0)) branches_R in
  let branchPackets :=  (combine branches_RArgs (numberElems constrTyps)) in
  let pbranchPackets :=
      map (matchProcessConstructors numIndParams tind discTypParams) branchPackets in
  let branchPackets_R :=(combine branches_R pbranchPackets) in
  let retArgs := map removeSortInfo retArgs in
  let brs :=
      map (transMatchBranch discTypParamsR
             o numIndParams tind branchPackets_R retTypLam
             retArgs (tprime disc)) (numberElems branchPackets_R) in
  let retTypOuter : STerm :=
    mkApp retTypLam
      (merge (map (vterm∘fst) retArgs)
             (map (tvmap vprime) (*FIX: tprime*) (snoc discTypIndices disc))) in
  let retTypOuter : STerm := mkLamL (retArgs) retTypOuter in
  mkApp
    (oterm o ((bterm [] retTypOuter):: (bterm [] disc)::(map (bterm []) brs)))
    (snoc discTypIndicesR (translate disc)).

(** Inductive-stle translation of matches. Used when translating pattern matching on proofs *)
Definition transMatchProof (translate: STerm -> STerm) (ienv: indEnv) (tind: inductive)
           (rsort: option sort)  (* we know it is Prop *)
           (numIndParams: nat) (lNumCArgs : list nat) (retTypLam disc discTyp : STerm)
           (branches : list SBTerm) : STerm :=
  let or := (CCase (propIndRInd tind, (3*numIndParams)%nat) (map (mult 3) lNumCArgs) None) in
  let retTypLam :=
      let o := (CCase (tind, numIndParams) lNumCArgs None) in
      let (_, retArgs) := getHeadLams retTypLam in (* this is a lambda, encoding  as _  in _ return _  with*)
      let lastVar :=
          let vars := map fst retArgs in
          last vars dummyVar in
      let mt := oterm o ((bterm [] retTypLam):: (bterm [] (vterm lastVar))
                                             :: (bterm [] discTyp)::(branches)) in
      let retTyp_R := translate (* in false mode?*) retTypLam in
      let (retTyp, rargs) := getHeadLams retTypLam in (* FIX: this was already done above. reuse that *)
      let (retTyp_R, retArgs_R) :=
          let nrargs := length rargs in
          getNHeadLams (3*nrargs) retTyp_R in
      let retTyp_R := mkApp (castIfNeeded (retTyp,rsort) (tprime retTyp) retTyp_R)
                        [mt; tvmap vprime mt] in
      mkLamL (map removeSortInfo retArgs_R) retTyp_R in
  let brs := map (translate∘get_nt) branches in
    (oterm or ((bterm [] retTypLam):: (bterm [] (translate disc))::(map (bterm []) brs))).

(*
  let fv : V := freshUserVar (all_vars mt) "retTyp" in
  mkLetIn fv  (headLamsToPi2 retTypLam)
  ((oterm (CConstruct (mkInd "Coq.Numbers.BinNums.N" 0) 0) [])).
  oterm o
    ((bterm [] retTyp):: (bterm [] disc):: (bterm [] discTyp)::lb) =>

  disc.
*)

(* to get the unfolding lemma for (fix name ... :=), first let bind the fix to name
  and then put the result of this function..
e.f. let name  :=  (fix name ... :=) in [output of this function]. This function
gets the name from fb*)
Definition fixUnfoldingProof (ienv : indEnv) (fb: fixDef V STerm) : STerm
  :=
  let fbmut := vterm (fname fb) in
  let (body, bargs) := getHeadLams (fbody fb) in
  let nargs := length bargs in
  (*TODO : find out whether fretType:Set or Prop. because a cast will then be needed.
assume. A fixpoint may return a Prop, in which case casting should not be done*)
  let fretType := (ftype fb) in
  let sarg : Arg := nth (structArg fb) bargs
                        (dummyVar, (oterm (CUnknown "fixUnfoldingProof:nthFail") [], None))in
  let sargType := fst (snd sarg) in
  let (tind, sargT) := flattenApp sargType [] in
  let tind : inductive := extractInd tind in
  let (tindDefn, numParams) :=  lookUpInd ienv tind in
  let constrTyps : list SBTerm := map snd (snd tindDefn) in
  let sargTIndices : list STerm := skipn numParams sargT in
  let sargTParams : list STerm := firstn numParams sargT in
  let constrTyps : list STerm := map (fun b => apply_bterm_unsafe b sargTParams) constrTyps  in
  let bargs : list (V*STerm):= mrs bargs in
  let eqt : STerm := mkEqSq (fst fretType) body (mkApp fbmut (map (vterm ∘fst) bargs)) in
  (* all indices must be vars *)
  let sargTIndicesVars : list V := flat_map free_vars sargTIndices in
  let caseRetType : STerm :=
      let indicArgs : list (V*STerm):=
          map (fun v => (v,opExtract (oterm (CUnknown "fixUnfoldingProof:ALMap") [])
              (ALFind bargs v))) sargTIndicesVars in
      mkLamL  (snoc indicArgs (removeSortInfo sarg)) eqt in
  let mkBranch (ctype : (nat * STerm)) : nat*STerm :=
      let (constrIndex, ctype) := ctype in
      let ctype := change_bvars_alpha (free_vars eqt) ctype in
      let (cretType,cargs) := getHeadPIs ctype in
      let cretIndices :=
          let (_,cRetTypArgs) := flattenApp cretType [] in
          skipn numParams cRetTypArgs in
      let indicesSubst := combine sargTIndicesVars cretIndices in
      let thisConstr : STerm := mkApp (mkConstr tind constrIndex)
                                      (sargTParams++(map (vterm ∘fst) cargs)) in
      (* each branch needs to be translated to match the current constructors *)
      let fretType := ssubst_aux (fst fretType) (snoc indicesSubst (fst sarg, thisConstr)) in
      (* do we also need to substitute the indices in the body ?*)
      let ret := (mkEqReflSq fretType
             (ssubst_aux body [(fst sarg, thisConstr)])) in
      (length cargs, mkLamL (mrs cargs) ret) in
  let branches : list (nat*STerm) := map mkBranch (numberElems constrTyps) in
  let o : CoqOpid:= (CCase (tind, numParams) (map fst branches) None) in
  let unfBody := oterm o (map (bterm []) (caseRetType::(vterm (fst sarg))::(map snd branches))) in
  mkLamL bargs unfBody.

(** get the inductive (type family) of the struct argument *)
Definition getStructArgInd (f: fixDef V STerm) : inductive :=
  let (_, args) := getHeadLams (fbody f) in
  let sargType := nth (structArg f) (map argType args) (mkUnknown "struct arg not found") in
  let (sind,_) := flattenApp sargType [] in
  extractInd sind.

Definition isStructArgProof (ienv : indEnv) (f: fixDef V STerm) : bool :=
  isIndProp ienv (getStructArgInd f).

Definition translateFix (ienv : indEnv) (bvars : list V)
           (t:  (fixDef V STerm) * (fixDef V STerm)) : (fixDef V STerm) :=
  let (t, t_R) := t in
  let (bodyOrig, args) := getHeadLams (fbody t) in
  let nargs := length args in
  let (body_R, bargs_R) := getNHeadLams (3*nargs) (fbody t_R) in
  let fretType := ftype t in
  let vargs := (map (vterm ∘ fst) args) in
  let fretType_R := ftype t_R in
  let fretType_R := castIfNeeded fretType (tprime (fst fretType)) (fst fretType_R) in
  let fretType := fst fretType in
  let fixApp : STerm := (mkApp (vterm (fname t)) vargs) in
  (* need thse apps. otherwise function extensionality may be needed *)
  let fixAppPrime : STerm := tprime fixApp in
  let bargs_R := (map removeSortInfo bargs_R) in
  let fretTypeFull :=
      mkPiL bargs_R (mkApp fretType_R [fixApp; fixAppPrime]) in
  let vl : V := freshUserVar (bvars++ allVars (fbody t) ++ allVars fretType) "equ" in
  let transportPL := mkLam vl fretType (mkApp fretType_R [vterm vl; fixAppPrime]) in
  let transportPR := mkLam vl (tprime fretType)
                           (mkApp fretType_R [bodyOrig; vterm vl]) in
  let eqLType : EqType STerm := (Build_EqType _ fretType bodyOrig fixApp) in
  let eqRType : EqType STerm := map_EqType tprime eqLType in
  let peqUnfolding := mkApp (fixUnfoldingProof ienv t) vargs  in

  let body : STerm := mkTransport transportPR eqRType (tprime peqUnfolding) body_R in
  let body : STerm := mkTransport transportPL eqLType peqUnfolding body in
  let body := mkLamL bargs_R body in
  (* the tprime below is duplicat computation. it was done in the main fix loop *)
(*  let fretTypeFull :=
      reduce 10 (mkAppBeta (ftype _ _ t_R) [vterm (fname _ _ t); vterm (vprime (fname _ _ t))]) in *)
  (* the name in t_R is not vreled *)
  {|fname := vrel (fname t);
    fbody :=  body;
    ftype := (fretTypeFull, None);
    structArg := 3*(structArg t) + (if isStructArgProof ienv t then 2 else 0)|}.

Variable ienv : indEnv.

Definition cVar: V := (0,nAnon  (* Coq picks some name like H *)). (* the variable c in the paper *)
Definition cVarP := Eval compute in vprime cVar.

Fixpoint translate (t:STerm) : STerm :=
match t with
| vterm n => vterm (vrel n)
| mkSort s =>
(* because the body of the lambda is closed, no capture possibility*)
      mkLamL
        [(cVar, t);
         (cVarP, t)]
         (mkTyRel (vterm cVar) (vterm cVarP) (mkSort (translateSort s)))
| mkCast tc _ _ => translate tc
| mkConstr i n => mkConst (constrTransName i n)
| mkConst c => mkConst (constTransName c)
| mkConstInd s => mkConst (indTransName s)
| mkLamS nm A Sa b => transLam translate (nm,(A,Sa)) (translate b)
| oterm (CFix len rargs sorts index) lbs =>
  let o := CFix len rargs [] in
  let mkLetBinding (p:nat*fixDef V STerm) (tb :STerm) : STerm :=
      let lbs := undoProcessFixBodyType len lbs in
      let lbsPrime := map btprime lbs in
      let (n,t) := p in
      let body := mkLetIn (vprime (fname t))
                      (oterm (o n) lbsPrime)
                      (tprime (getProcessedFixFullType t))
                      tb
                       in
      mkLetIn (fname t)
              (oterm (o n) lbs)
               ((getProcessedFixFullType  t))
              body in
  let bvars := getFirstBTermVars lbs in
  (* delaying the translation will only confuse the termination checker *)
  let fds_R  := tofixDefSqAux bvars (translate ∘ get_nt) len rargs [] lbs in
  let fds  := tofixDefSqAux bvars (get_nt) len rargs sorts lbs in
  let letBindings th := fold_right mkLetBinding th (numberElems fds) in
  let (o,lb) := fixDefSq bterm (map (translateFix ienv bvars) (combine fds fds_R)) in
    letBindings (oterm (o index) lb)
| mkPiS nm A Sa B Sb =>
  let f := mkPiRNew piff needSpecialTyRel Sa Sb in
  let A1 := A in
  let A2 := tvmap vprime A1 in
  let B1 := (mkLam nm A1 B) in
  let B2 := tvmap vprime B1 in
  let B_R := transLam translate (nm,(A,Sa)) ((translate B)) in
   f nm A1 A2 (translate A) B1 B2 B_R
| oterm (CApply _) (fb::argsb) =>
  (* if this changes, change [extractGoodRelFromApp above, which is used in indType.v *)
    mkAppBeta (translate (get_nt fb)) (flat_map (appArgTranslate translate) argsb)
(* Const C needs to be translated to Const C_R, where C_R is the registered translation
  of C. Until we figure out how to make such databases, we can assuming that C_R =
    f C, where f is a function from strings to strings that also discards all the
    module prefixes *)
| oterm (CCase (tind, numIndParams) lNumCArgs rsort)
    ((bterm [] retTyp):: (bterm [] disc):: (bterm [] discTyp)::lb) =>
  if isIndProp ienv tind then
    transMatchProof translate ienv tind rsort numIndParams lNumCArgs retTyp disc discTyp lb
  else
    transMatch translate ienv tind rsort numIndParams lNumCArgs retTyp disc discTyp lb
| _ => oterm (CUnknown "bad case in translate") []
end.

End trans.

Import MonadNotation.
Open Scope monad_scope.

Require Import List.

Definition genParam (ienv : indEnv) (piff: bool) (b:bool) (id: ident) : TemplateMonad unit :=
  id_s <- tmQuoteSq id true;;
(*  _ <- tmPrint id_s;; *)
  match id_s with
  Some (inl t) =>
  let t_R := (translate piff ienv t) in
  if b then (@tmMkDefinitionSq (constTransName id)  t_R)
  else
    trr <- tmReduce Ast.all t_R;;
    tmPrint trr  ;;
    trrt <- tmReduce Ast.all (fromSqNamed t_R);;
    tmPrint trrt
  | _ => ret tt
  end.


Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.lib.EnsemblesProperties.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimunLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Section Lindenbaum_Flat.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {sL: SeparationLanguage L}
        {Gamma: ProofTheory L}
        {SC: NormalSequentCalculus L Gamma}
        {bSC: BasicSequentCalculus L Gamma}
        {fwSC: FiniteWitnessedSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {AX: NormalAxiomatization L Gamma}
        {minAX: MinimunAxiomatization L Gamma}
        {ipGamma: IntuitionisticPropositionalLogic L Gamma}
        {sGamma: SeparationLogic L Gamma}.

Lemma Lindenbaum_preserves_context_sepcon_included_l: forall Phi2 Psi,
  Lindenbaum_preserves (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  apply Lindenbaum_preserves_by_finiteness.
  + apply context_sepcon_included_l_finite_captured.
  + apply context_sepcon_included_l_subset_preserved.
Qed.

Lemma Lindenbaum_context_sepcon_included_l_ensures_derivable_closed: forall Phi Psi,
  Lindenbaum_ensures (context_sepcon_included_l Phi Psi) derivable_closed.
Proof.
  intros.
  apply Lindenbaum_for_derivable_closed.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + apply context_sepcon_included_l_derivable_subset_preserved.
Qed.

Lemma Lindenbaum_context_sepcon_included_l_ensures_orp_witnessed: forall Phi Psi
      (DC: derivable_closed Psi)
      (OW: orp_witnessed Psi),
  Lindenbaum_ensures (context_sepcon_included_l Phi Psi) orp_witnessed.
Proof.
  intros.
  apply Lindenbaum_for_orp_witnessed.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + apply context_sepcon_included_l_subset_preserved.
  + apply context_sepcon_included_l_context_orp_captured; auto.
  + apply Lindenbaum_context_sepcon_included_l_ensures_derivable_closed.
Qed.

Lemma Lindenbaum_context_sepcon_included_l_ensures_consistent: forall Phi Psi
  (CONSI: consistent Psi),
  Lindenbaum_ensures (context_sepcon_included_l Phi Psi) consistent.
Proof.
  intros.
  apply Lindenbaum_for_consistent.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + intros Phi' ?.
    eapply context_sepcon_consistent_rev_left; eauto.
Qed.

End Lindenbaum_Flat.


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

(***
Modulus : 2^384 - 317
Base: 22 + 10/17
***)

Definition curve : CurveParameters :=
  {|
    sz := 17%nat;
    base := 22 + 10/17;
    bitwidth := 32;
    s := 2^384;
    c := [(1, 317)];
    carry_chains := Some [seq 0 (pred 17); [0; 1]]%nat;

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

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

    mul_code := None;

    square_code := None;

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

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


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 X Y M Aprime Bprime : Universe, ((wd_ X Y /\ (wd_ A M /\ (wd_ Aprime M /\ (wd_ B M /\ (wd_ Bprime M /\ (wd_ B X /\ (wd_ B Y /\ (wd_ A X /\ (wd_ A Y /\ (wd_ A Aprime /\ (wd_ X Aprime /\ (wd_ Y Aprime /\ (wd_ A B /\ (col_ X Y M /\ (col_ B M Bprime /\ (col_ Bprime X Y /\ col_ M A Aprime)))))))))))))))) -> col_ M Bprime X)).
Proof.
  time tac.
Qed.

End FOFProblem.


From st.STLCmuVS Require Import lang.
From st.STLCmu Require Import types.

Definition binop_res_type (op : bin_op) : type :=
  match op with
  | PlusOp => TInt | MinusOp => TInt
  | EqOp => TBool | LeOp => TBool | LtOp => TBool
  end.

Reserved Notation "Γ ⊢ₙₒ e : τ" (at level 74, e, τ at next level).

Inductive typed (Γ : list type) : expr → type → Prop :=
 | Var_typed x τ : Γ !! x = Some τ → Γ ⊢ₙₒ Var x : τ
 | Unit_typed : Γ ⊢ₙₒ Lit (LitUnit) : TUnit
 | Bool_typed b : Γ ⊢ₙₒ Lit (LitBool b) : TBool
 | Int_typed z : Γ ⊢ₙₒ Lit (LitInt z) : TInt
 | BinOp_typed op e1 e2 :
     Γ ⊢ₙₒ e1 : TInt → Γ ⊢ₙₒ e2 : TInt → Γ ⊢ₙₒ BinOp op e1 e2 : binop_res_type op
 | Seq_typed e1 e2 τ :
     Γ ⊢ₙₒ e1 : TUnit → Γ ⊢ₙₒ e2 : τ → Γ ⊢ₙₒ Seq e1 e2 : τ
 | Pair_typed e1 e2 τ1 τ2 :
    Γ ⊢ₙₒ e1 : τ1 → Γ ⊢ₙₒ e2 : τ2 → Γ ⊢ₙₒ Pair e1 e2 : TProd τ1 τ2
 | Fst_typed e τ1 τ2 : Γ ⊢ₙₒ e : TProd τ1 τ2 → Γ ⊢ₙₒ Fst e : τ1
 | Snd_typed e τ1 τ2 : Γ ⊢ₙₒ e : TProd τ1 τ2 → Γ ⊢ₙₒ Snd e : τ2
 | InjL_typed e τ1 τ2 : Γ ⊢ₙₒ e : τ1 → Γ ⊢ₙₒ InjL e : τ1 + τ2
 | InjR_typed e τ1 τ2 : Γ ⊢ₙₒ e : τ2 → Γ ⊢ₙₒ InjR e : TSum τ1 τ2
 | Case_typed e0 e1 e2 τ1 τ2 τ3 :
    Γ ⊢ₙₒ e0 : TSum τ1 τ2 → τ1 :: Γ ⊢ₙₒ e1 : τ3 → τ2 :: Γ ⊢ₙₒ e2 : τ3 →
    Γ ⊢ₙₒ Case e0 e1 e2 : τ3
 | If_typed e0 e1 e2 τ :
    Γ ⊢ₙₒ e0 : TBool → Γ ⊢ₙₒ e1 : τ → Γ ⊢ₙₒ e2 : τ → Γ ⊢ₙₒ If e0 e1 e2 : τ
 | LetIn_typed e2 e1 τ1 τ2 :
    τ1 :: Γ ⊢ₙₒ e2 : τ2 → Γ ⊢ₙₒ e1 : τ1 → Γ ⊢ₙₒ LetIn e1 e2 : τ2
 | Lam_typed e τ1 τ2 :
    τ1 :: Γ ⊢ₙₒ e : τ2 → Γ ⊢ₙₒ Lam e : TArrow τ1 τ2
 (* | Fix_typed e τ : *)
    (* Γ ⊢ₙₒ e : TArrow τ τ → Γ ⊢ₙₒ Fix e : τ *)
 (* | Rec_typed e τ1 τ2 : *)
    (* TArrow τ1 τ2 :: τ1 :: Γ ⊢ₙₒ e : τ2 → Γ ⊢ₙₒ Rec e : TArrow τ1 τ2 *)
 | App_typed e1 e2 τ1 τ2 :
    Γ ⊢ₙₒ e1 : TArrow τ1 τ2 → Γ ⊢ₙₒ e2 : τ1 → Γ ⊢ₙₒ App e1 e2 : τ2
 (* | TLam_typed e τ : *)
    (* subst (ren (+1)) <$> Γ ⊢ₙₒ e : τ → Γ ⊢ₙₒ TLam e : TForall τ *)
 (* | TApp_typed e τ τ' : Γ ⊢ₙₒ e : TForall τ → Γ ⊢ₙₒ TApp e : τ.[τ'/] *)
 | Fold_typed e τ : Γ ⊢ₙₒ e : τ.[TRec τ/] → Γ ⊢ₙₒ Fold e : TRec τ
 | Unfold_typed e τ : Γ ⊢ₙₒ e : TRec τ → Γ ⊢ₙₒ Unfold e : τ.[TRec τ/]
where "Γ ⊢ₙₒ e : τ" := (typed Γ e τ%Tₙₒ).

Lemma typed_subst_invariant Γ e τ s1 s2 :
  Γ ⊢ₙₒ e : τ → (∀ x, x < length Γ → s1 x = s2 x) → e.[s1] = e.[s2].
Proof.
  intros Htyped; revert s1 s2.
  assert (∀ x Γ, x < length (subst (ren (+1)) <$> Γ) → x < length Γ).
  { intros ??. by rewrite fmap_length. }
  assert (∀ {A} `{Ids A} `{Rename A} (s1 s2 : nat → A) x,
    (x ≠ 0 → s1 (pred x) = s2 (pred x)) → up s1 x = up s2 x).
  { intros A H1 H2. rewrite /up=> s1 s2 [|x] //=; auto with f_equal lia. }
  induction Htyped => s1 s2 Hs; f_equal/=; eauto using lookup_lt_Some with lia;
  apply IHHtyped; by rewrite fmap_length.
Qed.
Lemma n_closed_invariant n (e : expr) s1 s2 :
  (∀ f, e.[upn n f] = e) → (∀ x, x < n → s1 x = s2 x) → e.[s1] = e.[s2].
Proof.
  intros Hnc. specialize (Hnc (ren (+1))).
  revert n Hnc s1 s2.
  induction e => m Hmc s1 s2 H1; asimpl in *; try f_equal;
    try (match goal with H : _ |- _ => eapply H end; eauto;
         try inversion Hmc; try match goal with H : _ |- _ => by rewrite H end;
         fail).
  - apply H1. rewrite iter_up in Hmc. destruct lt_dec; try lia.
    asimpl in *. cbv in x. replace (m + (x - m)) with x in Hmc by lia.
    inversion Hmc; lia.
  - apply (IHe0 (S m)).
    + inversion Hmc. by do 2 rewrite H2.
    + intro n. destruct n eqn:eq. by asimpl.
      intro neq. asimpl. rewrite (H1 n0). by simpl. lia.
  - unfold upn in *.
    apply (IHe (S m)).
    + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end.
    + intros [|[|x]] H2; [by cbv| |].
      asimpl; rewrite H1; auto with lia.
      asimpl; rewrite H1; auto with lia.
  (* - unfold upn in *. *)
  (*   change (e.[up (up (upn m (ren (+1))))]) with *)
  (*   (e.[iter (S (S m)) up (ren (+1))]) in *. *)
  (*   apply (IHe (S (S m))). *)
  (*   + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end. *)
  (*   + intros [|[|x]] H2; [by cbv|by cbv |]. *)
  (*     asimpl; rewrite H1; auto with lia. *)
  - change (e1.[up (upn m (ren (+1)))]) with
    (e1.[iter (S m) up (ren (+1))]) in *.
    apply (IHe0 (S m)).
    + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end.
    + intros [|x] H2; [by cbv |].
      asimpl; rewrite H1; auto with lia.
  - change (e2.[up (upn m (ren (+1)))]) with
    (e2.[upn (S m) (ren (+1))]) in *.
    apply (IHe1 (S m)).
    + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end.
    + intros [|x] H2; [by cbv |].
      asimpl; rewrite H1; auto with lia.
Qed.

Lemma n_closed_invariant_type n (e : type) s1 s2 :
  (∀ f, e.[upn n f] = e) → (∀ x, x < n → s1 x = s2 x) → e.[s1] = e.[s2].
Proof.
  intros Hnc. specialize (Hnc (ren (+1))).
  revert n Hnc s1 s2.
  induction e => m Hmc s1 s2 H1; asimpl in *; try f_equal;
    try (match goal with H : _ |- _ => eapply H end; eauto;
         try inversion Hmc; try match goal with H : _ |- _ => by rewrite H end;
         fail).
  - unfold upn in *.
    apply (IHe (S m)).
    + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end.
    + intros [|[|x]] H2; [by cbv| |].
      asimpl; rewrite H1; auto with lia.
      asimpl; rewrite H1; auto with lia.
  - apply H1. rewrite iter_up in Hmc. destruct lt_dec; try lia.
    asimpl in *. cbv in X. replace (m + (X - m)) with X in Hmc by lia.
    inversion Hmc; lia.
  (* - unfold upn in *. *)
  (*   apply (IHe (S m)). *)
  (*   + inversion Hmc; match goal with H : _ |- _ => (by rewrite H) end. *)
  (*   + intros [|[|x]] H2; [by cbv| |]. *)
  (*     asimpl; rewrite H1; auto with lia. *)
  (*     asimpl; rewrite H1; auto with lia. *)
Qed.

Lemma subst_list_cons_closed_S_n_type (t : type) (ts : list type)
        (tn : type) (Ctn : Closed_n (S (length ts)) tn) :
  tn.[subst_list_old (t :: ts)] = tn.[up (subst_list_old ts)].[t/].
Proof.
  rewrite subst_comp. apply n_closed_invariant_type with (n := S (length ts)).
  apply Ctn.
  intros x px.
  rewrite /subst_list_old.
  destruct x. by asimpl.
  asimpl. destruct (ts !! x) eqn:eq.
  - simpl. by rewrite eq.
  - assert (length ts ≤ x). by apply lookup_ge_None_1.
    lia.
Qed.

Definition env_subst (vs : list val) (x : var) : expr :=
  from_option id (Var x) (of_val <$> vs !! x).

Lemma typed_n_closed Γ τ e : Γ ⊢ₙₒ e : τ → (∀ f, e.[upn (length Γ) f] = e).
Proof.
  intros H. induction H => f; asimpl; simpl in *; auto with f_equal.
  - apply lookup_lt_Some in H. rewrite iter_up. destruct lt_dec; auto with lia.
  (* - f_equal. apply IHtyped. *)
  (* - by f_equal; rewrite map_length in IHtyped. *)
Qed.

Lemma n_closed_subst_head_simpl n e w ws :
  (∀ f, e.[upn n f] = e) →
  S (length ws) = n →
  e.[of_val w .: env_subst ws] = e.[env_subst (w :: ws)].
Proof.
  intros H1 H2.
  rewrite /env_subst. eapply n_closed_invariant; eauto=> /= -[|x] ? //=.
  destruct (lookup_lt_is_Some_2 ws x) as [v' Hv]; first lia; simpl.
  by rewrite Hv.
Qed.

Lemma typed_subst_head_simpl Δ τ e w ws :
  Δ ⊢ₙₒ e : τ → length Δ = S (length ws) →
  e.[of_val w .: env_subst ws] = e.[env_subst (w :: ws)].
Proof. eauto using n_closed_subst_head_simpl, typed_n_closed. Qed.

Lemma n_closed_subst_head_simpl_2 n e w w' ws :
  (∀ f, e.[upn n f] = e) → (S (S (length ws))) = n →
  e.[of_val w .: of_val w' .: env_subst ws] = e.[env_subst (w :: w' :: ws)].
Proof.
  intros H1 H2.
  rewrite /env_subst. eapply n_closed_invariant; eauto => /= -[|[|x]] H3 //=.
  destruct (lookup_lt_is_Some_2 ws x) as [v' Hv]; first lia; simpl.
  by rewrite Hv.
Qed.

Lemma typed_subst_head_simpl_2 Δ τ e w w' ws :
  Δ ⊢ₙₒ e : τ → length Δ = 2 + length ws →
  e.[of_val w .: of_val w' .: env_subst ws] = e.[env_subst (w :: w' :: ws)].
Proof. eauto using n_closed_subst_head_simpl_2, typed_n_closed. Qed.

Lemma n_closed_subst_head_simpl_3 n e w1 w2 w3 ws :
  (∀ f, e.[upn n f] = e) → S (S (S (length ws))) = n →
  e.[of_val w1 .: of_val w2 .: of_val w3 .: env_subst ws] =
  e.[env_subst (w1 :: w2 :: w3 :: ws)].
Proof.
  intros H1 H2.
  rewrite /env_subst. eapply n_closed_invariant; eauto => /= -[|[|[|x]]] H3 //=.
  destruct (lookup_lt_is_Some_2 ws x) as [v' Hv]; first lia; simpl.
  by rewrite Hv.
Qed.

Lemma typed_subst_head_simpl_3 Δ τ e w1 w2 w3 ws :
  Δ ⊢ₙₒ e : τ → length Δ = 3 + length ws →
  e.[of_val w1 .: of_val w2 .: of_val w3 .:env_subst ws] =
  e.[env_subst (w1 :: w2 :: w3 :: ws)].
Proof. eauto using n_closed_subst_head_simpl_3, typed_n_closed. Qed.

Lemma n_closed_subst_head_simpl_4 n e w1 w2 w3 w4 ws :
  (∀ f, e.[upn n f] = e) → S (S (S (S (length ws)))) = n →
  e.[of_val w1 .: of_val w2 .: of_val w3 .: of_val w4 .: env_subst ws] =
  e.[env_subst (w1 :: w2 :: w3 :: w4 :: ws)].
Proof.
  intros H1 H2.
  rewrite /env_subst. eapply n_closed_invariant; eauto => /= -[|[|[|[|x]]]] H3 //=.
  destruct (lookup_lt_is_Some_2 ws x) as [v' Hv]; first lia; simpl.
  by rewrite Hv.
Qed.

Lemma typed_subst_head_simpl_4 Δ τ e w1 w2 w3 w4 ws :
  Δ ⊢ₙₒ e : τ → length Δ = 4 + length ws →
  e.[of_val w1 .: of_val w2 .: of_val w3 .: of_val w4 .:env_subst ws] =
  e.[env_subst (w1 :: w2 :: w3 :: w4 :: ws)].
Proof. eauto using n_closed_subst_head_simpl_4, typed_n_closed. Qed.

Lemma empty_env_subst e : e.[env_subst []] = e.
Proof. change (env_subst []) with (@ids expr _). by asimpl. Qed.

(** Weakening *)
Lemma context_gen_weakening ξ Γ' Γ e τ :
  Γ' ++ Γ ⊢ₙₒ e : τ →
  Γ' ++ ξ ++ Γ ⊢ₙₒ e.[upn (length Γ') (ren (+ (length ξ)))] : τ.
Proof.
  intros H1.
  remember (Γ' ++ Γ) as Ξ. revert Γ' Γ ξ HeqΞ.
  induction H1 => Γ1 Γ2 ξ HeqΞ; subst; asimpl in *; eauto using typed.
  - rewrite iter_up; destruct lt_dec as [Hl | Hl].
    + constructor. rewrite lookup_app_l; trivial. by rewrite lookup_app_l in H.
    + asimpl. constructor. rewrite lookup_app_r; auto with lia.
      rewrite lookup_app_r; auto with lia.
      rewrite lookup_app_r in H; auto with lia.
      match goal with
        |- _ !! ?A = _ => by replace A with (x - length Γ1) by lia
      end.
  - econstructor; eauto. by apply (IHtyped2 (_::_)). by apply (IHtyped3 (_::_)).
  - econstructor; eauto. by apply (IHtyped1 (_::_)).
  - econstructor; eauto. by apply (IHtyped (_::_)).
  (* - constructor. by apply (IHtyped (_ :: _ :: _)). *)
  (* - constructor. *)
  (*   specialize (IHtyped *)
  (*     (subst (ren (+1)) <$> Γ1) (subst (ren (+1)) <$> Γ2) (subst (ren (+1)) <$> ξ)). *)
  (*   asimpl in *. rewrite ?map_length in IHtyped. *)
  (*   repeat rewrite fmap_app. apply IHtyped. *)
  (*   by repeat rewrite fmap_app. *)
Qed.

Lemma context_weakening ξ Γ e τ :
  Γ ⊢ₙₒ e : τ → ξ ++ Γ ⊢ₙₒ e.[(ren (+ (length ξ)))] : τ.
Proof. eapply (context_gen_weakening _ []). Qed.

Lemma typed_nil e τ : [] ⊢ₙₒ e : τ  → ∀Γ, Γ ⊢ₙₒ e : τ.
Proof.
  intros de Γ. replace Γ with (Γ ++ []) by by rewrite app_nil_r.
  replace e with e.[ren (+ (length Γ))]. by apply context_weakening.
  replace e with e.[ids] at 2 by by asimpl. eapply typed_subst_invariant.
  apply de. simpl. lia.
Qed.

Lemma context_weakening1 τ1 Γ e τ :
  Γ ⊢ₙₒ e : τ → (τ1 :: Γ) ⊢ₙₒ e.[(ren (+ 1))] : τ.
Proof. change (τ1 :: Γ) with ([τ1] ++ Γ). apply context_weakening. Qed.

Lemma context_weakening2 τ1 τ2 Γ e τ :
  Γ ⊢ₙₒ e : τ → (τ1 :: τ2 :: Γ) ⊢ₙₒ e.[(ren (+ 2))] : τ.
Proof. change (τ1 :: τ2 :: Γ) with ([τ1; τ2] ++ Γ). apply context_weakening. Qed.

Lemma context_weakening3 τ1 τ2 τ3 Γ e τ :
  Γ ⊢ₙₒ e : τ → (τ1 :: τ2 :: τ3 :: Γ) ⊢ₙₒ e.[(ren (+ 3))] : τ.
Proof. change (τ1 :: τ2 :: τ3 :: Γ) with ([τ1; τ2; τ3] ++ Γ). apply context_weakening. Qed.

Lemma context_weakening4 τ1 τ2 τ3 τ4 Γ e τ :
  Γ ⊢ₙₒ e : τ → (τ1 :: τ2 :: τ3 :: τ4 :: Γ) ⊢ₙₒ e.[(ren (+ 4))] : τ.
Proof. change (τ1 :: τ2 :: τ3 :: τ4 :: Γ) with ([τ1; τ2; τ3; τ4] ++ Γ). apply context_weakening. Qed.

Lemma context_weakening5 τ1 τ2 τ3 τ4 τ5 Γ e τ :
  Γ ⊢ₙₒ e : τ → (τ1 :: τ2 :: τ3 :: τ4 :: τ5 :: Γ) ⊢ₙₒ e.[(ren (+ 5))] : τ.
Proof. change (τ1 :: τ2 :: τ3 :: τ4 :: τ5 :: Γ) with ([τ1; τ2; τ3; τ4; τ5] ++ Γ). apply context_weakening. Qed.

Lemma context_gen_strengthening ξ Γ' Γ e τ :
  Γ' ++ ξ ++ Γ ⊢ₙₒ e.[upn (length Γ') (ren (+ (length ξ)))] : τ →
  Γ' ++ Γ ⊢ₙₒ e : τ.
Proof.
  intros Ht.
  remember (Γ' ++ ξ ++ Γ) as Ξ.
  remember e.[upn (length Γ') (ren (+length ξ))] as e'.
  revert Γ' Γ ξ HeqΞ e Heqe'.
  induction Ht => Γ1 Γ2 ξ HeqΞ t Heqe'; subst;
    (destruct t; inversion Heqe' as [Heqe'2]; subst;
     asimpl in Heqe'; eauto using typed;
     first try (rewrite iter_up in Heqe'; destruct lt_dec;
            inversion Heqe'; subst; fail)).
  - econstructor.
    rewrite iter_up in Heqe'2; destruct lt_dec; asimpl in Heqe'2.
    + inversion Heqe'2; subst. rewrite lookup_app_l; auto.
      rewrite lookup_app_l in H; auto.
    + inversion Heqe'2; subst.
      rewrite ?lookup_app_r in H; auto with lia.
      rewrite lookup_app_r; auto with lia.
      replace (length Γ1 + length ξ + (x0 - length Γ1) - length Γ1 - length ξ)
      with (x0 - length Γ1) in H; auto with lia.
  - econstructor; eauto. by eapply (IHHt2 (_::_)). by eapply (IHHt3 (_::_)).
  - econstructor; eauto. by eapply (IHHt1 (_::_)).
  - econstructor; eauto. by eapply (IHHt (_::_)).
  (* - econstructor; eauto. by eapply (IHHt (_ :: _::_)). *)
  (* - constructor. *)
  (*   specialize (IHHt *)
  (*     (subst (ren (+1)) <$> Γ1) (subst (ren (+1)) <$> Γ2) *)
  (*     (subst (ren (+1)) <$> ξ)). *)
  (*   rewrite !map_length in IHHt. *)
  (*   repeat rewrite fmap_app. apply IHHt; auto. *)
  (*   by repeat rewrite fmap_app. *)
Qed.

Lemma context_strengthening ξ Γ e τ :
  ξ ++ Γ ⊢ₙₒ e.[(ren (+ (length ξ)))] : τ → Γ ⊢ₙₒ e : τ.
Proof. eapply (context_gen_strengthening _ []). Qed.

Definition swap_list n m : list nat := (seq n m) ++ seq 0 n.

Definition lookup_n (l : list nat) i : nat :=
  match l !! i with
  | Some x => x
  | None => i
  end.

Lemma lookup_n_swap_list_out n m i :
  i ≥ n + m → lookup_n (swap_list n m) i = i.
Proof.
  rewrite /lookup_n /swap_list => Hge.
  rewrite lookup_ge_None_2; first done.
  rewrite app_length !seq_length; lia.
Qed.

Lemma lookup_n_swap_list_in n m i :
  i < n + m → lookup_n (swap_list n m) i < n + m.
Proof.
  rewrite /lookup_n /swap_list => Hge.
  edestruct (@lookup_lt_is_Some_2 nat (seq n m ++ seq 0 n) i) as [x Hx].
  { rewrite app_length !seq_length; lia. }
  rewrite Hx.
  destruct (decide (i < m)).
  - rewrite lookup_app_l in Hx; last by rewrite seq_length.
    apply lookup_seq in Hx; lia.
  - rewrite lookup_app_r in Hx; last rewrite seq_length; auto with lia.
    apply lookup_seq in Hx; lia.
Qed.

Lemma lookup_n_swap_list_r n m i :
  i < m → lookup_n (swap_list n m) i = n + i.
Proof.
  rewrite /lookup_n /swap_list => Hlt.
  rewrite lookup_app_l; last by rewrite seq_length.
  rewrite lookup_seq_lt; auto.
Qed.

Lemma lookup_n_swap_list_l n m i :
  m ≤ i → i < n + m → lookup_n (swap_list n m) i = (i - m).
Proof.
  rewrite /lookup_n /swap_list => Hle Hlt.
  rewrite lookup_app_r; last rewrite seq_length; try lia.
  rewrite lookup_seq_lt; rewrite ?seq_length; auto with lia.
Qed.

Lemma context_swap_typed Γ' ξ' ξ Γ e τ :
  Γ' ++ ξ' ++ ξ ++ Γ ⊢ₙₒ e : τ →
  Γ' ++ ξ ++ ξ' ++ Γ ⊢ₙₒ e.[upn (length Γ') (ren (lookup_n (swap_list (length ξ) (length ξ'))))] : τ.
Proof.
  intros Ht.
  remember (Γ' ++ ξ' ++ ξ ++ Γ) as Ξ. revert Γ' ξ' ξ Γ HeqΞ.
  induction Ht => Γ' ξ' ξ Γ1 HeqΞ; simpl; eauto using typed.
  - subst. rewrite iter_up; destruct lt_dec as [Hl | Hl].
    + econstructor.
      match goal with
        H : _ !! _ = Some _ |- _ => revert H
      end.
      rewrite !lookup_app_l; auto.
    + constructor. simpl. rewrite lookup_app_r; auto with lia.
      replace (length Γ' + lookup_n (swap_list (length ξ) (length ξ')) (x - length Γ') - length Γ') with
      (lookup_n (swap_list (length ξ) (length ξ')) (x - length Γ')) by lia.
      match goal with
        H : _ !! _ = Some _ |- _ =>
        rewrite lookup_app_r in H; auto with lia; rename H into Hlu
      end.
      destruct (decide ((x - length Γ') < (length ξ) + (length ξ'))).
      * rewrite app_assoc. rewrite app_assoc in Hlu.
        rewrite lookup_app_l; rewrite lookup_app_l in Hlu;
          rewrite ?app_length; eauto with lia; try apply lookup_n_swap_list_in; auto.
        destruct (decide ((x - length Γ') < (length ξ'))).
        -- rewrite lookup_n_swap_list_r; auto.
           rewrite lookup_app_r; rewrite lookup_app_l in Hlu; auto with lia.
           replace (length ξ + (x - length Γ') - length ξ) with (x - length Γ') by lia.
           done.
        -- rewrite lookup_n_swap_list_l; auto with lia.
           rewrite lookup_app_l; rewrite lookup_app_r in Hlu; auto with lia.
      * rewrite lookup_n_swap_list_out; auto with lia.
        rewrite app_assoc. rewrite app_assoc in Hlu.
        rewrite lookup_app_r; rewrite lookup_app_r in Hlu;
          rewrite ?app_length; try rewrite ?app_length in Hlu; auto with lia.
        replace (x - length Γ' - (length ξ + length ξ')) with
        (x - length Γ' - (length ξ' + length ξ)) by lia.
        done.
  - econstructor; eauto.
    + eapply (IHHt2 (_ :: _)). by simpl; f_equal.
    + eapply (IHHt3 (_ :: _)). by simpl; f_equal.
  - econstructor.
    + apply (IHHt1 (_ :: _)). by simpl; repeat f_equal.
    + apply (IHHt2). by simpl; repeat f_equal.
  - econstructor.
    + apply (IHHt (_ :: _)). by simpl; repeat f_equal.
  (* - econstructor. apply (IHHt (_ :: _ :: _)). by simpl; repeat f_equal. *)
  (* - constructor. *)
  (*   specialize (IHHt *)
  (*     (subst (ren (+1)) <$> Γ') (subst (ren (+1)) <$> ξ') *)
  (*     (subst (ren (+1)) <$> ξ) (subst (ren (+1)) <$> Γ1)). *)
  (*   asimpl in *. rewrite ?map_length in IHHt. *)
  (*   repeat rewrite fmap_app. eapply IHHt. *)
  (*   by rewrite HeqΞ; repeat rewrite fmap_app. *)
Qed.

Lemma closed_context_weakening ξ Γ e τ :
  (∀ f, e.[f] = e) → Γ ⊢ₙₒ e : τ → ξ ++ Γ ⊢ₙₒ e : τ.
Proof. intros H1 H2. erewrite <- H1. by eapply context_weakening. Qed.

Require Import Coq.Logic.FunctionalExtensionality.

Lemma ren_upn_ren n m:
  (λ x : type, x.[ren (+1)].[upn (S n) (ren (+m))]) =
  (λ x : type, x.[upn n (ren (+m))].[ren (+1)]).
Proof.
  extensionality i.
  by asimpl.
Qed.

Lemma context_gen_rename Γ e τ n m :
  Γ ⊢ₙₒ e : τ → subst (upn n (ren (+m))) <$> Γ ⊢ₙₒ
                     e : τ.[upn n (ren (+m))].
Proof.
  intros Ht. revert n m.
  induction Ht => n m; try (asimpl in *; eauto using typed; fail).
  - econstructor.
    by rewrite list_lookup_fmap H.
  - destruct op; asimpl; econstructor; eauto.
  (* - asimpl. econstructor. *)
  (*   specialize (IHHt (S n) m). *)
  (*   asimpl in *. *)
  (*   rewrite -list_fmap_compose /compose in IHHt. *)
  (*   rewrite -list_fmap_compose /compose. *)
  (*   by rewrite -ren_upn_ren. *)
  (* - specialize (IHHt n m). asimpl in IHHt. *)
  (*   replace (τ.[τ'/].[upn n (ren (+m))]) with *)
  (*   (τ.[upn (S n) (ren (+m))].[τ'.[upn n (ren (+m))]/]) by by asimpl. *)
  (*   by econstructor. *)
  - specialize (IHHt n m). asimpl in IHHt.
    econstructor.
    by asimpl in *.
  - specialize (IHHt n m). asimpl in IHHt.
    replace (τ.[TRec τ/].[upn n (ren (+m))]) with
    (τ.[upn (S n) (ren (+m))].[TRec τ.[upn (S n) (ren (+m))]/]) by by asimpl.
    by econstructor.
Qed.

Lemma context_rename Γ e τ m :
  Γ ⊢ₙₒ e : τ → subst (ren (+m)) <$> Γ ⊢ₙₒ e : τ.[ren (+m)].
Proof.
  eapply (context_gen_rename _ _ _ 0).
Qed.

Lemma typed_gen_subst Γ1 Γ2 e1 τ1 e2 τ2 :
  Γ1 ++ τ2 :: Γ2 ⊢ₙₒ e1 : τ1 →
  Γ2 ⊢ₙₒ e2 : τ2 →
  Γ1 ++ Γ2 ⊢ₙₒ e1.[upn (length Γ1) (e2 .: ids)] : τ1.
Proof.
  remember (Γ1 ++ τ2 :: Γ2) as ξ. intros Ht. revert Γ1 Γ2 e2 τ2 Heqξ.
  induction Ht => Γ1 Γ2 oe2 oτ2 Heqξ; asimpl in *; eauto using typed.
  - subst. rewrite iter_up; destruct lt_dec as [Hl | Hl].
    + econstructor.
      match goal with
        H : _ !! _ = Some _ |- _ => revert H
      end.
      rewrite !lookup_app_l; auto.
    + asimpl. remember (x - length Γ1) as n. destruct n.
       * match goal with
           H : (Γ1 ++ oτ2 :: Γ2) !! x = Some τ |- _ =>
           rewrite lookup_app_r in H; auto with lia; rewrite -Heqn in H;
             inversion H; subst
         end.
         by apply context_weakening.
       * asimpl.
         match goal with
           H : (Γ1 ++ oτ2 :: Γ2) !! x = Some τ |- _ =>
           rewrite lookup_app_r in H; auto with lia; rewrite -Heqn in H;
             inversion H; subst
         end.
         change (ids (length Γ1 + n)) with (@ids expr _ n).[ren (+(length Γ1))].
         by apply context_weakening; constructor.
  - econstructor; eauto.
    + eapply (IHHt2 (_ :: _)); eauto; by simpl; f_equal.
    + eapply (IHHt3 (_ :: _)); eauto; by simpl; f_equal.
  - econstructor; eauto.
    eapply (IHHt1 (_ :: _)); eauto; by simpl; f_equal.
  - econstructor; eauto.
    eapply (IHHt (_ :: _)); eauto; by simpl; f_equal.
  (* - econstructor. eapply (IHHt (_ :: _ :: _)); eauto; by simpl; repeat f_equal. *)
  (* - constructor. *)
  (*   specialize (IHHt *)
  (*     (subst (ren (+1)) <$> Γ1) (subst (ren (+1)) <$> Γ2)). *)
  (*   asimpl in *. rewrite ?map_length in IHHt. *)
  (*   repeat rewrite fmap_app. eapply IHHt; eauto using context_rename. *)
  (*   by rewrite Heqξ; repeat rewrite fmap_app. *)
Qed.

Lemma typed_subst Γ2 e1 τ1 e2 τ2 :
  τ2 :: Γ2 ⊢ₙₒ e1 : τ1 → Γ2 ⊢ₙₒ e2 : τ2 → Γ2 ⊢ₙₒ e1.[e2/] : τ1.
Proof. apply (typed_gen_subst []). Qed.


Ltac deex :=
  repeat match goal with
         | [ H: exists (name:_), _ |- _ ] =>
           let name' := fresh name in
           destruct H as [name' H]
         end.

Theorem example (n:nat) (Hex: exists n, n > 3) : exists n, n > 3.
Proof.
  deex.
  (* creates a fresh n0 for the witness, and preserves the hypothesis name. *)
  exists n0; assumption.
Qed.


From mm Require Import util abt.
Set Implicit Arguments.

Module Type SYNTAX_BASIS.
  Declare Module A : ABT.

  Parameter t : Type.

  Parameter var : nat -> t.

  Parameter to_abt : t -> A.t.
  Parameter of_abt : A.t -> t.

  Parameter var_to_abt : forall n, to_abt (var n) = A.var n.

  Parameter ws_to_abt : forall e, A.ws (to_abt e).
  Parameter of_to_abt : forall e, of_abt (to_abt e) = e.
  Parameter to_of_abt : forall a, A.ws a -> to_abt (of_abt a) = a.

  Parameter t_map : (nat -> nat -> t) -> nat -> t -> t.
  Parameter t_map_to_abt_comm : forall ov e c,
      to_abt (t_map ov c e) = A.t_map (fun c x => to_abt (ov c x)) c (to_abt e).

  Parameter shift : nat -> nat -> t -> t.
  Parameter shift_to_abt_comm : forall e c d, to_abt (shift c d e) = A.shift c d (to_abt e).

  Parameter subst : list t -> t -> t.
  Parameter subst_to_abt_comm : forall e rho,
      to_abt (subst rho e) = A.subst (map to_abt rho) (to_abt e).
  Parameter map_shift_to_abt_comm : forall c d rho,
      map to_abt (map (shift c d) rho) = map (A.shift c d) (map to_abt rho).

  Parameter wf : nat -> t -> Prop.
  Parameter wf_to_abt : forall e n, wf n e <-> A.wf n (to_abt e).

  Parameter identity_subst : nat -> list t.
  Parameter identity_subst_to_abt_comm : forall n, map to_abt (identity_subst n) = A.identity_subst n.
End SYNTAX_BASIS.

Module abt_util (SB : SYNTAX_BASIS).
  Include SB.

  Definition descend n rho :=
    identity_subst n ++ map (shift 0 n) rho.

  Lemma descend_to_abt_comm :
    forall n rho,
      map to_abt (descend n rho) = A.descend n (map to_abt rho).
  Proof.
    unfold descend.
    intros n rho.
    now rewrite map_app, identity_subst_to_abt_comm, map_shift_to_abt_comm.
  Qed.

  Lemma wf_of_abt :
    forall a n,
      A.ws a ->
      wf n (of_abt a) <-> A.wf n a.
  Proof.
    intros.
    pose proof wf_to_abt (of_abt a) n.
    rewrite to_of_abt in *; auto.
  Qed.

  Lemma wf_shift : forall e c d n, wf n e -> wf (d + n) (shift c d e).
  Proof.
    intros.
    rewrite wf_to_abt in *.
    rewrite shift_to_abt_comm.
    now apply A.wf_shift.
  Qed.

  Lemma wf_shift' : forall e n, wf n e -> wf (S n) (shift 0 1 e).
  Proof.
    intros e n WF.
    now apply wf_shift with (c := 0) (d := 1).
  Qed.

  Lemma wf_map_shift' :
    forall n G,
      Forall (wf n) G ->
      Forall (wf (S n)) (map (shift 0 1) G).
  Proof.
    intros n G F.
    rewrite Forall_map.
    eapply Forall_impl; [|eassumption].
    intros ty WF.
    now apply wf_shift'.
  Qed.

  Lemma map_subst_to_abt_comm :
    forall rho1 rho2,
      map to_abt (map (subst rho2) rho1) =
      map (A.subst (map to_abt rho2)) (map to_abt rho1).
  Proof.
    intros rho1 rho2.
    rewrite !map_map.
    apply map_ext.
    intros e'.
    auto using subst_to_abt_comm.
  Qed.

  Lemma wf_subst : forall e n rho, wf (length rho) e -> Forall (wf n) rho -> wf n (subst rho e).
  Proof.
    intros e n rho WF F.
    rewrite wf_to_abt in *.
    rewrite subst_to_abt_comm.
    apply A.wf_subst.
    - now rewrite map_length.
    - rewrite Forall_map.
      eapply Forall_impl; try eassumption.
      intros e' WF'.
      now rewrite <- wf_to_abt.
  Qed.

  Lemma identity_subst_length : forall n, length (identity_subst n) = n.
  Proof.
    intros.
    pose proof A.identity_subst_length n.
    rewrite <- identity_subst_to_abt_comm in *.
    now rewrite map_length in *.
  Qed.

  Lemma wf_identity_subst: forall n : nat, Forall (wf n) (identity_subst n).
  Proof.
    intros.
    pose proof A.wf_identity_subst n.
    rewrite <- identity_subst_to_abt_comm in *.
    rewrite Forall_map in *.
    eapply Forall_impl; [|eassumption].
    intros e. simpl.
    now rewrite wf_to_abt.
  Qed.

  Lemma wf_subst_id :
    forall n e1 e2,
      wf n e1 ->
      wf (S n) e2 ->
      wf n (subst (e1 :: identity_subst n) e2).
  Proof.
    intros n e1 e2 WF1 WF2.
    apply wf_subst.
    - simpl. now rewrite identity_subst_length.
    - constructor; [now auto|].
      apply wf_identity_subst.
  Qed.

  Lemma wf_weaken : forall e n d, n <= d -> wf n e -> wf d e.
  Proof.
    intros e n d LE.
    rewrite !wf_to_abt.
    eauto using A.wf_weaken.
  Qed.

  Lemma to_abt_inj :
    forall e1 e2,
      to_abt e1 = to_abt e2 -> e1 = e2.
  Proof.
    intros e1 e2.
    rewrite <- of_to_abt with (e := e1).
    rewrite <- of_to_abt with (e := e2).
    rewrite !to_of_abt by auto using ws_to_abt.
    congruence.
  Qed.

  Definition shift_onvar d := (fun c x => if x <? c then var x else var (x + d)).
  Definition shift_via_t_map (c d : nat) (e : t) : t :=
    t_map (shift_onvar d) c e.

  Lemma shift_via_t_map_is_shift :
    forall d e c,
      shift_via_t_map c d e = shift c d e.
  Proof.
    intros d e c.
    apply to_abt_inj.
    unfold shift_via_t_map.
    rewrite t_map_to_abt_comm.
    rewrite shift_to_abt_comm.
    rewrite <- A.shift_via_t_map_is_shift.
    unfold A.shift_via_t_map.
    apply A.t_map_ext.
    clear.
    intros c x.
    unfold shift_onvar, A.shift_onvar.
    destruct (_ <? _); now rewrite var_to_abt.
  Qed.

  Lemma t_map_bump :
    forall ov d e c,
      t_map ov (c + d) e = t_map (fun c x => ov (c + d) x) c e.
  Proof.
    intros ov d e c.
    apply to_abt_inj.
    rewrite !t_map_to_abt_comm.
    apply A.t_map_bump.
  Qed.

  Lemma t_map_0 :
    forall ov e c,
      t_map ov c e = t_map (fun c' x => ov (c' + c) x) 0 e.
  Proof.
    intros ov e c.
    apply t_map_bump with (c := 0).
  Qed.

  Lemma t_map_ext :
    forall ov ov',
      (forall c x, ov c x = ov' c x) ->
      forall e c,
        t_map ov c e = t_map ov' c e.
  Proof.
    intros ov ov' H e c.
    apply to_abt_inj.
    rewrite !t_map_to_abt_comm.
    apply A.t_map_ext.
    clear -H.
    intros c x.
    now rewrite H.
  Qed.

  Lemma t_map_t_map :
    forall ov1 ov2 e c1 c2,
      t_map ov2 c2 (t_map ov1 c1 e) =
      t_map (fun c x => t_map ov2 (c + c2 - c1) (ov1 c x)) c1 e.
  Proof.
    intros ov1 ov2 e c1 c2.
    apply to_abt_inj.
    rewrite !t_map_to_abt_comm.
    rewrite A.t_map_t_map.
    apply A.t_map_ext.
    clear.
    intros c x.
    now rewrite t_map_to_abt_comm.
  Qed.

  Lemma shift_merge :
    forall e c1 c2 d1 d2,
      c1 <= c2 ->
      c2 <= c1 + d1  ->
      shift c2 d2 (shift c1 d1 e) = shift c1 (d1 + d2) e.
  Proof.
    intros e c1 c2 d1 d2 LE1 LE2.
    apply to_abt_inj.
    rewrite !shift_to_abt_comm.
    now rewrite A.shift_merge.
  Qed.

  Lemma shift_merge' : forall e c d1 d2 , shift c d2 (shift c d1 e) = shift c (d2 + d1) e.
  Proof.
    intros e c d1 d2.
    apply to_abt_inj.
    rewrite !shift_to_abt_comm.
    now rewrite A.shift_merge'.
  Qed.

  Lemma shift_nop_d :
    forall e c,
      shift c 0 e = e.
  Proof.
    intros e c.
    apply to_abt_inj.
    rewrite shift_to_abt_comm.
    now rewrite A.shift_nop_d.
  Qed.

  Lemma subst_subst :
    forall e rho1 rho2,
      wf (List.length rho1) e ->
      List.Forall (wf (List.length rho2)) rho1 ->
      subst rho2 (subst rho1 e) =
      subst (List.map (subst rho2) rho1) e.
  Proof.
    intros e rho1 rho2 WF F.
    apply to_abt_inj.
    rewrite !subst_to_abt_comm.
    rewrite A.subst_subst.
    - now rewrite map_subst_to_abt_comm.
    - now rewrite map_length, <- wf_to_abt.
    - rewrite map_length, Forall_map.
        eapply Forall_impl; [|eassumption].
        intros e'.
        now rewrite wf_to_abt.
  Qed.

  Lemma subst_shift_singleton :
    forall e e',
      wf 0 e ->
      subst [e'] (shift 0 1 e) = e.
  Proof.
    intros.
    apply to_abt_inj.
    rewrite subst_to_abt_comm, shift_to_abt_comm.
    simpl.
    rewrite A.subst_shift_singleton; auto.
    now rewrite <- wf_to_abt.
  Qed.

  Lemma subst_identity :
    forall e n,
      subst (identity_subst n) e = e.
  Proof.
    intros e n.
    apply to_abt_inj.
    rewrite subst_to_abt_comm, identity_subst_to_abt_comm.
    now rewrite A.subst_identity.
  Qed.

  Lemma map_subst_identity_subst :
    forall rho,
      map (subst rho) (identity_subst (length rho))
      = rho.
  Proof.
    intros rho.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite map_subst_to_abt_comm.
    rewrite SB.identity_subst_to_abt_comm.
    replace (length rho) with (length (map to_abt rho))
      by auto using map_length.
    apply A.map_subst_identity_subst.
  Qed.

  Lemma wf_subst_inv :
    forall e n rho,
      wf n (subst rho e) ->
      wf (max n (length rho)) e.
  Proof.
    intros e n rho.
    rewrite !wf_to_abt.
    rewrite subst_to_abt_comm.
    intros WF.
    apply A.wf_subst_inv in WF.
    now rewrite map_length in WF.
  Qed.

  Lemma wf_subst_id_inv :
    forall n e1 e2,
      wf n (subst (e1 :: identity_subst n) e2) ->
      wf (S n) e2.
  Proof.
    intros n e1 e2 WF.
    apply wf_subst_inv in WF.
    simpl in *.
    rewrite identity_subst_length in *.
    now rewrite Nat.max_r in * by lia.
  Qed.

  Lemma wf_shift_inv :
    forall e c d n,
      wf n (shift c d e) ->
      wf (max c (n - d)) e.
  Proof.
    intros e c d n.
    rewrite !wf_to_abt.
    rewrite shift_to_abt_comm.
    intros WF.
    now apply A.wf_shift_inv in WF.
  Qed.

  Lemma wf_shift_inv' :
    forall e n,
      wf (S n) (shift 0 1 e) ->
      wf n e.
  Proof.
    intros e n WF.
    apply wf_shift_inv with (c := 0) (d := 1) in WF.
    simpl in *.
    now rewrite Nat.sub_0_r in *.
  Qed.

  Lemma wf_map_shift_inv' :
    forall l n,
      Forall (wf (S n)) (map (shift 0 1) l) ->
      Forall (wf n) l.
  Proof.
    intros l n F.
    rewrite Forall_map in *.
    eapply Forall_impl; [|eassumption].
    auto using wf_shift_inv'.
  Qed.

  Lemma subst_cons :
    forall e v rho,
      wf (S (length rho)) e ->
      Forall (wf 0) rho ->
      subst [v] (subst (descend 1 rho) e) =
      subst (v :: rho) e.
  Proof.
    intros e v rho WF F.
    apply to_abt_inj.
    rewrite !subst_to_abt_comm, descend_to_abt_comm.
    simpl.
    rewrite A.subst_cons; auto.
    - now rewrite map_length, <- wf_to_abt.
    - rewrite Forall_map.
      eapply Forall_impl; [|eassumption].
      intros.
      now rewrite <- wf_to_abt.
  Qed.

  Lemma descend_length :
    forall n rho,
      length (descend n rho) = n + length rho.
  Proof.
    intros n rho.
    unfold descend.
    now rewrite app_length, map_length, identity_subst_length.
  Qed.

  Lemma descend_length1 :
    forall rho,
      length (descend 1 rho) = S (length rho).
  Proof.
    intros rho.
    now rewrite descend_length.
  Qed.

  Lemma Forall_wf_to_abt :
    forall n l,
      Forall (wf n) l <-> Forall (A.wf n) (map to_abt l).
  Proof.
    intros n l.
    rewrite Forall_map.
    split; refine (@Forall_impl _ _ _ _ _); firstorder using wf_to_abt.
  Qed.

  Lemma descend_wf :
    forall n s rho,
      Forall (wf n) rho ->
      Forall (wf (s + n)) (descend s rho).
  Proof.
    intros n s rho F.
    rewrite Forall_wf_to_abt in *.
    rewrite descend_to_abt_comm.
    auto using A.descend_wf.
  Qed.

  Lemma descend_wf1 :
    forall n rho,
      Forall (wf n) rho ->
      Forall (wf (S n)) (descend 1 rho).
  Proof.
    intros n rho F.
    apply descend_wf with (s := 1).
    assumption.
  Qed.

  Lemma descend_1 :
    forall rho,
      descend 1 rho = var 0 :: map (shift 0 1) rho.
  Proof.
    intros rho.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite descend_to_abt_comm.
    simpl.
    rewrite var_to_abt.
    rewrite map_shift_to_abt_comm.
    now rewrite A.descend_1.
  Qed.

  Lemma descend_2 :
    forall rho,
      descend 2 rho = var 0 :: var 1 :: map (shift 0 2) rho.
  Proof.
    intros rho.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite descend_to_abt_comm.
    simpl.
    rewrite A.descend_2.
    rewrite !var_to_abt.
    now rewrite map_shift_to_abt_comm.
  Qed.

  Lemma shift_shift :
    forall e c1 d1 c2 d2,
      c2 <= c1 ->
      shift c2 d2 (shift c1 d1 e) =
      shift (c1 + d2) d1 (shift c2 d2 e).
  Proof.
    intros e c1 d1 c2 d2 LE.
    apply to_abt_inj.
    rewrite !shift_to_abt_comm.
    now apply A.shift_shift.
  Qed.

  Lemma shift_inj :
    forall e1 e2 c d,
      shift c d e1 = shift c d e2 ->
      e1 = e2.
  Proof.
    intros e1 e2 c d S.
    apply to_abt_inj.
    apply f_equal with (f := to_abt) in S.
    rewrite !shift_to_abt_comm in S.
    eauto using A.shift_inj.
  Qed.

  Lemma shift_shift' :
    forall c d e,
      shift 0 1 (shift c d e) = shift (S c) d (shift 0 1 e).
  Proof.
    intros c d e.
    apply to_abt_inj.
    rewrite !shift_to_abt_comm.
    apply A.shift_shift'.
  Qed.

  Lemma map_shift_map_shift' :
    forall c d l,
      map (shift 0 1) (map (shift c d) l) =
      map (shift (S c) d) (map (shift 0 1) l).
  Proof.
    intros c d l.
    rewrite !map_map.
    apply map_ext.
    auto using shift_shift'.
  Qed.

  Definition SIS d n := (map (shift 0 d) (identity_subst n)).
  Lemma SIS_to_abt_comm :
    forall d n,
      map to_abt (SIS d n) = A.SIS d n.
  Proof.
    intros d n.
    unfold SIS.
    now rewrite map_shift_to_abt_comm, identity_subst_to_abt_comm.
  Qed.

  Lemma map_shift_identity_subst_split :
    forall c d n,
      c <= n ->
      map (shift c d) (identity_subst n) =
      identity_subst c ++ SIS (c + d) (n - c).
  Proof.
    intros c d n LE.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite map_app.
    rewrite !map_shift_to_abt_comm.
    rewrite !identity_subst_to_abt_comm, SIS_to_abt_comm.
    now rewrite A.map_shift_identity_subst_split.
  Qed.

  Lemma map_shift_identity_subst' :
    forall c d,
      map (shift c d) (identity_subst c) =
      identity_subst c.
  Proof.
    intros c d.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite map_shift_to_abt_comm.
    rewrite !identity_subst_to_abt_comm.
    rewrite A.map_shift_identity_subst_split by lia.
    rewrite Nat.sub_diag.
    cbn.
    now rewrite app_nil_r.
  Qed.

  Lemma subst_shift :
    forall e rho1 rho2 rho3 n1 n2,
      wf (List.length (rho1 ++ rho3)) e ->
      List.length rho1 = n1 ->
      List.length rho2 = n2 ->
      subst (rho1 ++ rho2 ++ rho3) (shift n1 n2 e) =
      subst (rho1 ++ rho3) e.
  Proof.
    intros e rho1 rho2 rho3 n1 n2 WF En1 En2. subst n1 n2.
    apply to_abt_inj.
    rewrite !subst_to_abt_comm, shift_to_abt_comm, !map_app.
    pose proof (A.subst_shift (to_abt e) (map to_abt rho1)
                              (map to_abt rho2) (map to_abt rho3)) as H.
    rewrite !map_length in *.
    rewrite H; auto.
    apply wf_to_abt.
    now rewrite !app_length, !map_length in *.
  Qed.

  Lemma shift_subst :
    forall e c d rho,
      wf (List.length rho) e ->
      shift c d (subst rho e) =
      subst (List.map (shift c d) rho) e.
  Proof.
    intros e c d rho WF.
    apply to_abt_inj.
    rewrite shift_to_abt_comm, !subst_to_abt_comm, !map_shift_to_abt_comm.
    apply A.shift_subst.
    rewrite map_length.
    now apply wf_to_abt.
  Qed.

  Lemma identity_subst_app :
    forall n1 n2,
      identity_subst (n1 + n2) = identity_subst n1 ++ SIS n1 n2.
  Proof.
    intros n1 n2.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite map_app, !identity_subst_to_abt_comm,
           SIS_to_abt_comm.
    apply A.identity_subst_app.
  Qed.

  Lemma subst_extend_with_identity :
    forall e rho n,
      subst rho e = subst (rho ++ SIS (length rho) n) e.
  Proof.
    intros e rho n.
    apply to_abt_inj.
    rewrite !subst_to_abt_comm, map_app, SIS_to_abt_comm.
    rewrite A.subst_extend_with_identity with (n := n).
    now rewrite map_length.
  Qed.

  Lemma SIS_length :
    forall d n,
      length (SIS d n) = n.
  Proof.
    intros d n.
    rewrite <- map_length with (f := to_abt).
    rewrite SIS_to_abt_comm.
    now rewrite A.SIS_length.
  Qed.

  Lemma wf_SIS : forall d n, Forall (wf (d + n)) (SIS d n).
  Proof.
    intros d n.
    rewrite Forall_wf_to_abt.
    rewrite SIS_to_abt_comm.
    apply A.wf_SIS.
  Qed.

  Lemma SIS_merge :
    forall n c d1 d2,
      c <= d1 ->
      map (shift c d2) (SIS d1 n) = SIS (d1 + d2) n.
  Proof.
    intros n c d1 d2 LE.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite map_shift_to_abt_comm, !SIS_to_abt_comm.
    now rewrite A.SIS_merge.
  Qed.

  Lemma SIS_merge_0 :
    forall n d1 d2,
      map (shift 0 d2) (SIS d1 n) = SIS (d1 + d2) n.
  Proof.
    intros n d1 d2.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite map_shift_to_abt_comm, !SIS_to_abt_comm.
    now rewrite A.SIS_merge_0.
  Qed.

  Lemma SIS_merge' :
    forall n d,
      map (shift 0 1) (SIS d n) = SIS (S d) n.
  Proof.
    intros n d.
    rewrite SIS_merge_0.
    now rewrite Nat.add_1_r.
  Qed.

  Lemma SIS_0 : forall n, SIS 0 n = identity_subst n.
  Proof.
    intros n.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite SIS_to_abt_comm, identity_subst_to_abt_comm.
    now rewrite A.SIS_0.
  Qed.

  Lemma SIS_app :
    forall n1 n2 d,
      SIS d (n1 + n2) = SIS d n1 ++ SIS (n1 + d) n2.
  Proof.
    intros n1 n2 d.
    apply map_inj with (f := to_abt).
    apply to_abt_inj.
    rewrite map_app, !SIS_to_abt_comm.
    now rewrite A.SIS_app.
  Qed.

  Lemma subst_shift_cons_identity_subst :
    forall c d n e1 e2,
      c <= n ->
      wf (S n) e2 ->
      subst (shift c d e1 :: identity_subst (d + n)) (shift (S c) d e2) =
      subst (shift c d e1 :: map (shift c d) (identity_subst n)) e2.
  Proof.
    intros c d n e1 e2 LE WF.

    replace (d + n) with (c + (d + (n - c))) by lia.
    rewrite identity_subst_app.
    rewrite SIS_app.
    rewrite app_comm_cons.
    rewrite subst_shift; simpl;
      [| | auto using f_equal, identity_subst_length | auto using SIS_length].
    + rewrite map_shift_identity_subst_split by assumption.
      now rewrite Nat.add_comm.
    + rewrite app_length, identity_subst_length, SIS_length.
      now replace (c + (n - c)) with n by lia.
  Qed.

  Lemma wf_cons :
    forall n e l,
      wf (S n) e ->
      Forall (wf n) l ->
      Forall (wf (S n)) (e :: map (shift 0 1) l).
  Proof.
    auto using wf_map_shift'.
  Qed.

  Lemma subst_shift_cons :
    forall e e' g,
      wf (length g) e ->
      subst (e' :: g) (shift 0 1 e) = subst g e.
  Proof.
    intros.
    pose proof @subst_shift e [] [e'] g.
    auto.
  Qed.

  Lemma subst_shift_app :
    forall e g1 g2 n1,
      wf (length g2) e ->
      length g1 = n1 ->
      subst (g1 ++ g2) (shift 0 n1 e) = subst g2 e.
  Proof.
    intros e g1 g2 n1 WF L. subst n1.
    pose proof @subst_shift e [] g1 g2.
    auto.
  Qed.

  Lemma subst_descend_shift :
    forall n rho e,
      wf (length rho) e ->
      subst (descend n rho) (shift 0 n e) =
      subst (map (shift 0 n) rho) e.
  Proof.
    intros n rho e WF.
    unfold descend.
    rewrite subst_shift_app.
    - reflexivity.
    - now rewrite map_length.
    - now rewrite identity_subst_length.
  Qed.

  Lemma subst_descend_shift_shift_subst :
    forall n rho e,
      wf (length rho) e ->
      subst (descend n rho) (shift 0 n e) =
      shift 0 n (subst rho e).
  Proof.
    intros n rho e WF.
    now rewrite subst_descend_shift, shift_subst by assumption.
  Qed.

  Lemma subst_cons_shift_shift_subst_1 :
    forall rho e,
      wf (length rho) e ->
      subst (var 0 :: map (shift 0 1) rho) (shift 0 1 e) =
      shift 0 1 (subst rho e).
  Proof.
    intros.
    rewrite <- subst_descend_shift_shift_subst by assumption.
    f_equal.
    unfold descend.
    replace (identity_subst 1) with [var 0].
    reflexivity.
    apply map_inj with (f := to_abt); [now apply to_abt_inj|].
    cbn.
    now rewrite identity_subst_to_abt_comm, var_to_abt.
  Qed.

  Lemma subst_cons_identity_subst_shift_1 :
    forall n e1 e2,
      wf n e1 ->
      subst (e2 :: identity_subst n) (shift 0 1 e1) = e1.
  Proof.
    intros n e1 e2 WF.
    rewrite subst_shift_cons.
    apply subst_identity.
    rewrite identity_subst_length.
    assumption.
  Qed.

  Lemma map_subst_cons_identity_subst_shift_1 :
    forall e n g,
      Forall (wf n) g ->
      map (fun x => subst (e :: identity_subst n) (shift 0 1 x)) g =
      map (subst g) (identity_subst (length g)).
  Proof.
    intros e n g F.
    rewrite map_subst_identity_subst.
    rewrite map_ext_Forall with (g := fun x => x); [ now rewrite map_id |].
    eauto using Forall_impl, subst_cons_identity_subst_shift_1.
  Qed.
End abt_util.