Require Import List.
Require Import Defns.

Require Import Eq.

(**
  * boundCon is Ty
 **)
Lemma boundCon_is_Ty_of_eTy :
  forall (S : sgn) (c : con) (A : eTy), boundCon c A (List.map (castSig) S) -> is_Ty_of_eTy A.
Proof.
  (intros **).
  (induction S).
  - (unfold boundCon in H).
    decompose record H.
    (simpl in H0).
    (apply app_cons_not_nil in H0).
    contradiction.

  - (destruct a as [[c0 [A' wA']]| ]).

    + (assert ({c = c0} + {c <> c0}) as [| ] by apply eq_con).

      * subst.

        (assert ({A = A'} + {A <> A'}) as [| ] by apply eq_eTy_dec).

        { subst.
          assumption. }
        { (apply IHS).
          (unfold boundCon in H).
          decompose record H.
          (unfold boundCon).
          (simpl in H0).
          (destruct x).
          - (simpl in H0).
            (inversion H0).
            (symmetry in H3; contradiction).
          - exists x.
              exists x0.

              split.
              (inversion H0; auto).
              intro.
              (apply H2).
              (right; auto). }
      * (apply IHS).
        (unfold boundCon in H).
        decompose record H.
        (unfold boundCon).
        (simpl in H0).
        (destruct x).
        { (simpl in H0).
          (inversion H0).
          (symmetry in H3; contradiction). }
        { exists x.
          exists x0.

          split.
          (inversion H0; auto).
          intro.
          (apply H2).
          (right; auto). }

    + (destruct p as [a [L wL]]).
      (apply IHS).
      (unfold boundCon in H).
      decompose record H.
      (unfold boundCon).
      (destruct x).
      * (inversion H0).
      * exists x.
          exists x0.

          split.
          (inversion H0; auto).
          intro.
          (apply H2).
          (right; auto).
Qed.

(**
  * boundTCon is K
 **)
Lemma boundTCon_is_K_of_eK :
  forall (S : sgn) (a : tcon) (L : eK), boundTCon a L (List.map (castSig) S) -> is_K_of_eK L.
Proof.
  (intros **).
  (induction S as [| el]).
  - (unfold boundTCon in H; decompose record H).
    (apply app_cons_not_nil in H0).
    contradiction.

  - (destruct el as [[c [A]]| [a0 [L' wL']]]).

    + (apply IHS).
      (unfold boundTCon in H).
      decompose record H.
      (unfold boundTCon).
      (destruct x).
      * (inversion H0).
      * exists x.
          exists x0.

          split.
          (inversion H0; auto).
          intro.
          (apply H2).
          (right; auto).

    + (assert ({a0 = a} + {a0 <> a}) as [| ] by apply eq_con).

      * subst.

        (assert ({L' = L} + {L' <> L}) as [| ] by apply eq_eK).

        { subst.
          assumption. }
        { (apply IHS).
          (unfold boundTCon in H).
          decompose record H.
          (unfold boundTCon).
          (destruct x).
          - (inversion H0).
            contradiction.
          - exists x.
              exists x0.

              split.
              (inversion H0; auto).
              intro.
              (apply H2).
              (right; auto). }
      * (apply IHS).
        (unfold boundTCon in H).
        decompose record H.
        (simpl in H0).
        (destruct x).
        { (inversion H0).
          contradiction. }
        { exists x.
          exists x0.

          split.
          (inversion H0; auto).
          intro.
          (apply H2).
          (right; auto). }

Qed.

(**
  * boundCon
 **)

(** decidability of boundCon **)

Lemma boundCon_dec :
  forall (S : esgn) (c : con),
  {A : _ | boundCon c A S} + {(forall A, ~ boundCon c A S)}.
Proof.
  (induction S; intros **).

  - right.
    (intros **). intro Hc.
    (unfold boundCon in Hc).
    decompose record Hc.
    (apply app_cons_not_nil in H).
    contradiction.

  - (destruct a).

    + (destruct p).

      (assert ({c = c0} + {c <> c0}) as [| ] by apply eq_con; subst).

      * (*destruct s. *)
        left.
        exists e.
        exists nil.
        eexists.
        (simpl).
        split.
        auto.
        intro.
        auto.
      * (destruct IHS with c).
        (destruct s).

        { left.
          exists x.
          (unfold boundCon).
          (simpl).
          (unfold boundCon in b).
          decompose record b.
          exists (inl (c0, e) :: x0).
          exists x1.
          (simpl).
          split.
          (rewrite H).
          auto.
          intro.
          (inversion H0).
          (inversion H2).
          (apply n; auto).
          (apply H1; auto).
        }
        {
          right.
          (intros **).
          intro.
          (unfold boundCon in H).
          decompose record H.
          (destruct x).
          - (inversion H0).
            (apply n).
            auto.

          - (assert (S = x ++ inl (c, A) :: x0)).
            (inversion H0).
            auto.
            (apply n0 with A).
            (unfold boundCon).
            (rewrite H1).
            exists x.
            exists x0.
            split.
            auto.
            intro.
            (apply H2).
            right.
            assumption.
        }
    +  (* inr cases *)
      (destruct IHS with c).

      * (* bound cases *)
        left.
        (destruct s).
        (destruct p).
        exists x.
        (unfold boundCon in b).
        decompose record b.
        (unfold boundCon).
        (rewrite H).
        exists (inr (t, e) :: x0).
        exists x1.
        (simpl).
        split.

        auto.
        (intros **).
        intro.
        (apply H1).
        (inversion H0).
        (inversion H2).
        assumption.
      * (* not bound at all *)
        right.
        (intros **).
        intro.
        (destruct p).
        (apply n with A).
        (unfold boundCon in H).
        decompose record H.
        (destruct x).
        (inversion H0).
        (inversion H0).
        exists x.
        exists x0.
        split.
        auto.
        (intros **).
        intro.
        (apply H2).
        right.
      assumption.
Defined.

(** determianacy of boundnCon **)

(*
Lemma boundnCon_weak_r :
  forall (Sig : esgn) (c : con) (a : tcon) (A : eTy)
    (L : {eK : _ | is_K_of_eK eK}),
  boundCon c A (inr (a, L) :: Sig) -> boundCon c A Sig.
Proof.
  intros.
  (unfold boundCon in H).
  decompose record H.
  (destruct x).
  - (inversion H0).
  -
    exists x.
      exists x0.
      (inversion H0).
      split.
      auto.
      intros.
      intro.
      (apply H2).
      right.
      assumption.
Qed.

Lemma boundnCon_weak_l :
  forall (S : sgn) (c d : con) (A : eTy) (B : {eTy : _ | is_Ty_of_eTy eTy}),
  boundCon c A (inl (d, B) :: S) -> c <> d -> boundCon c A S.
Proof.
  intros.
  (unfold boundCon in H).
  decompose record H.
  (destruct x).
  (inversion H1).
  (destruct H0).
  (symmetry; assumption).
  exists x.
  exists x0.
  (inversion H1).
  split.
  auto.
  intros.
  intro.
  (apply H3).
  right.
  assumption.
Qed.
*)
(*
Lemma boundnCon_weak_determinacy:
  forall (S : sgn) (c : con) (A1 A2 : eTy),
    boundnCon c A1 (inl (c, A2) :: S) ->
    ~ indomnCon c S
    -> A1 = A2.
Proof.
  intros.
  unfold boundnCon in H.
  decompose record H.
  destruct x.
  inversion H1.
  reflexivity.
  destruct H0.
  exists A1.
  exists x.
  exists x0.
  split.
  inversion H1.
  reflexivity.
  intros; intro.
  apply H3 with nA'.
  right.
  assumption.
Qed.
 *)

(*
Lemma boundCon_determinacy:
  forall (S : sgn) (c : con) (A1 A2 : eTy),
    wfsig_nl S ->
    boundCon c A1 S ->
    boundCon c A2 S ->
    A1 = A2.
Proof.
  intros.
  induction H.
  (* nil case *)
  intros.
  unfold boundnCon in H0.
  decompose record H0.
  apply app_cons_not_nil in H.
  contradiction.
  (* step case *)
  intros.
  apply IHwfsig_nl; eapply boundnCon_weak_r ; eauto.
  (* *)
  assert ({c = c0} + {c <> c0}) by (apply eq_con).
  destruct H4.
  rewrite e in H0.
  rewrite e in H1.
  assert (A1 = nA).
  eauto using boundnCon_weak_determinacy; auto.
  assert (A2 = nA).
  eauto using boundnCon_weak_determinacy; auto.
  rewrite H4.
  rewrite H5.
  reflexivity.
  apply IHwfsig_nl; eauto using boundnCon_weak_l; auto.
Qed.
*)

(**
  * boundsnCon
 **)

