Require Export CoqRecon.Semantics.DamasMilner
        CoqRecon.Unify.Unify.

Reserved Notation "g ⫦ e ∴ t ⊣ X ≀ C" (at level 70).

Definition Instantiates
           (g : pgamma) '((∀ TS, t) as p : poly) (WS : list nat) : Prop :=
  length (uniques TS) = length (uniques WS) /\
  Forall (fun W => W ∉ ptvars p) WS (*/\ Disjoint WS (FTV g)*).

Definition captures (g : pgamma) (t : typ) : list nat :=
  filter (fun T => negb (member T (FTV g))) (uniques (tvars t)).

Definition Generalize (s : tenv) (g : pgamma) (t : typ) : list nat :=
  captures (s ◀ g) t.

(** Based on [Types and Programming Languages],
    as well as the Cornell CS 3110 textbook
    by Michael Clarkson:
    [https://github.com/cs3110/textbook] *)
Inductive DM_constraint (Γ : pgamma)
  : term -> typ -> list nat -> list (typ * typ) -> Prop :=
| dmc_bool (b : bool) :
    Γ ⫦ b ∴ TBool ⊣ [] ≀ []
| dmc_nat (n : nat) :
    Γ ⫦ n ∴ TNat ⊣ [] ≀ []
| dmc_abs x e (T : nat) τ χ C :
    T ∉ χ ->
    (x, ∀ [], TVar T) :: Γ ⫦ e ∴ τ ⊣ χ ≀ C ->
    Γ ⫦ λ x ⇒ e ∴ T → τ ⊣ T :: χ ≀ C
| dmc_app e1 e2 T τ1 τ2 χ1 χ2 C1 C2 :
    χ1 ∩ χ2 = [] ->
    χ1 ∩ tvars τ2 = [] ->
    χ2 ∩ tvars τ1 = [] ->
    T ∉ χ1 ∪ χ2 ∪ tvars τ1 ∪ tvars τ2 ∪ Ctvars C1 ∪ Ctvars C2 ->
    Γ ⫦ e1 ∴ τ1 ⊣ χ1 ≀ C1 ->
    Γ ⫦ e2 ∴ τ2 ⊣ χ2 ≀ C2 ->
    Γ ⫦ e1 ⋅ e2 ∴ T ⊣ T :: χ1 ∪ χ2 ≀ (τ1, τ2 → T) :: C1 ∪ C2
| dmc_cond e1 e2 e3 τ1 τ2 τ3 χ1 χ2 χ3 C1 C2 C3 :
    χ1 ∩ χ2 = [] ->
    χ1 ∩ χ3 = [] ->
    χ2 ∩ χ3 = [] ->
    Γ ⫦ e1 ∴ τ1 ⊣ χ1 ≀ C1 ->
    Γ ⫦ e2 ∴ τ2 ⊣ χ2 ≀ C2 ->
    Γ ⫦ e3 ∴ τ3 ⊣ χ3 ≀ C3 ->
    Γ ⫦ Cond e1 e2 e3 ∴ τ2 ⊣ χ1 ∪ χ2 ∪ χ3
      ≀ (τ1,TBool) :: (τ2,τ3) :: C1 ∪ C2 ∪ C3
| dmc_op o e1 e2 τ1 τ2 τ τ' χ1 χ2 C1 C2 :
    χ1 ∩ χ2 = [] ->
    op_typs o τ τ' ->
    Γ ⫦ e1 ∴ τ1 ⊣ χ1 ≀ C1 ->
    Γ ⫦ e2 ∴ τ2 ⊣ χ2 ≀ C2 ->
    Γ ⫦ Op o e1 e2 ∴ τ' ⊣ χ1 ∪ χ2 ≀ (τ,τ1) :: (τ,τ2) :: C1 ∪ C2
| dmc_var x TS WS τ :
    lookup x Γ = Some (∀ TS, τ) ->
    Instantiates Γ (∀ TS, τ) WS ->
    Γ ⫦ x ∴ ~[uniques TS ⟼  map TVar (uniques WS)]~ † τ ⊣ WS ≀ []
| dmc_let x e1 e2 τ1 τ2 χ1 χ2 C1 C2 σ :
    χ1 ∩ χ2 = [] ->
    Unify C1 σ ->
    Γ ⫦ e1 ∴ τ1 ⊣ χ1 ≀ C1 ->
    (x, ∀ (Generalize σ Γ (σ † τ1)), σ † τ1)
      :: σ ◀ Γ ⫦ e2 ∴ τ2 ⊣ χ2 ≀ C2 ->
    Γ ⫦ LetIn x e1 e2 ∴ τ2 ⊣ χ1 ∪ χ2 ≀ C1 ∪ C2
where "g ⫦ e ∴ t ⊣ X ≀ C" := (DM_constraint g e t X C) : type_scope.

Reserved Notation "g ⊢W e ∴ t ⊣ X ≀ s" (at level 70).

(** Algorithm W, as given by Luis Damas. *)
Inductive W (Γ : pgamma)
  : term -> typ -> list nat -> tenv -> Prop :=
| W_bool (b : bool) :
    Γ ⊢W b ∴ TBool ⊣ [] ≀ ∅
| W_nat (n : nat) :
    Γ ⊢W n ∴ TNat ⊣ [] ≀ ∅
| W_cond e1 e2 e3 τ1 τ2 τ3 χ1 χ2 χ3 σ σ1 σ1' σ2 σ3 :
    χ1 ∩ χ2 = [] ->
    χ1 ∩ χ3 = [] ->
    χ2 ∩ χ3 = [] ->
    Unify [(τ1,TBool)] σ1' ->
    Unify [(σ3 † τ2, τ3)] σ ->
    Γ ⊢W e1 ∴ τ1 ⊣ χ1 ≀ σ1 ->
    σ1' ‡ σ1 ◀ Γ ⊢W e2 ∴ τ2 ⊣ χ2 ≀ σ2 ->
    σ2 ‡ σ1' ‡ σ1 ◀ Γ ⊢W e3 ∴ τ3 ⊣ χ3 ≀ σ3 ->
    Γ ⊢W Cond e1 e2 e3 ∴ σ † τ3 ⊣ χ1 ∪ χ2 ∪ χ3 ≀ σ ‡ σ2 ‡ σ1' ‡ σ1
| W_op o e1 e2 τ1 τ2 τ τ' χ1 χ2 σ1 σ1' σ2 σ2' :
    χ1 ∩ χ2 = [] ->
    op_typs o τ τ' ->
    Unify [(τ,τ1)] σ1' ->
    Unify [(τ,τ2)] σ2' ->
    Γ ⊢W e1 ∴ τ1 ⊣ χ1 ≀ σ1 ->
    σ1' ‡ σ1 ◀ Γ ⊢W e2 ∴ τ2 ⊣ χ2 ≀ σ2 ->
    Γ ⊢W Op o e1 e2 ∴ τ' ⊣ χ1 ∪ χ2 ≀ σ2' ‡ σ2 ‡ σ1' ‡ σ1
| W_abs x e (T : nat) τ χ σ :
    T ∉ χ ->
    (x, ∀ [], T) :: Γ ⊢W e ∴ τ ⊣ χ ≀ σ ->
    Γ ⊢W λ x ⇒ e ∴ σ † T → τ ⊣ T :: χ ≀ σ
| W_app e1 e2 T τ1 τ2 χ1 χ2 σ σ1 σ2 :
    χ1 ∩ χ2 = [] ->
    χ1 ∩ tvars τ2 = [] ->
    χ2 ∩ tvars τ1 = [] ->
    T ∉ χ1 ∪ χ2 ∪ tvars τ1 ∪ tvars τ2 ->
    Unify [(σ2 † τ1, τ2 → T)] σ ->
    Γ ⊢W e1 ∴ τ1 ⊣ χ1 ≀ σ1 ->
    σ1 ◀ Γ ⊢W e2 ∴ τ2 ⊣ χ2 ≀ σ2 ->
    Γ ⊢W e1 ⋅ e2 ∴ σ † T ⊣ T :: χ1 ∪ χ2 ≀ σ ‡ σ2 ‡ σ1
| W_var x TS WS τ :
    lookup x Γ = Some (∀ TS, τ) ->
    Instantiates Γ (∀ TS, τ) WS ->
    Γ ⊢W x ∴ ~[uniques TS ⟼  map TVar (uniques WS)]~ † τ ⊣ WS ≀ ∅
| W_let x e1 e2 τ1 τ2 χ1 χ2 σ1 σ2 :
    χ1 ∩ χ2 = [] ->
    Γ ⊢W e1 ∴ τ1 ⊣ χ1 ≀ σ1 ->
    (x, ∀ (Generalize σ1 Γ τ1), τ1) :: σ1 ◀ Γ ⊢W e2 ∴ τ2 ⊣ χ2 ≀ σ2 ->
    Γ ⊢W LetIn x e1 e2 ∴ τ2 ⊣ χ1 ∪ χ2 ≀ σ2 ‡ σ1
where "g ⊢W e ∴ t ⊣ X ≀ s" := (W g e t X s) : type_scope.


From Tuto0 Require Export Loader.
Require Import Ltac_utils.

Lemma LP1P2P3 : forall P1 P2 P3 P4 P5 P6 P7 P8 ,
rk(P2 :: P3 ::  nil) = 2 -> rk(P2 :: P4 ::  nil) = 2 -> rk(P3 :: P4 ::  nil) = 2 ->
rk(P1 :: P2 :: P3 :: P4 ::  nil) = 2 -> rk(P1 :: P2 :: P5 ::  nil) = 3 -> rk(P1 :: P3 :: P6 ::  nil) = 3 ->
rk(P5 :: P6 ::  nil) = 2 -> rk(P1 :: P4 :: P7 ::  nil) = 3 -> rk(P5 :: P7 ::  nil) = 2 ->
rk(P6 :: P7 ::  nil) = 2 -> rk(P1 :: P5 :: P6 :: P7 ::  nil) = 2 -> rk(P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: P7 :: P8 ::  nil) = 4 ->

rk(P1 :: P2 :: P3 ::  nil) = 2.
Proof.
  intros.
  pprove.
  Require Import pprove_LP1P2P3_104.
  solve_using LP1P2P3.
Qed.

Lemma LP1P2P4 : forall P1 P2 P3 P4 P5 P6 P7 P8 ,
rk(P2 :: P3 ::  nil) = 2 -> rk(P2 :: P4 ::  nil) = 2 -> rk(P3 :: P4 ::  nil) = 2 ->
rk(P1 :: P2 :: P3 :: P4 ::  nil) = 2 -> rk(P1 :: P2 :: P5 ::  nil) = 3 -> rk(P1 :: P3 :: P6 ::  nil) = 3 ->
rk(P5 :: P6 ::  nil) = 2 -> rk(P1 :: P4 :: P7 ::  nil) = 3 -> rk(P5 :: P7 ::  nil) = 2 ->
rk(P6 :: P7 ::  nil) = 2 -> rk(P1 :: P5 :: P6 :: P7 ::  nil) = 2 -> rk(P1 :: P2 :: P3 :: P4 :: P5 :: P6 :: P7 :: P8 ::  nil) = 4 ->

rk(P1 :: P2 :: P4 ::  nil) = 2.
Proof.
  intros.
  pprove.
  Require Import pprove_LP1P2P4_188.
  solve_using LP1P2P4.
Qed.


(* -*- coq-prog-args: ("-emacs" "-indices-matter" "-type-in-type") -*- *)

Require Export Utf8_core.
Require Import HoTT HoTT.hit.Truncations Connectedness.
Require Import reflective_subuniverse.

Set Universe Polymorphism.
Global Set Primitive Projections.

Local Open Scope path_scope.

(* Readability *)
Arguments trunc_arrow {H} {A} {B} {n} H0: simpl never.
Arguments trunc_sigma {A} {P} {n} H H0: simpl never.
Arguments istrunc_paths {A} {n} H x y: simpl never.
Arguments trunc_succ {n} {A} H _ _: simpl never.

Arguments O {n} subU T.
Arguments O_unit {n} subU T a.
Arguments subuniverse_Type {n} subU.

Section Preliminary.

  (* Defiinition 10, (v) *)
  Record Modality n := Build_Modality {

                               underlying_subu : subuniverse_struct n ;

                               subu_sigma : forall (A:subuniverse_Type underlying_subu) (B:A -> subuniverse_Type underlying_subu), IsSubu n underlying_subu (BuildTruncType n {x:A & B x})
                                            }.

  Context `{ua: Univalence}.
  Context `{fs: Funext}.

  (* Proposition 11 *)
  Definition O_rec_dep {n} {mod : Modality n} (subU := underlying_subu n mod)
             (A:TruncType n) (B: (O subU A) -> subuniverse_Type subU) (g : forall (a:A), (B (O_unit subU A a)))
  : {f : forall (z:(O subU A)), (B z) & forall a:A, f (O_unit subU A a) = g a}.
    apply subuniverse_sigma. exact ua. exact fs.
    apply subu_sigma.
  Defined.

  Definition is_equiv_Opaths {n} {mod : Modality n} (subU := underlying_subu n mod)
             (A:TruncType n) (x y : O subU A)
    : IsEquiv (O_unit subU (BuildTruncType _ (x = y))).
  Proof.
    simple refine (isequiv_adjointify _ _ _ _).
    - simple refine (O_rec _ _ _ (Build_subuniverse_Type _ _ (BuildTruncType _ (x=y)) _) _).
      exact idmap.
    - unfold Sect.
      intro u.
      match goal with
      |[|- ?ff (?gg u) = _] => set (F := ff); set (G := gg)
      end.
      revert u.
      simple refine (O_rec_dep _ (λ u, Build_subuniverse_Type _ _ (BuildTruncType _ (F (G u) = u)) _) _).1.
      intro u; unfold F; clear F; unfold G; clear G. cbn.
      rewrite (λ P Q f, ap10 (O_rec_retr _ subU P Q f)).
      reflexivity.
    - intro u.
      rewrite (λ P Q f, ap10 (O_rec_retr _ subU P Q f)).
      reflexivity.
  Defined.

  (* Proposition 16, for HProps *)
  Definition hprop_stability {n} {mod : Modality n} (subU := underlying_subu n mod) (P:hProp) (t : IsTrunc n P)
  : IsHProp (O subU (@BuildTruncType n P t)).
    apply hprop_allpath.
    intros x.
    transparent assert (modf : ((O subU (@BuildTruncType n P t)) -> subuniverse_Type subU)).
    { intro y.
      simple refine (Build_subuniverse_Type _ subU (BuildTruncType n (x=y)) _). }
    simple refine (O_rec_dep _ modf _).1.
    intro y. unfold modf; clear modf; simpl.
    revert x.
    transparent assert (modf : ((O subU (@BuildTruncType n P t)) -> subuniverse_Type subU)).
    { intro x.
      simple refine (Build_subuniverse_Type _ subU (BuildTruncType n (x=O_unit subU _ y)) _). }
    simple refine (O_rec_dep _ modf _).1.
    intros x. unfold modf; clear modf; simpl in *.
    apply ap. simple refine (path_ishprop x y).
  Defined.

  (* Lemma 13 *)
  Definition modal_contr_modal_is_equiv n (mod : Modality n.+1) (subU := underlying_subu n.+1 mod) (X:TruncType n.+1) (Y : subuniverse_Type subU) (f : X -> Y) (mod_contr_f : forall y, Contr (O subU (BuildTruncType (n.+1) (hfiber f y))))
  : (O subU X) <~> Y.
    simple refine (equiv_adjointify _ _ _ _).
    - apply O_rec; exact f.
    - intro y.
      destruct (mod_contr_f y) as [c _].
      revert c. apply O_rec; intros [c p].
      apply O_unit; exact c.
    - intro x.
      destruct (mod_contr_f x) as [c Tc].
      cbn in *. clear Tc.
      revert c.
      pose (sheaf_family := λ c, (Build_subuniverse_Type _ subU (BuildTruncType (n.+1) (O_rec (n.+1) subU X Y f
                   (O_rec (n.+1) subU
                      (BuildTruncType (n.+1) (hfiber f x))
                      (O subU X) (λ X0 : hfiber f x, O_unit subU X X0.1) c) = x)) _)).
      simple refine (O_rec_dep (BuildTruncType (n.+1) (hfiber f x)) sheaf_family _).1.
      unfold sheaf_family; clear sheaf_family.
      intros [c p]. simpl.
      assert (p0 := ap10 (O_rec_retr (n.+1) subU (BuildTruncType (n.+1) (hfiber f x)) (O subU X) (λ X0 : hfiber f x, O_unit subU X X0.1)) (c;p)).

      apply (transport (λ U, O_rec (n.+1) subU X Y f U = x) p0^); clear p0.
      exact ((ap10 (O_rec_retr (n.+1) subU X Y f) c) @ p).
    - intro x. destruct (mod_contr_f (O_rec (n.+1) subU X Y f x)) as [c Tc]. simpl in *.
      transparent assert (cc : (O subU
               (BuildTruncType (n.+1) (hfiber f (O_rec (n.+1) subU X Y f x))))).
      { clear Tc; clear c. revert x.
        pose proof (@O_rec_dep (n.+1) mod X (λ x, (O subU
               (BuildTruncType (n.+1) (hfiber f (O_rec (n.+1) subU X Y f x)))))).
        simpl in X0.
        simple refine (X0 _).1.
        intro x. simpl.
        apply O_unit. exists x.
        exact (ap10 (O_rec_retr (n.+1) subU X Y f) x)^. }
      Opaque O_rec_dep.
      simpl in cc.
      specialize (Tc cc). rewrite Tc.
      unfold cc. clear Tc; clear cc; clear c; simpl.
      fold subU.
      revert x.
      pose (sheaf_family := λ x, (Build_subuniverse_Type (n.+1) subU
                                   (BuildTruncType (n.+1) (O_rec n.+1 subU
     {|
     trunctype_type := hfiber f (O_rec n.+1 subU X Y f x);
     istrunc_trunctype_type := trunc_sigma (istrunc_trunctype_type X)
                                 (λ a : X,
                                  istrunc_paths
                                    (trunc_succ (istrunc_trunctype_type Y))
                                    (f a) (O_rec n.+1 subU X Y f x)) |}
     (O subU X)
     (λ X0 : hfiber f (O_rec n.+1 subU X Y f x),
      O_unit subU X (let (proj1_sig, _) := X0 in proj1_sig))
     ((O_rec_dep X
         (λ x0 : O subU X,
          O subU
            {|
            trunctype_type := hfiber f (O_rec n.+1 subU X Y f x0);
            istrunc_trunctype_type := trunc_sigma (istrunc_trunctype_type X)
                                        (λ a : X,
                                         istrunc_paths
                                           (trunc_succ
                                              (istrunc_trunctype_type Y))
                                           (f a) (O_rec n.+1 subU X Y f x0)) |})
         (λ x0 : X,
          O_unit subU
            {|
            trunctype_type := hfiber f
                                (O_rec n.+1 subU X Y f (O_unit subU X x0));
            istrunc_trunctype_type := trunc_sigma (istrunc_trunctype_type X)
                                        (λ a : X,
                                         istrunc_paths
                                           (trunc_succ
                                              (istrunc_trunctype_type Y))
                                           (f a)
                                           (O_rec n.+1 subU X Y f
                                              (O_unit subU X x0))) |}
            (x0; (ap10 (O_rec_retr n.+1 subU X Y f) x0)^))).1 x) = x)) _)).
      simple refine (O_rec_dep X sheaf_family _).1.
      unfold sheaf_family in *; simpl in *; clear sheaf_family.
      intro x. simpl.
      rewrite ((O_rec_dep X
         (λ x0 : O subU X,
          O subU
            {|
            trunctype_type := hfiber f (O_rec n.+1 subU X Y f x0);
            istrunc_trunctype_type := trunc_sigma (istrunc_trunctype_type X)
                                        (λ a : X,
                                         istrunc_paths
                                           (trunc_succ
                                              (istrunc_trunctype_type Y))
                                           (f a) (O_rec n.+1 subU X Y f x0)) |})
         (λ x0 : X,
          O_unit subU
            {|
            trunctype_type := hfiber f
                                (O_rec n.+1 subU X Y f (O_unit subU X x0));
            istrunc_trunctype_type := trunc_sigma (istrunc_trunctype_type X)
                                        (λ a : X,
                                         istrunc_paths
                                           (trunc_succ
                                              (istrunc_trunctype_type Y))
                                           (f a)
                                           (O_rec n.+1 subU X Y f
                                              (O_unit subU X x0))) |}
            (x0; (ap10 (O_rec_retr n.+1 subU X Y f) x0)^))).2 x).
      fold subU.
      exact (ap10 (O_rec_retr (n.+1) subU (BuildTruncType (n.+1) (hfiber f (O_rec (n.+1) subU X Y f (O_unit subU X x)))) (O subU X) (λ X0 : (hfiber f (O_rec (n.+1) subU X Y f (O_unit subU X x))), O_unit subU X X0.1)) (x; (ap10 (O_rec_retr (n.+1) subU X Y f) x)^)).
  Defined.

  (* Lemma 15 *)
  Lemma O_unit_O_contr_fibers {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod) (X:TruncType n.+1) (Tr : forall x, IsTrunc n.+1 (hfiber (O_unit subU X) x))
  : forall x, Contr (O subU (@BuildTruncType (n.+1) (hfiber (O_unit subU X) x) (Tr x))).
    intros x.
    simple refine (BuildContr _ _ _).
    revert x.
    apply O_rec_dep.
    Opaque O_rec_dep.
    intro a. apply O_unit. simpl. exists a. reflexivity.
    intro y. simpl.
    revert y.
    transparent assert (shf : ((((O subU (@BuildTruncType (n.+1) (hfiber (O_unit subU X) x) (Tr x)))) -> subuniverse_Type subU))).
    { intro y.
      simple refine (Build_subuniverse_Type _ subU (BuildTruncType _ ((O_rec_dep X
      (λ z : O (underlying_subu n.+1 mod) X,
       O subU
         {|
         trunctype_type := hfiber (O_unit subU X) z;
         istrunc_trunctype_type := Tr z |})
      (λ a : X,
       O_unit subU
         {|
         trunctype_type := hfiber (O_unit subU X)
                             (O_unit (underlying_subu n.+1 mod) X a);
         istrunc_trunctype_type := Tr (O_unit (underlying_subu n.+1 mod) X a) |}
         (a; 1))).1 x = y)) _). }
    simple refine (O_rec_dep (@BuildTruncType (n.+1) (hfiber (O_unit subU X) x) (Tr x)) shf _).1.
    unfold shf; clear shf; simpl.
    intros [y p]. destruct p.
    match goal with
      |[|- ?XX.1 _ = _] => exact (XX.2 y)
    end.
  Defined.

  Global Instance is_modal_IsTrunc
        (n p: trunc_index)
        (mod : Modality (n.+1))
        (subU := underlying_subu _ mod)
        (trunc_prop : forall (T : subuniverse_Type subU), IsTrunc (n.+1) (IsTrunc p T))
        (T : subuniverse_Type subU)
    : IsSubu (n.+1) subU (@BuildTruncType (n.+1) (IsTrunc p T) (trunc_prop T)).
  Proof.
    revert T.
    induction p.
    - intros T.
      rewrite <- subuniverse_iff_O; [idtac | exact ua | exact fs].
      simple refine (isequiv_adjointify _ _ _ _).
      + intro X.
        simple refine (@contr_inhabited_hprop T _ _).
        apply hprop_allpath. intros x y.
        pose (sheaf := Build_subuniverse_Type (n.+1) subU (BuildTruncType _ (x=y)) _).
        revert X.
        apply (O_rec (n.+1) subU _ sheaf).
        intros [c pc]. unfold sheaf; clear sheaf. simpl.
        apply hprop_allpath.
        intros u v. exact ((pc u)^ @ (pc v)).
        revert X. apply O_rec.
        simpl.
        intros. exact (center _ X).
      + intro X. simpl.
        simple refine (path_ishprop _ _).
        transparent assert (hp : hProp).
        { exists (Contr (T)).
          apply hprop_trunc. }
        apply (hprop_stability (mod:=mod) hp (trunc_prop T)).
      + intro X. simpl.
        simple refine (path_ishprop _ _).
    - simpl in *. intros T.
      rewrite <- subuniverse_iff_O.
      simple refine (isequiv_adjointify _ _ _ _).
      + intro X.
        assert (trunc_pr : ∀ T : subuniverse_Type subU,
                             IsTrunc n.+1 (IsTrunc p T)).
        intro S. apply (@trunc_leq -1 (n.+1) tt _ _).
        simpl in *.
        intros x y.
        pose (sheaf := Build_subuniverse_Type (n.+1) subU (BuildTruncType (n.+1) (x=y)) _).
        specialize (IHp trunc_pr sheaf).
        unfold sheaf in *; clear sheaf. simpl in IHp.

        rewrite <- subuniverse_iff_O in IHp.
        apply (equiv_inv (IsEquiv := IHp)).
        revert X. apply O_rec.
        intros X. apply O_unit. exact (X x y). exact ua. exact fs.
      + intro X. simpl.
        simple refine (path_ishprop _ _).
        transparent assert (hp : hProp).
        { exists (IsTrunc p.+1 T).
          apply hprop_trunc. }
        apply (hprop_stability (mod:=mod) hp (trunc_prop T)).
      + intro X. simpl.
        simple refine (path_ishprop _ _).
      + exact ua.
      + exact fs.
  Defined.

  (* Section III.B : if [A] and [B] are modal and [f:A -> B], then [IsEquiv f] is modal *)
  Lemma is_modal_IsEquiv
        (n p: trunc_index)
        (mod : Modality (n.+1))
        (subU := underlying_subu _ mod)
        (trunc_prop : forall (A B : subuniverse_Type subU) (f:A -> B), IsTrunc (n.+1) (IsEquiv f))
  : forall (A B : subuniverse_Type subU) (f: A -> B), IsSubu (n.+1) subU (BuildTruncType (n.+1) (IsEquiv f)).
    intros A B f.
    rewrite <- subuniverse_iff_O.
    simple refine (isequiv_adjointify _ _ _ _).
    - intro H.
      simple refine (isequiv_adjointify _ _ _ _).
      + intro x. revert H.
        apply O_rec. intro H. simpl in H.
        exact (f^-1 x).
      + intro X.
        revert H. simpl.
        pose (shf := λ H, Build_subuniverse_Type (n.+1) subU (BuildTruncType (n.+1) (f
     (O_rec n.+1 subU
        {|
        trunctype_type := IsEquiv f;
        istrunc_trunctype_type := trunc_prop A B f |} A
        (λ H0 : IsEquiv f, f^-1 X) H) = X)) _).
        simple refine (O_rec_dep _ shf _).1.
        unfold shf; clear shf; simpl.
        intro H.
        pose (rew := λ P Q f, ap10 (O_rec_retr (n.+1) subU P Q f)).
        rewrite rew. rewrite eisretr. reflexivity.
      + intro X.
        revert H; simpl.
        pose (shf := λ H, Build_subuniverse_Type (n.+1) subU (BuildTruncType (n.+1) (O_rec n.+1 subU
                                                                                {|
                                                                                trunctype_type := IsEquiv f;
                                                                                istrunc_trunctype_type := trunc_prop A B f |} A
                                                                                (λ H0 : IsEquiv f, f^-1 (f X)) H = X)) _).

        simple refine (O_rec_dep _ shf _).1.
        unfold shf; clear shf; simpl.
        intro H.
        pose (rew := λ P Q f, ap10 (O_rec_retr (n.+1) subU P Q f)).
        rewrite rew. rewrite eissect. reflexivity.
    - intro X.
      simple refine (path_ishprop _ _).
      transparent assert (hp : hProp).
      { exists (IsEquiv f). apply hprop_isequiv. }
      exact (hprop_stability (mod := mod) hp (trunc_prop A B f)).
    - intro X.
      simple refine (path_ishprop _ _).
    - exact ua. - exact fs.
  Qed.

End Preliminary.

Section LexModality.

  Context `{ua: Univalence}.
  Context `{fs: Funext}.

  Definition IsLex {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod)
    := forall (A:TruncType (trunc_S n)), forall (x y:A),
         Contr (O subU A) -> Contr (O subU (BuildTruncType (n.+1) (x=y))).

  Lemma IsHProp_IsLex {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod)
  : IsHProp (IsLex mod).
    simple refine trunc_forall.
  Defined.

  Lemma O_contr_sigma {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod) {A : TruncType n.+1} {B : A -> TruncType n.+1}
        (contrA : Contr (O subU A))
        (contrB : forall a, Contr (O subU (B a)))
        (trΣ : IsTrunc n.+1 {a:A & (B a)})
  : Contr (O subU (BuildTruncType _ {a:A & (B a)})).
    simple refine (BuildContr _ _ _).
    - generalize (center (O subU A)).
      apply O_rec; intro a.
      generalize (center (O subU (B a))).
      apply O_rec; intro b.
      apply O_unit.
      exists a. exact b.
    - transparent assert (shf : ((O subU (BuildTruncType _ {a:A & (B a)})) -> subuniverse_Type subU)).
      { intro y. simple refine (Build_subuniverse_Type _ subU (BuildTruncType _ (O_rec n.+1 subU A
     (O subU
        {| trunctype_type := ∃ a : A, B a; istrunc_trunctype_type := trΣ |})
     (λ a : A,
      O_rec n.+1 subU (B a)
        (O subU
           {|
           trunctype_type := ∃ a0 : A, B a0;
           istrunc_trunctype_type := trΣ |})
        (λ b : B a,
         O_unit subU
           {|
           trunctype_type := ∃ a0 : A, B a0;
           istrunc_trunctype_type := trΣ |} (a; b))
        (center (O subU (B a)))) (center (O subU A)) = y))  _). }
      simple refine (O_rec_dep _ shf _).1.
      unfold shf; clear shf; intros [a b]; simpl.

      assert (X : (center (O subU A)) = O_unit subU A a) by apply contr.
      rewrite X; clear X.
      pose (rew := λ P Q f, ap10 (O_rec_retr (n.+1) (subU) P Q f)).
      rewrite rew.

      assert (X : (center (O subU (B a))) = O_unit subU (B a) b) by apply contr.
      rewrite X; clear X.
      rewrite rew.
      reflexivity.
  Qed.

  (* Lemma 14 *)
  Definition IsLex_contr_fibers {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod) (islex : IsLex mod) {A B:TruncType n.+1} (f : A -> B) (contrA : Contr (O subU A)) (contrB : Contr (O subU B))
  : forall y:B, Contr (O subU (BuildTruncType (n.+1) (hfiber f y))).
  Proof.
    intro y.
    simple refine (@O_contr_sigma _ mod A (λ x, (BuildTruncType _ (f x = y))) _ _ _).
    (* exact contrA. *)
    intro a.
    (* assert (rew : trunc_succ (istrunc_paths B.2 (f a) y) = istrunc_paths (trunc_succ B.2) (f a) y) by apply path_ishprop. *)
    (* rewrite <- rew; clear rew. *)
    exact (islex B (f a) y contrB).
  Qed.

  Lemma islex_compat_func {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod) (X Y:TruncType n.+1) (f: X -> Y) (y:Y)
  : forall a:{a:X & f a = y}, (function_lift _ subU X Y f (O_unit subU _ a.1) = O_unit subU Y y).
    intros a. simpl.
    pose (foo := ap10 (O_rec_retr _ subU X (O subU Y) (λ x : X, O_unit subU Y (f x))) a.1).
    exact (transport (λ U, O_rec _ subU X (O subU Y) (λ x : X, O_unit subU Y (f x)) (O_unit subU X a.1) = O_unit subU Y U) a.2 foo).
  Defined.

  (* Proposition 12 *)
  Lemma islex_to_hfibers_preservation {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod) (islex : IsLex mod)
  : forall (X Y:TruncType n.+1) (f : X -> Y) (y:Y), trunctype_type (@st _ subU (O subU (BuildTruncType _ (hfiber f y)))) = {rx : (O subU X) & function_lift _ subU X Y f rx = O_unit subU Y y}.
    intros X Y f y.
    apply path_universe_uncurried.
    simple refine (modal_contr_modal_is_equiv _
                                       mod
                                       (BuildTruncType _ (hfiber f y))
                                       (Build_subuniverse_Type _ subU (BuildTruncType (n.+1) (∃ rx : O subU X, function_lift n.+1 subU X Y f rx = O_unit subU Y y)) _)
                                       _ _).
    exact (subu_sigma _ mod (O subU X) (λ rx, Build_subuniverse_Type _ subU (BuildTruncType _ (function_lift n.+1 subU X Y f rx = O_unit subU Y y)) _)).
    cbn.
    - exact (@functor_hfiber _ _ _ _
               f
               (O_rec _ subU X (O subU Y) (O_unit subU Y o f))
               (O_unit subU X)
               (O_unit subU Y)
               (λ a, (ap10 (O_rec_retr _ subU X (O subU Y) (O_unit subU Y o f)) a)^)
               y
            ).
    - intros [rx p]. fold subU.
      pose (T' :=
              {z : (hfiber (O_unit subU X) rx) &
                   (@functor_hfiber _ _ _ _
                                    (O_unit subU X)
                                    (O_unit subU Y)
                                    f
                                    (O_rec _ subU X (O subU Y) (O_unit subU Y o f))
                                    (λ a, (ap10 (O_rec_retr _ subU X (O subU Y) (O_unit subU Y o f)) a))
                                    rx) z = (y;p^)}).
      assert (TrT': IsTrunc n.+1 T').
      { unfold T'.
        simple refine (trunc_sigma (n:=n.+1) _ _). }

      pose (oT' := O subU (BuildTruncType _ T')).
      simple refine (contr_equiv' oT' _).
      apply function_lift_equiv'. exact fs. apply equiv_inverse. simpl.
      unfold T', hfiber, functor_hfiber; simpl.
      apply equiv_path.
      pose
        (q := @hfiber_functor_hfiber _ _ _ _
                                     f
                                     (O_rec _ subU X (O subU Y) (O_unit subU Y o f))
                                     (O_unit subU X)
                                     (O_unit subU Y)
                                     (λ a, (ap10 (O_rec_retr _ subU X (O subU Y) (O_unit subU Y o f)) a)^)
                                     y
                                     rx
                                     p).
      etransitivity; try exact (path_universe_uncurried q). clear q.
      apply path_universe_uncurried.
      apply equiv_functor_sigma_id. intro a.
      unfold functor_hfiber.
      match goal with
      |[|- functor_sigma _ ?pp _ = _ <~> functor_sigma _ ?qq _ = _ ]
       => assert (rew: pp = qq)
      end.
      funext. hott_simpl.
      destruct rew.
      apply equiv_path; reflexivity.
      unfold oT', T'. simpl.
      unfold IsLex in islex.
      assert (rew :trunc_sigma
                                            (istrunc_trunctype_type
                                               {|
                                               trunctype_type := hfiber
                                                  (O_unit subU X) rx;
                                               istrunc_trunctype_type := trunc_sigma
                                                  (istrunc_trunctype_type X)
                                                  (λ
                                                  a : X,
                                                  istrunc_paths
                                                  (trunc_succ
                                                  (istrunc_trunctype_type
                                                  (O subU X)))
                                                  (O_unit subU X a) rx) |})
                                            (λ
                                             a : {|
                                                 trunctype_type := hfiber
                                                  (O_unit subU X) rx;
                                                 istrunc_trunctype_type := trunc_sigma
                                                  (istrunc_trunctype_type X)
                                                  (λ
                                                  a : X,
                                                  istrunc_paths
                                                  (trunc_succ
                                                  (istrunc_trunctype_type
                                                  (O subU X)))
                                                  (O_unit subU X a) rx) |},
                                             istrunc_paths
                                               (trunc_succ
                                                  (istrunc_trunctype_type
                                                  {|
                                                  trunctype_type := hfiber
                                                  (O_unit subU Y)
                                                  (O_rec n.+1 subU X
                                                  (O subU Y)
                                                  (O_unit subU Y o f) rx);
                                                  istrunc_trunctype_type := trunc_sigma
                                                  (istrunc_trunctype_type Y)
                                                  (λ
                                                  a0 : Y,
                                                  istrunc_paths
                                                  (trunc_succ
                                                  (istrunc_trunctype_type
                                                  (O subU Y)))
                                                  (O_unit subU Y a0)
                                                  (O_rec n.+1 subU X
                                                  (O subU Y)
                                                  (λ
                                                  x : X,
                                                  O_unit subU Y (f x)) rx)) |}))
                                               (functor_hfiber
                                                  (λ
                                                  a0 : X,
                                                  ap10
                                                  (O_rec_retr n.+1 subU X
                                                  (O subU Y)
                                                  (λ
                                                  x : X,
                                                  O_unit subU Y (f x))) a0)
                                                  rx a)
                                               (y; p^)) = TrT') by apply path_ishprop.
      rewrite <- rew; clear rew.
      simple refine (@IsLex_contr_fibers _ mod
                                 islex
                                 (BuildTruncType _ (hfiber (O_unit subU X) rx))
                                 (BuildTruncType _ (hfiber (O_unit subU Y) (O_rec _ subU X (O subU Y) (O_unit subU Y o f) rx)))
                                 (functor_hfiber
                                        (λ a : X,
                                               ap10
                                                 (O_rec_retr n.+1 subU X
                                                             (O subU Y) (λ x : X, O_unit subU Y (f x)))
                                                 a) rx)
                                 _ _
                                 (y;p^)).

      exact (O_unit_O_contr_fibers mod X _ rx).
      exact (O_unit_O_contr_fibers mod Y _ (O_rec _ subU X (O subU Y) (O_unit subU Y o f) rx)).
  Defined.

  (* Proposition 12 *)
  Lemma islex_to_hfibers_preservation_compat {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod) (islex : IsLex mod)
  : forall (X Y:TruncType n.+1) (f: X -> Y) (y:Y) (a:{a:X & f a = y}),
      ((equiv_path _ _ (islex_to_hfibers_preservation mod islex X Y f y)) o (O_unit subU _)) a = (O_unit subU _ a.1; islex_compat_func mod X Y f y a).
    simpl. intros X Y f y a.
    unfold islex_to_hfibers_preservation; simpl.
    unfold modal_contr_modal_is_equiv.
    unfold equiv_adjointify.
    rewrite transport_path_universe_uncurried.
    cbn.
    pose (rew := λ P Q f, ap10 (O_rec_retr (n.+1) subU P Q f)).
    rewrite rew; clear rew.
    apply path_sigma' with 1. simpl. unfold islex_compat_func.
    simpl.
    rewrite transport_paths_FlFr.
    rewrite ap_const.
    hott_simpl.
  Qed.

  Lemma path_subuniverse_type {n:trunc_index} (mod:Modality (trunc_S n)) (subU := underlying_subu (trunc_S n) mod) (islex : IsLex mod) (X Y:subuniverse_Type subU)
    : IsSubu _ subU (BuildTruncType _ (X <~> Y)).
  Proof.
    rewrite <- subuniverse_iff_O; try assumption.
    transparent assert (FF: (O subU
     {| trunctype_type := X <~> Y; istrunc_trunctype_type := istrunc_equiv |}
                             → X <~> Y)).
    { intro p.
      simple refine (equiv_adjointify _ _ _ _).
      + intro x. revert p. apply O_rec.
        intro e. exact (e x).
      + intro y. revert p. apply O_rec.
        intro e. exact (e^-1 y).
      + intro y. cbn. revert p.
        pose (Helper := ((O subU (BuildTruncType _ (X <~> Y))) -> subuniverse_Type subU)).
        transparent assert (shf: Helper).
        { subst Helper.
          intro p.
          simple refine (Build_subuniverse_Type _ _ (BuildTruncType _ (O_rec n.+1 subU
                                                                      {| trunctype_type := X <~> Y; istrunc_trunctype_type := istrunc_equiv |}
                                                                      Y
                                                                      (λ e : X <~> Y,
                                                                             e
                                                                               (O_rec n.+1 subU
                                                                                {|
                                                                                trunctype_type := X <~> Y;
                                                                                istrunc_trunctype_type := istrunc_equiv |} X
                                                                                (λ e0 : X <~> Y, e0^-1 y) p)) p = y)) _). }
        simple refine (O_rec_dep _ shf _).1.
        subst Helper; subst shf; cbn.
        intro e.
        do 2 rewrite (λ P Q f, ap10 (O_rec_retr _ subU P Q f)).
        apply eisretr.
      + intro x. cbn. revert p.
        pose (Helper := ((O subU (BuildTruncType _ (X <~> Y))) -> subuniverse_Type subU)).
        transparent assert (shf: Helper).
        { subst Helper.
          intro p.
          simple refine (Build_subuniverse_Type _ _ (BuildTruncType _ (O_rec n.+1 subU
                                                                      {| trunctype_type := X <~> Y; istrunc_trunctype_type := istrunc_equiv |}
                                                                      X
                                                                      (λ e : X <~> Y,
                                                                             e^-1
                                                                              (O_rec n.+1 subU
                                                                                {|
                                                                                trunctype_type := X <~> Y;
                                                                                istrunc_trunctype_type := istrunc_equiv |} Y
                                                                                (λ e0 : X <~> Y, e0 x) p)) p = x)) _). }
        simple refine (O_rec_dep _ shf _).1.
        subst Helper; subst shf; cbn.
        intro e.
        do 2 rewrite (λ P Q f, ap10 (O_rec_retr _ subU P Q f)).
        apply eissect. }
    simple refine (isequiv_adjointify _ FF _ _).
    - unfold Sect.
      simple refine (O_rec_dep _ (λ x, Build_subuniverse_Type _ _ (BuildTruncType _ (O_unit subU
     {| trunctype_type := X <~> Y; istrunc_trunctype_type := istrunc_equiv |}
     (FF x) = x)) _) _).1.
      cbn.
      intro x. apply ap. subst FF. cbn.
      apply path_equiv. cbn.
      apply path_forall; intro y.
      apply (λ P Q f, ap10 (O_rec_retr _ subU P Q f)).
    - intro e.
      apply path_equiv. cbn.
      apply path_forall; intro y.
      apply (λ P Q f, ap10 (O_rec_retr _ subU P Q f)).
  Defined.
End LexModality.


(*|
###########################################
Returning a record from a definition in Coq
###########################################

:Link: https://stackoverflow.com/q/45650879
|*)

(*|
Question
********

Suppose I've got a ``record`` that contains two ``nat``\ s.
|*)

Record toy := {
    num1 : nat;
    num2 : nat
  }.

(*|
I want to build a definition that given two ``nat``\ s returns a
``record`` containing those two ``nat``\ s.

.. code-block:: coq

    Definition args_to_toy_record (n1 : nat) (n2 : nat) : toy :=
      (* { num1 = n1; num2 = n2} ?? *)

Unfortunately, the official documentation only seems to cover the
simpler cases when the return type is a ``bool`` or a ``nat``. Is such
a thing possible in coq? If yes, what is the best method to achieve
it?
|*)

(*|
Answer
******

You had it almost right. You just need slightly different syntax:
|*)

Reset Initial. (* .none *)
Record toy := {
    num1 : nat;
    num2 : nat
  }.

Definition args_to_toy_record (n1 : nat) (n2 : nat) : toy :=
  {| num1 := n1; num2 := n2 |}.

(*|
Alternatively, you can use regular constructor syntax. Every record
``toto`` in Coq is declared as an inductive (sometimes, coinductive)
type with a single constructor ``Build_toto``, whose arguments are
exactly the fields of the record:
|*)

Reset args_to_toy_record. (* .none *)
Definition args_to_toy_record (n1 : nat) (n2 : nat) : toy :=
  Build_toy n1 n2.

(*|
You can also name the record constructor explicitly, like this:
|*)

Reset Initial. (* .none *)
Record toy := Toy {
                 num1 : nat;
                 num2 : nat
               }.

Definition args_to_toy_record (n1 : nat) (n2 : nat) : toy :=
  Toy n1 n2.


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.Solidity.stdTypes.

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

Require Import CommonQCEnvironment.
Require Import LocalState.VestingPool.

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

#[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.

Require Import VestingPool.VestingPool.
Import VestingPoolContract.
(* ContractLRecord *)

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

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

#[global]
Instance Contract_GenSized: GenSized ContractLRecord.
refine GenSizedxprod.
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 LocalStateLRecord) | 0.
refine Showxprod.
Defined.

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

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

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

#[global] Instance LedgerEq_Dec: forall (l1 l2: LedgerLRecord LocalStateLRecord), 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.


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

End FOFProblem.


Require Import Coq.Logic.FunctionalExtensionality Coq.Arith.EqNat Coq.MSets.MSets Coq.Vectors.Vector Names Sets Fun Config.

Reserved Notation "ns ';' f '|-' p" (at level 40).

Inductive typing : NameSets.t -> Fun.temp_name_mapping -> config -> Prop :=
  | NIL : NameSets.empty ; Fun.empty |- nil
  | MSG : forall x y, NameSets.empty ; Fun.empty |- send x y
  | ACT_empty : forall p x y, (* x /= y? *)
                  NameSets.empty ; Fun.empty |- p ->
                  NameSets.singleton x ; Fun.ch_1 x |- create x y p
  | ACT_x : forall p x y,
              NameSets.singleton x ; Fun.ch_1 x |- p ->
              x <> y ->
              NameSets.singleton x ; Fun.ch_1 x |- create x y p
  | ACT_z : forall p x y z,
              NameSets.singleton z ; Fun.ch_1 z |- p ->
              x <> z ->
              y <> z ->
              NameSets.add x (NameSets.singleton z) ; Fun.ch_2 x z |- create x y p
  | ACT_xz : forall p x y z,
               NameSets.add x (NameSets.singleton z) ; Fun.ch_2 x z |- p ->
               x <> z ->
               x <> y ->
               y <> z ->
               NameSets.add x (NameSets.singleton z) ; Fun.ch_2 x z |- create x y p
  | COMP : forall ns1 ns2 f1 f2 p1 p2,
             ns1 ; f1 |- p1 ->
             ns2 ; f2 |- p2 ->
             NameSets.Empty (NameSets.inter ns1 ns2) ->
             NameSets.union ns1 ns2 ; Fun.fun_plus f1 f2 |- compose p1 p2
  | RES : forall ns f p x,
            ns ; f |- p ->
            NameSets.remove x ns ; Fun.fun_remove f x |- restrict x p
  | CASE_nil : forall x, NameSets.empty ; Fun.empty |- caseof x List.nil
  | CASE_cons : forall ns ns' f f' p x y l,
                  ns ; f |- p ->
                  ns' ; f' |- caseof x l ->
                  Fun.Compatible f f' ->
                  NameSets.union ns ns' ; Fun.fun_plus f f' |- caseof x ((y, p) :: l)
  | INST_1 : forall n u v z p x y,
               NameSets.singleton u ; Fun.ch_1 u |- create u z p ->
               NameSets.singleton x ; Fun.ch_1 x |- instantiate_1 n u v z p x y
  | INST_2 : forall n u1 u2 v z p x1 x2 y,
               NameSets.add u1 (NameSets.singleton u2) ; Fun.ch_2 u1 u2 |- create u1 z p ->
               x1 <> x2 ->
               NameSets.add x1 (NameSets.singleton x2) ; Fun.ch_2 x1 x2 |- instantiate_2 n u1 u2 v z p x1 x2 y
  where "ns ';' f '|-' p" := (typing ns f p).

Hint Constructors typing.

Goal exists (ns : NameSets.t) (f : Fun.temp_name_mapping), ns ; f |- create (name_cons 0) (name_cons 1) nil.
Proof.
  exists (NameSets.singleton (name_cons 0)).
  exists (fun x => match x with
                     | name_cons 0 => Some star_bottom
                     | _ => None
                   end).

  replace (fun x : name => match x with
                             | name_cons 0 => Some star_bottom
                             | name_cons (S _) => None
                           end)
          with (Fun.ch_1 (name_cons 0)).
  eapply ACT_empty.
  apply NIL.
  apply functional_extensionality.
  intro.
  unfold Fun.ch_1.
  compute.
  destruct x.
  induction n.
    auto.
    auto.
Qed.

Goal forall (ns : NameSets.t) (f : Fun.temp_name_mapping),
       ~ ns ; f |- compose (create (name_cons 0) (name_cons 1) nil) (create (name_cons 0) (name_cons 2) nil).
Proof.
  unfold not.
  intros.
  assert (forall x, ~ NameSets.Empty (NameSets.singleton x)).
    unfold NameSets.Empty, not; intros.
    apply H0 with x.
    apply NameSets.F.singleton_2; auto.
    destruct x; auto.
  inversion H; subst.
  inversion H3; subst.
    inversion H6; subst.
      apply inter_not_empty in H7; auto.

      apply inter_not_empty in H7; auto.

      inversion H10.

      inversion H8.
      symmetry in H4; apply Fun.ch_2_not_empty in H4; auto.
    inversion H6; subst.
      apply inter_not_empty in H7; auto.

      apply inter_not_empty in H7; auto.

      inversion H11.

      inversion H5.
      symmetry in H4; apply Fun.ch_2_not_empty in H4; auto.
    inversion H6; subst.
      inversion H9.

      inversion H9.

      inversion H9.

      inversion H9.
    inversion H6; subst.
      inversion H5.
      symmetry in H4; apply Fun.ch_2_not_empty in H4; auto.

      inversion H5.
      symmetry in H4; apply Fun.ch_2_not_empty in H4; auto.

      inversion H5.
      symmetry in H4; apply Fun.ch_2_not_empty in H4; auto.

      inversion H5.
      symmetry in H4; apply Fun.ch_2_not_empty in H4; auto.
Qed.

Lemma typing_in_domain_1 : forall ns f p (ty : ns ; f |- p) x,
                        Fun.in_domain f x ->
                        NameSets.mem x ns = true.
Proof.
  intros.
  induction ty.
    unfold Fun.in_domain in H.
    compute in H.
    auto.

    unfold Fun.in_domain in H.
    compute in H.
    auto.

    apply Fun.ch_1_in_domain in H.
    rewrite H.
    apply NameSets.EP.singleton_mem_1.

    apply Fun.ch_1_in_domain in H.
    rewrite H.
    apply NameSets.EP.singleton_mem_1.

    apply Fun.ch_2_in_domain in H.
    inversion H.
      rewrite H2.
      apply NameSets.EP.add_mem_1.

      rewrite <- H2.
      erewrite NameSets.EP.add_mem_2.
        apply NameSets.EP.singleton_mem_1.
        destruct x0, z.
        intro.
        apply H0.
        rewrite H3; auto.

    apply Fun.ch_2_in_domain in H.
    inversion H.
      rewrite H3.
      apply NameSets.EP.add_mem_1.
      rewrite <- H3.
      erewrite NameSets.EP.add_mem_2.
        apply NameSets.EP.singleton_mem_1.
        destruct x0, z.
        intro.
        apply H0.
        rewrite H4; auto.

    apply Fun.fun_plus_in_domain in H.
    apply NameSets.F.mem_iff.
    apply mem_union.
    inversion H.
      apply IHty1 in H1.
      apply NameSets.F.mem_iff in H1.
      left; apply H1.

      apply IHty2 in H1.
      apply NameSets.F.mem_iff in H1.
      right; apply H1.

    apply Fun.fun_remove_in_domain_2 in H.
    inversion_clear H.
    apply IHty in H1.
    rewrite NameSets.EP.remove_mem_2.
      auto.
      destruct x0, x.
      intro.
      apply H0.
      rewrite H.
      auto.

    exfalso; apply H; auto.

    apply Fun.fun_plus_in_domain in H.
    apply NameSets.F.mem_iff.
    apply mem_union.
    inversion H.
      apply IHty1 in H1.
      apply NameSets.F.mem_iff in H1.
      left; auto.

      apply IHty2 in H1.
      apply NameSets.F.mem_iff in H1.
      right; auto.

    apply Fun.ch_1_in_domain in H.
    rewrite H.
    apply NameSets.EP.singleton_mem_1.

    apply Fun.ch_2_in_domain in H.
    inversion H.
      rewrite H1.
      apply NameSets.EP.add_mem_1.

      rewrite <- H1.
      erewrite NameSets.EP.add_mem_2.
        apply NameSets.EP.singleton_mem_1.
        destruct x1, x2.
        intro.
        apply H0.
        rewrite H2; auto.
Qed.

Lemma typing_in_domain_2 : forall ns f p (ty : ns ; f |- p) x,
                        NameSets.mem x ns = true ->
                        Fun.in_domain f x.
Proof.
  intros.

  assert (forall P : Prop, P -> ~~P).
    intro.
    intro.
    intro.
    apply H1.
    auto.

  unfold Fun.in_domain.
  intro.
  induction ty.
    rewrite NameSets.EP.empty_mem in H.
    discriminate.

    rewrite NameSets.EP.empty_mem in H.
    discriminate.

    unfold Fun.ch_1 in H1.
    destruct (beq_name x0 x) eqn:?.
      discriminate.
      apply beq_name_false_iff in Heqb.
      apply Heqb.
      apply NameSets.EP.singleton_mem_3 in H.
      destruct x0, x.
      auto.

    unfold Fun.ch_1 in H1.
    destruct (beq_name x0 x) eqn:?.
      discriminate.
      apply beq_name_false_iff in Heqb.
      apply Heqb.
      apply NameSets.EP.singleton_mem_3 in H.
      destruct x0, x.
      auto.

    unfold Fun.ch_2 in H1.
    destruct (beq_name x0 x) eqn:?.
      discriminate.
      destruct (beq_name z x) eqn:?.
        discriminate.
        apply beq_name_false_iff in Heqb.
        apply beq_name_false_iff in Heqb0.
        rewrite NameSets.EP.add_mem_2 in H.
          apply NameSets.EP.singleton_mem_3 in H.
          destruct z, x, x0.
          rewrite H in Heqb0.
          auto.

          destruct x, x0.
          intro.
          rewrite H4 in Heqb.
          auto.

    unfold Fun.ch_2 in H1.
    destruct (beq_name x0 x) eqn:?.
      discriminate.
      destruct (beq_name z x) eqn:?.
        discriminate.
        apply beq_name_false_iff in Heqb.
        apply beq_name_false_iff in Heqb0.
        rewrite NameSets.EP.add_mem_2 in H.
          apply NameSets.EP.singleton_mem_3 in H.
          destruct z, x, x0.
          rewrite H in Heqb0.
          auto.

          destruct x, x0.
          intro.
          rewrite H5 in Heqb.
          auto.

    rewrite NameSets.EP.union_mem in H.
    apply orb_true_iff in H.
    inversion H.
      apply IHty1 in H3.
        auto.
        apply H0 in H1.
        apply Fun.fun_plus_not_in_domain in H1.
        inversion H1.
        unfold Fun.in_domain in H4.
        destruct (f1 x).
          exfalso; apply H4; intro; discriminate.
          auto.
      apply IHty2 in H3.
        auto.
        apply H0 in H1.
        apply Fun.fun_plus_not_in_domain in H1.
        inversion H1.
        unfold Fun.in_domain in H5.
        destruct (f2 x).
          exfalso; apply H5; intro; discriminate.
          auto.

    apply H0 in H1.
    apply Fun.fun_remove_not_in_domain_2 in H1.
    inversion H1.
    rewrite <- H2 in H.
    rewrite NameSets.EP.remove_mem_1 in H.
    discriminate.
    apply NameSets.EP.remove_mem_3 in H.
    apply IHty in H.
      auto.
      unfold Fun.in_domain in H2.
      destruct (f x).
        exfalso; apply H2; intro; discriminate.
        auto.

    apply NameSets.F.empty_iff with x.
    apply NameSets.F.mem_iff; auto.

    rewrite NameSets.EP.union_mem in H.
    apply orb_true_iff in H.
    inversion H.
      apply IHty1 in H3; auto.
      apply H0 in H1.
      apply Fun.fun_plus_not_in_domain in H1.
      inversion H1.
      unfold Fun.in_domain in H4.
      destruct (f x).
        exfalso; apply H4; intro; discriminate.
        auto.
      apply IHty2 in H3; auto.
      apply H0 in H1.
      apply Fun.fun_plus_not_in_domain in H1.
      inversion H1.
      unfold Fun.in_domain in H5.
      destruct (f' x).
        exfalso; apply H5; intro; discriminate.
        auto.

    unfold Fun.ch_1 in H1.
    destruct (beq_name x0 x) eqn:?.
      discriminate.
      apply beq_name_false_iff in Heqb.
      apply Heqb.
      apply NameSets.EP.singleton_mem_3 in H.
      destruct x0, x.
      auto.

    unfold Fun.ch_2 in H1.
    destruct (beq_name x1 x) eqn:?.
      discriminate.
      destruct (beq_name x2 x) eqn:?.
        discriminate.
        apply beq_name_false_iff in Heqb.
        apply beq_name_false_iff in Heqb0.
        rewrite NameSets.EP.add_mem_2 in H.
          apply NameSets.EP.singleton_mem_3 in H.
          destruct x, x1, x2.
          rewrite H in Heqb0.
          auto.

          destruct x1, x.
          intro.
          rewrite H3 in Heqb.
          auto.
Qed.

Lemma typing_in_range_in_domain : forall ns f p (ty : ns ; f |- p), Fun.in_range_in_domain f.
Proof.
  intros.
  induction ty.
    apply Fun.ch_0_in_range_in_domain.

    apply Fun.ch_0_in_range_in_domain.

    apply Fun.ch_1_in_range_in_domain.

    apply Fun.ch_1_in_range_in_domain.

    apply Fun.ch_2_in_range_in_domain; auto.

    apply Fun.ch_2_in_range_in_domain; auto.

    apply Fun.fun_plus_in_range_in_domain; auto.

    apply Fun.fun_remove_in_range_in_domain; auto.

    apply Fun.ch_0_in_range_in_domain.

    apply Fun.fun_plus_in_range_in_domain; auto.

    apply Fun.ch_1_in_range_in_domain.

    apply Fun.ch_2_in_range_in_domain; auto.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e384m317_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e384m317_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime P : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Aprime Bprime /\ (wd_ Bprime Cprime /\ (wd_ Aprime Cprime /\ (wd_ Bprime Cprime /\ (wd_ Cprime P /\ (wd_ Bprime P /\ (col_ Bprime Cprime P /\ col_ P Aprime Cprime)))))))))) -> col_ Aprime Bprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import ssreflect ssrfun ssrbool.
