(* -*- 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.


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.