From isla Require Import opsem.

Definition a1827c : isla_trace :=
  Smt (DeclareConst 38%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R5" [] (RegVal_Base (Val_Symbolic 38%Z)) Mk_annot :t:
  Smt (DefineConst 61%Z (Manyop (Bvmanyarith Bvadd) [Unop (Extract 63%N 0%N) (Unop (ZeroExtend 64%N) (Val (Val_Symbolic 38%Z) Mk_annot) Mk_annot) Mk_annot; Val (Val_Bits (BV 64%N 0x798%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R5" [] (RegVal_Base (Val_Symbolic 61%Z)) Mk_annot :t:
  Smt (DeclareConst 62%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 62%Z)) Mk_annot :t:
  Smt (DefineConst 63%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 62%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 63%Z)) Mk_annot :t:
  tnil
.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Blech.Reflect.

Import CategoryNotations.
Import FunctorNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
 Definition id A: Functor A A :=
{|
  op x := x ;
  map _ _ x := x ;
|}.

Next Obligation.
Proof.
  exists.
  - intros.
    reflexivity.
  - intros.
    reflexivity.
  - intros ? ? ? ? p.
    auto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8synthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus lv0 lv1)) (plus lv1 (Succ lv0))).
Admitted.
QuickChick conj8synthconj6.


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 O E Eprime A : Universe, ((wd_ O Eprime /\ (wd_ O A /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (col_ O E A /\ (col_ O E O /\ (col_ O E A /\ (col_ O Eprime A /\ (col_ O O A /\ col_ Eprime O A)))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 D T B C : Universe, ((wd_ A D /\ (wd_ D T /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ B D /\ (wd_ C D /\ (wd_ C T /\ (wd_ B T /\ (wd_ A T /\ (col_ B D C /\ (col_ A D T /\ col_ A C T)))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(***
Modulus : 2^205 - 45*2^198 - 1
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 7%nat;
    base := 32;
    bitwidth := 32;
    s := 2^205;
    c := [(1, 1); (45, 2^198)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    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.


Require Import vcfloat.VCFloat.

Section NAN.
Variable NAN: Nans.

Definition BFMA {NAN: Nans} {t: type} : forall (x y z: ftype t), ftype t :=
    Binary.Bfma (fprec t) (femax t) (fprec_gt_0 t)
      (fprec_lt_femax t) (fma_nan t) BinarySingleNaN.mode_NE.

End NAN.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Coq.Program.Equality.
Require Import Logic.FunctionalExtensionality.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import seq ssreflect ssrbool ssrnat eqtype.

Require Import FinProof.Common.
Require Import FinProof.MonadTransformers21.
Require Import FinProof.Common.
Require Import FinProof.StateMonad21.
Require Import FinProof.StateMonad21Instances.
Require Import FinProof.Types.IsoTypes.

Require Import UMLang.UrsusLib.

Require Import UrsusStdLib.Cpp.stdTypes.

Require Import UrsusTVM.Cpp.tvmTypes.
Require Import UrsusTVM.Cpp.tvmFunc.
Require Import UrsusTVM.Cpp.tvmNotations.
Require Import UrsusTVM.Cpp.tvmCells.

Require Import Project.CommonQCEnvironment.

(*Fully qualified name are mandatory in multi-contract environment*)
Require Import Contracts.FromGiver.DFromGiver.Ledger.

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
Set Warnings "-extraction-opaque-accessed,-extraction".

Local Open  Scope N_scope.

Definition LedgerDefault : LedgerLRecord  := Eval compute in default.

#[local]
Remove Hints isoid : typeclass_instances.
#[local]
Remove Hints iso_show : typeclass_instances.
#[local]
Remove Hints iso_shrink : typeclass_instances.
#[local]
Remove Hints iso_genSized : typeclass_instances.

(* ContractLRecord *)

#[global]
Instance Contract_Show: Show ContractLRecord.
refine Showprod.
Defined.

#[global]
Instance Contract_Shrink: Shrink ContractLRecord.
refine Shrinkprod.
Defined.

#[global]
Instance Contract_GenSized: GenSized ContractLRecord.
refine GenSizedprod.
Defined.

(*MessagesAndEvents*)

#[global]
Instance MessagesAndEvents_Show: Show MessagesAndEventsLRecord.
refine Showxprod.
Defined.

#[global]
Instance MessagesAndEvents_Shrink: Shrink MessagesAndEventsLRecord.
refine Shrinkxprod.
Defined.

#[global]
Instance MessagesAndEvents_GenSized: GenSized MessagesAndEventsLRecord.
refine GenSizedxprod.
Defined.

(*LocalState*)

#[global]
Instance LocalState_Show: Show LocalStateLRecord.
refine Showxprod.
Defined.

#[global]
Instance LocalState_Shrink: Shrink LocalStateLRecord.
refine Shrinkxprod.
Defined.

#[global]
Instance LocalState_GenSized: GenSized LocalStateLRecord.
refine GenSizedxprod.
Defined.

(*Ledger*)

#[global]
Instance Ledger_Show: Show LedgerLRecord | 0.
refine Showxprod.
Defined.

#[global]
Instance Ledger_Shrink: Shrink LedgerLRecord  | 0.
refine Shrinkxprod.
Defined.

#[global]
Instance Ledger_GenSized: GenSized LedgerLRecord | 0 .
refine GenSizedxprod.
Defined.

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

#[global] Instance LedgerEq_Dec: forall (l1 l2: LedgerLRecord), Dec (l1 = l2).
intros.
esplit.
unfold decidable.
repeat decide equality.
Defined.

#[global] Instance ContractEq_Dec: forall (l1 l2: ContractLRecord), Dec (l1 = l2).
intros.
esplit.
unfold decidable.
repeat decide equality.
Defined.


Require Import Metalib.Metatheory.
Require Import Coq.Lists.List.
Require Import Coq.Program.Equality.
Require Import Coq.Sorting.Permutation.
Require Import Linear.Language.
Require Import Linear.Environment.
Require Import Linear.Infrastructure.
Require Import Linear.Data.AssocList.
Require Import Linear.Data.Subsequence.
Require Import Linear.Data.Permutation.

Set Implicit Arguments.

(* Basic Properties of Typing Relation *)

Lemma typing_uniq : forall U1 L1 e1 T1,
    typing U1 L1 e1 T1 ->
    uniq (U1 ++ L1).
Proof.
  intros U1 L1 e1 T1 H1; induction H1;
    try match goal with
        | [ H1 : well_formed_cont _ _ _ |- _ ] => inversion H1; subst
        end; simpl_env; auto.
  - pose proof (split_cont_dom H).
    destruct (split_cont_uniq H) as [? [? ?]]. solve_uniq.
  - pose proof (split_cont_dom H).
    destruct (split_cont_uniq H) as [? [? ?]]. solve_uniq.
Qed.

Lemma typing_disjoint : forall U1 L1 e1 T1,
    typing U1 L1 e1 T1 ->
    disjoint U1 L1.
Proof.
  intros U1 L1 e1 T1 H1.
  apply typing_uniq in H1. solve_uniq.
Qed.

Lemma typing_exact_un : forall U1 L1 e1 T1,
    typing U1 L1 e1 T1 ->
    qual_cont_exact U U1.
Proof.
  intros U1 L1 e1 T1 H1; induction H1;
    try match goal with
        | [ H1 : well_formed_cont _ _ _ |- _ ] => inversion H1; subst
        end; auto.
  - eapply qual_cont_exact_permute.
    + eapply Permutation_middle.
    + constructor; auto.
Qed.

Lemma typing_exact_lin : forall U1 L1 e1 T1,
    typing U1 L1 e1 T1 ->
    qual_cont_exact L L1.
Proof.
  intros U1 L1 e1 T1 H1; induction H1;
    try match goal with
        | [ H1 : well_formed_cont _ _ _ |- _ ] => inversion H1; subst
        end; simpl; auto.
  - repeat constructor.
  - destruct (split_cont_exact_lin H) as [? ?]. auto.
  - destruct (split_cont_exact_lin H) as [? ?]. auto.
Qed.

(* Typing Relation Satisfies Exchange *)

Hint Resolve qual_cont_exact_permute      : permutation.
Hint Resolve well_formed_cont_permute_un  : permutation.
Hint Resolve well_formed_cont_permute_lin : permutation.

Theorem typing_exchange_un : forall U1 U2 L1 e1 T1,
    Permutation U1 U2 ->
    typing U1 L1 e1 T1 ->
    typing U2 L1 e1 T1.
Proof.
  intros U1 U2 L1 e1 T1 H1 H2.
  generalize dependent U2; induction H2; intros U3 H2;
    try solve [econstructor; eauto 2 with permutation].
  - apply permute_exists_mid in H2 as [U4 [H3 [H4 H5]]];
      subst; constructor; eauto with permutation.
  - apply typing_abs_un with (A1 := A1).
    + eauto with permutation.
    + intros x1 H3. eapply H1; [| constructor]; eauto.
Qed.

Theorem typing_exchange_lin : forall U1 L1 L2 e1 T1,
    Permutation L1 L2 ->
    typing U1 L1 e1 T1 ->
    typing U1 L2 e1 T1.
Proof.
  intros U1 L1 L2 e1 T1 H1 H2.
  generalize dependent L2; induction H2; intros L4 H2;
  try solve [rewrite (Permutation_nil H2); eauto];
  try solve [apply (split_cont_permute H2) in H as [L5 [L6 [? [? ?]]]]; eauto].
  - rewrite (Permutation_length_1_inv H2). constructor; eauto.
  - apply typing_abs_un with (A1 := A1).
    + eauto with permutation.
    + intros x1 H3. eapply H1; eauto.
  - apply typing_abs_lin with (A1 := A1).
    + eauto with permutation.
    + intros x1 H3. eapply H1; [| constructor]; eauto.
Qed.

(* Typing Relation Satisfies Unrestricted Weakening *)

Theorem typing_weaken_un : forall F1 U1 L1 e1 T1,
  qual_cont_exact U F1 ->
  uniq (F1 ++ U1 ++ L1) ->
  typing U1 L1 e1 T1 ->
  typing (F1 ++ U1) L1 e1 T1.
Proof.
  intros F1 U1 L1 e1 T1 H1 H2 H3.
  generalize dependent F1; induction H3; intros F1 H2 H3.
  - rewrite_env ((F1 ++ U1) ++ (x1 ~ un P1) ++ U2).
    inversion H. subst. constructor; [| solve_uniq].
    rewrite_env (F1 ++ (U1 ++ U2)).
    apply well_formed_cont_weaken_un_left; solve_uniq.
  - inversion H. subst. constructor; [| solve_uniq].
    apply well_formed_cont_weaken_un_left; solve_uniq.
  - inversion H. subst. constructor.
    apply well_formed_cont_weaken_un_left; solve_uniq.
  - rewrite_env ((F1 ++ U1) ++ L1) in H3.
    pose proof (split_cont_uniq_app_left _ H H3) as H4.
    pose proof (split_cont_uniq_app_right _ H H3) as H5.
    simpl_env in H4. simpl_env in H5. eauto.
  - rewrite_env ((F1 ++ U1) ++ L1) in H3.
    pose proof (split_cont_uniq_app_left _ H H3) as H4.
    pose proof (split_cont_uniq_app_right _ H H3) as H5.
    simpl_env in H4. simpl_env in H5. eauto.
  - apply typing_abs_un with (A1 := union A1 (dom (F1 ++ U1 ++ L1))).
    + eapply well_formed_cont_weaken_un_left; eauto.
    + intros x1 H4. eapply typing_exchange_un.
      * simpl. symmetry. apply Permutation_middle.
      * apply H1; auto. simpl_env. solve_uniq.
  - apply typing_abs_lin with (A1 := union A1 (dom (F1 ++ U1 ++ L1))).
    + eapply well_formed_cont_weaken_un_left; eauto.
    + intros x1 H4. eapply H1; auto. solve_uniq.
Qed.

Theorem typing_weaken_un_mid : forall F1 U1 U2 L1 e1 T1,
    qual_cont_exact U F1 ->
    uniq (U1 ++ F1 ++ U2 ++ L1) ->
    typing (U1 ++ U2) L1 e1 T1 ->
    typing (U1 ++ F1 ++ U2) L1 e1 T1.
Proof.
  intros F1 U1 U2 L1 e1 T1 H1 H2 H3.
  rewrite_env ((U1 ++ F1) ++ U2).
  eapply typing_exchange_un.
  + apply Permutation_app_tail.
    apply Permutation_app_comm.
  + simpl_env. eapply typing_weaken_un; solve_uniq.
Qed.

Lemma subcont_permute : forall {A : Type} (E1 E2 : list (atom * A)),
    uniq E1 ->
    uniq E2 ->
    submap E1 E2 ->
    exists E3, Permutation E2 (E3 ++ E1).
Proof.
  intros A E1 E2 H1 H2 H3. generalize dependent E2.
  induction E1 as [| [x1 T1] E1 IH]; intros E2 H2 H3.
  - exists E2. simpl_env. auto.
  - assert (H4 : binds x1 T1 ((x1 ~ T1) ++ E1)) by auto.
    apply H3 in H4. apply binds_inv in H4 as [E4 [E5 H5]]; subst.
    assert (H5 : submap E1 (E4 ++ E5)). intros x2 T2 H4.
    assert (H6 : binds x2 T2 ((x1 ~ T1) ++ E1)) by auto.
    apply H3 in H6. apply binds_remove_mid in H6. auto. intros H7.
    inversion H1. subst. eapply binds_dom_contradiction; eauto.
    inversion H1. subst. assert (H8 : uniq (E4 ++ E5)) by solve_uniq.
    destruct (IH H4 _ H8 H5) as [E6 H9]. exists E6. simpl.
    repeat rewrite <- Permutation_middle. auto.
Qed.

Theorem typing_weaken_un_subcont : forall U1 U2 L1 e1 T1,
    subcont U1 U2 ->
    qual_cont_exact U U2 ->
    uniq (U2 ++ L1) ->
    typing U1 L1 e1 T1 ->
    typing U2 L1 e1 T1.
Proof.
  intros U1 U2 L1 e1 T1 H1 H2 H3 H4.
  pose proof (typing_uniq H4) as H5.
  apply uniq_app_iff in H3 as [H6 [H7 H8]].
  apply uniq_app_iff in H5 as [H9 [H10 H11]].
  apply subcont_permute in H1 as [U3 H12]; auto.
  apply (typing_exchange_un (Permutation_sym H12)).
  apply typing_weaken_un; auto.
  - apply (qual_cont_exact_permute H12) in H2.
    apply qual_cont_exact_app_inv in H2 as [H2 H13]. auto.
  - rewrite_env ((U3 ++ U1) ++ L1). eapply uniq_permute.
    + rewrite <- H12. reflexivity.
    + apply uniq_app_iff. repeat split; auto.
Qed.

Theorem typing_weaken_un_subseq : forall U1 U2 L1 e1 T1,
    subsequence U1 U2 ->
    qual_cont_exact U U2 ->
    uniq (U2 ++ L1) ->
    typing U1 L1 e1 T1 ->
    typing U2 L1 e1 T1.
Proof.
  intros U1 U2 L1 e1 T1 H1 H2 H3 H4.
  apply subseq_submap in H1.
  eapply typing_weaken_un_subcont; eauto.
Qed.

(* Typing Relation Satisfies Unrestricted Strengthening *)

Theorem typing_strengthen_un_mid : forall U1 U2 L1 e1 T1 x1 P1,
    x1 `notin` free_vars e1 ->
    typing (U1 ++ (x1 ~ un P1) ++ U2) L1 e1 T1 ->
    typing (U1 ++ U2) L1 e1 T1.
Proof.
  intros U1 U2 L1 e1 T1 x1 P1 H1 H2.
  dependent induction H2; try rename x into H3.
  - simpl in H1. inversion H; subst.
    assert (H5 : x0 <> x1) by auto.
    assert (H6 : uniq (U0 ++ (x0 ~ un P0) ++ U3)) by solve_uniq.
    destruct (assoc_equate_split_uniq _ _ _ _ _ _ H5 H6 H3) as [F1 [F2 [? | ?]]].
    + subst. simpl_env. repeat constructor.
      -- rewrite H3 in H6. solve_uniq.
      -- assert (H7 : qual_cont_exact U (U0 ++ (x0 ~ un P0) ++ U3)).
         eapply qual_cont_exact_weaken_mid; [constructor |]; auto.
         rewrite H3 in H7. apply qual_cont_exact_app_inv in H7 as [H7 H8].
         rewrite_env ((F1 ++ F2) ++ U2). apply qual_cont_exact_weaken_left.
         ++ eapply qual_cont_exact_strengthen_mid; eauto.
         ++ eapply qual_cont_exact_strengthen_left; eauto.
      -- rewrite H3 in H6. solve_uniq.
    + subst. rewrite_env ((U1 ++ F1) ++ (x0 ~ un P0) ++ F2). repeat constructor.
      -- rewrite H3 in H6. solve_uniq.
      -- assert (H7 : qual_cont_exact U (U0 ++ (x0 ~ un P0) ++ U3)).
         eapply qual_cont_exact_weaken_mid; [constructor |]; auto.
         simpl_env. rewrite H3 in H7. rewrite app_assoc in H7.
         apply qual_cont_exact_app_inv in H7 as [H7 H8].
         apply qual_cont_exact_weaken_left.
         ++ eapply qual_cont_exact_strengthen_left.
            eapply qual_cont_exact_permute.
            eapply Permutation_app_comm. eauto.
         ++ eapply qual_cont_exact_strengthen_mid; eauto.
      -- rewrite H3 in H6. solve_uniq.
  - constructor; eauto using well_formed_cont_strengthen_un_mid.
  - constructor; eauto using well_formed_cont_strengthen_un_mid.
  - simpl in H1. econstructor; eauto.
  - simpl in H1. econstructor; eauto.
  - pick fresh z1 and apply typing_abs_un.
    + eapply well_formed_cont_strengthen_un_mid; eauto.
    + rewrite_env (((z1 ~ un P0) ++ U1) ++ U2).
      eapply H2 with (x3 := x1); simpl; eauto.
      eapply free_vars_notin_open; eauto.
  - pick fresh z1 and apply typing_abs_lin.
    + eapply well_formed_cont_strengthen_un_mid; eauto.
    + eapply H2 with (x3 := x1); simpl; auto.
      eapply free_vars_notin_open; eauto.
Qed.

Theorem typing_strengthen_un_left : forall U1 L1 e1 T1 x1 P1,
    x1 `notin` free_vars e1 ->
    typing ((x1 ~ un P1) ++ U1) L1 e1 T1 ->
    typing U1 L1 e1 T1.
Proof.
  intros U1 L1 e1 T1 x1 P1 H1 H2.
  rewrite_env (nil ++ U1).
  eapply typing_strengthen_un_mid; eauto.
Qed.

(* Typing Relation Satisfies Unrestricted Contraction *)

Theorem typing_contract_un_mid : forall U1 U2 L1 x1 x2 x3 e1 P1 T1,
    x3 `notin` dom (U1 ++ U2 ++ L1) ->
    typing (U1 ++ (x1 ~ un P1) ++ (x2 ~ un P1) ++ U2) L1 e1 T1 ->
    typing (U1 ++ (x3 ~ un P1) ++ U2) L1 ([x2 ~> x3] ([x1 ~> x3] e1)) T1.
Proof.
  intros U1 U2 L1 x1 x2 x3 e1 P1 T1 H1 H2.
  dependent induction H2; simpl.
  - rename x into H2. inversion H. subst. destruct_eq_decs.
    + apply assoc_equate_uniq in H2 as [H6 [H7 H8]]; [| solve_uniq].
      inversion H7. subst. constructor; eauto. simpl_env in H.
      eapply well_formed_cont_strengthen_un_mid; eauto.
    + apply assoc_equate_uniq in H2 as [H6 [H7 H8]]; [| solve_uniq].
      inversion H7. subst. constructor; eauto. simpl_env in H.
      eapply well_formed_cont_strengthen_un_mid; eauto.
    + rewrite_env ((U1 ++ (x1 ~ un P1)) ++ (x0 ~ un P1) ++ U2) in H2.
      apply assoc_equate_uniq in H2 as [H6 [H7 H8]]; [| solve_uniq].
      inversion H7. subst. constructor; eauto. simpl_env in H.
      eapply well_formed_cont_strengthen_un_mid; eauto.
    + assert (H5 : x0 <> x1) by auto.
      assert (H6 : uniq (U0 ++ (x0 ~ un P0) ++ U3)) by solve_uniq.
      destruct (assoc_equate_split_uniq _ _ _ _ _ _ H5 H6 H2) as [F1 [F2 [? | ?]]]; subst.
      * simpl_env. repeat constructor.
        -- simpl in H6. rewrite H2 in H6. solve_uniq.
        -- assert (H7 : qual_cont_exact U (x0 ~ un P0)) by (constructor; auto).
           pose proof (qual_cont_exact_weaken_mid _ _ H7 H4) as H8. simpl in H8.
           rewrite H2 in H8. apply qual_cont_exact_app_inv in H8 as [H8 H9].
           rewrite_env ((F1 ++ F2) ++ ((x3 ~ un P1) ++ U2)).
           apply qual_cont_exact_weaken_left.
           ++ eapply qual_cont_exact_strengthen_mid; eauto.
           ++ inversion H9. inversion H12. constructor; auto.
        -- simpl in H6. rewrite H2 in H6. solve_uniq.
      * apply cons_eq_app in H7 as [[F3 [? ?]] | [? ?]]; subst.
        -- rewrite_env ((U1 ++ (x3 ~ un P1) ++ F3) ++ (x0 ~ un P0) ++ F2).
           repeat constructor.
           ++ simpl in H6. rewrite H2 in H6. solve_uniq.
           ++ assert (H7 : qual_cont_exact U (x0 ~ un P0)) by (constructor; auto).
              pose proof (qual_cont_exact_weaken_mid _ _ H7 H4) as H8. simpl in H8.
              rewrite_env ((U1 ++ (x1 ~ un P1) ++ (x2 ~ un P1)) ++ (F3 ++ (x0 ~ un P0) ++ F2)) in H2.
              rewrite H2 in H8. apply qual_cont_exact_app_inv in H8 as [H8 H9].
              rewrite_env ((U1 ++ (x3 ~ un P1)) ++ (F3 ++ F2)).
              apply qual_cont_exact_weaken_left.
              ** apply qual_cont_exact_comm.
                 apply qual_cont_exact_comm in H8.
                 inversion H8. inversion H12. constructor; auto.
              ** eapply qual_cont_exact_strengthen_mid; eauto.
           ++ simpl in H6. rewrite H2 in H6. solve_uniq.
        -- inversion H8. congruence.
  - destruct_eq_decs; try solve [analyze_binds H0].
    inversion H; subst. repeat constructor.
    + solve_uniq.
    + rewrite_env (U1 ++ ((x1 ~ un P1) ++ (x2 ~ un P1)) ++ U2) in H3.
      simpl_env. eapply qual_cont_exact_replace_mid; [constructor |]; eauto.
    + solve_uniq.
  - inversion H. subst. repeat constructor.
    + solve_uniq.
    + rewrite_env (U1 ++ ((x1 ~ un P1) ++ (x2 ~ un P1)) ++ U2) in H2.
      simpl_env. eapply qual_cont_exact_replace_mid; [constructor |]; eauto.
  - repeat rewrite dom_app in H1. rewrite (split_cont_dom H) in H1.
    econstructor; eauto.
    + eapply IHtyping1; solve_uniq.
    + eapply IHtyping2; solve_uniq.
    + eapply IHtyping3; solve_uniq.
  - repeat rewrite dom_app in H1. rewrite (split_cont_dom H) in H1.
    econstructor; eauto.
    + eapply IHtyping1; solve_uniq.
    + eapply IHtyping2; solve_uniq.
  - pick fresh z1 and apply typing_abs_un.
    + rewrite_env (U1 ++ ((x1 ~ un P1) ++ (x2 ~ un P1)) ++ U2) in H.
      inversion H; subst; constructor; simpl_env; auto.
      * solve_uniq.
      * eapply qual_cont_exact_replace_mid; [constructor |]; eauto.
      * solve_uniq.
      * eapply qual_cont_exact_replace_mid; [constructor |]; eauto.
    + rewrite_env (((z1 ~ un P0) ++ U1) ++ (x3 ~ un P1) ++ U2).
      repeat rewrite subst_open_var; eauto.
  - pick fresh z1 and apply typing_abs_lin.
    + rewrite_env (U1 ++ ((x1 ~ un P1) ++ (x2 ~ un P1)) ++ U2) in H.
      inversion H; subst; constructor; simpl_env; auto.
      * solve_uniq.
      * eapply qual_cont_exact_replace_mid; [constructor |]; eauto.
      * solve_uniq.
      * eapply qual_cont_exact_replace_mid; [constructor |]; eauto.
    + simpl_env. repeat rewrite subst_open_var; eauto.
Qed.

Theorem typing_contract_un_left : forall U1 L1 x1 x2 x3 e1 P1 T1,
    x3 `notin` dom (U1 ++ L1) ->
    typing ((x1 ~ un P1) ++ (x2 ~ un P1) ++ U1) L1 e1 T1 ->
    typing ((x3 ~ un P1) ++ U1) L1 ([x2 ~> x3] ([x1 ~> x3] e1)) T1.
Proof.
  intros U1 L1 x1 x2 x3 e1 P1 T1 H1 H2.
  rewrite_env (nil ++ (x3 ~ un P1) ++ U1).
  rewrite_env (nil ++ ((x1 ~ un P1) ++ (x2 ~ un P1)) ++ U1) in H2.
  eapply typing_contract_un_mid; eauto.
Qed.


From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening GenericTyping LogicalRelation.

Set Primitive Projections.
Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.

Create HintDb substitution.
#[global] Hint Constants Opaque : substitution.
#[global] Hint Variables Transparent : substitution.
Ltac substitution := eauto with substitution.

(* The type of our inductively defined validity relation:
  for some R : VRel, R Γ eqSubst says
  that according to R, Γ is valid and the associated substitution validity and equality
  are validSubst and eqSubst.
  One should think of VRel as a functional relation taking one argument Γ and returning
  2 outputs validSubst and eqSubst *)

  Definition VRel@{i j | i < j +} `{ta : tag} `{!WfContext ta} :=
  forall
    (Γ : context)
    (validSubst : forall (Δ : context) (σ : nat -> term) (wfΔ : [|- Δ]), Type@{i})
    (eqSubst : forall (Δ : context) (σ σ' : nat -> term) (wfΔ : [|- Δ ]), validSubst Δ σ wfΔ -> Type@{i})
    , Type@{j}.

(* A VPack contains the data corresponding to the codomain of VRel seen as a functional relation *)

Module VPack.

  Record VPack@{i} `{ta : tag} `{!WfContext ta} {Γ : context} :=
  {
    validSubst : forall (Δ : context) (σ : nat -> term) (wfΔ : [|- Δ]), Type@{i} ;
    eqSubst : forall (Δ : context) (σ σ' : nat -> term) (wfΔ : [|- Δ ]), validSubst Δ σ wfΔ -> Type@{i} ;
  }.

  Arguments VPack : clear implicits.
  Arguments VPack {_ _}.
  Arguments Build_VPack {_ _}.
End VPack.

Export VPack(VPack,Build_VPack).

Notation "[ P | Δ ||-v σ : Γ | wfΔ ]" := (@VPack.validSubst _ _ Γ P Δ σ wfΔ) (at level 0, P, Δ, σ, Γ, wfΔ at level 50).
Notation "[ P | Δ ||-v σ ≅ σ' : Γ | wfΔ | vσ ]" := (@VPack.eqSubst _ _ Γ P Δ σ σ' wfΔ vσ) (at level 0, P, Δ, σ, σ', Γ, wfΔ, vσ at level 50).

(* An VPack it adequate wrt. a VRel when its three unpacked components are *)
#[universes(polymorphic)] Definition VPackAdequate@{i j} `{ta : tag} `{!WfContext ta} {Γ : context}
  (R : VRel@{i j}) (P : VPack@{i} Γ) : Type@{j} :=
  R Γ P.(VPack.validSubst) P.(VPack.eqSubst).

Arguments VPackAdequate _ _ /.

Module VAd.

  Record > VAdequate `{ta : tag} `{!WfContext ta} {Γ : context} {R : VRel} :=
  {
    pack :> VPack Γ ;
    adequate :> VPackAdequate R pack
  }.

  Arguments VAdequate : clear implicits.
  Arguments VAdequate {_ _}.
  Arguments Build_VAdequate {_ _ _ _}.

End VAd.

Export VAd(VAdequate,Build_VAdequate).
(* These coercions would be defined using the >/:> syntax in the definition of the record,
  but this fails here due to the module being only partially exported *)
Coercion VAd.pack : VAdequate >-> VPack.
Coercion VAd.adequate : VAdequate >-> VPackAdequate.

Notation "[ R | ||-v Γ ]"                            := (VAdequate Γ R) (at level 0, R, Γ at level 50).
Notation "[ R | Δ ||-v σ : Γ | RΓ | wfΔ ]"           := (RΓ.(@VAd.pack _ _ Γ R).(VPack.validSubst) Δ σ wfΔ) (at level 0, R, Δ, σ, Γ, RΓ, wfΔ at level 50).
Notation "[ R | Δ ||-v σ ≅ σ' : Γ | RΓ | wfΔ | vσ ]" := (RΓ.(@VAd.pack _ _ Γ R).(VPack.eqSubst) Δ σ σ' wfΔ vσ) (at level 0, R, Δ, σ, σ', Γ, RΓ, wfΔ, vσ at level 50).

Record typeValidity@{u i j k l} `{ta : tag} `{!WfContext ta}
  `{!WfType ta} `{!Typing ta} `{!ConvType ta}
  `{!ConvTerm ta} `{!ConvNeuConv ta} `{!RedType ta} `{!TypeNf ta} `{!TypeNe ta} `{!RedTerm ta} `{!TermNf ta} `{!TermNe ta}
  {Γ : context} {VΓ : VPack@{u} Γ}
  {l : TypeLevel} {A : term} :=
  {
    validTy : forall {Δ : context} {σ : nat -> term}
      (wfΔ : [|- Δ ])
      (vσ : [ VΓ | Δ ||-v σ : Γ | wfΔ ])
      , [LogRel@{i j k l} l | Δ ||- A [ σ ] ] ;
    validTyExt : forall {Δ : context} {σ σ' : nat -> term}
      (wfΔ : [|- Δ ])
      (vσ  : [ VΓ | Δ ||-v σ  : Γ | wfΔ ])
      (vσ' : [ VΓ | Δ ||-v σ' : Γ | wfΔ ])
      (vσσ' : [ VΓ | Δ ||-v σ ≅ σ' : Γ | wfΔ | vσ ])
      , [LogRel@{i j k l} l | Δ ||- A [ σ ] ≅ A [ σ' ] | validTy wfΔ vσ ]
  }.

Arguments typeValidity : clear implicits.
Arguments typeValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Notation "[ P | Γ ||-v< l > A ]" := (typeValidity Γ P l A) (at level 0, P, Γ, l, A at level 50).

Definition emptyValidSubst `{ta : tag} `{!WfContext ta} : forall (Δ : context) (σ : nat -> term) (wfΔ : [|- Δ]), Type := fun _ _ _ => unit.
Definition emptyEqSubst@{u} `{ta : tag} `{!WfContext ta} : forall (Δ : context) (σ σ' : nat -> term) (wfΔ : [|- Δ]), emptyValidSubst@{u} Δ σ wfΔ -> Type@{u} := fun _ _ _ _ _ => unit.
Definition emptyVPack `{ta : tag} `{!WfContext ta} : VPack ε :=
  Build_VPack _ emptyValidSubst emptyEqSubst.

Section snocValid.
  Universe u i j k l.
  Context `{ta : tag} `{!WfContext ta}
  `{!WfType ta} `{!Typing ta} `{!ConvType ta}
  `{!ConvTerm ta} `{!ConvNeuConv ta} `{!RedType ta} `{!TypeNf ta} `{!TypeNe ta} `{!RedTerm ta}  `{!TermNf ta} `{!TermNe ta}
  {Γ : context} {VΓ : VPack@{u} Γ} {A : term} {l : TypeLevel}
  {vA : typeValidity@{u i j k l} Γ VΓ l A (* [ VΓ | Γ ||-v< l > A ] *)}.

  Record snocValidSubst {Δ : context} {σ : nat -> term} {wfΔ : [|- Δ]} : Type :=
    {
      validTail : [ VΓ | Δ ||-v ↑ >> σ : Γ | wfΔ ] ;
      validHead : [ Δ ||-< l > σ var_zero : A[↑ >> σ] | validTy vA wfΔ validTail ]
    }.

  Arguments snocValidSubst : clear implicits.

  Record snocEqSubst {Δ : context} {σ σ' : nat -> term} {wfΔ : [|- Δ]} {vσ : snocValidSubst Δ σ wfΔ} : Type :=
    {
      eqTail : [ VΓ | Δ ||-v ↑ >> σ ≅ ↑ >> σ' : Γ | wfΔ | validTail vσ ] ;
      eqHead : [ Δ ||-< l > σ var_zero ≅ σ' var_zero : A[↑ >> σ] | validTy vA wfΔ (validTail vσ) ]
    }.

  Definition snocVPack := Build_VPack@{u (* max(u,k) *)} (Γ ,, A) snocValidSubst (@snocEqSubst).
End snocValid.

Arguments snocValidSubst : clear implicits.
Arguments snocValidSubst {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Arguments snocEqSubst : clear implicits.
Arguments snocEqSubst {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Arguments snocVPack : clear implicits.
Arguments snocVPack {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Unset Elimination Schemes.

Inductive VR@{i j k l} `{ta : tag}
  `{WfContext ta} `{WfType ta} `{Typing ta}
  `{ConvType ta} `{ConvTerm ta} `{ConvNeuConv ta}
  `{RedType ta} `{!TypeNf ta} `{!TypeNe ta} `{RedTerm ta} `{!TermNf ta} `{!TermNe ta} : VRel@{k l} :=
  | VREmpty : VR ε emptyValidSubst@{k} emptyEqSubst@{k}
  | VRSnoc : forall {Γ A l}
    (VΓ : VPack@{k} Γ)
    (VΓad : VPackAdequate@{k l} VR VΓ)
    (VA : typeValidity@{k i j k l} Γ VΓ l A (*[ VΓ | Γ ||-v< l > A ]*)),
    VR (Γ ,, A) (snocValidSubst Γ VΓ A l VA) (snocEqSubst Γ VΓ A l VA).

Set Elimination Schemes.

Notation "[||-v Γ ]"                             := [ VR | ||-v Γ ] (at level 0, Γ at level 50).
Notation "[ Δ ||-v σ : Γ | VΓ | wfΔ ]"           := [ VR | Δ ||-v σ : Γ | VΓ | wfΔ ]  (at level 0, Δ, σ, Γ, VΓ, wfΔ at level 50).
Notation "[ Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | vσ ]" := [ VR | Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | vσ ] (at level 0, Δ, σ, σ', Γ, VΓ, wfΔ, vσ at level 50).
Notation "[ Γ ||-v< l > A | VΓ ]"                := [ VΓ | Γ ||-v< l > A ] (at level 0, Γ, l , A, VΓ at level 50).

Section MoreDefs.
  Context `{ta : tag} `{WfContext ta} `{WfType ta} `{Typing ta}
  `{ConvType ta} `{ConvTerm ta} `{ConvNeuConv ta} `{RedType ta} `{!TypeNf ta} `{!TypeNe ta} `{RedTerm ta} `{!TermNf ta} `{!TermNe ta}.

  Definition validEmpty@{i j k l} : [VR@{i j k l}| ||-v ε ] := Build_VAdequate emptyVPack VREmpty.

  Definition validSnoc@{i j k l} {Γ} {A l}
    (VΓ : [VR@{i j k l}| ||-v Γ]) (VA : [Γ ||-v< l > A | VΓ])
    : [||-v Γ ,, A ] :=
    Build_VAdequate (snocVPack Γ VΓ A l VA) (VRSnoc VΓ VΓ VA).

  Record termValidity@{i j k l} {Γ l} {t A : term}
    {VΓ : [VR@{i j k l}| ||-v Γ]}
    {VA : typeValidity@{k i j k l} Γ VΓ l A (*[Γ ||-v<l> A |VΓ]*)} : Type :=
    {
      validTm : forall {Δ σ}
        (wfΔ : [|- Δ]) (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]),
        [Δ ||-<l> t[σ] : A[σ] | validTy VA wfΔ Vσ ] ;
      validTmExt : forall {Δ : context} {σ σ' : nat -> term}
        (wfΔ : [|- Δ ])
        (Vσ  : [Δ ||-v σ  : Γ | VΓ | wfΔ ])
        (Vσ' : [ Δ ||-v σ' : Γ | VΓ | wfΔ ])
        (Vσσ' : [ Δ ||-v σ ≅ σ' : Γ | VΓ | wfΔ | Vσ ]),
        [Δ ||-<l> t[σ] ≅ t[σ'] : A[σ] | validTy VA wfΔ Vσ ]
    }.

  Record typeEqValidity@{i j k l} {Γ l} {A B : term}
    {VΓ : [VR@{i j k l}| ||-v Γ]}
    {VA : typeValidity@{k i j k l} Γ VΓ l A (*[Γ ||-v<l> A |VΓ]*)} : Type :=
    {
      validTyEq : forall {Δ σ}
        (wfΔ : [|- Δ]) (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]),
        [Δ ||-<l> A[σ] ≅ B[σ] | validTy VA wfΔ Vσ]
    }.

  Record termEqValidity@{i j k l} {Γ l} {t u A : term}
    {VΓ : [VR@{i j k l}| ||-v Γ]}
    {VA : typeValidity@{k i j k l} Γ VΓ l A (*[Γ ||-v<l> A |VΓ]*)} : Type :=
    {
      validTmEq : forall {Δ σ}
        (wfΔ : [|- Δ]) (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]),
        [Δ ||-<l> t[σ] ≅ u[σ] : A[σ] | validTy VA wfΔ Vσ]
    }.

  Record tmEqValidity {Γ l} {t u A : term} {VΓ : [||-v Γ]} : Type :=
    {
      Vty  : [Γ ||-v< l > A | VΓ] ;
      Vlhs : @termValidity Γ l t A VΓ Vty ;
      Vrhs : @termValidity Γ l u A VΓ Vty ;
      Veq  : @termEqValidity Γ l t u A VΓ Vty
    }.

  Record redValidity {Γ} {t u A : term} {VΓ : [||-v Γ]} : Type :=
    {
      validRed : forall {Δ σ}
        (wfΔ : [|- Δ]) (Vσ : [Δ ||-v σ : Γ | VΓ | wfΔ]),
        [Δ |- t[σ] :⇒*: u[σ] : A[σ]]
    }.
End MoreDefs.

Arguments termValidity : clear implicits.
Arguments termValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.
Arguments Build_termValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Arguments typeEqValidity : clear implicits.
Arguments typeEqValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.
Arguments Build_typeEqValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Arguments termEqValidity : clear implicits.
Arguments termEqValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.
Arguments Build_termEqValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Arguments tmEqValidity : clear implicits.
Arguments tmEqValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.
Arguments Build_tmEqValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Arguments redValidity : clear implicits.
Arguments redValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.
Arguments Build_redValidity {_ _ _ _ _ _ _ _ _ _ _ _ _}.

Notation "[ Γ ||-v< l > t : A | VΓ | VA ]"     := (termValidity Γ l t A VΓ VA) (at level 0, Γ, l, t, A, VΓ, VA at level 50).
Notation "[ Γ ||-v< l > A ≅ B | VΓ | VA ]"     := (typeEqValidity Γ l A B VΓ VA) (at level 0, Γ, l, A, B, VΓ, VA at level 50).
Notation "[ Γ ||-v< l > t ≅ u : A | VΓ | VA ]" := (termEqValidity Γ l t u A VΓ VA) (at level 0, Γ, l, t, u, A, VΓ, VA at level 50).
Notation "[ Γ ||-v< l > t ≅ u : A | VΓ ]"      := (tmEqValidity Γ l t u A VΓ) (at level 0, Γ, l, t, u, A, VΓ at level 50).
Notation "[ Γ ||-v t :⇒*: u : A | VΓ ]"      := (redValidity Γ t u A VΓ) (at level 0, Γ, t, u, A, VΓ at level 50).

Section Inductions.
  Context `{ta : tag} `{WfContext ta} `{WfType ta} `{Typing ta}
  `{ConvType ta} `{ConvTerm ta} `{ConvNeuConv ta} `{RedType ta} `{!TypeNf ta} `{!TypeNe ta} `{RedTerm ta} `{!TermNf ta} `{!TermNe ta}.

  Theorem VR_rect
    (P : forall {Γ vSubst vSubstExt}, VR Γ vSubst vSubstExt -> Type)
    (hε : P VREmpty)
    (hsnoc : forall {Γ A l VΓ VΓad VA},
      P VΓad -> P (VRSnoc (Γ := Γ) (A := A) (l := l) VΓ VΓad VA)) :
    forall {Γ vSubst vSubstExt} (VΓ : VR Γ vSubst vSubstExt), P VΓ.
  Proof.
    fix ih 4; destruct VΓ; [exact hε | apply hsnoc; apply ih].
  Defined.

  Theorem validity_rect
    (P : forall {Γ : context}, [||-v Γ] -> Type)
    (hε : P validEmpty)
    (hsnoc : forall {Γ A l} (VΓ : [||-v Γ]) (VA : [Γ ||-v< l > A | VΓ]), P VΓ -> P (validSnoc VΓ VA)) :
    forall {Γ : context} (VΓ : [||-v Γ]), P VΓ.
  Proof.
    intros Γ [[s eq] VΓad]; revert Γ s eq VΓad.
    apply VR_rect.
    - apply hε.
    - intros *; apply hsnoc.
  Defined.

  Lemma invValidity {Γ} (VΓ : [||-v Γ]) :
    match Γ as Γ return [||-v Γ] -> Type with
    | nil => fun VΓ₀ => VΓ₀ = validEmpty
    | (A :: Γ)%list => fun VΓ₀ =>
      ∑ l (VΓ : [||-v Γ]) (VA : [Γ ||-v< l > A | VΓ]), VΓ₀ = validSnoc VΓ VA
    end VΓ.
  Proof.
    pattern Γ, VΓ. apply validity_rect.
    - reflexivity.
    - intros; do 3 eexists; reflexivity.
  Qed.

  Lemma invValidityEmpty (VΓ : [||-v ε]) : VΓ = validEmpty.
  Proof. apply (invValidity VΓ). Qed.

  Lemma invValiditySnoc {Γ A} (VΓ₀ : [||-v Γ ,, A ]) :
      ∑ l (VΓ : [||-v Γ]) (VA : [Γ ||-v< l > A | VΓ]), VΓ₀ = validSnoc VΓ VA.
  Proof. apply (invValidity VΓ₀). Qed.

End Inductions.

(* Tactics to instantiate validity proofs in the context with
  valid substitions *)

Definition wfCtxOfsubstS `{GenericTypingProperties}
  `{TypeNf ta} `{TypeNe ta} `{TermNf ta} `{TermNe ta}
  {Γ Δ σ} {VΓ : [||-v Γ]} {wfΔ : [|- Δ]} :
  [Δ ||-v σ : Γ | VΓ | wfΔ] -> [|- Δ] := fun _ => wfΔ.

Ltac instValid vσ :=
  let wfΔ := (eval unfold wfCtxOfsubstS in (wfCtxOfsubstS vσ)) in
  repeat lazymatch goal with
  | [H : typeValidity _ _ _ _ |- _] =>
    let X := fresh "R" H in
    try pose (X := validTy H wfΔ vσ) ;
    block H
  | [H : termValidity _ _ _ _ _ _ |- _] =>
    let X := fresh "R" H in
    try pose (X := validTm H wfΔ vσ) ;
    block H
  | [H : typeEqValidity _ _ _ _ _ _ |- _] =>
    let X := fresh "R" H in
    try pose (X := validTyEq H wfΔ vσ) ;
    block H
  | [H : termEqValidity _ _ _ _ _ _ _ |- _] =>
    let X := fresh "R" H in
    try pose (X := validTmEq H wfΔ vσ) ;
    block H
  end; unblock.

Ltac instValidExt vσ' vσσ' :=
  repeat lazymatch goal with
  | [H : typeValidity _ _ _ _ |- _] =>
    let X := fresh "RE" H in
    try pose (X := validTyExt H _ _ vσ' vσσ') ;
    block H
  | [H : termValidity _ _ _ _ _ _ |- _] =>
    let X := fresh "RE" H in
    try pose (X := validTmExt H _ _ vσ' vσσ') ;
    block H
  end; unblock.

Ltac instAllValid vσ vσ' vσσ' :=
  instValid vσ ;
  instValid vσ' ;
  instValidExt vσ' vσσ'.


Require Import VST.msl.msl_direct.
Require Import CertiGraph.msl_ext.ramify_tactics.
Require Import CertiGraph.msl_ext.overlapping_direct.
Require Import VST.msl.predicates_sa.

Lemma precise_left_sepcon_andp_distr_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CA : Canc_alg A}:
  forall P P1 P2 Q R, precise P -> P1 |-- P -> P2 |-- P -> (P1 * Q) && (P2 * R) |-- (P1 && P2) * (Q && R).
Proof.
  intros.
  unfold sepcon, andp, derives; simpl.
  intros.
  destruct H2 as [[?y [?z [? [? ?]]]] [?y [?z [? [? ?]]]]].
  exists y, z.
  assert (P y) by auto.
  assert (P y0) by auto.
  equate_precise_direct y y0.
  equate_canc z z0.
  repeat split; auto.
Qed.

(* derives_precise, precise_emp is in predicates_sa.v. *)

Lemma precise_sepcon_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A}:
  forall P Q, precise Q -> precise P -> precise (P * Q).
Proof.
  repeat intro; destruct H1 as [w11 [w12 [? [? ?]]]], H2 as [w21 [w22 [? [? ?]]]].
  assert (w11 = w21) by (apply join_join_sub in H1; generalize (join_sub_trans H1 H3); intro;
                         apply join_join_sub in H2; generalize (join_sub_trans H2 H4); intro;
                         hnf in H0; apply H0 with (w := w); trivial).
  assert (w12 = w22) by (apply join_join_sub' in H1; generalize (join_sub_trans H1 H3); intro;
                         apply join_join_sub' in H2; generalize (join_sub_trans H2 H4); intro;
                         hnf in H; apply H with (w := w); trivial).
  rewrite H9 in *; rewrite H10 in *; equate_join w1 w2; auto.
Qed.

Lemma precise_wand_ewand_d {A} {JA : Join A} {PA : Perm_alg A} {SA: Sep_alg A} {CA : Canc_alg A}:
  forall R P Q R', precise P -> R |-- P * (Q -* R') -> Q * (ewand P R) |-- R'.
Proof.
  intros. intro w. intros. destruct_sepcon H1 h. destruct H3 as [h3 [h4 [? [? ?]]]].
  specialize (H0 h4 H5). destruct_sepcon H0 h. equate_precise_direct h3 h0.
  equate_canc h2 h5. apply (H7 h1); auto.
Qed.


Require Export Categories.Typ.

Program Definition Yoneda (C: Category): Functor C (Fun (co C) Typ) := {|
  fobj A := {|
    fobj X := @hom C X A;
    fmap X Y f g := @comp C _ _ _ g f;
  |};
  fmap A B f := {|
    transform X g := f ∘ g;
  |}
|}.
Next Obligation.
  extensionality f.
  apply (@comp_id_r C).
Qed.
Next Obligation.
  extensionality h.
  apply (@comp_assoc C).
Qed.
Next Obligation.
  extensionality g.
  apply comp_assoc.
Qed.
Next Obligation.
  natural_eq x.
  extensionality f.
  apply comp_id_l.
Qed.
Next Obligation.
  natural_eq x.
  extensionality h.
  symmetry.
  apply comp_assoc.
Qed.

Notation よ := Yoneda.

Lemma Yoneda_lemma {C: Category} (c: C) (P: Fun (co C) Typ): Hom (Fun (co C) Typ) (よ C c, P) ≃ P c.
Proof.
  constructor.
  unshelve eexists.
  exact (fun η => η c (id c)).
  unshelve eexists.
  intros x.
  unshelve eexists.
  exact (fun d f => fmap P f x).
  2: extensionality η.
  3: extensionality x.
  2, 3: unfold comp, id; simpl.
  2: natural_eq x.
  2: extensionality f.
  + intros b a f.
    simpl in a, b.
    change (a ~> b) in f.
    extensionality g.
    change (fmap P (g ∘ f) x = (fmap P f ∘ fmap P g) x).
    apply (f_equal (fun f => f x)).
    apply (@fmap_comp _ _ P).
  + change (よ C c ~> P) in η.
    specialize (@naturality _ _ _ _ η c x f) as H.
    apply (f_equal (fun f => f (id c))) in H.
    unfold comp in H; simpl in H.
    rewrite comp_id_l in H.
    now symmetry.
  + change (fmap P (id c) x = id (P c) x).
    apply (f_equal (fun f => f x)).
    apply (@fmap_id _ _ P).
Qed.

Lemma Yoneda_full (C: Category): full (よ C).
Proof.
  intros x y η.
  exists (η x (id x)).
  natural_eq z.
  extensionality f.
  specialize (@naturality _ _ _ _ η x z f) as H.
  simpl in H.
  unfold comp at 1 5 in H; simpl in H.
  apply (f_equal (fun f => f (id x))) in H.
  symmetry.
  rewrite <- (comp_id_l f) at 1.
  exact H.
Qed.

Lemma Yoneda_faithful (C: Category): faithful (よ C).
Proof.
  intros x y f g H.
  generalize (proj1 (natural_eq _ _) H).
  clear H; intros H.
  simpl in H.
  specialize (H x).
  apply (f_equal (fun f => f (id x))) in H.
  now rewrite !comp_id_r in H.
Qed.

Lemma Yoneda_fully_faithful (C: Category): fully_faithful (よ C).
Proof.
  apply full_and_faithful.
  split.
  apply Yoneda_full.
  apply Yoneda_faithful.
Qed.

(* fully_faithful_iso is currently to strict in its universes *)
Lemma Yoneda_principle {C: Category} (A B: C): よ C A ≃ よ C B <-> A ≃ B.
Proof.
  split.
  + intros [η].
    constructor.
    exists (to η A (id A)),  (to η⁻¹ B (id B)).
    specialize (@naturality _ _ _ _ (to η⁻¹) B A (to η A (id A))) as H.
    apply (f_equal (fun f => f (id B))) in H.
    unfold comp in H; simpl in H.
    change (from ?i) with (to i⁻¹) in H.
    etransitivity.
    symmetry.
    exact H.
    rewrite comp_id_l.
    change ((η⁻¹ ∘ η) A (id A) = id (よ C A) A (id A)).
    f_equal.
    apply inv_l.
    specialize (@naturality _ _ _ _ (to η) A B (to η⁻¹ B (id B))) as H.
    apply (f_equal (fun f => f (id A))) in H.
    unfold comp in H; simpl in H.
    change (from ?i) with (to i⁻¹) in H.
    etransitivity.
    symmetry.
    exact H.
    rewrite comp_id_l.
    change ((η ∘ η⁻¹) B (id B) = id (よ C B) B (id B)).
    f_equal.
    apply inv_r.
  + intros [f].
    constructor.
    1: unshelve eexists.
    2: unshelve eexists.
    1: exists (fun Z g => f ∘ g).
    2: exists (fun Z g => f⁻¹ ∘ g).
    3, 4: natural_eq Z.
    1, 2: intros Y X g.
    1, 2: simpl in Y, X.
    1, 2: change (X ~> Y) in g.
    all: extensionality h.
    all: simpl in h.
    1, 2: unfold comp at 1 3; simpl.
    3, 4: unfold comp at 1, id; simpl.
    all: change (from ?i) with (to i⁻¹).
    1, 2: apply comp_assoc.
    all: rewrite comp_assoc, <- comp_id_l.
    all: f_equal.
    apply inv_l.
    apply inv_r.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(*     A development written by Pierre Castéran for Coq V6.1

Coq : A product of inria : "http://pauillac.inria.fr/coq/coq-eng.html"

Pierre Castéran : A product of LaBRI :

LaBRI, Universite Bordeaux-I      |    12 place Puy Paulin
351 Cours de la Liberation        |    33000 Bordeaux
F-33405 TALENCE Cedex             |    France
France                            |    (+ 33) 5 56 81 15 80
tel : (+ 33) 5 56 84 69 31
fax : (+ 33) 5 56 84 66 69
email: casteran@labri.u-bordeaux.fr
www: http://dept-info.labri.u-bordeaux.fr/~casteran

"Les rêves sont aussi beaux que la réalité, mais ils ne sont pas mieux".
( J.L.Borges )

*)
Require Import nat_trees.
Require Import search_trees.
Require Import Arith.

Inductive RMAX (t t' : nat_tree) (n : nat) : Prop :=
    rmax_intro :
      occ t n ->
      (forall p : nat, occ t p -> p <= n) ->
      (forall q : nat, occ t' q -> occ t q) ->
      (forall q : nat, occ t q -> occ t' q \/ n = q) ->
      ~ occ t' n -> search t' -> RMAX t t' n.

Hint Resolve rmax_intro: searchtrees.

(* base cases *)

Lemma rmax_nil_nil : forall n : nat, RMAX (bin n NIL NIL) NIL n.
(*******************************************************)
Proof.
 intro n; split; auto with searchtrees arith.
 intros p H; inversion_clear H; auto with searchtrees arith.
 absurd (occ NIL p); auto with searchtrees arith.
 absurd (occ NIL p); auto with searchtrees arith.
 intros q H; inversion_clear H; auto with searchtrees arith.
Defined.

Lemma rmax_t_NIL :
 forall (t : nat_tree) (n : nat),
 search (bin n t NIL) -> RMAX (bin n t NIL) t n.
(************************************************************)
Proof.
 intros t n H; split; auto with searchtrees arith.
 intros p H0.
 elim (occ_inv n p t NIL H0); intro H1.
 elim H1; auto with searchtrees arith.
 elim H1; intro H2.
 apply lt_le_weak.
 elim (maj_l n t NIL H); auto with searchtrees arith.
 absurd (occ NIL p); auto with searchtrees arith.
 intros q H1; elim (occ_inv n q t NIL H1); intros; auto with searchtrees arith.
 elim H0.
 auto with searchtrees arith.
 intro H'; absurd (occ NIL q); auto with searchtrees arith.
 apply not_left with n NIL; auto with searchtrees arith.
 apply search_l with n NIL; auto with searchtrees arith.
Defined.

Hint Resolve rmax_t_NIL: searchtrees.

(* We study the case of a search tree (bin n t1 (bin p t2 t3))  *)

Section RMAX_np.
     Variable n p q : nat.
     Variable t1 t2 t3 t' : nat_tree.
     Hypothesis S1 : search (bin n t1 (bin p t2 t3)).
     Hypothesis R1 : RMAX (bin p t2 t3) t' q.
     Hint Resolve S1 R1: searchtrees.

     Remark rmax_1 : occ (bin n t1 (bin p t2 t3)) q.
     (**********************************************)
     Proof.
      elim R1; auto with searchtrees arith.
     Qed.

     Hint Resolve rmax_1: searchtrees.

     Remark rmax_2 : n < p.
     (**********************)
     Proof.
      elim (min_r _ _ _ S1); auto with searchtrees arith.
     Qed.

     Hint Resolve rmax_2: searchtrees.

     Remark rmax_3 : min n t'.
     (************************)
     Proof.
      apply min_intro.
      intros q' H.
      elim R1; intros.
      elim (min_r _ _ _ S1); auto with searchtrees arith.
     Qed.
     Hint Resolve rmax_3: searchtrees.

     Remark rmax_4 : search (bin n t1 t').
     (************************************)
     Proof.
      apply bin_search.
      apply search_l with n (bin p t2 t3); auto with searchtrees arith.
      elim R1; auto with searchtrees arith.
      apply maj_l with (bin p t2 t3); auto with searchtrees arith.
      auto with searchtrees arith.
     Qed.

     Hint Resolve rmax_4: searchtrees.

     Remark rmax_5 : n < q.
     (**********************)
     Proof.
      elim R1; intros; apply lt_le_trans with p; auto with searchtrees arith.
     Qed.

     Hint Resolve rmax_5: searchtrees.

     Remark rmax_6 :
      forall p0 : nat, occ (bin n t1 (bin p t2 t3)) p0 -> p0 <= q.
     (******************************************************************)
     Proof.
      intros p0 H.
      elim R1.
      intros H0 H1 H2 H3 H4 H5.
      elim (occ_inv _ _ _ _ H); intro H6.
      elim H6; auto with searchtrees arith.
      elim H6; intro H7.
      elim (maj_l _ _ _ S1).
      intro H8.
      cut (p0 < n); auto with searchtrees arith.
      intro; apply lt_le_weak.
      apply lt_trans with n; auto with searchtrees arith.
      elim (min_r _ _ _ S1); auto with searchtrees arith.
     Qed.

     Hint Resolve rmax_6: searchtrees.

     Remark rmax_7 :
      forall q' : nat,
      occ (bin n t1 t') q' -> occ (bin n t1 (bin p t2 t3)) q'.
     (*******************************************************)
     Proof.
      intros q' H; elim (occ_inv _ _ _ _ H); intro H0.
      elim H0; auto with searchtrees arith.
      elim H0; auto with searchtrees arith.
      intro H1; elim R1; auto with searchtrees arith.
     Qed.

     Hint Resolve rmax_7: searchtrees.

     Remark rmax_8 : ~ occ (bin n t1 t') q.
     (************************************)
     Proof.
      unfold not in |- *; intro F.
      elim (occ_inv _ _ _ _ F).
      intro eg; absurd (n < q); auto with searchtrees arith.
      elim eg; auto with searchtrees arith.
      simple induction 1; intro H1.
      absurd (occ t1 q); auto with searchtrees arith.
      apply not_left with n (bin p t2 t3); auto with searchtrees arith.
      elim R1; auto with searchtrees arith.
     Qed.

     Hint Resolve rmax_8: searchtrees.

     Remark rmax_9 :
      forall q0 : nat,
      occ (bin n t1 (bin p t2 t3)) q0 -> occ (bin n t1 t') q0 \/ q = q0.
     (****************************************)
     Proof.
      intros q0 H.
      elim (occ_inv _ _ _ _ H).
      simple induction 1; left; auto with searchtrees arith.
      simple induction 1; intro H'.
      left; auto with searchtrees arith.
      elim R1; intros H1 H2 H3 H4 H5 H6.
      elim (H4 _ H'); auto with searchtrees arith.
     Qed.

     Hint Resolve rmax_9: searchtrees.

     Lemma rmax_t1_t2t3 : RMAX (bin n t1 (bin p t2 t3)) (bin n t1 t') q.
     (*******************************************************************)
     Proof.
      apply rmax_intro; auto with searchtrees arith.
     Qed.

End RMAX_np.

Hint Resolve rmax_t1_t2t3: searchtrees.

Lemma rmax :
 forall t : nat_tree,
 search t -> binp t -> {q : nat &  {t' : nat_tree | RMAX t t' q}}.
(*********************************************)
Proof.

simple induction t;
 [ intros s b; exists 0; exists NIL
 | intros n t1 hr1 t2; case t2;
    [ intros hr2 s b; exists n; exists t1
    | intros n' t1' t2' hr2 s b; elim hr2;
       [ intros num ex; elim ex; intros tr htr; exists num;
          exists (bin n t1 tr)
       | idtac
       | idtac ] ] ]; auto with searchtrees arith.
absurd (binp NIL); auto with searchtrees arith.
eapply search_r; eauto with searchtrees arith.

(*
 Refine
 Fix rmax{rmax/1 : (t:nat_tree)(search t)->(binp t)->
        {q:nat & {t':nat_tree | (RMAX t t' q)}} :=
  [t][ty:=[q]{t':nat_tree | (RMAX t t' q)}]
    <[t](search t)->(binp t)->{q :nat & (ty q)}>Cases t of
       NIL => [s,b](existS ? ty O (exist ? ? NIL ?))
      |(bin n t1 NIL) => [s,b](existS ? ty n (exist ? ? t1 ?))
      |(bin n t1 t2) => [s,b]Cases (rmax t2 ? ?) of
             (existS num (exist tr _)) =>
                (existS ? ty num (exist ? ? (bin n t1 tr) ?))
            end
      end}.
*)
(*
 Realizer Fix rmax{rmax/1 : nat_tree -> nat*nat_tree :=
                   [t:nat_tree]<nat*nat_tree>
                      Cases t of
                        NIL => (O,NIL)
                      | (bin n t1 NIL) => (n,t1)
                      | (bin n t1 t2) =>
         		    <nat*nat_tree>let (num,tr) =   (rmax t2)
                             in (num,(bin n t1 tr)) end
                         }.
 Program_all.
*)
Defined.


Require Import Coq.Strings.String Coq.Lists.List.
Require Export Fiat.Common.Coq__8_4__8_5__Compat.

Set Implicit Arguments.

Local Open Scope list_scope.
Local Open Scope string_scope.

Fixpoint list_of_string (s : string) : list Ascii.ascii
  := match s with
       | "" => nil
       | String ch s' => ch :: list_of_string s'
     end.

Fixpoint string_of_list (ls : list Ascii.ascii) : string
  := match ls with
       | nil => ""
       | ch :: ls' => String ch (string_of_list ls')
     end.

Fixpoint string_copy (n : nat) (ch : Ascii.ascii)
  := match n with
       | 0 => EmptyString
       | S n' => String.String ch (string_copy n' ch)
     end.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 Provide standard test objects for all test files.

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax.
Require Export List.
Import ListNotations.
Import LibEnvNotations.

Definition k  := A.
Definition ka := A.
Definition kb := B.

(* Bug 4 i_i does not handle negative numbers! *)
Definition v'    := (i_e (i_i 4)).
Definition v''   := (i_e (i_i 6)).
Definition v     := (i_e (i_i 3)).
Definition v0    := (i_e (i_i 0)).
Definition v1    := (i_e (i_i 1)).
Definition vi0   := (i_e (i_i 0)).
Definition vi1   := (i_e (i_i 1)).
Definition vi2   := (i_e (i_i 2)).

Definition e    := (i_e (i_i 0)).
Definition e'   := (i_e (i_i 1)).
Definition e0   := (i_e (i_i 0)).
Definition e1   := (i_e (i_i 1)).
Definition e2   := (i_e (i_i 1)).

Definition s  := (retn (i_e (i_i 0))).
Definition s' := (retn (i_e (i_i 0))).
Definition s1 := (retn (i_e (i_i 1))).
Definition s2 := (retn (i_e (i_i 2))).

Parameter alpha_ : var.
Parameter beta_  : var.
Parameter gamma_ : var.

Definition alpha := (ftvar alpha_).
Definition beta  := (ftvar beta_).
Definition gamma := (ftvar gamma_).

Parameter varx  : var.
Parameter varx' : var.
Parameter vary  : var.
Parameter vary' : var.
Parameter varz  : var.
Parameter varz' : var.

Definition x     := (fevar varx).
Definition x'    := (fevar varx').
Definition y     := (fevar vary).
Definition y'    := (fevar vary').
Definition z     := (fevar varz).
Definition z'    := (fevar varz').

Definition i     := (i_i 0).
Definition i1    := (i_i 1).
Definition i2    := (i_i 2).
Definition i3    := (i_i 3).

Definition tau  := cint.
Definition tau' := cross cint cint.
Definition t    := cint.
Definition t'   := cross cint cint.
Definition t0   := cint.
Definition t1   := cross cint cint.

Definition p0   := [(i_pe zero_pe)].
Definition p1   := [(i_pe one_pe)].

Definition h    := (single varx e) & hdot.

Definition q := aliases.

(* We use these to show that substitution ignores expresions without
  type variables, f, substitutes all alphas falphaalpha, and ignores
  type other type variables, fbetabeta. *)
Definition f           :=
  (dfun tau  tau (retn (inst (p_e x pdot) tau))).
Definition faa :=
  (dfun tau  alpha (retn (inst (p_e x pdot) alpha))).
Definition fbb  :=
  (dfun tau  beta (retn (inst (p_e x pdot) beta))).

Definition applff  := (e_s (appl (f_e f)   (f_e f))).
Definition applfaa := (e_s (appl (f_e faa) (f_e faa))).
Definition applfbb := (e_s (appl (f_e fbb) (f_e fbb))).

Definition ufg  := (ufun A faa).
Definition ufaa := (ufun A faa).
Definition ufbb := (ufun A faa).

Ltac unfold_test_utilities :=
 unfold k, ka, kb, v', v'', v, v0, v1, vi0, vi1, vi2, e, e', e0, e1, e2, s, s', s1, s2, alpha, beta, gamma, x, x', y, y', z, z', i, i1, i2, i3, tau, tau', t, t', t0, t1, p0, p1, h, q, f, faa, fbb, applff, applfaa, applfbb, ufg, ufaa, ufbb in *.


Require Import Coq.Lists.List.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Crypto.Util.Strings.String.
Import ListNotations.
Local Open Scope list_scope.
Local Open Scope char_scope.

Definition subscript_map :=
  Eval cbv in
    List.combine
      ["("; ")"; "+"; "-";
       "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9";
       "=";
       "a"; "e"; "h"; "i"; "j"; "k"; "l"; "m"; "n"; "o"; "p"; "r"; "s"; "t"; "u"; "v"; "x"; "y"]%char
      ["₍"; "₎"; "₊"; "₋";
       "₀"; "₁"; "₂"; "₃"; "₄"; "₅"; "₆"; "₇"; "₈"; "₉";
       "₌";
       "ₐ"; "ₑ"; "ₕ"; "ᵢ"; "ⱼ"; "ₖ"; "ₗ"; "ₘ"; "ₙ"; "ₒ"; "ₚ"; "ᵣ"; "ₛ"; "ₜ"; "ᵤ"; "ᵥ"; "ₓ"; "ᵧ"]%string.

Module Ascii.
  Definition to_subscript_opt (c : ascii) : option string
    := option_map snd (find (fun '(ch, _) => Ascii.eqb c ch) subscript_map).
  Definition to_subscript (c : ascii) : string
    := match to_subscript_opt c with
       | Some s => s
       | None => String c EmptyString
       end.
End Ascii.

Module Export WORKAROUND_EXTRACTION_DONT_SHADOW_OCAML_STRING.
Module String.
  Definition to_subscript (s : string) : string
    := string_of_list_ascii (List.flat_map (fun a => list_ascii_of_string (Ascii.to_subscript a)) (list_ascii_of_string s)).
End String.
End WORKAROUND_EXTRACTION_DONT_SHADOW_OCAML_STRING.