Require Import Generic.lemmas.
Require Import PG32.pg32_inductive.
Require Import List.
Require Import PG32.pg32_spreads_packings PG32.pg32_packings.

Import ListNotations.

Require Import PG32.pg32_packings_part1 PG32.pg32_packings_part2 PG32.pg32_packings_part3 PG32.pg32_packings_part4 PG32.pg32_packings_part5 PG32.pg32_packings_part6.

Lemma abcdef_bool_lr : forall x y z t u v,
    x && y && z && t && u && v -> x /\y /\ z /\ t /\ u /\ v.
Proof.
  intros x y z t u v Hv'.
  destruct  (and_bool_lr _ _ Hv') as [Hu' Hv].
  destruct (and_bool_lr _ _ Hu') as [Ht' Hu].
  destruct (and_bool_lr _ _ Ht') as [Hz' Ht].
  destruct (and_bool_lr _ _ Hz') as [Hy' Hz].
  destruct (and_bool_lr _ _ Hy') as [Hx Hy].
  repeat split; assumption.
Qed.

Lemma is_packing_descr_B :
  forall s1 s2 s3 s4 s5 s6 s7 : list Line,
    ltS s1 s2 && ltS s2 s3 && ltS s3 s4 && ltS s4 s5 && ltS s5 s6 && ltS s6 s7 ->
    In s1 spreads -> In s2 spreads -> In s3 spreads -> In s4 spreads ->
    In s5 spreads -> In s6 spreads -> In s7 spreads ->
    (is_packing7 s1 s2 s3 s4 s5 s6 s7) -> In [s1;s2;s3;s4;s5;s6;s7] packings.
Proof.
  intros s1 s2 s3 s4 s5 s6 s7 Hlt Hs1 Hs2 Hs3 Hs4 Hs5 Hs6 Hs7 His.
  decompose [and] (abcdef_bool_lr _ _ _ _ _ _ Hlt); clear Hlt;
    decompose [or] (In_spreads_decomp s1 Hs1); clear Hs1; subst s1.
  apply aux_S0; assumption.
  apply aux_S1; assumption.
  apply aux_S2; assumption.
  apply aux_S3; assumption.
  apply aux_S4; assumption.
  apply aux_S5; assumption.
  apply aux_S6; assumption.
  apply aux_S7; assumption.
  apply aux_S8; assumption.
  apply aux_S9; assumption.
  apply aux_S10; assumption.
  apply aux_S11; assumption.
  apply aux_S12; assumption.
  apply aux_S13; assumption.
  apply aux_S14; assumption.
  apply aux_S15; assumption.
  apply aux_S16; assumption.
  apply aux_S17; assumption.
  apply aux_S18; assumption.
  apply aux_S19; assumption.
  apply aux_S20; assumption.
  apply aux_S21; assumption.
  apply aux_S22; assumption.
  apply aux_S23; assumption.
  apply aux_S24; assumption.
  apply aux_S25; assumption.
  apply aux_S26; assumption.
  apply aux_S27; assumption.
  apply aux_S28; assumption.
  apply aux_S29; assumption.
  apply aux_S30; assumption.
  apply aux_S31; assumption.
  apply aux_S32; assumption.
  apply aux_S33; assumption.
  apply aux_S34; assumption.
  apply aux_S35; assumption.
  apply aux_S36; assumption.
  apply aux_S37; assumption.
  apply aux_S38; assumption.
  apply aux_S39; assumption.
  apply aux_S40; assumption.
  apply aux_S41; assumption.
  apply aux_S42; assumption.
  apply aux_S43; assumption.
  apply aux_S44; assumption.
  apply aux_S45; assumption.
  apply aux_S46; assumption.
  apply aux_S47; assumption.
  apply aux_S48; assumption.
  apply aux_S49; assumption.
  apply aux_S50; assumption.
  apply aux_S51; assumption.
  apply aux_S52; assumption.
  apply aux_S53; assumption.
  apply aux_S54; assumption.
  apply aux_S55; assumption.
Qed.

(* main theorem *)
Lemma is_packing_descr : forall s1 s2 s3 s4 s5 s6 s7 : list Line,
    ltS s1 s2 && ltS s2 s3 && ltS s3 s4 && ltS s4 s5 && ltS s5 s6 && ltS s6 s7 ->
    In s1 spreads -> In s2 spreads -> In s3 spreads -> In s4 spreads ->
    In s5 spreads -> In s6 spreads -> In s7 spreads ->
    (is_packing7 s1 s2 s3 s4 s5 s6 s7) <-> In [s1;s2;s3;s4;s5;s6;s7] packings.
Proof.
  intros; split; [apply is_packing_descr_B ; assumption| apply is_packing_descr_A].
Qed.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
Set Implicit Arguments.

Section PACO3.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.

(** ** Signatures *)

Record sig3T  :=
  exist3T {
      proj3T0: @T0;
      proj3T1: @T1 proj3T0;
      proj3T2: @T2 proj3T0 proj3T1;
    }.
Definition uncurry3  (R: rel3 T0 T1 T2): rel1 sig3T :=
  fun x => R (proj3T0 x) (proj3T1 x) (proj3T2 x).
Definition curry3  (R: rel1 sig3T): rel3 T0 T1 T2 :=
  fun x0 x1 x2 => R (@exist3T x0 x1 x2).

Lemma uncurry_map3 r0 r1 (LE : r0 <3== r1) : uncurry3 r0 <1== uncurry3 r1.
Proof. intros [] H. apply LE. apply H. Qed.

Lemma uncurry_map_rev3 r0 r1 (LE: uncurry3 r0 <1== uncurry3 r1) : r0 <3== r1.
Proof.
  red; intros. apply (LE (@exist3T x0 x1 x2) PR).
Qed.

Lemma curry_map3 r0 r1 (LE: r0 <1== r1) : curry3 r0 <3== curry3 r1.
Proof.
  red; intros. apply (LE (@exist3T x0 x1 x2) PR).
Qed.

Lemma curry_map_rev3 r0 r1 (LE: curry3 r0 <3== curry3 r1) : r0 <1== r1.
Proof.
  intros [] H. apply LE. apply H.
Qed.

Lemma uncurry_bij1_3 r : curry3 (uncurry3 r) <3== r.
Proof. unfold le3. intros. apply PR. Qed.

Lemma uncurry_bij2_3 r : r <3== curry3 (uncurry3 r).
Proof. unfold le3. intros. apply PR. Qed.

Lemma curry_bij1_3 r : uncurry3 (curry3 r) <1== r.
Proof. intros [] H. apply H. Qed.

Lemma curry_bij2_3 r : r <1== uncurry3 (curry3 r).
Proof. intros [] H. apply H. Qed.

Lemma uncurry_adjoint1_3 r0 r1 (LE: uncurry3 r0 <1== r1) : r0 <3== curry3 r1.
Proof.
  apply uncurry_map_rev3. eapply le1_trans; [apply LE|]. apply curry_bij2_3.
Qed.

Lemma uncurry_adjoint2_3 r0 r1 (LE: r0 <3== curry3 r1) : uncurry3 r0 <1== r1.
Proof.
  apply curry_map_rev3. eapply le3_trans; [|apply LE]. apply uncurry_bij2_3.
Qed.

Lemma curry_adjoint1_3 r0 r1 (LE: curry3 r0 <3== r1) : r0 <1== uncurry3 r1.
Proof.
  apply curry_map_rev3. eapply le3_trans; [apply LE|]. apply uncurry_bij2_3.
Qed.

Lemma curry_adjoint2_3 r0 r1 (LE: r0 <1== uncurry3 r1) : curry3 r0 <3== r1.
Proof.
  apply uncurry_map_rev3. eapply le1_trans; [|apply LE]. apply curry_bij1_3.
Qed.

(** ** Predicates of Arity 3
*)

Definition paco3(gf : rel3 T0 T1 T2 -> rel3 T0 T1 T2)(r: rel3 T0 T1 T2) : rel3 T0 T1 T2 :=
  curry3 (paco (fun R0 => uncurry3 (gf (curry3 R0))) (uncurry3 r)).

Definition upaco3(gf : rel3 T0 T1 T2 -> rel3 T0 T1 T2)(r: rel3 T0 T1 T2) := paco3 gf r \3/ r.
Arguments paco3 : clear implicits.
Arguments upaco3 : clear implicits.
Hint Unfold upaco3.

Definition monotone3 (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2) :=
  forall x0 x1 x2 r r' (IN: gf r x0 x1 x2) (LE: r <3= r'), gf r' x0 x1 x2.