(*

(** decidability of boundsnCon **)

Lemma boundsCon_dec:
  forall (sS :ssgn) (c : con),
    { tau | boundsCon c tau sS } +
    { forall tau, ~boundsCon c tau sS }.
Proof.
  intros.
  induction sS.
  right.
  intros.
  intro.
  unfold boundsnCon in H.
  decompose record H.
  apply app_cons_not_nil in H0.
  contradiction.
  destruct a.
  destruct p.
  assert ({c = c0} + {c <> c0}) by (apply eq_con).
  destruct H.
  rewrite e.
  left.
  exists s.
  exists nil.
  exists sS.
  split.
  auto.
  intros.
  intro.
  inversion H.
  destruct IHsS.
  left.
  destruct s0.
  exists x.
  unfold boundsnCon in b.
  decompose record b.
  exists (inl (c0, s) :: x0).
  exists x1.
  rewrite H.
  split.
  auto.
  intros.
  intro.
  inversion H0.
  inversion H2.
  apply n; auto.
  apply H1 with tau'; auto.
  right.
  intros.
  intro.
  unfold boundsnCon in H.
  decompose record H.
  destruct x.
  inversion H0.
  apply n; auto.
  assert (sS = x ++ inl (c, tau) :: x0).
  inversion H0.
  auto.
  apply n0 with tau.
  rewrite H1.
  exists x.
  exists x0.
  split.
  auto.
  intro.
  intro.
  apply H2 with tau'.
  right.
  assumption.
  (* inr cases *)
  destruct IHsS.
  left.
  destruct s.
  exists x.
  unfold boundsnCon in b.
  decompose record b.
  rewrite H.
  exists (inr p :: x0).
  exists x1.
  split.
  auto.
  intros.
  intro.
  apply H1 with tau'.
  inversion H0.
  inversion H2.
  assumption.
  (* not bound at all *)
  right.
  intros.
  intro.
  apply n with tau.
  unfold boundsnCon in H.
  decompose record H.
  destruct x.
  inversion H0.
  inversion H0.
  exists x.
  exists x0.
  split.
  auto.
  intros.
  intro.
  apply H2 with tau'.
  right.
  assumption.
Qed.

(** determianacy of boundsnCon **)

Lemma boundsnCon_weak_r:
  forall (sS : snsgn) (c : con) (a : tcon) (tau : snTy) (kappa : snK),
    boundsnCon c tau (inr (a , kappa) :: sS) ->
    boundsnCon c tau sS.
Proof.
  intros.
  unfold boundsnCon in H.
  decompose record H.
  destruct x.
  inversion H0.
  exists x.
  exists x0.
  inversion H0.
  split.
  auto.
  intros.
  intro.
  apply H2 with tau'.
  right.
  assumption.
Qed.

Lemma boundsnCon_weak_l:
  forall (sS : snsgn) (c d : con) (tau1 tau2 : snTy),
    boundsnCon c tau1 (inl (d , tau2) :: sS) ->
    c <> d ->
    boundsnCon c tau1 sS.
Proof.
  intros.
  unfold boundsnCon in H.
  decompose record H.
  destruct x.
  inversion H1.
  destruct H0.
  symmetry; assumption.
  exists x.
  exists x0.
  inversion H1.
  split.
  auto.
  intros.
  intro.
  apply H3 with tau'.
  right.
  assumption.
Qed.

Lemma boundsnCon_weak_determinacy:
  forall (sS : snsgn) (c : con) (tau1 tau2 : snTy),
    boundsnCon c tau1 (inl (c, tau2) :: sS) ->
    ~ indomsnCon c sS
    -> tau1 = tau2.
Proof.
  intros.
  unfold boundsnCon in H.
  decompose record H.
  destruct x.
  inversion H1.
  reflexivity.
  destruct H0.
  exists tau1.
  exists x.
  exists x0.
  split.
  inversion H1.
  reflexivity.
  intros; intro.
  apply H3 with tau'.
  right.
  assumption.
Qed.

Lemma boundsnCon_determinacy:
  forall (sS : snsgn) (a : tcon) (tau1 tau2 : snTy),
    wfssig_nl sS ->
    boundsnCon a tau1 sS ->
    boundsnCon a tau2 sS ->
    tau1 = tau2.
Proof.
  intros.
  induction H.
  (* nil case *)
  intros.
  unfold boundsnCon in H0.
  decompose record H0.
  apply app_cons_not_nil in H.
  contradiction.
  (* step case *)
  intros.
  apply IHwfssig_nl; eapply boundsnCon_weak_r ; eauto.
  (* *)
  assert ({c = a} + {c <> a}) by (apply eq_con).
  destruct H3.
  rewrite <- e in H0.
  rewrite <- e in H1.
  assert (tau1 = tau).
  eauto using boundsnCon_weak_determinacy; auto.
  assert (tau2 = tau).
  eauto using boundsnCon_weak_determinacy; auto.
  rewrite H3.
  rewrite H4.
  reflexivity.
  apply IHwfssig_nl; eauto using boundsnCon_weak_l; auto.
Qed.
 *)

(**
  * boundTCon
 **)

(** decidability of boundnTCon **)

Lemma boundTCon_dec :
  forall (S : esgn) (a : tcon),
  {L : _ | boundTCon a L S} + {(forall L, ~ boundTCon a L S)}.