Definition _monotone3 (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2) :=
  forall r r'(LE: r <3= r'), gf r <3== gf r'.

Lemma monotone3_eq (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2) :
  monotone3 gf <-> _monotone3 gf.
Proof. unfold monotone3, _monotone3, le3. split; intros; eapply H; eassumption. Qed.

Lemma monotone3_map (gf: rel3 T0 T1 T2 -> rel3 T0 T1 T2)
      (MON: _monotone3 gf) :
  _monotone (fun R0 => uncurry3 (gf (curry3 R0))).
Proof.
  red; intros. apply uncurry_map3. apply MON; apply curry_map3; assumption.
Qed.

Lemma monotone3_compose (gf gf': rel3 T0 T1 T2 -> rel3 T0 T1 T2)
      (MON1: monotone3 gf)
      (MON2: monotone3 gf'):
  monotone3 (compose gf gf').
Proof.
  red; intros. eapply MON1. apply IN.
  intros. eapply MON2. apply PR. apply LE.
Qed.

Lemma monotone3_union (gf gf': rel3 T0 T1 T2 -> rel3 T0 T1 T2)
      (MON1: monotone3 gf)
      (MON2: monotone3 gf'):
  monotone3 (gf \4/ gf').
Proof.
  red; intros. destruct IN.
  - left. eapply MON1. apply H. apply LE.
  - right. eapply MON2. apply H. apply LE.
Qed.

Lemma _paco3_mon_gen (gf gf': rel3 T0 T1 T2 -> rel3 T0 T1 T2) r r'
    (LEgf: gf <4= gf')
    (LEr: r <3= r'):
  paco3 gf r <3== paco3 gf' r'.
Proof.
  apply curry_map3. red; intros. eapply paco_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma paco3_mon_gen (gf gf': rel3 T0 T1 T2 -> rel3 T0 T1 T2) r r' x0 x1 x2
    (REL: paco3 gf r x0 x1 x2)
    (LEgf: gf <4= gf')
    (LEr: r <3= r'):
  paco3 gf' r' x0 x1 x2.
Proof.
  eapply _paco3_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma paco3_mon_bot (gf gf': rel3 T0 T1 T2 -> rel3 T0 T1 T2) r' x0 x1 x2
    (REL: paco3 gf bot3 x0 x1 x2)
    (LEgf: gf <4= gf'):
  paco3 gf' r' x0 x1 x2.
Proof.
  eapply paco3_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upaco3_mon_gen (gf gf': rel3 T0 T1 T2 -> rel3 T0 T1 T2) r r' x0 x1 x2
    (REL: upaco3 gf r x0 x1 x2)
    (LEgf: gf <4= gf')
    (LEr: r <3= r'):
  upaco3 gf' r' x0 x1 x2.
Proof.
  destruct REL.
  - left. eapply paco3_mon_gen; [apply H | apply LEgf | apply LEr].
  - right. apply LEr, H.
Qed.

Lemma upaco3_mon_bot (gf gf': rel3 T0 T1 T2 -> rel3 T0 T1 T2) r' x0 x1 x2
    (REL: upaco3 gf bot3 x0 x1 x2)
    (LEgf: gf <4= gf'):
  upaco3 gf' r' x0 x1 x2.
Proof.
  eapply upaco3_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Section Arg3.

Variable gf : rel3 T0 T1 T2 -> rel3 T0 T1 T2.
Arguments gf : clear implicits.

Theorem _paco3_mon: _monotone3 (paco3 gf).
Proof.
  red; intros. eapply curry_map3, _paco_mon; apply uncurry_map3; assumption.
Qed.

Theorem _paco3_acc: forall
  l r (OBG: forall rr (INC: r <3== rr) (CIH: l <3== rr), l <3== paco3 gf rr),
  l <3== paco3 gf r.
Proof.
  intros. apply uncurry_adjoint1_3.
  eapply _paco_acc. intros.
  apply uncurry_adjoint1_3 in INC. apply uncurry_adjoint1_3 in CIH.
  apply uncurry_adjoint2_3.
  eapply le3_trans. eapply (OBG _ INC CIH).
  apply curry_map3.
  apply _paco_mon; try apply le1_refl; apply curry_bij1_3.
Qed.

Theorem _paco3_mult_strong: forall r,
  paco3 gf (upaco3 gf r) <3== paco3 gf r.
Proof.
  intros. apply curry_map3.
  eapply le1_trans; [| eapply _paco_mult_strong].
  apply _paco_mon; intros [] H; apply H.
Qed.

Theorem _paco3_fold: forall r,
  gf (upaco3 gf r) <3== paco3 gf r.
Proof.
  intros. apply uncurry_adjoint1_3.
  eapply le1_trans; [| apply _paco_fold]. apply le1_refl.
Qed.

Theorem _paco3_unfold: forall (MON: _monotone3 gf) r,
  paco3 gf r <3== gf (upaco3 gf r).
Proof.
  intros. apply curry_adjoint2_3.
  eapply _paco_unfold; apply monotone3_map; assumption.
Qed.

Theorem paco3_acc: forall
  l r (OBG: forall rr (INC: r <3= rr) (CIH: l <3= rr), l <3= paco3 gf rr),
  l <3= paco3 gf r.
Proof.
  apply _paco3_acc.
Qed.

Theorem paco3_mon: monotone3 (paco3 gf).
Proof.
  apply monotone3_eq.
  apply _paco3_mon.
Qed.

Theorem upaco3_mon: monotone3 (upaco3 gf).
Proof.
  red; intros.
  destruct IN.
  - left. eapply paco3_mon. apply H. apply LE.
  - right. apply LE, H.
Qed.

Theorem paco3_mult_strong: forall r,
  paco3 gf (upaco3 gf r) <3= paco3 gf r.
Proof.
  apply _paco3_mult_strong.
Qed.

Corollary paco3_mult: forall r,
  paco3 gf (paco3 gf r) <3= paco3 gf r.
Proof. intros; eapply paco3_mult_strong, paco3_mon; [apply PR|..]; intros; left; assumption. Qed.

Theorem paco3_fold: forall r,
  gf (upaco3 gf r) <3= paco3 gf r.
Proof.
  apply _paco3_fold.
Qed.

Theorem paco3_unfold: forall (MON: monotone3 gf) r,
  paco3 gf r <3= gf (upaco3 gf r).
Proof.
  intro. eapply _paco3_unfold; apply monotone3_eq; assumption.
Qed.

End Arg3.

Arguments paco3_acc : clear implicits.
Arguments paco3_mon : clear implicits.
Arguments upaco3_mon : clear implicits.
Arguments paco3_mult_strong : clear implicits.
Arguments paco3_mult : clear implicits.
Arguments paco3_fold : clear implicits.
Arguments paco3_unfold : clear implicits.

Global Instance paco3_inst  (gf : rel3 T0 T1 T2->_) r x0 x1 x2 : paco_class (paco3 gf r x0 x1 x2) :=
{ pacoacc    := paco3_acc gf;
  pacomult   := paco3_mult gf;
  pacofold   := paco3_fold gf;
  pacounfold := paco3_unfold gf }.

End PACO3.

Global Opaque paco3.

Hint Unfold upaco3.
Hint Resolve paco3_fold.
Hint Unfold monotone3.


(** * LDef: STLC with records (as lists). *)

(** This file started out as SF's Records.v but has been modified to
    have records as lists of declarations (in contrast to SF's approach). *)

Load Init.
Require Export SfLib.
Require Import LibTactics.

Require Export Common.
Import Common.

(* ###################################################################### *)

(**  ** SYNTAX:
<<
       t ::=                          Terms:
           | true, false                 boolean values
           | x                           variable
           | \x:T1.t2                    abstraction
           | t1 t2                       application
           | {F1; ...; Fn}               record
           | t.i                         projection
           | if tb then te else tf       conditional
           | let F in e                  let
       T ::=                          Types:
           | X                           base type (not used)
           | Bool                        boolean type
           | T1 -> T2                    function type
           | {L1; ...; Ln}               record type
       F ::=                          Definitions:
           | val x = t                   bind value to id
       L ::=                          Declarations:
           | val x : T                   id has type
>>
*)

(**  *** Types [ty] *)

Inductive ty : Type :=
  | TBase     : id -> ty
  | TBool     : ty
  | TArrow    : ty -> ty -> ty
  | TRcd      : (list decl) -> ty
with decl : Type :=
  | Lv        : id -> ty -> decl.

(** *** Terms [tm] *)

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar  : id -> tm
  | tabs  : id -> ty -> tm -> tm
  | tapp  : tm -> tm -> tm
  | trcd  : list def -> tm
  | tproj : tm -> id -> tm
  | tif : tm -> tm -> tm -> tm
  | tlet : def -> tm -> tm
with def : Type :=
  | Fv    : id -> tm -> def.

(** In SF there is an observation about how an embedded list doesn't
    give a useful induction principle, so they have
    the following for types:
<<
      | TRNil : ty
      | TRCons : id -> ty -> ty -> ty
>>
    Since this allows TRCons to be applied to non-record components,
    they have a way to tell whether types are well-formed.  The same
    thing applies to terms.

    Instead, we use a list of declarations and fix the induction
    principle.  Similarly, record terms are lists of definitions.
*)

(** *** "Case" tactic notations and [tm_ind_tactic]  *)

Tactic Notation "T_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TBase" | Case_aux c "TBool"
  | Case_aux c "TArrow" | Case_aux c "TRcd" ].

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ttrue" | Case_aux c "tfalse"
  | Case_aux c "tvar" | Case_aux c "tabs" | Case_aux c "tapp"
  | Case_aux c "trcd" | Case_aux c "tproj"| Case_aux c "tif"
  | Case_aux c "tlet" ].

Ltac tm_ind_tactic t C :=
  t_cases (induction t as
    [ | | x | x Tx tb IHtb | t1 IHt1 t2 IHt2 | Fs | tr IHtr x
    | ti IHti tt IHtt te IHte | F t ] using tm_rect) C.

(** *** Functions and lemmas for dealing with definition and declaration lists *)

Definition add_vdef x t Fs := (Fv x t) :: Fs.
Definition add_vdecl x T Ls := (Lv x T) :: Ls.

Fixpoint lookup_vdef x Fs :=
  match Fs with
    | nil => None
    | (Fv y t) :: Fs' =>
        if eq_id_dec y x then Some t else lookup_vdef x Fs'
    (* | _ :: Fs' => lookup_vdef x Fs' *)
  end.

Fixpoint lookup_vdecl x Ls :=
  match Ls with
    | nil => None
    | (Lv y T) :: Ls' =>
        if eq_id_dec y x then Some T else lookup_vdecl x Ls'
  end.

Lemma lookup_add_vdef_eq :
  forall (x : id) (t : tm) (Fs : list def),
    lookup_vdef x (add_vdef x t Fs) = Some t.
Proof.
  intros. simpl. apply eq_id.
Qed.

Lemma lookup_add_vdef_neq :
  forall (x y : id) (t : tm) (Fs : list def),
    y <> x ->
    lookup_vdef x (add_vdef y t Fs) = lookup_vdef x Fs.
Proof.
  intros. simpl. apply neq_id. apply H.
Qed.

Lemma lookup_add_vdecl_eq :
  forall (x : id) (T : ty) (Ls : list decl),
    lookup_vdecl x (add_vdecl x T Ls) = Some T.
Proof.
  intros. simpl. apply eq_id.
Qed.

Lemma lookup_add_vdecl_neq :
  forall (x y : id) (T : ty) (Ls : list decl),
    y <> x ->
    lookup_vdecl x (add_vdecl y T Ls) = lookup_vdecl x Ls.
Proof.
  intros. simpl. apply neq_id. apply H.
Qed.

Lemma lookup_add_vdecl_shadow : forall (ctxt: list decl) t1 t2 x1 x2,
  lookup_vdecl x1 (add_vdecl x2 t2 (add_vdecl x2 t1 ctxt))
    = lookup_vdecl x1 (add_vdecl x2 t2 ctxt).
Proof with auto.
  intros. unfold add_vdecl, lookup_vdecl. destruct (eq_id_dec x2 x1)...
Qed.

(** Lemma [lookup_add_vdecl_case] allows one to more easily handle the
    two possible cases of [lookup_vdecl] after [add_vdecl] (except as a cons).
    Move to generic code. *)

Lemma lookup_add_vdecl_case :
  forall x y T Ls' r,
    lookup_vdecl x (add_vdecl y T Ls') = r ->
    (y=x /\ Some T = r) \/ (y<>x /\ lookup_vdecl x Ls' = r).
Proof.
  introv Hlk.
  unfold lookup_vdecl, add_vdecl in Hlk.
  destruct (eq_id_dec y x) as [ He | Hne].
    SCase "y=x". left. auto.
    SCase "y<>x". fold lookup_vdecl in Hlk. right. auto.
Qed.

(** A previous attempt at an induction-like rule for casing on the outcome of
    lookup over add. The rule can be proved, but I can't figure out
    how to apply it to prove [ctxts_agree_on_lookup]. *)

Lemma lookup_add_vdecl_case_old :
  forall (P : id -> id -> ty -> list decl -> option ty -> Prop)
    (Heq : forall x T Ls' r, r = Some T -> P x x T Ls' r)
    (Hneq : forall x y T Ls' r, r = (lookup_vdecl x Ls') -> y<>x -> P x y T Ls' r),
    forall x y T Ls' r, lookup_vdecl x (add_vdecl y T Ls') = r ->
      P x y T Ls' r.
Proof.
  intros P Heq Hneq x y T Ls' r Hlk.
  unfold lookup_vdecl, add_vdecl in Hlk.
  destruct (eq_id_dec y x) as [ He | Hne].
    SCase "y=x". subst. apply Heq. reflexivity.
    SCase "y<>x". fold lookup_vdecl in Hlk.
      subst r. apply (Hneq _ _ _ _ _ eq_refl Hne).
Qed.

(* ###################################################################### *)
(** ** Custom recursion principles. *)

(** *** Extended recursion on types, [ty_xrect]

    The coq-generated recursion principle for types ([ty]) has the following type:
<<
  ty_rect :
    forall P : ty -> Type,
      (forall i : id, P (TBase i)) ->
      P TBool ->
      (forall t : ty, P t -> forall t0 : ty, P t0 -> P (TArrow t t0)) ->
      (forall r : list decl, P (TRcd r)) -> (* records *)
    forall t : ty, P t
>>

    Notice that the "step" function for records has type
    [forall r : list decl, P (TRcd r))],
    which does not provide recursive applications for the [ty] values within the
    list of declarations.

    The following custom recursion principle replaces the records case
    with four:
      - an additional proposition function [Q] over [list decl] (at the top),
      - a proof that for record body type, [Trb], [Q Trb] implies [P (TRcd Trb)],
      - a proof of [Q nil] and
      - a proof that [P T] and [Q Trb] implies [Q (cons x T Trb))]
*)

Definition ty_xrect
  (P: ty -> Type)
  (Q: list decl -> Type)
    (fTBase : forall x : id, P (TBase x))
    (fTBool : P (TBool))
    (fTArrow : forall T1 : ty, P T1 -> forall T2 : ty, P T2 -> P (TArrow T1 T2))
    (fTRcd' : forall Trb : list decl, Q Trb -> P (TRcd Trb))
      (fTRcd_nil' : Q nil)
      (fTRcd_cons' : forall (x : id) (T : ty) (Trb : list decl),
                       P T -> Q Trb -> Q ((Lv x T) :: Trb))
  : forall T : ty, P T
  := fix F (T : ty) : P T :=
     let fix G (Trb : list decl) : Q Trb :=
         match Trb with
           | nil => fTRcd_nil'
           | (Lv x T) :: Trb' => fTRcd_cons' x T Trb' (F T) (G Trb')
         end
     in match T with
       | TBase x => fTBase x
       | TBool => fTBool
       | TArrow T1 T2 => fTArrow T1 (F T1) T2 (F T2)
       | TRcd Trb => fTRcd' Trb (G Trb)
     end.

(** *** Extended recursion on terms, [tm_xrect]

    Here is the extended recursion principle for terms [tm].
    This version directly delegates to the recursion principles for
    lists and terms, [list_rect] and [tm_rect].
*)

Definition tm_xrect
  (P: tm -> Type)
  (Q: def -> Type)
  (QL: list def -> Type)
    (ftm_true :   P ttrue)
    (ftm_false :  P tfalse)
    (ftm_var :  forall x : id,
                  P (tvar x) )
    (ftm_abs :  forall (x : id) (T : ty) (t : tm), P t ->
                  P (tabs x T t) )
    (ftm_app :  forall t1 : tm, P t1 ->
                forall t2 : tm, P t2 ->
                  P (tapp t1 t2) )
    (ftm_rcd :  forall rb : list def, QL rb ->
                  P (trcd rb) )
    (ftm_proj : forall t : tm, P t ->
                forall x : id,
                  P (tproj t x) )
    (ftm_if :   forall tb : tm, P tb ->
                forall tt : tm, P tt ->
                forall te : tm, P te ->
                  P (tif tb tt te) )
    (ftm_let :  forall (F : def), Q F ->
                forall (t : tm), P t ->
                  P (tlet F t) )

    (fdef_v : forall (x : id) (t : tm), P t ->
                Q (Fv x t) )

    (fdefs_nil :    QL nil)
    (fdefs_cons : forall (F : def), Q F ->
                  forall (Fs : list def), QL Fs ->
                    QL (F :: Fs) )

  : forall t : tm, P t
  := fix rec_tm (t : tm) : P t :=
       let rec_F (F : def) : Q F :=
         match F with
           | Fv x t => fdef_v x t (rec_tm t)
         end
       in let fix rec_Fs (Fs : list def) : QL Fs :=
         match Fs with
           | nil => fdefs_nil
           | F :: Fs' => fdefs_cons F (rec_F F) Fs' (rec_Fs Fs')
         end
       in match t with
            | ttrue => ftm_true
            | tfalse => ftm_false
            | tvar x => ftm_var x
            | tabs x T t => ftm_abs x T t (rec_tm t)
            | tapp t1 t2 => ftm_app t1 (rec_tm t1) t2 (rec_tm t2)
            | trcd rb => ftm_rcd rb (rec_Fs rb)
            | tproj t x => ftm_proj t (rec_tm t) x
            | tif eb et ee => ftm_if eb (rec_tm eb) et (rec_tm et) ee (rec_tm ee)
            | tlet F t => ftm_let F (rec_F F) t (rec_tm t)
          end.

(** *** [tm_xind_tactic] extended induction tactic *)

Tactic Notation "t_xcases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ttrue" | Case_aux c "tfalse"
  | Case_aux c "tvar" | Case_aux c "tabs" | Case_aux c "tapp"
  | Case_aux c "trcd" | Case_aux c "tproj" | Case_aux c "tif" | Case_aux c "tlet"
  | Case_aux c "F_v" | Case_aux c "Fs_nil" | Case_aux c "Fs_cons" ].

Ltac tm_xind_tactic tv Qv QLv C :=
  t_xcases (induction tv
    as [
       |
       | ?x
       | ?x ?Tx ?tb ?IHtb
       | ?t1 ?IHt1 ?t2 ?IHt2
       | ?Fs ?IHFs
       | ?tr ?IHtr ?x
       | ?ti ?IHti ?tt ?IHtt ?te ?IHte
       | ?F ?IHF ?t ?IHt
       | ?x ?t ?IHt
       |
       | ?F ?IHF ?Fs ?IHFs ]
    using tm_xrect with (Q:=Qv) (QL:=QLv)) C.

(* ###################################################################### *)
(** ** Reduction *)
(** *** Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).
Reserved Notation "'[' x ':<=' s ']' t" (at level 20).
Reserved Notation "'[' x ':<=' s ']*' Fs" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) {struct t} : tm :=
  match t with
    | ttrue => ttrue
    | tfalse => tfalse
    | tvar y => if eq_id_dec x y then s else t
    | tabs y T t1 =>  tabs y T (if eq_id_dec x y then t1 else ([x:=s] t1))
    | tapp t1 t2 => tapp ([x:=s] t1) ([x:=s] t2)
    | trcd Fs => trcd ([x:<=s]* Fs)
    | tproj t1 i => tproj ([x:=s] t1) i
    | tif t1 t2 t3 => tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
    | tlet (Fv y ty) tb => tlet (Fv y ([x:=s] ty))
                                (if eq_id_dec x y then tb else ([x:=s] tb))
  end

with subst_def (x:id) (s:tm) (F:def) : def :=
  match F with (Fv i t) => (Fv i ([x:=s] t)) end

where "'[' x ':=' s ']' t" := (subst x s t)
and "'[' x ':<=' s ']' F" := (subst_def x s F)
and "'[' x ':<=' s ']*' Fs" := (map (subst_def x s) Fs).

(**  This substitution assumes that [s] is closed,
     which is OK since the step relation is only defined on closed terms.
     This would need to change if [s] was allowed to have free variables.*)

(* ###################################################################### *)

(** *** Values
<<
       v ::=                          Values:
           | true | false                boolean values
           | \x:T.t                      abstractions
           | {i1=v1, ..., in=vn}         record values
>>
Note that a record is a value if all of its fields are. *)

Inductive is_value : tm -> Prop :=
  | v_true :
      is_value ttrue
  | v_false :
      is_value tfalse
  | v_abs : forall x T11 t12,
      is_value (tabs x T11 t12)
  | v_rcd : forall r,
      is_value_defs r ->
      is_value (trcd r)

with is_value_def : def -> Prop :=
  | vF_v : forall x t,
      is_value t -> is_value_def (Fv x t)

with is_value_defs : (list def) -> Prop :=
  | vFs_nil :
      is_value_defs nil
  | vFs_cons : forall F Fs,
      is_value_def F ->
      is_value_defs Fs ->
      is_value_defs (F :: Fs).

Hint Constructors is_value is_value_def is_value_defs.

Scheme is_value_xind := Minimality for is_value Sort Prop
with is_value_def_xind := Minimality for is_value_def Sort Prop
with is_value_defs_xind := Minimality for is_value_defs Sort Prop.

(** *** Reduction rules
<<
                               is_value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              is_value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'

                                 t1 ==> t1'
                               --------------                         (ST_Proj)
                               t1.i ==> t1'.i

                          -------------------------                (ST_ProjRcd)
                          {..., i=vi, ...}.i ==> vi

                                 ti ==> ti'                            (ST_Rcd)
    --------------------------------------------------------------------
    {i1=v1, ..., im=vm, in=tn, ...} ==> {i1=v1, ..., im=vm, in=tn', ...}

                    --------------------------------                (ST_IfTrue)
                    (if true then t1 else t2) ==> t1

                    ---------------------------------              (ST_IfFalse)
                    (if false then t1 else t2) ==> t2

                              t1 ==> t1'
         ----------------------------------------------------           (ST_If)
         (if t1 then t2 else t3) ==> (if t1' then t2 else t3)

                              F >==> F'
                     ---------------------------                       (ST_Let)
                     let F in t ==> let F' in t

                             is_value v
                      -------------------------                     (ST_LetDef)
                      let x=v in t ==> [x:=v]t
>>
*)

Reserved Notation "t1 '==>' t2" (at level 40).
Reserved Notation "F1 '>==>' F2" (at level 40).
Reserved Notation "rb1 '*>==>' rb2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         is_value v2 ->
         (tapp (tabs x T11 t12) v2) ==> ([x:=v2]t12)
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         (tapp t1 t2) ==> (tapp t1' t2)
  | ST_App2 : forall v1 t2 t2',
         is_value v1 ->
         t2 ==> t2' ->
         (tapp v1 t2) ==> (tapp v1 t2')
  | ST_Proj : forall t1 t1' i,
        t1 ==> t1' ->
        (tproj t1 i) ==> (tproj t1' i)
  | ST_ProjRcd : forall r x vx,
        is_value_defs r ->
        lookup_vdef x r = Some vx ->
        (tproj (trcd r) x) ==> vx
  | ST_Rcd : forall rb rb',
        rb *>==> rb' ->
        (trcd rb) ==> (trcd rb')
  | ST_IfTrue : forall t1 t2,
        (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
        (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
        t1 ==> t1' ->
        (tif t1 t2 t3) ==> (tif t1' t2 t3)
  | ST_Let : forall F F' t,
        F >==> F' ->
        (tlet F t) ==> (tlet F' t)
  | ST_LetDef : forall x vx t2,
        is_value vx ->
        (tlet (Fv x vx) t2) ==> [x:=vx]t2

with step_def : def -> def -> Prop :=
  | STD_V : forall x t t',
        t ==> t' ->
        (Fv x t) >==> (Fv x t')

with step_defs : (list def) -> (list def) -> Prop :=
  | STR_Head : forall F F' Fs,
        F >==> F' ->
        (F :: Fs) *>==> (F' :: Fs)
  | STR_Tail : forall F Fs Fs',
        is_value_def F ->
        Fs *>==> Fs' ->
        (F :: Fs) *>==> (F :: Fs')

where "t1 '==>' t2" := (step t1 t2)
and "F1 '>==>' F2" := (step_def F1 F2)
and "rb1 '*>==>' rb2" := (step_defs rb1 rb2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
  | Case_aux c "ST_Proj" | Case_aux c "ST_ProjRcd" | Case_aux c "ST_Rcd"
  | Case_aux c "ST_IfTrue" | Case_aux c "ST_IfFalse" | Case_aux c "ST_If"
  | Case_aux c "ST_Let" | Case_aux c "ST_LetDef" ].

Tactic Notation "step_defs_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "STR_Head" | Case_aux c "STR_Tail" ].

Hint Constructors step step_def step_defs.

Scheme step_xind := Minimality for step Sort Prop
with step_def_xind := Minimality for step_def Sort Prop
with step_defs_xind := Minimality for step_defs Sort Prop.

Tactic Notation "step_xcases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1" | Case_aux c "ST_App2"
  | Case_aux c "ST_Proj" | Case_aux c "ST_ProjRcd" | Case_aux c "ST_Rcd"
  | Case_aux c "ST_IfTrue" | Case_aux c "ST_IfFalse" | Case_aux c "ST_If"
  | Case_aux c "ST_Let" | Case_aux c "ST_LetDef"
  | Case_aux c "STD_V" | Case_aux c "STR_Head" | Case_aux c "STR_Tail" ].

(** *** Multi-step *)

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(** **** Normalization tactics *)

Tactic Notation "normalize" :=
   repeat (eapply multi_step ;
             [ (eauto 10; fail) | (instantiate; simpl)]);
   apply multi_refl.

(* Verbose version: *)

Tactic Notation "print_goal" := match goal with |- ?x => idtac x end.
Tactic Notation "normalize_v" :=
   repeat (print_goal; eapply multi_step ;
             [ (eauto 10; fail) | (instantiate; simpl)]);
   apply multi_refl.

(* ###################################################################### *)
(** ** Typing *)

(** *** Contexts *)

Definition context := list decl.
Definition empty := nil (A:=decl).

(** *** Typing rules:
<<
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x : T

                      Gamma , x:T11 |- t12 : T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 : T11->T12

                        Gamma |- t1 : T11->T12
                          Gamma |- t2 : T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 : T12

               Gamma |- [i1=t1, ..., in=tn] *: [1:T1, ..., in:Tn]
               --------------------------------------------------       (T_Rcd)
               Gamma |- {i1=t1, ..., in=tn} : {i1:T1, ..., in:Tn}

                       Gamma |- t : {..., i:Ti, ...}
                       -----------------------------                    (T_Proj)
                             Gamma |- t.i : Ti

                         --------------------                           (T_True)
                         Gamma |- true : Bool

                         ---------------------                          (T_False)
                         Gamma |- false : Bool

       Gamma |- t1 : Bool    Gamma |- t2 : T    Gamma |- t3 : T
       --------------------------------------------------------         (T_If)
                  Gamma |- if t1 then t2 else t3 : T

                Gamma |- F ==> L    Gamma , L |- t : T
                --------------------------------------                  (T_Let)
                       Gamma |- let L in t : T

                            Gamma |- t : T
                       ------------------------                         (F_V)
                       Gamma |- x = e ==> x : T

                        -------------------                             (Fs_Nil)
                        Gamma |- []  *:  []

                           Gamma |- F ==> L
                          Gamma |- Fs *: Ls
                  ---------------------------------                     (Fs_Cons)
                  Gamma |- F :: Fs  ==>*  L :: Ls
>>
*)

Reserved Notation "Gamma '|--' t '\in' T" (at level 40).
Reserved Notation "Gamma '|--' r '*\in' Tr" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      lookup_vdecl x Gamma = Some T ->
      Gamma |-- tvar x \in T
  | T_Abs : forall Gamma x T1 T2 tb,
      add_vdecl x T1 Gamma |-- tb \in T2 ->
      Gamma |-- (tabs x T1 tb) \in (TArrow T1 T2)
  | T_App : forall Gamma T1 T2 t1 t2,
      Gamma |-- t1 \in (TArrow T1 T2) ->
      Gamma |-- t2 \in T1 ->
      Gamma |-- (tapp t1 t2) \in T2
  | T_Rcd : forall Gamma tr Tr,
      Gamma |-- tr *\in Tr ->
      Gamma |-- (trcd tr) \in (TRcd Tr)
  | T_Proj : forall Gamma x t Tx Tr,
      Gamma |-- t \in (TRcd Tr) ->
      lookup_vdecl x Tr = Some Tx ->
      Gamma |-- (tproj t x) \in Tx
  | T_True : forall Gamma,
       Gamma |-- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |-- tfalse \in TBool
  | T_If : forall Gamma t1 t2 t3 T,
       Gamma |-- t1 \in TBool ->
       Gamma |-- t2 \in T ->
       Gamma |-- t3 \in T ->
       Gamma |-- tif t1 t2 t3 \in T
  | T_Let : forall Gamma F L t T,
       def_yields Gamma F L ->
       (L :: Gamma) |-- t \in T ->
       Gamma |-- (tlet F t) \in T

with def_yields : context -> def -> decl -> Prop :=
  | F_V : forall Gamma x t T,
       Gamma |-- t \in T ->
       def_yields Gamma (Fv x t) (Lv x T)

with rcd_has_type : context -> (list def) -> (list decl) -> Prop :=
  | TR_Nil : forall Gamma,
      Gamma |-- nil *\in nil
  | TR_Cons : forall Gamma F L Fs Ls,
      def_yields Gamma F L ->
      Gamma |-- Fs *\in Ls ->
      Gamma |-- (F :: Fs) *\in (L :: Ls)

where "Gamma '|--' t '\in' T" := (has_type Gamma t T)
and   "Gamma '|--' r '*\in' Tr" := (rcd_has_type Gamma r Tr).

Hint Constructors has_type def_yields rcd_has_type.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
  | Case_aux c "T_Rcd" | Case_aux c "T_Proj"
  | Case_aux c "T_True" | Case_aux c "T_False" | Case_aux c "T_If"
  | Case_aux c "T_Let" ].

Tactic Notation "rcd_has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "TR_Nil" | Case_aux c "TR_Cons" ].

(** *** Extended induction principle for [has_type] *)

Scheme has_type_xind := Minimality for has_type Sort Prop
with def_yields_xind := Minimality for def_yields Sort Prop
with rcd_has_type_xind := Minimality for rcd_has_type Sort Prop.

Tactic Notation "has_type_xcases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs" | Case_aux c "T_App"
  | Case_aux c "T_Rcd" | Case_aux c "T_Proj"
  | Case_aux c "T_True" | Case_aux c "T_False" | Case_aux c "T_If"
  | Case_aux c "T_Let"
  | Case_aux c "F_V"
  | Case_aux c "TR_Nil" | Case_aux c "TR_Cons" ].

Ltac has_type_xind_tactic Hht Qv QLv C :=
  has_type_xcases (induction Hht
    as [ ?Gamma ?x ?T ?Hlk
       | ?Gamma ?x ?T1 ?T2 ?tb ?Htb ?IHHtb
       | ?Gamma ?T1 ?T2 ?t1 ?t2 ?Ht1 ?IHHt1 ?Ht2 ?IHHt2
       | ?Gamma ?tr ?Tr ?Htr ?IHHtr
       | ?Gamma ?x ?t ?Tx ?Tr ?Ht ?IHHt ?Hlk
       | ?Gamma
       | ?Gamma
       | ?Gamma ?tb ?tt ?te ?T ?Htb ?IHHtb ?Htt ?IHHtt ?Hte ?IHHte
       | ?Gamma ?F ?L ?t ?T ?HF ?IHHF ?Ht ?IHHt

       | ?Gamma ?x ?t ?T ?Ht ?IHHt

       | ?Gamma
       | ?Gamma ?F ?L ?Fs ?Ls ?HF ?IHHF ?HFs ?IHHFs
       ]
    using has_type_xind with (P0:=Qv) (P1:=QLv)) C.


(* Test for evar map consistency - was failing at some point and was *)
(* assumed to be solved from revision 10151 (but using a bad fix) *)

Require Import List.
Set Implicit Arguments.

Inductive rose : Set := Rose : nat -> list rose -> rose.

Section RoseRec.
Variables (P: rose -> Set)(L: list rose -> Set).
Hypothesis
  (R: forall n rs, L rs -> P (Rose n rs))
  (Lnil: L nil)
  (Lcons: forall r rs, P r -> L rs -> L (cons r rs)).

Fixpoint rose_rec2 (t:rose) {struct t} : P t :=
  match t as x return P x with
  | Rose n rs =>
    R n ((fix rs_ind (l' : list rose): L l' :=
         match l' as x return L x with
         | nil => Lnil
         | cons t tl => Lcons (rose_rec2 t) (rs_ind tl)
         end)
         rs)
  end.
End RoseRec.

Lemma rose_map : rose -> rose.
Proof. intro H; elim H using rose_rec2 with
    (L:=fun _ => list rose); (* was assumed to fail here *)
(*  (L:=fun (_:list rose) => list rose); *)
  clear H; simpl; intros.
  exact (Rose n rs). exact nil. exact (H::H0).
Defined.