Proof.
  intros S a.
  induction S as [ | [ [c A ] | [ a' L ] ]  ].
  -
    right.
    intros L Hc; unfold boundTCon in Hc.
    decompose record Hc.
    (apply app_cons_not_nil in H).
    contradiction.
  - destruct IHS as [ HL | Hc ].
    + left.
      (destruct HL as [L Hb ]).
      exists L.
      (unfold boundTCon in Hb).
      decompose record Hb.
      (unfold boundTCon).
      (rewrite H).
      exists (inl (c, A) :: x).
      exists x0.
      split.
      auto.
      intro Hc.
      (apply H1).
      (inversion Hc).
      (inversion H0).
      assumption.
    + (* not bound at all *)
      right.
      (intros **).
       intro.
       (apply Hc with L).
       (unfold boundTCon in H).
       decompose record H.
       (destruct x).
       (inversion H0).
       (inversion H0).
       exists x.
       exists x0.
       split.
       auto.
       (intros **).
        intro.
        (apply H2).
        right.
        assumption.

        - (* inr - inr case *)
          (assert ({a' = a} + {a' <> a}) by apply eq_tcon).
          (destruct H).
          * (rewrite e).
            left.
            exists L.
            exists nil.
            exists S.
            split.
            auto.
            (intros **).
             intro.
             (inversion H).
             * (destruct IHS).
               { left.
                 (destruct s).
                 exists x.
                 (unfold boundTCon in b).
                 decompose record b.
                 (simpl).
                 exists (inr (a', L) :: x0).
                 exists x1.
        (simpl).
        (rewrite H).
        split.
        eauto.
        (intros **).
        intro.
        (inversion H0).
        (inversion H2).
        (apply n; auto).
        (apply H1; auto).
        }
        { right.
          (intros **).
          intro.
          (unfold boundTCon in H).
          decompose record H.
          (destruct x).
          (inversion H0).
          (apply n; auto).
          (simpl in H0).
          (assert (S = x ++ inr (a, L0) :: x0)).
          (inversion H0).
          auto.
          (apply n0 with L0).
          (unfold boundTCon).
          (rewrite H1).
          exists x.
          exists x0.
          split.
          auto.
          (intros **).
          intro.
          (apply H2).
          right.
          assumption.
        }
Defined.

(** determianacy of boundTCon **)

(*
Lemma boundTCon_weak_l :
  forall (S : sgn) (c a : tcon) (A : {eTy : _ | is_Ty_of_eTy eTy}) (L : eK),
  boundTCon a L (inl (c, A) :: S) -> boundTCon a L S.
Proof.
  intros.
  (unfold boundTCon in H).
  decompose record H.
  (destruct x).
  (inversion H0).
  exists x.
  exists x0.
  (inversion H0).
  split.
  auto.
  intros.
  intro.
  (apply H2).
  right.
  assumption.
Qed.

Lemma boundnTCon_weak_r :
  forall (S : sgn) (a b : tcon) (L : eK) (K : {eK : _ | is_K_of_eK eK}),
  boundTCon a L (inr (b, K) :: S) -> a <> b -> boundTCon a L S.
Proof.
  intros.
  (unfold boundTCon in H).
  decompose record H.
  (destruct x).
  (inversion H1).
  (destruct H0).
  (symmetry; assumption).
  exists x.
  exists x0.
  (inversion H1).
  split.
  auto.
  intros.
  intro.
  (apply H3).
  right.
  assumption.
Qed.
*)
(*
Lemma boundnTCon_weak_determinacy:
  forall (S : sgn) (a : tcon) (L1 L2 : eK),
    boundnTCon a L1 (inr (a, L2) :: S) ->
    ~ indomnTCon a S
    -> L1 = L2.
Proof.
  intros.
  unfold boundnTCon in H.
  decompose record H.
  destruct x.
  inversion H1.
  reflexivity.
  destruct H0.
  exists L1.
  exists x.
  exists x0.
  split.
  inversion H1.
  reflexivity.
  intros; intro.
  apply H3 with nL'.
  right.
  assumption.
Qed.
 *)

(*
Lemma boundnTCon_determinacy:
  forall (S : sgn) (a : tcon) (L1 L2 : eK),
    wfsig_nl S ->
    boundTCon a L1 S ->
    boundTCon a L2 S ->
    L1 = L2.
Proof.
  intros.
  induction H.
  (* nil case *)
  intros.
  unfold boundnTCon in H0.
  decompose record H0.
  apply app_cons_not_nil in H.
  contradiction.
  (* step case *)
  intros.
  (* *)
  assert ({a = a0} + {a <> a0}) by (apply eq_tcon).
  destruct H4.
  rewrite e in H0.
  rewrite e in H1.
  assert (L1 = nL).
  eauto using boundnTCon_weak_determinacy; auto.
  assert (L2 = nL).
  eauto using boundnTCon_weak_determinacy; auto.
  rewrite H4.
  rewrite H5.
  reflexivity.
  (* *)
  eauto using boundnTCon_weak_r; auto.
  apply IHwfsig_nl; eauto using boundnTCon_weak_l.
Qed.
 *)

(**
  * boundsnTCon
 **)

(** decidability of boundsnTCon **)

(*
Lemma boundsnTCon_dec:
  forall (sS : snsgn) (a : tcon),
    {kappa | boundsnTCon a kappa sS} + {forall kappa , ~ boundsnTCon a kappa sS}.
Proof.
  intros.
  induction sS.
  right.
  intros.
  intro.
  unfold boundsnTCon in H.
  decompose record H.
  apply app_cons_not_nil in H0.
  contradiction.
  destruct a0.
  (* inl cases *)
  destruct IHsS.
  left.
  destruct s.
  exists x.
  unfold boundsnTCon in b.
  decompose record b.
  rewrite H.
  exists (inl p :: x0).
  exists x1.
  split.
  auto.
  intros.
  intro.
  apply H1 with kappa'.
  inversion H0.
  inversion H2.
  assumption.
  (* not bound at all *)
  right.
  intros.
  intro.
  apply n with kappa.
  unfold boundsnTCon in H.
  decompose record H.
  destruct x.
  inversion H0.
  inversion H0.
  exists x.
  exists x0.
  split.
  auto.
  intros.
  intro.
  apply H2 with kappa'.
  right.
  assumption.
  (* int cases *)
  destruct p.
  assert ({a = t} + {a <> t}) by (apply eq_con).
  destruct H.
  rewrite e.
  left.
  exists s.
  exists nil.
  exists sS.
  split.
  auto.
  intros.
  intro.
  inversion H.
  destruct IHsS.
  left.
  destruct s0.
  exists x.
  unfold boundsnTCon in b.
  decompose record b.
  exists (inr (t, s) :: x0).
  exists x1.
  rewrite H.
  split.
  auto.
  intros.
  intro.
  inversion H0.
  inversion H2.
  apply n; auto.
  apply H1 with kappa'; auto.
  right.
  intros.
  intro.
  unfold boundsnTCon in H.
  decompose record H.
  destruct x.
  inversion H0.
  apply n; auto.
  assert (sS = x ++ inr (a, kappa) :: x0).
  inversion H0.
  auto.
  apply n0 with kappa.
  rewrite H1.
  exists x.
  exists x0.
  split.
  auto.
  intro.
  intro.
  apply H2 with kappa'.
  right.
  assumption.
Qed.

(** determianacy of boundsnTCon **)

Lemma boundsnTCon_weak_l:
  forall (sS : snsgn) (c : con) (a : tcon) (tau : snTy) (kappa : snK),
    boundsnTCon a kappa (inl (c , tau) :: sS) ->
    boundsnTCon a kappa sS.
Proof.
  intros.
  unfold boundsnTCon in H.
  decompose record H.
  destruct x.
  inversion H0.
  exists x.
  exists x0.
  inversion H0.
  split.
  auto.
  intros.
  intro.
  apply H2 with kappa'.
  right.
  assumption.
Qed.

Lemma boundsnTCon_weak_r:
  forall (sS : snsgn) (a b : tcon) (kappa1 kappa2 : snK),
    boundsnTCon a kappa1 (inr (b , kappa2) :: sS) ->
    a <> b ->
    boundsnTCon a kappa1 sS.
Proof.
  intros.
  unfold boundsnTCon in H.
  decompose record H.
  destruct x.
  inversion H1.
  destruct H0.
  symmetry; assumption.
  exists x.
  exists x0.
  inversion H1.
  split.
  auto.
  intros.
  intro.
  apply H3 with kappa'.
  right.
  assumption.
Qed.

Lemma boundsnTCon_weak_determinacy:
  forall (sS : snsgn) (a : tcon) (kappa1 kappa2 : snK),
    boundsnTCon a kappa1 (inr (a, kappa2) :: sS) ->
    ~ indomsnTCon a sS
    -> kappa1 = kappa2.
Proof.
  intros.
  unfold boundsnTCon in H.
  decompose record H.
  destruct x.
  inversion H1.
  reflexivity.
  destruct H0.
  exists kappa1.
  exists x.
  exists x0.
  split.
  inversion H1.
  reflexivity.
  intros; intro.
  apply H3 with kappa'.
  right.
  assumption.
Qed.

Lemma boundsnTCon_determinacy:
  forall (sS : snsgn) (a : tcon) (kappa1 kappa2 : snK),
    wfssig_nl sS ->
    boundsnTCon a kappa1 sS ->
    boundsnTCon a kappa2 sS ->
    kappa1 = kappa2.
Proof.
  intros.
  induction H.
  (* nil case *)
  intros.
  unfold boundsnTCon in H0.
  decompose record H0.
  apply app_cons_not_nil in H.
  contradiction.
  (* step case *)
  intros.
  (* *)
  assert ({a = a0} + {a <> a0}) by (apply eq_tcon).
  destruct H3.
  rewrite e in H0.
  rewrite e in H1.
  assert (kappa1 = kappa).
  eauto using boundsnTCon_weak_determinacy; auto.
  assert (kappa2 = kappa).
  eauto using boundsnTCon_weak_determinacy; auto.
  rewrite H3.
  rewrite H4.
  reflexivity.
  (* *)
  eauto using boundsnTCon_weak_r; auto.
  apply IHwfssig_nl; eauto using boundsnTCon_weak_l.
Qed.

 *)

(**  checking of boundsnTcon **)

(*
Lemma boundsnTCon_check:
  forall (sS : snsgn) (a : tcon) (kappa : snK),
    wfssig_nl sS ->
    {boundsnTCon a kappa sS} + {~ boundsnTCon a kappa sS}.
Proof.
  intros.
  assert ({ kappa' | boundsnTCon a kappa' sS} +
          { forall kappa', ~ boundsnTCon a kappa' sS})
    as [ [kappa'] | ]
      by (apply boundsnTCon_dec).
  - assert ({kappa = kappa'} + {kappa <> kappa'})
      as [ eq_kappa | ]
        by ( apply eq_snK).
    + (* kappa = kappa' *)
      rewrite eq_kappa.
      left; auto.
    + (* kappa <> kappa' *)
      right; intro Hb.
      assert (kappa = kappa')
        by (eauto using boundsnTCon_determinacy).
      contradiction.
  - right; intro.
    eapply n; eauto.
Qed.

(*
(** erausre stability for TCon **)
Lemma indomsnTCon_stable:
  forall (S : nsgn) (a : tcon),
    indomsnTCon a (erasure_nsgn S) ->
    indomnTCon a S.
Proof.

  intros S a.

  induction S.

  - intro H.
    unfold indomsnTCon in H.
    unfold boundsnTCon in H.
    decompose record H.
    simpl in H1.
    apply app_cons_not_nil in H1.
    contradiction.

  - destruct a0.
    destruct p.
    simpl.

    intro H.

    assert (indomnTCon a S).
    apply IHS.

    unfold indomsnTCon.
    unfold boundsnTCon.
    unfold indomsnTCon in H.
    unfold boundsnTCon in H.

    decompose record H.
    exists x.

    destruct x0.
    simpl in H1; inversion H1.

    exists x0.
    exists x1.

    simpl in H1.
    inversion H1.
    split; auto.
    intros; intro.
    eapply H2.
    right; eauto.

    unfold indomnTCon in H0.
    unfold boundnTCon in H0.
    decompose record H0.

    unfold indomnTCon.
    unfold boundnTCon.
    exists x.
    exists (inl (c, n) :: x0).
    exists x1.
    split.
    simpl.
    f_equal; auto.

    intros; intro.
    eapply H3.
    destruct H1.
    inversion e.
    eauto.

    destruct p.
    simpl.

    assert ({t = a} + {t <> a}) as [ | ] by (apply eq_tcon).

    + rewrite e.
      intros.
      unfold indomnTCon.
      unfold boundnTCon.

      exists n.
      exists nil.
      exists S.
      split.
      simpl; auto.
      intros; intro.
      inversion H0.

    + intros.
      assert (indomnTCon a S).
      apply IHS.

      unfold indomsnTCon in H.
      unfold boundsnTCon in H.
      decompose record H.

      destruct x0.
      simpl in H1.
      inversion H1.
      contradiction.

      unfold indomsnTCon.
      unfold boundsnTCon.
      exists x.
      exists x0.
      exists x1.

      split.
      simpl in H1.
      inversion H1.
      auto.

      intros; intro.
      eapply H2.
      right; eauto.

      unfold indomnTCon in H0.
      unfold boundnTCon in H0.
      decompose record H0.

      unfold indomnTCon.
      unfold boundnTCon.
      exists x.
      exists (inr (t, n) :: x0).
      exists (x1).
      split.
      simpl.
      f_equal; auto.
      intros; intro.
      eapply H3.
      destruct H1.
      inversion e; contradiction.
      eauto.
Qed.

(** * Stability if indomsnCon and indomsnTCon * **)

(** erausre stability for con **)
Lemma indomsnCon_stable:
  forall (S : nsgn) (c : con),
    indomsnCon c (erasure_nsgn S) ->
    indomnCon c S.
Proof.
  intros S a;
  unfold indomsnCon;
  unfold boundsnCon;
  unfold indomnCon;
  unfold boundnCon.
  induction S.

  - intro H.
    decompose record H.
    simpl in H1.
    apply app_cons_not_nil in H1.
    contradiction.

  - destruct a0; destruct p;
    simpl.

    + assert ({c = a} + {c <> a}) as [ | ] by (apply eq_con).

      * rewrite e.
        intros.

        exists n.
        exists nil.
        exists S.
        split.
        simpl; auto.
        intros; intro.
        inversion H0.

      * intros.
        assert (indomnCon a S).

        { apply IHS.
          decompose record H.

          destruct x0.
          simpl in H1.
          inversion H1.
          contradiction.

          exists x.
          exists x0.
          exists x1.

          split.
          simpl in H1.
          inversion H1.
          auto.

          intros; intro.
          eapply H2.
          right; eauto. }

      unfold indomnCon in H0.
      unfold boundnCon in H0.
      decompose record H0.

      exists x.
      exists (inl (c, n) :: x0).
      exists (x1).
      split.
      simpl.
      f_equal; auto.
      intros; intro.
      eapply H3.
      destruct H1.
      inversion e; contradiction.
      eauto.

    +
    intro H.
    decompose record H.

    assert (indomnCon a S).
    { apply IHS.

      exists x.
      destruct x0.
      simpl in H1; inversion H1.

      exists x0.
      exists x1.

      simpl in H1.
      inversion H1.
      split; auto.
      intros; intro.
      eapply H2.
      right; eauto. }

    unfold indomnCon in H0.
    unfold boundnCon in H0.
    decompose record H0.

    exists x2.
    exists (inr (t, n) :: x3).
    exists x4.
    split.
    simpl.
    f_equal; auto.

    intros; intro.
    eapply H5.
    destruct H3.
    inversion e.
    eauto.
Qed.

*)

*)


Require Import ZArith.
Require Import QArith.
Require Import Lqa.
Require Import Coq.micromega.Psatz.
Require Import Toy.CC.usl.interface.
Require Import Toy.CC.lib.
Require Import Toy.CC.type.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Sound.Sound_Flat.
Require Import Logic.SeparationLogic.ShallowEmbedded.PredicateSeparationLogic.
Require Import Logic.PropositionalLogic.ShallowEmbedded.PredicatePropositionalLogic.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.

Definition storeJ : Join store := equiv_Join.

Definition storeSA : SeparationAlgebra store := equiv_SA.

Open Scope Q.
Definition Q_Join : Join Q := fun q1 q2 q =>
  0 < q1 /\ 0 < q2 /\ 0 < q /\ q1 <= 1 /\ q2 <= 1 /\ q <= 1 /\ Qeq q (q1 + q2).

Definition Q_SA : @SeparationAlgebra Q Q_Join.
Proof.
  constructor; intros; unfold join, Q_Join in *;
  [| exists (mxyz - mx)]; repeat (split; try tauto; lra).
Qed.

Open Scope Z.

Definition Z_Join : Join Z := equiv_Join.

Definition Z_SA : SeparationAlgebra Z:= equiv_SA.

Definition QZ_Join : Join (Q * Z):= @prod_Join _ _ Q_Join Z_Join.

Definition QZ_SA : SeparationAlgebra (Q * Z) := @prod_SA Q Z Q_Join Z_Join Q_SA Z_SA.

Definition optionunit_Join : Join (option unit) := @option_Join unit (@trivial_Join unit).

Definition optionunit_SA : SeparationAlgebra (option unit) := @option_SA _ _ trivial_SA.

Definition lock1_Join : Join (Q * (option unit)) := @prod_Join _ _ Q_Join optionunit_Join.

Definition lock1_SA : SeparationAlgebra (Q * (option unit)) := @prod_SA _ _ Q_Join optionunit_Join Q_SA optionunit_SA.

Definition lock2_Join : Join (Assertion_D) := equiv_Join.

Definition lock2_SA : SeparationAlgebra Assertion_D := equiv_SA.

Definition lock_Join : Join (Q * (option unit) * Assertion_D) := @prod_Join _ _ lock1_Join lock2_Join.

Definition lock_SA : SeparationAlgebra (Q * (option unit) * Assertion_D) := @prod_SA _ _ lock1_Join lock2_Join lock1_SA lock2_SA.

Definition QZandLock_Join : Join ((Q * Z) + (Q * (option unit) * Assertion_D)) := @sum_Join _ _ QZ_Join lock_Join.

Definition QZandLock_SA : SeparationAlgebra ((Q * Z) + (Q * (option unit) * Assertion_D)) := @sum_SA _ _ QZ_Join lock_Join QZ_SA lock_SA.

Definition heapJ : Join heap := @fun_Join _ _ (@option_Join _ (QZandLock_Join)).

Definition heapSA : SeparationAlgebra heap := @fun_SA _ _ _ (@option_SA _ _ (QZandLock_SA)).

Definition stateJ : Join state := @prod_Join _ _ storeJ heapJ.

Definition stateSA : SeparationAlgebra state := @prod_SA store heap storeJ heapJ storeSA heapSA.

Definition stateR : KripkeModel.KI.Relation (state) := fun x y => x = y.

Definition SepCon (P : Assertion) (Q : Assertion) : Assertion :=
  fun st => exists st1 st2, (P st1) /\ (Q st2) /\ (stateJ st1 st2 st).

Module NaiveLang <: LanguageSig.
  Definition expr := Assertion.
  Section NaiveLang.
    Definition context := expr -> Prop.
    Definition provable (e : expr) : Prop := forall st, e st.
    Definition impp (e1 e2 : expr) : expr := fun st => e1 st -> e2 st.
    Definition andp (e1 e2 : expr) : expr := fun st => e1 st /\ e2 st.
    Definition orp (e1 e2 : expr) : expr := fun st => e1 st \/ e2 st.
    Definition sepcon := SepCon.
    Definition negp (e : expr) : expr := fun st => ~ e st.
    Definition falsep : expr := fun st => False.
    Definition truep : expr := fun st => True.
    Definition emp : expr := fun st => forall p, snd st p = None.
  End NaiveLang.
End NaiveLang.

Module NaiveRule.
Include DerivedNames (NaiveLang).

Instance L : Language := (Build_Language expr) .
Instance minL : (MinimumLanguage L) := (Build_MinimumLanguage L impp) .
Instance andpL : (AndLanguage L) := (Build_AndLanguage L andp) .
Instance sepconL : (SepconLanguage L) := (Build_SepconLanguage L sepcon) .
Instance falsepL : (FalseLanguage L) := (Build_FalseLanguage L falsep) .

Lemma falsep_sepcon_impp : (forall x : expr, provable (impp (sepcon falsep x) falsep)) .
Proof.
  unfold provable, impp, sepcon, falsep. intros.
  destruct H as [st1 [st2 ?]]. tauto.
Qed.

Lemma ufoptionj : forall {A : Type} (J : SeparationAlgebra.Join A) (a1 a2 a : option A) ,
  @OSAGenerators.option_join A J a1 a2 a <->
  (a1 = None /\ a2 = None /\ a = None) \/
  (exists v, a1 = None /\ a2 = Some v /\ a = Some v) \/
  (exists v, a1 = Some v /\ a2 = None /\ a = Some v) \/
  (exists v1 v2 v, a1 = Some v1 /\ a2 = Some v2 /\ a = Some v /\ J v1 v2 v).
Proof.
  unfold iff; split; intros.
  + destruct H.
    - left; tauto.
    - right; left; exists a; tauto.
    - right; right; left; exists a; tauto.
    - right; right; right. exists a,b,c; tauto.
  + destruct H as [? | [? | [? | ?]]].
    - destruct H as [? [? ?]]. rewrite H, H0, H1; constructor.
    - destruct H as [v [? [? ?]]]. rewrite H, H0, H1; constructor.
    - destruct H as [v [? [? ?]]]. rewrite H, H0, H1; constructor.
    - destruct H as [v1 [v2 [v [? [? [? ?]]]]]].
      rewrite H, H0, H1; constructor; tauto.
Qed.

Lemma ufsumj : forall {A B : Type} (J1 : SeparationAlgebra.Join A) (J2 : SeparationAlgebra.Join B) (a1 a2 a : A + B),
  @OSAGenerators.sum_join A B J1 J2 a1 a2 a <->
  (exists al1 al2 al, a1 = inl al1 /\ a2 = inl al2 /\ a = inl al /\ J1 al1 al2 al) \/
  (exists ar1 ar2 ar, a1 = inr ar1 /\ a2 = inr ar2 /\ a = inr ar /\ J2 ar1 ar2 ar).
Proof.
  unfold iff; split; intros.
  + destruct H.
    - left; exists a, b, c; tauto.
    - right; exists a, b, c; tauto.
  + destruct H.
    - destruct H as [al1 [al2 [al [? [? [? ?]]]]]].
      rewrite H, H0, H1. constructor; tauto.
    - destruct H as [ar1 [ar2 [ar [? [? [? ?]]]]]].
      rewrite H, H0, H1. constructor; tauto.
Qed.

Lemma sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) .
Proof.
  intros.
  unfold provable, impp, sepcon.
  unfold SepCon. intros.
  destruct H as [st1 [st2 [? [? ?]]]].
  exists st2, st1. split; [tauto|]. split; [tauto|].
  unfold stateJ in *. unfold prod_Join in *.
  destruct H1. split.
  + clear H2. unfold join in *. unfold storeJ in *.
    unfold equiv_Join in *. tauto.
  + clear H1. unfold join in *. unfold heapJ in *.
    unfold fun_Join in *. intros p0. specialize (H2 p0).
    unfold join in *. unfold option_Join in *. rewrite ufoptionj in *.
    destruct H2 as [? | [? | [? | ?]]].
    - left. tauto.
    - right. right. left. destruct H1 as [v0 ?]. exists v0. tauto.
    - right. left. destruct H1 as [v0 ?]. exists v0. tauto.
    - right. right. right. destruct H1 as [v1 [v2 [v ?]]].
      exists v2, v1, v. split; try split; try split; try tauto.
      destruct H1 as [? [? [? ?]]]. clear H1 H2 H3.
      unfold QZandLock_Join in *. rewrite ufsumj in *.
      destruct H4 as [? | ?].
      * left. destruct H1 as [al1 [al2 [al ?]]].
        exists al2, al1, al. split; try split; try split; try tauto.
        destruct H1 as [? [? [? ?]]].
        clear H1 H2 H3. unfold QZ_Join in *. unfold prod_Join in *.
        split.
        ++ destruct H4. unfold join in *. unfold Q_Join in *. lra.
        ++ destruct H4. unfold join in *. unfold Z_Join in *. unfold equiv_Join in *. tauto.
      * right. destruct H1 as [ar1 [ar2 [ar ?]]].
        exists ar2, ar1, ar. split; try split; try split; try tauto.
        destruct H1 as [? [? [? ?]]]. clear H1 H2 H3.
        unfold lock_Join in *. unfold prod_Join in *.
        split.
        ++ destruct H4. unfold join in *. unfold lock1_Join in *. unfold prod_Join in *.  split.
          -- unfold join in *. unfold Q_Join in *. lra.
          -- unfold join in *. unfold optionunit_Join in *. unfold option_Join in *.
            destruct H1. rewrite ufoptionj in *.
            destruct H3 as [? | [? | [? | ?]]].
            ** left. tauto.
            ** destruct H3 as [vv ?]. right. right. left. exists vv. tauto.
            ** destruct H3 as [vv ?]. right. left. exists vv. tauto.
            ** destruct H3 as [? [? [? [? [? [? ?]]]]]]. unfold trivial_Join in *. tauto.
        ++ destruct H4. unfold join in *. unfold lock2_Join in *. unfold equiv_Join in *. try tauto.
Qed.

(* Proof.
  intros x y.
  pose proof (@sound_sepcon_comm L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y).
  exact (@sound_sepcon_comm L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y).
Qed. *)

Lemma sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) .
Admitted.
(* Proof.
  intros x y z.
  exact (@sound_sepcon_assoc1 L _ _ (Build_Model state) (unit_kMD _) tt stateR stateJ stateSA (Pred_SM _) (Pred_kminSM _) (Pred_fsepconSM _) x y z).
Qed.   *)

Lemma sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
Proof.
  unfold provable, impp, sepcon, SepCon; intros.
  destruct H1 as [st1 [st2 ?]]; exists st1, st2.
  specialize (H st1); specialize (H0 st2); tauto.
Qed.

Lemma andp_intros : (forall x y : expr, provable (impp x (impp y (andp x y)))) .
Proof.
  unfold provable, impp, andp. auto.
Qed.

Lemma andp_elim1 : (forall x y : expr, provable (impp (andp x y) x)) .
Proof.
  unfold provable, impp, andp. tauto.
Qed.

Lemma andp_elim2 : (forall x y : expr, provable (impp (andp x y) y)) .
Proof.
  unfold provable, impp, andp. tauto.
Qed.

Lemma modus_ponens : (forall x y : expr, provable (impp x y) -> provable x -> provable y) .
Proof.
  unfold provable, impp, andp. auto.
Qed.

Lemma axiom1 : (forall x y : expr, provable (impp x (impp y x))) .
Proof.
  unfold provable, impp. auto.
Qed.

Lemma axiom2 : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z)))) .
Proof.
  unfold provable, impp. auto.
Qed.

End NaiveRule.

Module T := LogicTheorem NaiveLang NaiveRule.
Import T.


Require Import MathClasses.interfaces.abstract_algebra.

Section RewritingTest.

  Parameter A:Type.
  Parameter A_Equiv: Equiv A.
  Parameter A_Setoid: Setoid A.

  Variable f: A -> A.
  Variable f': A -> A.
  Variable g: A -> A.

  Lemma E: equiv f f'. Admitted.

  Parameter f_mor : Setoid_Morphism f.
  Parameter f'_mor : Setoid_Morphism f'.
  Parameter g_mor : Setoid_Morphism g.

  Instance equiv_proper:
    @Proper (forall (_ : forall _ : A, A) (_ : forall _ : A, A), Prop)
            (@respectful (forall _ : A, A) (forall _ : forall _ : A, A, Prop)
                         (@equiv (forall _ : A, A) (@ext_equiv A A_Equiv A A_Equiv))
                         (@respectful (forall _ : A, A) Prop
                                      (@equiv (forall _ : A, A) (@ext_equiv A A_Equiv A A_Equiv))
                                      (@flip Prop Prop Prop impl)))
            (@equiv (forall _ : A, A) (@ext_equiv A A_Equiv A A_Equiv)).
  Proof.
    Set Printing Implicit. Show.
  Admitted.

  Lemma Foo:
    f = f'.
  Proof.
    setoid_rewrite E.

  Admitted.

  Lemma Bar:
    compose f g = compose f' g.
  Proof.
    rewrite E.
  Qed.

End RewritingTest.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

Section General_Order.
Variable S : Type.
Variable O : S -> S -> Prop.
Variable E : S -> S -> Prop.

(** merge_order is the order which is the disjuction of two other orders. *)

Definition is_order :=
  (forall x : S, ~ O x x) /\ (forall x y z : S, O x y -> O y z -> O x z).

Definition wf_ind :=
  forall P : S -> Prop,
  (forall q : S, (forall r : S, O r q -> P r) -> P q) -> forall q : S, P q.

Definition is_equality :=
  (forall x : S, E x x) /\
  (forall x y : S, E x y -> E y x) /\
  (forall x y z : S, E x y -> E y z -> E x z).

(* The well_definedness proof (of the merged order) does not seem to need the totality of the order with respect to the Leibniz equlqity, but rather with respect to an equality which is rewriteable in the order predicates, hence we consign to the following property *)

Definition is_well_def_rht :=
  forall x y : S, O x y -> forall z : S, E y z -> O x z.

Definition is_well_def_lft :=
  forall x y : S, O x y -> forall z : S, E x z -> O z y.

End General_Order.

Record well_ordering : Type :=
  {wfcrr :> Type;
   order : wfcrr -> wfcrr -> Prop;
   equality : wfcrr -> wfcrr -> Prop;
   is_ord : is_order wfcrr order;
   is_eq : is_equality wfcrr equality;
   ord_is_wf : wf_ind wfcrr order;
   ord_wd_rht : is_well_def_rht wfcrr order equality}.

Section Negation_Order.
Variable S : well_ordering.

Let O := order S.

Lemma order_lt_le_weak : forall n m : S, O m n -> ~ O n m.
Proof.
 intros.
 elim (is_ord S).
 intro.
 intro.
 intro.
 apply H0 with n.
 apply H1 with m.
 assumption.
 assumption.
Defined.

End Negation_Order.

Section Merge_Order.

Variable S1 S2 : well_ordering.
Let O1 := order S1.
Let O2 := order S2.
Let E1 := equality S1.
Let E2 := equality S2.

Definition merge_lt (x1 : S1) (p1 : S2) (x2 : S1) (p2 : S2) :=
  O1 x1 x2 \/ E1 x1 x2 /\ O2 p1 p2.

Definition merge_le (x1 : S1) (p1 : S2) (x2 : S1) (p2 : S2) :=
  merge_lt x1 p1 x2 p2 \/ E1 x1 x2 /\ E2 p1 p2.

Let S1ind_wf := ord_is_wf S1.
Let S2ind_wf := ord_is_wf S2.

Lemma merge_lt_wf :
 forall P : S1 -> S2 -> Prop,
 (forall (q : S1) (t : S2),
  (forall (r : S1) (u : S2), merge_lt r u q t -> P r u) -> P q t) ->
 forall (x : S1) (p : S2), P x p.
Proof.
 intros.
 (* New Subgoal *)
 assert
  (forall r : S1,
   (forall r' : S1, O1 r' r -> forall t' : S2, P r' t') ->
   forall t : S2, P r t).
 clear x p.
 intros x.
 intros.
 set (x_aux := x) in *.
 assert (E1 x_aux x).
 unfold x_aux in |- *.
 elim (is_eq S1).
 intros.
 apply H1.
 generalize H1.
 generalize x_aux.
 apply (S2ind_wf (fun p : S2 => forall x_aux : S1, E1 x_aux x -> P x_aux p)).
 intros.
 apply H.
 intros.
 case H4.
 intro.
 apply H0.
 apply (ord_wd_rht S1) with x_aux0.
 assumption.
 assumption.
 intro a.
 elim a.
 intros.
 apply H2.
 assumption.
 elim (is_eq S1).
 intros.
 elim H8.
 intros.
 apply H10 with x_aux0.
 assumption.
 assumption.
 (* End New SUBGOAL *)

 generalize x.
 clear x.
 apply (S2ind_wf (fun p : S2 => forall x : S1, P x p)).
 intros.
 apply H.
 clear p.
 intros x' p.
 intro.
 case H2.

 intro.
 generalize p.
 assert
  (S1ind_wf_ :
   forall P : S1 -> Prop,
   (forall q : S1, (forall r : S1, O1 r q -> P r) -> P q) ->
   forall t : S1, P t).
 apply S1ind_wf.
 apply S1ind_wf_ with (P := fun x : S1 => forall p1 : S2, P x p1).
 intros.
 apply H0.
 intros.
 apply H4.
 assumption.

 intro a.
 elim a.
 intros.
 apply H1.
 assumption.
Defined.

End Merge_Order.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export rules_typehood.

(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(* begin hide *)

Hint Rewrite @nh_vars_hyps_app : slow.
Hint Rewrite @nh_vars_hyps_snoc : slow.

(* end hide *)

(* [25] ============ LAMBDA EQUALITY (ALT) ============ *)

(**

  The following rule is called the lambda equality rule.  It allows
  one to prove that lambda-abstractions are well-typed.
<<

   H |- \x1.t1 = \x2.t2 in x:A->B

     By lambdaEquality  z ()

     H z : A |- t1[x1\z] = t2[x2\z] in B[x\z]
     H |- istype(A)
>>
 *)

Definition rule_lambda_equality_alt {o}
           (A B t1 t2 : NTerm)
           (x1 x2 x z : NVar)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality
                      (mk_lam x1 t1)
                      (mk_lam x2 t2)
                      (mk_function A x B))))
    [ mk_baresequent
        (snoc H (mk_hyp z A))
        (mk_conclax (mk_equality
                       (subst t1 x1 (mk_var z))
                       (subst t2 x2 (mk_var z))
                       (subst B x (mk_var z)))),
      mk_baresequent
        H
        (mk_conclax (mk_istype A )) ]
    [sarg_var z].

Lemma rule_lambda_equality_alt_true {o} :
  forall lib (A B t1 t2 : NTerm)
         (x1 x2 x z : NVar)
         (H   : @barehypotheses o)
         (bc1 : !LIn z (bound_vars B))
         (bc2 : !LIn z (bound_vars t1))
         (bc3 : !LIn z (bound_vars t2)),
    rule_true lib (rule_lambda_equality_alt A B t1 t2 x1 x2 x z H).
Proof.
  intros.
  unfold rule_lambda_equality_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.
  duplicate wfct as wfi.
  rw <- @wf_equality_iff in wfct.
  destruct wfct as [ wl1 wfct ].
  destruct wfct as [ wl2 wfct ].
  rw <- @wf_function_iff in wfct.
  destruct wfct as [ wA wB ].
  duplicate ce0 as ce.
  allrw @nh_vars_hyps_snoc; allsimpl.

  exists (@covered_axiom o (nh_vars_hyps H)); GC.

  (* We prove some simple facts on our sequents *)
  assert ((z <> x -> !LIn z (free_vars B))
          # (z <> x1 -> !LIn z (free_vars t1))
          # (z <> x2 -> !LIn z (free_vars t2))
          # !LIn z (free_vars A)
          # !LIn z (vars_hyps H)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
  try (complete (generalize (cg z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (generalize (cg0 z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (generalize (cg1 z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (apply_in_hyp p;
                 generalize (subvars_hs_vars_hyps H); intro sv;
                 rw subvars_prop in sv;
                 apply sv in p; sp)).

  destruct vhyps as [ nzB vhyps ].
  destruct vhyps as [ nzt1 vhyps ].
  destruct vhyps as [ nzt2 vhyps ].
  destruct vhyps as [ nzA nzH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  lsubst_tac.
  rw @member_eq.
  rw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality lib
                (mk_function A x B) (mk_lam x1 t1) (mk_lam x2 t2) s1 s2 H
                wT wl1 wl2 c1 c0 c2 c3 cT cT0 eqh sim);
    intro k.
  lsubst_tac.
  apply k; clear k.

  rw @tequality_function.
  split.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2 eqh sim); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  rw @member_eq in hyp2.
  rw @equality_axiom_in_mkc_istype in hyp2.
  rw @tequality_mkc_istype in hyp0; try (complete auto).

  (* Then we prove that the b's are type families *)
  intros a a' ea.
  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* we have to prove the functionality of our hypotheses *)
  apply hyps_functionality_snoc2; simpl; try (complete sp).
  introv. intro eq. intro sim'.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s' eqh sim'); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  rw @equality_axiom_in_mkc_istype in hyp1.
  rw @tequality_mkc_istype in hyp0; try (complete auto).

  (* we have to prove the similarity of our hypotheses *)
  autodimp hyp1 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wA c4; sp.

  (* we can now use hyp1 *)
  exrepnd; lsubst_tac.

  (* we use hyp0 *)
  rw @tequality_mkc_equality in hyp0; repnd.

  (* we use hyp3 *)
  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a)) cT1
          = substc a x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c5)) as eq1
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq1 in hyp3.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s2 (z, a')) cT2
          = substc a' x (lsubstc_vars B wB (csub_filter s2 [x]) [x] c7)) as eq2
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq2 in hyp3.

  sp.

  (* we prove the membership *)
  clear dependent s1; clear dependent s2.
  introv hf sim.
  lsubst_tac.
  rw @equality_in_function3.

  dands.

  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.
  lsubst_tac.
  rw @member_eq in hyp2.
  rw @equality_axiom_in_mkc_istype in hyp2. auto.

  introv ea.

  assert (cover_vars (mk_var z) (snoc s1 (z, a)))
    as cv1 by (apply @cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  assert (cover_vars (mk_var z) (snoc s2 (z, a')))
    as cv2 by (apply @cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  assert (disjoint (free_vars (@mk_var o z)) (bound_vars t1))
    as disj1 by (simpl; rw disjoint_singleton_l; sp).

  assert (disjoint (free_vars (@mk_var o z)) (bound_vars t2))
    as disj2 by (simpl; rw disjoint_singleton_l; sp).

  assert (disjoint (free_vars (@mk_var o z)) (bound_vars B))
    as disjB by (simpl; rw disjoint_singleton_l; sp).

  dands.

  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s1 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* we have to prove the functionality of our hypotheses *)
  apply hyps_functionality_snoc2; simpl; try (complete sp).
  introv eq sim'.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s' hf sim'); clear hyp2; intro hyp2; exrepd.
  lsubst_tac.
  rw @tequality_mkc_istype in t. auto.

  (* we have to prove the similarity of our hypotheses *)
  autodimp hyp1 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s1 a a' wA c1; sp.
  apply @similarity_refl in sim; auto.

  exrepnd.
  lsubst_tac.
  rw @tequality_mkc_equality in hyp0; repnd.
  clear hyp1 hyp0.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a)) cT
          = substc a x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c2)) as eq1
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq1 in hyp3; clear eq1.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a')) cT0
          = substc a' x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c2)) as eq2
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq2 in hyp3; clear eq2.
  auto.

  repeat betared.

  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* we have to prove the functionality of our hypotheses *)
  apply hyps_functionality_snoc2; simpl; try (complete sp).
  introv eq sim'.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s' hf sim'); clear hyp2; intro hyp2; exrepd.
  lsubst_tac.
  rw @tequality_mkc_istype in t. auto.

  (* we have to prove the similarity of our hypotheses *)
  autodimp hyp1 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wA c1; sp.

  exrepnd.
  lsubst_tac.
  rw @member_eq in hyp1.
  rw <- @member_equality_iff in hyp1.

  apply @equality_commutes4 in hyp0; auto; clear hyp1.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a)) cT
          = substc a x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c2)) as eq
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq in hyp0; clear eq.

  assert (lsubstc (subst t1 x1 (mk_var z)) w2 (snoc s1 (z, a)) c4
          = substc a x1 (lsubstc_vars t1 w1 (csub_filter s1 [x1]) [x1] c0)) as eq
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq in hyp0; clear eq.

  assert (lsubstc (subst t2 x2 (mk_var z)) w3 (snoc s2 (z, a')) c7
          = substc a' x2 (lsubstc_vars t2 w0 (csub_filter s2 [x2]) [x2] c3)) as eq
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq in hyp0; clear eq.
  auto.
Qed.

(* [23] ============ LAMBDA FORMATION ============ *)

(**

 The following rule is the alternate lambda formation rule.  It says
 that to prove that a function type is true, it is enough to prove
 that given a element [z] in its domain [A], we can prove that its
 codomain [B[x\z]] is true.  We also have to prove that its domain [A]
 is a well-formed type. In this rule we use the istype(A) form of that
 assertion. It does not require any universe level.
<<
   H |- x:A -> B ext \z.b

     By lambdaFormationAlt lvl(i) z ()

     H z : A |- B[x\z] ext b
     H |- istype(A)
>>

 *)

Definition rule_lambda_formation_alt {p}
           (A B b : NTerm)
           (x z  : NVar)
           (H    : @barehypotheses p) :=
  mk_rule
    (mk_baresequent H (mk_concl (mk_function A x B) (mk_lam z b)))
    [ mk_baresequent (snoc H (mk_hyp z A))
                    (mk_concl (subst B x (mk_var z)) b),
      mk_baresequent H (mk_conclax (mk_istype A)) ]
    [sarg_var z].

Lemma rule_lambda_formation_alt_true {p} :
  forall lib (A B b : NTerm)
         (x z : NVar)
         (H   : @barehypotheses p)
         (bc1 : !LIn z (bound_vars B)),
    rule_true lib (rule_lambda_formation_alt A B b x z H).
Proof.
  intros.
  unfold rule_lambda_formation_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent (snoc H (mk_hyp z A))
                                  (mk_concl (subst B x (mk_var z)) b))
                   (inl eq_refl))
             (hyps (mk_baresequent H (mk_conclax (mk_istype A)))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.
  duplicate wfct as wfi.
  rw <- @wf_function_iff in wfct.
  destruct wfct as [ wa wb ].
  duplicate ce0 as ce.
  allrw @nh_vars_hyps_snoc; allsimpl.

  assert (covered (mk_lam z b) (nh_vars_hyps H)) as cv.
  clear hyp1 hyp2.
  allunfold @covered; allsimpl; allrw app_nil_r.
  allrw subvars_remove_nvars.
  allrw <- snoc_as_append; sp.

  exists cv; GC.

  (* We prove some simple facts on our sequents *)
  assert ((z <> x -> !LIn z (free_vars B))
          # !LIn z (free_vars A)
          # !LIn z (vars_hyps H)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
  try (complete (generalize (cg z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (apply_in_hyp p;
                 generalize (subvars_hs_vars_hyps H); intro sv;
                 rw subvars_prop in sv;
                 apply sv in p; sp)).

  destruct vhyps as [ nzB vhyps ].
  destruct vhyps as [ nzA nzH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  (* We prove our first subgoal *)
  assert (forall s2 pC2,
            similarity lib s1 s2 H
            -> tequality lib (lsubstc (mk_function A x B) wfi s1 pC1)
                         (lsubstc (mk_function A x B) wfi s2 pC2)) as tfb.
  clear s2 pC2 pt2 sim.
  intros s2 pC2 sim.
  lift_lsubst.
  rw @tequality_function.

  (* we have to prove that A is a type and B is a type family *)
  split.

  (* we use our 2nd hypothesis to prove that A is a type *)
  pose proof (@mk_istype_true2_implies p lib H A) as xx.
  autodimp xx G. unfold sequent_true2. exists (wfh, (wfct0, wfce0), (ct, ce)). auto.
  specialize (xx s1 s2 wa c1 c0 eqh sim) as xx.
  destruct xx. auto.

  (* we use our 1st hypothesis to prove that B is a type family *)
  intros.
  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 h.

  (* To use our 1st hyp, we first have to prove that the hypotheses are functional *)
  intros s3 sim3.
  inversion sim3; cpx; allsimpl; cpx; clear_irr.
  assert (cover_vars A s4) as c4
    by (apply similarity_cover_vars with (t := A) in sim0; auto).
  (* we use our hyp (coming from proving that our sequent is true) that says that H is functional *)
  rw @eq_hyps_snoc; simpl.

  exists s1 s4 a t2 wa c1 c4; sp.
  (* now to prove that functionality statement on A, we use our 2nd hyp *)
  pose proof (@mk_istype_true2_implies p lib H A) as xx.
  autodimp xx G. unfold sequent_true2. exists (wfh, (wfct0, wfce0), (ct, ce)). auto.
  specialize (xx s1 s4 wa c1 c4 eqh sim0) as xx.
  destruct xx. auto.
  (* and we're done proving that the hypotheses are functional *)

  (* now we can keep using our 1st hypothesis *)
  autodimp hyp1 hyp.

  (* For that we have to prove that the two terms we picked to be equal in A are actually equal in A *)
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wa c1; sp.
  (* easy enough *)

  (* and again, we keep on using our 1st hypothesis *)
  exrepd. (* we prove that from t *)

  assert (lsubstc (subst B x (mk_var z)) wfct1 (snoc s1 (z, a)) pC0
          = substc a x (lsubstc_vars B wb (csub_filter s1 [x]) [x] c2)) as eq1
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq1 in t.

  assert (lsubstc (subst B x (mk_var z)) wfct1 (snoc s2 (z, a')) pC3
          = substc a' x (lsubstc_vars B wb (csub_filter s2 [x]) [x] c3)) as eq2
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq2 in t.
  auto.
  (* and we're done proving our 1st subgoal (the tequality) *)

  (* We now prove our second subgoal *)
  sp; lift_lsubst.
  applydup @similarity_refl in sim.
  rw @equality_in_function.

  sp.
  (* We have to prove 3 goals *)

  (* 1) we have to prove that A is a type *)
  generalize (tfb s1 pC1 sim0); sp.
  lsubst_tac.
  allrw @tequality_function; sp.

  (* 2) we have to prove that B is a type family *)
  generalize (tfb s1 pC1 sim0); sp.
  lsubst_tac.
  allrw @tequality_function; sp.

  (* 3) we have to prove that b is a member B *)
  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* first we have to prove that the hypotheses are functional *)
  intros s3 sim3.
  inversion sim3; cpx; allsimpl; cpx; clear_irr.
  assert (cover_vars A s4) as c4
    by (apply similarity_cover_vars with (t := A) in sim1; auto).
  (* we use our hyp (coming from proving that our sequent is true) that says that H is functional *)
  allapplydup eqh.
  rw @eq_hyps_snoc; simpl.
  exists s1 s4 a t2 wa c1 c4; sp.
  (* now to prove that functionality statement on A, we use our 2nd hyp (from tfb) *)
  assert (cover_vars (mk_isect A x B) s4) as c5
    by (apply cover_vars_isect; sp;
        allapplydup @similarity_dom; sp;
        apply @cover_vars_upto_eq_dom_csub with (s2 := s4) in c2; sp;
        allrw; sp).
  generalize (tfb s4 c5 sim1); sp.
  lsubst_tac.
  allrw @tequality_function; sp.
  (* and we're done proving that the hypotheses are functional *)

  (* now we can keep using our 1st hypothesis *)
  autodimp hyp1 hyp.

  (* For that we have to prove that the two terms we picked to be equal in A are actually equal in A *)
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wa c1; sp.
  (* easy enough *)

  (* and again, we keep on using our 1st hypothesis *)
  exrepd. (* we prove that from e *)
  clear t; clear_irr.

  assert (lsubstc (subst B x (mk_var z)) wfct1 (snoc s1 (z, a)) pC0
          = substc a x (lsubstc_vars B wb (csub_filter s1 [x]) [x] c2)) as eq1.
  rewrite substc_eq_lsubstc; simpl.
  apply lsubstc_eq_if_csubst.
  rewrite csubst_app.
  unfold subst, csubst.
  try (rw lsubstn_lsubst; try (complete (simpl; rw disjoint_singleton_r; sp))).
  rewrite simple_lsubst_lsubst;
    try (complete (sp; allapply @in_csub2sub; sp));
    try (complete (simpl; sp; cpx; simpl; apply disjoint_singleton_l; auto)).
  rewrite lsubst_sub_singleton.
  rewrite fold_csubst.
  rewrite csubst_snoc_var;
    try (complete (allapply @similarity_dom; exrepd; allrw; sp)).
  rewrite <- csub2sub_app; simpl.
  rewrite <- snoc_as_append.
  rewrite <- lsubst_swap;
    try (complete (sp; allapply @in_csub2sub; sp));
    try (complete (rewrite @dom_csub_eq; rewrite @dom_csub_csub_filter; rw in_remove_nvars; simpl; sp)).
  repeat (rewrite <- @csub2sub_cons).
  repeat (rewrite @fold_csubst).
  destruct (eq_var_dec z x); subst.
  (* if they're equal it's easy *)
  rewrite csubst_cons_trim.
  rewrite csub_filter_snoc1; sp.
  (* if they're not: *)
  rewrite <- csubst_csub_filter with (l := [z]);
    try (rw disjoint_singleton_r; sp).
  assert (x <> z) as d by auto; simpl.
  apply memvar_singleton_diff_r in d; rewrite d.
  rewrite csub_filter_snoc1; sp.
  rewrite csubst_cons_trim.
  rewrite <- csub_filter_app_r; simpl.
  symmetry.
  rewrite <- csubst_csub_filter with (l := [z]); simpl;
    try (rw disjoint_singleton_r; sp).
  rewrite d.
  rewrite csub_filter_swap.
  rewrite <- csub_filter_app_r; sp.

  rewrite eq1 in e; clear eq1.

  lsubst_tac; sp.

  assert (cequivc lib
            (lsubstc b wfce1 (snoc s1 (z, a)) pt0)
            (mkc_apply
               (mkc_lam z (lsubstc_vars b wfce1 (csub_filter s1 [z]) [z] c0))
               a)) as ceq1.
  apply cequivc_sym.
  revert c0; rw @csub_filter_trivial; introv;
  try (complete (simpl; sp; subst; allapply @similarity_dom; repnd; allrw sim1; sp)).
  destruct_cterms; unfold cequivc; simpl; unfold csubst; simpl.
  allrw @csub2sub_snoc; simpl.
  generalize (cequiv_beta lib z (lsubst b (csub2sub s1)) x1); introv ceq1.
  autodimp ceq1 hyp.
  apply csubst.isprog_vars_lsubst.
  introv k; allrw @in_range_iff; exrepnd; allapply @in_csub2sub; sp.
  simpl.
  rw @isprog_vars_eq; sp.
  allunfold @covered.
  rw @dom_csub_eq.
  allapply @similarity_dom; repnd; allrw.
  apply subvars_trans with (vs2 := snoc (nh_vars_hyps H) z); sp.
  rw subvars_prop; introv j; allsimpl; allrw in_snoc; sp.
  generalize (subset_hs_vars_hyps H); intro k.
  right; apply k; sp.
  rw @nt_wf_eq; sp.
  autodimp ceq1 hyp.
  allrw @isprogram_eq; sp.
  rw @simple_lsubst_snoc in ceq1; sp.
  rw @isprogram_eq; sp.
  allapply @in_csub2sub; sp.

  assert (cequivc lib
            (lsubstc b wfce1 (snoc s2 (z, a')) pt3)
            (mkc_apply
               (mkc_lam z (lsubstc_vars b wfce1 (csub_filter s2 [z]) [z] c3))
               a'))
         as ceq2.
  apply cequivc_sym.
  revert c3; rw @csub_filter_trivial; introv;
  try (complete (simpl; sp; subst; allapply @similarity_dom; repnd; allrw sim; sp)).
  destruct_cterms; unfold cequivc; simpl; unfold csubst; simpl.
  allrw @csub2sub_snoc; simpl.
  generalize (cequiv_beta lib z (lsubst b (csub2sub s2)) x0); introv ceq2.
  autodimp ceq2 hyp.
  apply csubst.isprog_vars_lsubst.
  introv k; allrw @in_range_iff; exrepnd; allapply @in_csub2sub; sp.
  simpl.
  rw @isprog_vars_eq; sp.
  allunfold @covered.
  rw @dom_csub_eq.
  allapply @similarity_dom; repnd; allrw.
  apply subvars_trans with (vs2 := snoc (nh_vars_hyps H) z); sp.
  rw subvars_prop; introv j; allsimpl; allrw in_snoc; sp.
  generalize (subset_hs_vars_hyps H); intro k.
  right; apply k; sp.
  rw @nt_wf_eq; sp.
  autodimp ceq2 hyp.
  allrw @isprogram_eq; sp.
  rw @simple_lsubst_snoc in ceq2; sp.
  rw @isprogram_eq; sp.
  allapply @in_csub2sub; sp.

  apply @equality_respects_cequivc_left with (t1 := lsubstc b wfce1 (snoc s1 (z, a)) pt0); sp.
  apply @equality_respects_cequivc_right with (t2 := lsubstc b wfce1 (snoc s2 (z, a')) pt3); sp.
Qed.

(* begin hide *)

Lemma rule_lambda_formation_alt_true_ex {p} :
  forall lib z A B b x H (bc1 : !LIn z (bound_vars B)),
    @rule_true_if p lib (rule_lambda_formation_alt A B b x z H).
Proof.
  intros.
  generalize (rule_lambda_formation_alt_true lib A B b x z H bc1); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* [28] ============ FUNCTION EXTENSIONALITY  (ALT) ============ *)

(**

  The following rule called the ``function extensionality rule''
  states that the equality between functions in Nuprl is extensional.
<<
   H |- f1 = f2 in x:A->B

     By functionExtensionality  z ()

     H z : A |- f1 z = f2 z in B[x\z]
     H |- istype(A)
>>
 *)

Definition rule_function_extensionality_alt {o}
           (A B f1 f2 : NTerm)
           (x z : NVar)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       H
       (mk_conclax (mk_equality f1 f2 (mk_function A x B))))
    [ mk_baresequent
        (snoc H (mk_hyp z A))
        (mk_conclax (mk_equality
                       (mk_apply f1 (mk_var z))
                       (mk_apply f2 (mk_var z))
                       (subst B x (mk_var z)))),
      mk_baresequent
        H
        (mk_conclax (mk_istype A)) ]
    [sarg_var z].

Lemma rule_function_extensionality_alt_true {o} :
  forall lib (A B f1 f2 : NTerm)
         (x z : NVar)
         (H   : @barehypotheses o)
         (bc1 : !LIn z (bound_vars B)),
    rule_true lib (rule_function_extensionality_alt A B f1 f2 x z H).
Proof.
  intros.
  unfold rule_function_extensionality_alt, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent (snoc H (mk_hyp z A))
                                  (mk_conclax (mk_equality
                                                 (mk_apply f1 (mk_var z))
                                                 (mk_apply f2 (mk_var z))
                                                 (subst B x (mk_var z)))))
                   (inl eq_refl))
             (hyps (mk_baresequent H (mk_conclax (mk_istype A)))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.
  duplicate wfct as wfi.
  rw <- @wf_equality_iff in wfct.
  destruct wfct as [ wf1 wfct ].
  destruct wfct as [ wf2 wfct ].
  rw <- @wf_function_iff in wfct.
  destruct wfct as [ wA wB ].

  exists (@covered_axiom o (nh_vars_hyps H)); GC.

  (* We prove some simple facts on our sequents *)
  assert ((z <> x -> !LIn z (free_vars B))
          # !LIn z (free_vars f1)
          # !LIn z (free_vars f2)
          # !LIn z (free_vars A)
          # !LIn z (vars_hyps H)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
  try (complete (generalize (cg z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (generalize (cg0 z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (generalize (cg1 z); sp;
                 allrw in_remove_nvars; allsimpl;
                 autodimp X0 h; sp));
  try (complete (apply_in_hyp p;
                 generalize (subvars_hs_vars_hyps H); intro sv;
                 rw subvars_prop in sv;
                 apply sv in p; sp)).

  destruct vhyps as [ nzB  vhyps ].
  destruct vhyps as [ nzf1 vhyps ].
  destruct vhyps as [ nzf2 vhyps ].
  destruct vhyps as [ nzA  nzH ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  assert (tequality lib
            (mkc_function (lsubstc A wA s1 c4) x
                          (lsubstc_vars B wB (csub_filter s1 [x]) [x] c5))
            (mkc_function (lsubstc A wA s2 c6) x
                          (lsubstc_vars B wB (csub_filter s2 [x]) [x] c7))) as eqfunc.

  rw @tequality_function.

  split.

  (* First, we prove that the a's are types *)
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2 eqh sim); clear hyp2; intro hyp2.
  exrepd.
  lift_lsubst in t.
  lift_lsubst in e.
  rw @tequality_mkc_istype in t. auto.

  (* Then we prove that the b's are type families *)
  intros a a' eqaa'.
  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s1 (z, a)) (snoc s2 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* we have to prove the functionality of our hypotheses *)
  apply hyps_functionality_snoc2; simpl; try (complete sp).
  introv eq s.
  vr_seq_true in hyp2.
  generalize (hyp2 s1 s' eqh s); clear hyp2; intro hyp2.
  exrepd.
  lift_lsubst in t.
  lift_lsubst in e.
  rw @tequality_mkc_istype in t. auto.

  (* we have to prove the similarity of our hypotheses *)
  autodimp hyp1 hyp.
  rw @similarity_snoc; simpl.
  exists s1 s2 a a' wA c4; sp.

  (* we can now use hyp1 *)
  exrepnd; lsubst_tac.

  (* we use hyp0 *)
  rw @tequality_mkc_equality in hyp0; repnd.

  (* we use hyp3 *)
  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s1 (z, a)) cT1
          = substc a x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c5)) as eq1
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq1 in hyp3.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s2 (z, a')) cT2
          = substc a' x (lsubstc_vars B wB (csub_filter s2 [x]) [x] c7)) as eq2
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq2 in hyp3.

  sp.

  (* we prove the membership *)
  assert (forall a a' s1 s2,
            hyps_functionality lib s1 H
            -> similarity lib s1 s2 H
            -> {c1f : cover_vars f1 s1
                , {c2f : cover_vars f2 s2
                , {c1A : cover_vars A s1
                , {c1B : cover_vars_upto B (csub_filter s1 [x]) [x]
                , equality lib a a' (lsubstc A wA s1 c1A)
                  -> equality lib
                       (mkc_apply (lsubstc f1 wf1 s1 c1f) a)
                       (mkc_apply (lsubstc f2 wf2 s2 c2f) a')
                       (substc a x (lsubstc_vars B wB (csub_filter s1 [x]) [x] c1B))}}}}) as eqlam.
  introv eqh0 sim0.

  assert (cover_vars f1 s0) as c1f1.
  clear eqfunc.
  allapply @similarity_dom; repnd.
  allrw @cover_vars_eq.
  allrw.
  rw sim2 in c1; sp.

  assert (cover_vars f1 s3) as c2f1.
  clear eqfunc.
  allapply @similarity_dom; repnd.
  allrw @cover_vars_eq.
  allrw.
  rw sim2 in c1; sp.

  assert (cover_vars f2 s0) as c1f2.
  clear eqfunc.
  allapply @similarity_dom; repnd.
  allrw @cover_vars_eq.
  allrw.
  rw sim2 in c2; sp.

  assert (cover_vars f2 s3) as c2f2.
  clear eqfunc.
  allapply @similarity_dom; repnd.
  allrw @cover_vars_eq.
  allrw.
  rw sim2 in c2; sp.

  assert (cover_vars_upto B (csub_filter s0 [x]) [x]) as cB0.
  clear eqfunc.
  allapply @similarity_dom; repnd.
  allunfold @cover_vars_upto.
  allrw @dom_csub_csub_filter.
  allrw.
  rw sim in c7; sp.

  assert (cover_vars_upto B (csub_filter s3 [x]) [x]) as cB3.
  clear eqfunc.
  allapply @similarity_dom; repnd.
  allunfold @cover_vars_upto.
  allrw @dom_csub_csub_filter.
  allrw.
  rw sim in c7; sp.

  assert (cover_vars A s0) as cA0.
  clear eqfunc.
  allrw @cover_vars_eq.
  allapply @similarity_dom; repnd.
  allrw.
  rw sim in c6; sp.

  assert (cover_vars A s3) as cA3.
  clear eqfunc.
  allrw @cover_vars_eq.
  allapply @similarity_dom; repnd.
  allrw.
  rw sim in c6; sp.

  exists c1f1 c2f2 cA0 cB0.
  introv eqaa'.

  vr_seq_true in hyp1.
  generalize (hyp1 (snoc s0 (z, a)) (snoc s3 (z, a'))); clear hyp1; intro hyp1.
  autodimp hyp1 hyp.

  (* we have to prove the functionality of our hypotheses *)
  apply hyps_functionality_snoc2; simpl; try (complete sp).
  introv eq s.
  vr_seq_true in hyp2.
  generalize (hyp2 s0 s' eqh0 s); clear hyp2; intro hyp2.
  exrepd.
  lift_lsubst in t.
  lift_lsubst in e.
  rw @tequality_mkc_istype in t. auto.

  (* we have to prove the similarity of our hypotheses *)
  autodimp hyp1 hyp.
  rw @similarity_snoc; simpl.
  exists s0 s3 a a' wA cA0; sp.

  (* we can now use hyp1 *)
  exrepnd; lsubst_tac.
  rw @tequality_mkc_equality in hyp0; repnd.
  rw @member_eq in hyp1.
  rw <- @member_equality_iff in hyp1.
  clear_irr; GC.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s0 (z, a)) cT1
          = substc a x (lsubstc_vars B wB (csub_filter s0 [x]) [x] cB0)) as eq1
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq1 in hyp0.
  rewrite eq1 in hyp1.
  rewrite eq1 in hyp3.
  clear eq1.

  assert (lsubstc (subst B x (mk_var z)) wT0 (snoc s3 (z, a')) cT2
          = substc a' x (lsubstc_vars B wB (csub_filter s3 [x]) [x] cB3)) as eq2
         by (apply lsubstc_subst_snoc_eq; try (complete sp);
             allapply @similarity_dom; exrepd; allrw; sp).

  rewrite eq2 in hyp3.
  clear eq2.

   (* a few useful assertions *)
  assert (similarity lib s1 s1 H)
         as sim1
         by (allapply @similarity_refl; sp).
  assert (similarity lib s2 s2 H)
         as sim2
         by (apply @similarity_sym in sim; allapplydup @similarity_refl; sp;
             apply eqh in sim; sp).
  assert (hyps_functionality lib s2 H)
         as eqh2
         by (apply @similarity_hyps_functionality_trans with (s1 := s1); sp).

  eapply equality_trans. exact hyp1. apply hyp0.
  apply equality_sym in hyp1. apply equality_refl in hyp1. auto.
  (* we start proving our conclusion *)
  rw @equality_in_function2.
  dands; try (complete sp).

  (* tequality *)
  apply tequality_mkc_equality_if_equal; try (complete sp).

  (* application in B *)
  rw @equality_in_function2.
  split; try (complete (apply @tequality_refl in eqfunc; sp)).
  introv e.
  assert (equality lib a' a' (lsubstc A wA s2 c6))
         as e'
         by (apply @equality_sym in e; apply @equality_refl in e;
             rw @tequality_function in eqfunc; repnd;
             eapply @tequality_preserving_equality;
             try (exact e); sp).

  generalize (eqlam a a' s1 s2 eqh sim); intro k1; exrepnd; clear_irr; sp.
  assert (hyps_functionality lib s2 H) as hf2.
  eapply similarity_hyps_functionality_trans; eauto.
  assert (similarity lib s2 s2 H) as sim2. eapply similarity_refl; apply similarity_sym; eauto.
  generalize (eqlam a' a' s2 s2 hf2 sim2). intro k2; exrepnd; clear_irr; sp.

  eapply @equality_trans; sp.
  exact k1.
  apply @equality_sym.
  eapply @tequality_preserving_equality.
  exact k2.
  apply @tequality_sym.
  rw @tequality_function in eqfunc; repnd; sp.

  (* application in B *)
  rw @equality_in_function2.
  split; try (complete (apply @tequality_refl in eqfunc; sp)).
  introv e.
  assert (equality lib a a (lsubstc A wA s1 c4)) as e' by (allapply @equality_refl; sp).

  generalize (eqlam a a' s1 s2 eqh sim); intro k1; exrepnd; clear_irr; sp.
  assert (similarity lib s1 s1 H ) as sim1. eapply similarity_refl; eauto.
  generalize (eqlam a a s1 s1 eqh sim1); intro k2; exrepnd; clear_irr; sp.

  eapply @equality_trans; sp.
  apply equality_sym.
  exact k2.
  auto.

  (* type *)
  apply @tequality_refl in eqfunc; sp.

  (* application in B *)
  assert (similarity lib s1 s1 H ) as sim1.
  eapply similarity_refl; eauto.
  introv e.
  generalize (eqlam a a' s1 s1 eqh sim1); intro k; exrepnd; clear_irr; sp.
Qed.


(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

  DdlCoq is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  DdlCoq is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export static_sem_lemmas.
Require Export US.

Inductive subterm : Term -> Term -> Prop :=
| subterm_refl : forall t, subterm t t
| subterm_trans : forall a b c, subterm a b -> subterm b c -> subterm a c
| subterm_func :
    forall f n (args : Vector.t Term n) t,
      Vector.In t args
      -> subterm t (KTfuncOf f n args)
| subterm_neg : forall t, subterm t (KTneg t)
| subterm_plus_l   : forall a b, subterm a (KTplus   a b)
| subterm_plus_r   : forall a b, subterm b (KTplus   a b)
| subterm_minus_l  : forall a b, subterm a (KTminus  a b)
| subterm_minus_r  : forall a b, subterm b (KTminus  a b)
| subterm_times_l  : forall a b, subterm a (KTtimes  a b)
| subterm_times_r  : forall a b, subterm b (KTtimes  a b)
| subterm_diff : forall t, subterm t (KTdifferential t).
Hint Constructors subterm.

Lemma implies_subset_cons_r_weak :
  forall {T} (l1 l2 : list T) x,
    subset l1 l2 -> subset l1 (x :: l2).
Proof.
  introv ss i; simpl; apply ss in i; tcsp.
Qed.

Lemma implies_subset_vec_flatten :
  forall {T} (l : list T) {n} (v : Vector.t (list T) n),
    (exists x, Vector.In x v /\ subset l x)
    -> subset l (vec_flatten v).
Proof.
  introv e i; exrepnd.
  apply in_vec_flatten.
  eexists; dands; eauto.
Qed.

Lemma subterm_implies_term_signature_subset :
  forall a b,
    subterm a b
    -> subset (term_signature a) (term_signature b).
Proof.
  introv st.
  induction st; simpl; auto; try (complete (apply implies_subset_app_r; tcsp)).
  { eapply subset_trans; eauto. }
  { apply implies_subset_cons_r_weak.
    apply implies_subset_vec_flatten.
    exists (term_signature t); dands; auto.
    apply in_vec_map; eexists; dands; eauto. }
Qed.

Lemma uniform_substitution_entry_in_term_if_subterm :
  forall e a b,
    subterm a b
    -> uniform_substitution_entry_in_term e a = true
    -> uniform_substitution_entry_in_term e b = true.
Proof.
  introv st.
  repeat (rewrite uniform_substitution_entry_in_term_eq).
  destruct e; auto.
  intro i.
  unfold in_signature in *.
  repeat (dest_cases w; GC).
  apply subterm_implies_term_signature_subset in st.
  apply st in i0; tcsp.
Qed.

Lemma subset_uniform_substitution_restriction_term_subterm :
  forall s t1 t2,
    subterm t1 t2
    -> subset (uniform_substitution_restriction_term s t1)
              (uniform_substitution_restriction_term s t2).
Proof.
  induction s; introv st; simpl; auto.
  dest_cases w; dest_cases y; symmetry in Heqw, Heqy.
  { apply subset_cons_l; simpl; dands; tcsp.
    apply implies_subset_cons_r_weak; auto. }
  { eapply uniform_substitution_entry_in_term_if_subterm in st;[|eauto].
    rewrite st in Heqy; ginv. }
  { apply implies_subset_cons_r_weak; auto. }
Qed.

Lemma implies_eassignables_subset_free_vars_uniform_substitution :
  forall s1 s2,
    subset s1 s2
    -> eassignables_subset
         (free_vars_uniform_substitution s1)
         (free_vars_uniform_substitution s2) = true.
Proof.
  introv h.
  apply eassignables_subset_iff; introv i.
  unfold free_vars_uniform_substitution in *.
  induction s1; simpl in *; ginv.
  apply subset_cons_l in h; repnd.
  autodimp IHs1 hyp.
  apply in_eassignables_app_true_iff in i; repndors; tcsp.
  clear dependent s1.

  induction s2; simpl in *; tcsp.
  apply in_eassignables_app_true_iff.
  repndors; subst; tcsp.
Qed.
Hint Resolve implies_eassignables_subset_free_vars_uniform_substitution : core.

Lemma eassignables_subset_subterm :
  forall s a b,
    subterm a b
    -> eassignables_subset
         (free_vars_sub_restrict_term s a)
         (free_vars_sub_restrict_term s b)
       = true.
Proof.
  introv st.
  unfold free_vars_sub_restrict_term.
  apply implies_eassignables_subset_free_vars_uniform_substitution.
  induction s; simpl; auto.
  dest_cases w; dest_cases y; symmetry in Heqw, Heqy.
  { apply subset_cons_l; simpl; dands; tcsp. }
  { eapply uniform_substitution_entry_in_term_if_subterm in st;[|eauto].
    rewrite st in Heqy; ginv. }
Qed.