From Coq Require Import ssreflect ssrfun ssrbool.

From Coq Require Import Ensembles.
From stdpp Require Import base fin_sets sets propset.
From MatchingLogic.Utils Require Import Lattice stdpp_ext.
From MatchingLogic Require Import Syntax Semantics.

Import MatchingLogic.Syntax.Notations.
Import MatchingLogic.Substitution.Notations.

Section monotonic.
  Open Scope ml_scope.
  Context {Σ : Signature}.

  (* Definitions and lemmas inside this section are useful for proving `is_monotonic`,
   but they are probably not usefull for any other purpose. *)
  Section respects_blacklist.
    (* Bp - Blacklist of Positive Occurrence - these variables can occur only negatively.
     Bn - Blacklist of Negative Occurrence - these variables can occur only positively *)
    Definition respects_blacklist (phi : Pattern) (Bp Bn : Ensemble svar) : Prop :=
      forall (var : svar),
        (Bp var -> svar_has_positive_occurrence var phi = false) /\ (Bn var -> @svar_has_negative_occurrence Σ var phi = false).

    Lemma respects_blacklist_app : forall (phi1 phi2 : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist phi1 Bp Bn -> respects_blacklist phi2 Bp Bn ->
        respects_blacklist (phi1 $ phi2)%ml Bp Bn.
    Proof.
      intros. unfold respects_blacklist in *.
      intros. split; intros; cbn; apply orb_false_iff; split; try apply H; try apply H0; auto.
    Qed.

    Lemma respects_blacklist_app_1 : forall (phi1 phi2 : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist (phi1 $ phi2)%ml Bp Bn -> respects_blacklist phi1 Bp Bn.
    Proof.
      unfold respects_blacklist.
      intros.
      specialize (H var).
      destruct H as [Hneg Hpos].
      split; intros.
      * specialize (Hneg H). cbn in Hneg.
        apply orb_false_iff in Hneg as [Hneg _]. assumption.
      * specialize (Hpos H). cbn in Hneg.
        apply orb_false_iff in Hpos as [Hpos _]. assumption.
    Qed.

    (* This proof is the same as for app_1 *)
    Lemma respects_blacklist_app_2 : forall (phi1 phi2 : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist (phi1 $ phi2) Bp Bn -> respects_blacklist phi2 Bp Bn.
    Proof.
      unfold respects_blacklist.
      intros.
      specialize (H var).
      destruct H as [Hneg Hpos].
      split; intros.
      * specialize (Hneg H). cbn in Hneg.
        apply orb_false_iff in Hneg as [_ Hneg]. assumption.
      * specialize (Hpos H). cbn in Hneg.
        apply orb_false_iff in Hpos as [_ Hpos]. assumption.
    Qed.

    Lemma respects_blacklist_impl : forall (phi1 phi2 : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist phi1 Bn Bp -> respects_blacklist phi2 Bp Bn ->
        respects_blacklist (phi1 ---> phi2) Bp Bn.
    Proof.
      intros. unfold respects_blacklist in *.
      intros. split; intros; cbn; apply orb_false_iff; split; try apply H; try apply H0; auto.
    Qed.

    Lemma respects_blacklist_impl_1 : forall (phi1 phi2 : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist (phi1 ---> phi2) Bp Bn -> respects_blacklist phi1 Bn Bp.
    Proof.
      unfold respects_blacklist.
      intros.
      specialize (H var).
      destruct H as [Hpos Hneg].
      split; intros.
      * specialize (Hneg H). cbn in Hneg.
        apply orb_false_iff in Hneg as [Hneg _]. assumption.
      * specialize (Hpos H). cbn in Hneg.
        apply orb_false_iff in Hpos as [Hpos _]. assumption.
    Qed.

    Lemma respects_blacklist_impl_2 : forall (phi1 phi2 : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist (phi1 ---> phi2) Bp Bn -> respects_blacklist phi2 Bp Bn.
    Proof.
      unfold respects_blacklist.
      intros.
      specialize (H var).
      destruct H as [Hpos Hneg].
      split; intros.
      * specialize (Hpos H). cbn in Hpos.
        apply orb_false_iff in Hpos as [_ Hpos]. assumption.
      * specialize (Hneg H). cbn in Hneg.
        apply orb_false_iff in Hneg as [_ Hneg]. assumption.
    Qed.

    Lemma respects_blacklist_ex : forall (phi : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist (patt_exists phi) Bp Bn -> respects_blacklist phi Bp Bn.
    Proof.
      intros. unfold respects_blacklist in *.
      intros. specialize (H var). destruct H as [Hneg Hpos].
      split; intros.
      * specialize (Hneg H). assumption.
      * specialize (Hpos H). assumption.
    Qed.

    Lemma respects_blacklist_ex' : forall (phi : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist phi Bp Bn -> respects_blacklist (patt_exists phi) Bp Bn.
    Proof.
      unfold respects_blacklist. intros.
      specialize (H var).
      destruct H as [Hneg Hpos].
      split; auto.
    Qed.

    Lemma respects_blacklist_mu : forall (phi : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist (patt_mu phi) Bp Bn -> respects_blacklist phi Bp Bn.
    Proof.
      unfold respects_blacklist. intros.
      specialize (H var).
      destruct H as [Hneg Hpos].
      split; intros; auto.
    Qed.

    Lemma respects_blacklist_mu' : forall (phi : Pattern) (Bp Bn : Ensemble svar),
        respects_blacklist phi Bp Bn -> respects_blacklist (patt_mu phi) Bp Bn.
    Proof.
      unfold respects_blacklist. intros.
      specialize (H var).
      destruct H as [Hneg Hpos].
      split; auto.
    Qed.

    Lemma respects_blacklist_union : forall (phi : Pattern) (Bp1 Bn1 Bp2 Bn2 : Ensemble svar),
        respects_blacklist phi Bp1 Bn1 ->
        respects_blacklist phi Bp2 Bn2 ->
        respects_blacklist phi (Ensembles.Union svar Bp1 Bp2) (Ensembles.Union svar Bn1 Bn2).
    Proof.
      unfold respects_blacklist.
      induction phi; intros; split; intros;
        destruct H1; unfold In in *;
          try specialize (H x0); try specialize (H x);
            try specialize (H0 x0); try specialize (H0 x); firstorder; try constructor.
    Qed.

    Lemma positive_occurrence_respects_blacklist_svar_open :
      forall (phi : Pattern) (dbi : db_index) (X : svar),
        no_negative_occurrence_db_b dbi phi ->
        X ∉ (free_svars phi) ->
        respects_blacklist (phi^{svar: dbi ↦ X}) (Empty_set svar) (Ensembles.Singleton svar X).
    Proof.
      intros phi dbi X Hpodb Hni.
      pose proof (Hpno := @not_free_implies_positive_negative_occurrence Σ phi X Hni).
      unfold respects_blacklist. intros.
      split; intros.
      * firstorder using positive_negative_occurrence_db_named.
      * inversion H. subst.
        pose (Hpd := positive_negative_occurrence_db_named phi dbi var).
        destruct Hpd as [Hpd1 Hpd2].
        destruct Hpno as [Hpno1 Hpno2].
        auto.
    Qed.

    Lemma mu_wellformed_respects_blacklist : forall (phi : Pattern) (X : svar),
        well_formed_positive (patt_mu phi) ->
        svar_is_fresh_in X phi ->
        respects_blacklist (phi^{svar: 0 ↦ X}) (Empty_set svar) (Ensembles.Singleton svar X).
    Proof.
      intros phi X H Hfr. simpl in H.
      apply andb_true_iff in H.
      destruct H as [Hpo Hwfp].
      apply positive_occurrence_respects_blacklist_svar_open; auto.
    Qed.

    (*
Lemma respects_blacklist_ex' : forall (phi : Pattern) (Bp Bn : Ensemble svar),
    respects_blacklist ()
respects_blacklist (evar_open 0 (evar_fresh variables (free_evars phi)) phi) Bp B
     *)

    Lemma evar_open_respects_blacklist :
      forall (phi : Pattern) (Bp Bn : Ensemble svar) (x : evar) (n : nat),
        respects_blacklist phi Bp Bn ->
        respects_blacklist (phi^{evar: n ↦ x}) Bp Bn.
    Proof.
      induction phi; try auto.
      - (* EVar bound *)
        intros. cbn.
        case_match; assumption.
      -  (* App *)
        intros.
        simpl.
        remember (respects_blacklist_app_1 phi1 phi2 Bp Bn H) as Hrb1. clear HeqHrb1.
        remember (respects_blacklist_app_2 phi1 phi2 Bp Bn H) as Hrb2. clear HeqHrb2.
        specialize (IHphi1 Bp Bn x n Hrb1).
        specialize (IHphi2 Bp Bn x n Hrb2).
        clear H Hrb1 Hrb2.
        apply respects_blacklist_app. assumption. assumption.
      - (* Impl *)
        intros.
        simpl.
        remember (respects_blacklist_impl_1 phi1 phi2 Bp Bn H) as Hrb1. clear HeqHrb1.
        remember (respects_blacklist_impl_2 phi1 phi2 Bp Bn H) as Hrb2. clear HeqHrb2.
        specialize (IHphi1 Bn Bp x n Hrb1).
        specialize (IHphi2 Bp Bn x n Hrb2).
        apply respects_blacklist_impl; assumption.
      - (* Ex *)
        intros. mlSimpl.
        apply respects_blacklist_ex'.
        apply respects_blacklist_ex in H.
        auto.
    Qed.
  End respects_blacklist.

  (* From the following section, `update_svar_val_comm`, `update_svar_shadow`
   and `is_monotonic` may be generally useful.
   The lemma `respects_blacklist_implies_monotonic` is only a technical lemma for proving `is_monotonic`,
   which is the main lemma of the section.
   *)
  Section with_model.

    Context {M : Model}.
    Let A := propset (Domain M).
    Let OS := PropsetOrderedSet (Domain M).
    Let L := PowersetLattice (Domain M).

    Lemma respects_blacklist_implies_monotonic :
      forall (n : nat) (phi : Pattern),
        le (size phi) n -> well_formed_positive phi ->
        forall (Bp Bn : Ensemble svar),
          respects_blacklist phi Bp Bn ->
          forall (ρ : @Valuation _ M)
                 (X : svar),
            (Bp X ->
             @AntiMonotonicFunction A OS (fun (S : propset (Domain M)) =>
                                            (@eval Σ M (update_svar_val X S ρ) phi)
                                         )
            ) /\
            (Bn X ->
             @MonotonicFunction A OS (fun S : propset (Domain M) =>
                                        (@eval Σ M (update_svar_val X S ρ) phi))
            )
    .
    Proof.
      induction n.
      - (* n = 0 *)
        intros. destruct phi; simpl in H; try inversion H.
        + (* EVar free *)
          unfold MonotonicFunction. unfold AntiMonotonicFunction. unfold leq. simpl.
          setoid_rewrite -> elem_of_subseteq.
          unfold In. split; intros; rewrite -> eval_free_evar_simpl in *; assumption.
        + (* SVar free *)
          unfold MonotonicFunction. unfold AntiMonotonicFunction. unfold leq. simpl.
          setoid_rewrite -> elem_of_subseteq.
          split; intros; rewrite -> eval_free_svar_simpl in *;
            unfold update_svar_val in *; destruct (decide (X = x)); subst.
          * unfold respects_blacklist in H1.
            specialize (H1 x).
            destruct H1 as [Hneg Hpos].
            specialize (Hneg H2).
            inversion Hneg. subst. cbn in H5. case_match; congruence.
          * simpl. simpl in H4. destruct (decide (X = x)). contradiction. apply H4.
          * simpl. simpl in H4. rewrite decide_eq_same. rewrite decide_eq_same in H4.
            auto.
          * simpl. simpl in H4. destruct (decide (X = x)). contradiction. apply H4.

        + (* EVar bound *)
          unfold AntiMonotonicFunction. unfold MonotonicFunction. unfold leq. simpl.
          split; intros; repeat rewrite -> eval_bound_evar_simpl;
            setoid_rewrite -> elem_of_subseteq;
            unfold In; intros; assumption.
        + (* SVar bound *)
          unfold AntiMonotonicFunction. unfold MonotonicFunction. unfold leq. simpl.
          split; intros; repeat rewrite -> eval_bound_svar_simpl;
            setoid_rewrite -> elem_of_subseteq;
            unfold In; intros; assumption.
        + (* Sym *)
          unfold AntiMonotonicFunction. unfold MonotonicFunction. unfold leq. simpl.
          split; intros; repeat rewrite -> eval_sym_simpl;
            setoid_rewrite -> elem_of_subseteq;
            unfold In; intros; assumption.
        + (* Bot *)
          unfold AntiMonotonicFunction. unfold MonotonicFunction. unfold leq. simpl.
          split; intros; rewrite -> eval_bott_simpl;
            setoid_rewrite -> elem_of_subseteq; intros; inversion H4.
      - (* S n *)
        intros phi Hsz Hwfp Bp Bn Hrb ρ V.
        destruct phi.
        * apply IHn. simpl. lia. assumption. assumption.
        * apply IHn. simpl. lia. assumption. assumption.
        * apply IHn. simpl. lia. assumption. assumption.
        * apply IHn. simpl. lia. assumption. assumption.
        * apply IHn. simpl. lia. assumption. assumption.
        * (* App *)
          remember (respects_blacklist_app_1 phi1 phi2 Bp Bn Hrb) as Hrb1. clear HeqHrb1.
          remember (respects_blacklist_app_2 phi1 phi2 Bp Bn Hrb) as Hrb2. clear HeqHrb2.
          simpl in Hwfp.
          apply andb_true_iff in Hwfp.
          destruct Hwfp as [Hwfp1 Hwfp2].

          (* phi1 and phi2 are smaller then the whole implication *)
          simpl in Hsz.
          assert (Hsz1: size phi1 <= n).
          { lia. }
          assert (Hsz2: size phi2 <= n).
          { lia. }

          split.
          {
            intros HBp. unfold AntiMonotonicFunction in *.
            intros.
            repeat rewrite -> eval_app_simpl.
            unfold app_ext. unfold leq in *. simpl in *.
            setoid_rewrite -> elem_of_subseteq.
            rewrite -> elem_of_subseteq in H.
            intros.
            destruct H0. destruct H0. destruct H0. destruct H1.

            exists x1. exists x2.
            split.
            - specialize (IHn phi1 Hsz1 Hwfp1 Bp Bn Hrb1 ρ V).
              destruct IHn as [IHam IHmo].
              apply (IHam HBp x y H x1). assumption.
            - split.
              + specialize (IHn phi2 Hsz2 Hwfp2 Bp Bn Hrb2 ρ V).
                destruct IHn as [IHam IHmo].
                apply (IHam HBp x y H x2). assumption.
              + assumption.
          }
          {
            intros HBp. unfold MonotonicFunction in *.
            intros.
            repeat rewrite -> eval_app_simpl.
            unfold app_ext. unfold leq in *. simpl in *.
            setoid_rewrite -> elem_of_subseteq.
            rewrite -> elem_of_subseteq in H.
            intros.
            destruct H0. destruct H0. destruct H0. destruct H1.

            exists x1. exists x2.
            split.
            - specialize (IHn phi1 Hsz1 Hwfp1 Bp Bn Hrb1 ρ V).
              destruct IHn as [IHam IHmo].
              apply (IHmo HBp x y H x1). assumption.
            - split.
              + specialize (IHn phi2 Hsz2 Hwfp2 Bp Bn Hrb2 ρ V).
                destruct IHn as [IHam IHmo].
                apply (IHmo HBp x y H x2). assumption.
              + assumption.
          }

        * (* Bot *)
          apply IHn. simpl. lia. assumption. assumption.
        * (* Impl *)
          (* phi1 and phi2 are well-formed-positive *)
          simpl in Hwfp.
          apply andb_true_iff in Hwfp.
          destruct Hwfp as [Hwfp1 Hwfp2].

          (* phi1 and phi2 are smaller then the whole implication *)
          simpl in Hsz.
          assert (Hsz1: size phi1 <= n).
          { lia. }
          assert (Hsz2: size phi2 <= n).
          { lia. }

          remember (respects_blacklist_impl_1 phi1 phi2 Bp Bn Hrb) as Hrb1. clear HeqHrb1.
          remember (respects_blacklist_impl_2 phi1 phi2 Bp Bn Hrb) as Hrb2. clear HeqHrb2.
          remember IHn as IHn1. clear HeqIHn1.
          rename IHn into IHn2.
          specialize (IHn1 phi1 Hsz1 Hwfp1 Bn Bp Hrb1 ρ V).
          specialize (IHn2 phi2 Hsz2 Hwfp2 Bp Bn Hrb2 ρ V).
          unfold AntiMonotonicFunction in *.
          unfold MonotonicFunction in *.

          split.
          {
            intros HBp.
            intros.
            repeat rewrite -> eval_imp_simpl.
            unfold leq in *. simpl in *.
            setoid_rewrite -> elem_of_subseteq.
            rewrite -> elem_of_subseteq in H.
            intros.
            destruct H0.
            + left.
              rewrite -> elem_of_difference in H0.
              destruct H0 as [_ H0].
              rewrite -> elem_of_difference.
              split.
              { apply elem_of_top'. }

              unfold not in *. intros.
              apply H0.

              destruct IHn1 as [IHn11 IHn12].
              apply (IHn12 HBp x y H x0).
              apply H1.
            + right. unfold Ensembles.In in *.
              destruct IHn2 as [IHn21 IHn22].
              apply (IHn21 HBp x y H x0 H0).
          }
          {
            intros HBn.
            intros. repeat rewrite -> eval_imp_simpl.
            unfold leq in *. simpl in *.
            rewrite elem_of_subseteq. rewrite -> elem_of_subseteq in H.
            intros.
            destruct H0.
            + left.

              rewrite -> elem_of_difference in H0.
              destruct H0 as [_ H0].
              rewrite -> elem_of_difference.
              split.
              { apply elem_of_top'. }

              unfold not in *. intros.
              apply H0.

              destruct IHn1 as [IHn11 IHn12].
              apply (IHn11 HBn x y H x0).
              apply H1.
            + right. unfold In in *.
              destruct IHn2 as [IHn21 IHn22].
              apply (IHn22 HBn x y H x0 H0).
          }
        * (* Ex *)
          simpl. remember (respects_blacklist_ex phi Bp Bn Hrb) as Hrb'. clear HeqHrb'.
          specialize (IHn (phi^{evar: 0 ↦ (evar_fresh (elements (free_evars phi)))})).
          rewrite <- evar_open_size in IHn.
          assert (Hsz': size phi <= n). simpl in *. lia.
          remember (evar_fresh (elements (free_evars phi))) as fresh.
          pose proof (Hwfp' := @wfp_evar_open Σ phi fresh 0 Hwfp).
          specialize (IHn Hsz' Hwfp' Bp Bn).
          pose proof (Hrb'' := evar_open_respects_blacklist phi Bp Bn fresh 0 Hrb').
          unfold MonotonicFunction in *. unfold AntiMonotonicFunction in *.
          unfold leq. simpl.
          setoid_rewrite elem_of_subseteq.

          split; intros HBp S1 S2 Hincl; rewrite -> eval_ex_simpl; simpl;
          unfold stdpp_ext.propset_fa_union; intros m; rewrite -> elem_of_PropSet;
            intros [c Hc]; rewrite -> eval_ex_simpl; simpl;
              unfold stdpp_ext.propset_fa_union; rewrite -> elem_of_PropSet; exists c;
              remember (update_evar_val fresh c ρ) as ρ';
              specialize (IHn Hrb'' ρ' V);
              destruct IHn as [IHn1 IHn2].
          {
            specialize (IHn1 HBp S1 S2 Hincl).
            remember (phi^{evar: 0 ↦ fresh}) as phi'.
            remember (update_svar_val V S1 ρ') as ρ''.
            unfold leq in IHn1. simpl in *. unfold Included in *. unfold In in *.
            subst.
            apply IHn1. apply Hc.
          }
          {
            specialize (IHn2 HBp S1 S2 Hincl).
            remember (phi^{evar: 0 ↦ fresh}) as phi'.
            remember (update_svar_val V S1 ρ') as ρ''.
            unfold leq in IHn1. simpl in *. unfold Included in *. unfold In in *.
            subst.
            apply IHn2. apply Hc.
          }
        * (* Mu *)
          remember Hwfp as Hwfpmu. clear HeqHwfpmu.
          simpl in Hsz.
          assert (Hsz': size phi <= n).
          { lia. }
          split.
          {
            unfold AntiMonotonicFunction. intros.
            repeat rewrite -> eval_mu_simpl.
            Arguments LeastFixpointOf : simpl never.
            Arguments leq : simpl never.
            simpl.

            remember (fresh_svar phi) as X'.
            remember (phi^{svar: 0 ↦ X'}) as phi'.
            pose proof (Hszeq := svar_open_size 0 X' phi).
            assert (Hsz'': size phi' <= n).
            { rewrite -> Heqphi'. rewrite <- Hszeq. assumption. }
            specialize (IHn phi' Hsz'').
            simpl in Hwfp.

            assert (Hrb': respects_blacklist phi' (Empty_set svar) (Ensembles.Singleton svar X')).
            { subst. apply mu_wellformed_respects_blacklist. apply Hwfpmu. apply set_svar_fresh_is_fresh. }

            simpl in Hwfpmu. apply andb_true_iff in Hwfpmu.
            destruct Hwfpmu as [Hnonegphi Hwfpphi].
            assert (Hwfp' : well_formed_positive phi').
            { subst. apply wfp_svar_open. exact Hwfpphi. }

            remember IHn as IHn'. clear HeqIHn'.
            specialize (IHn' Hwfp' (Empty_set svar) (Ensembles.Singleton svar X') Hrb').
            remember IHn' as Hy. clear HeqHy.
            rename IHn' into Hx.
            specialize (Hx (update_svar_val V x ρ) X').
            specialize (Hy (update_svar_val V y ρ) X').

            apply lfp_preserves_order.
            - apply Hy. constructor.
            - apply Hx. constructor.
            - clear Hx. clear Hy.
              intros.
              destruct (decide (X' = V)).
              + (* X' = V *)
                rewrite <- e.
                repeat rewrite -> update_svar_val_shadow.
                unfold leq. simpl. unfold Included. unfold In. auto.
              + (* X' <> V*)
                pose proof (Uhsvcx := @update_svar_val_comm Σ M X' V x0 x ρ n0).
                rewrite -> Uhsvcx.
                pose proof (Uhsvcy := @update_svar_val_comm Σ M X' V x0 y ρ n0).
                rewrite -> Uhsvcy.

                assert (HrbV: respects_blacklist phi' (Ensembles.Singleton svar V) (Empty_set svar)).
                {
                  unfold respects_blacklist. intros. split.
                  - intros. inversion H1. rewrite <- H2.
                    unfold respects_blacklist in Hrb.
                    specialize (Hrb V).
                    destruct Hrb as [Hrbn Hrbp].
                    specialize (Hrbn H).
                    rewrite <- H2 in *. clear H2.
                    subst.
                    apply positive_negative_occurrence_named_svar_open.
                    *
                      unfold not. intros. assert (fresh_svar phi = V).
                      {
                        symmetry. assumption.
                      }
                      unfold not in n0. destruct (n0 H3).
                    * assumption.
                  - intros. destruct H1.
                }

                specialize (IHn Hwfp' (Ensembles.Singleton svar V) (Empty_set svar) HrbV).
                specialize (IHn (update_svar_val X' x0 ρ) V).
                destruct IHn as [IHam IHmo].
                apply IHam. constructor. assumption.
          }
          (* This is the same as the previous, with minor changes *)
          {
            unfold MonotonicFunction. intros.
            repeat rewrite -> eval_mu_simpl.
            Arguments LeastFixpointOf : simpl never.
            Arguments leq : simpl never.
            simpl.

            remember (fresh_svar phi) as X'.
            remember (phi^{svar: 0 ↦ X'}) as phi'.
            pose proof (Hszeq := svar_open_size 0 X' phi).
            assert (Hsz'': size phi' <= n).
            { rewrite -> Heqphi'. rewrite <- Hszeq. assumption. }
            specialize (IHn phi' Hsz'').
            simpl in Hwfp.

            assert (Hrb': respects_blacklist phi' (Empty_set svar) (Ensembles.Singleton svar X')).
            { subst. apply mu_wellformed_respects_blacklist. apply Hwfpmu. apply set_svar_fresh_is_fresh. }

            simpl in Hwfpmu. apply andb_true_iff in Hwfpmu.
            destruct Hwfpmu as [Hnonegphi Hwfpphi].
            assert (Hwfp' : well_formed_positive phi').
            { subst. apply wfp_svar_open. exact Hwfpphi. }

            remember IHn as IHn'. clear HeqIHn'.
            specialize (IHn' Hwfp' (Empty_set svar) (Ensembles.Singleton svar X') Hrb').
            remember IHn' as Hy. clear HeqHy.
            rename IHn' into Hx.
            specialize (Hx (update_svar_val V x ρ) X').
            specialize (Hy (update_svar_val V y ρ) X').

            apply lfp_preserves_order.
            - apply Hx. constructor.
            - apply Hy. constructor.
            - clear Hy. clear Hx.
              intros.
              destruct (decide (X' = V)).
              + (* X' = V *)
                rewrite <- e.
                repeat rewrite -> update_svar_val_shadow.
                unfold leq. simpl. unfold Included. unfold Ensembles.In. auto.
              + (* X' <> V*)
                pose proof (Uhsvcx := @update_svar_val_comm Σ M X' V x0 x ρ n0).
                rewrite -> Uhsvcx.
                pose proof (Uhsvcy := @update_svar_val_comm Σ M X' V x0 y ρ n0).
                rewrite -> Uhsvcy.

                assert (HrbV: respects_blacklist phi' (Empty_set svar) (Ensembles.Singleton svar V)).
                {
                  unfold respects_blacklist. intros. split.
                  - intros. inversion H1.
                  - intros. inversion H1. rewrite <- H2.
                    unfold respects_blacklist in Hrb.
                    specialize (Hrb V).
                    destruct Hrb as [Hrbn Hrbp].
                    specialize (Hrbp H).
                    rewrite <- H2 in *. clear H2.
                    subst.
                    apply positive_negative_occurrence_named_svar_open.
                    *
                      unfold not. intros. assert (fresh_svar phi = V).
                      {
                        symmetry. assumption.
                      }
                      unfold not in n0. destruct (n0 H3).
                    * assumption.
                }

                specialize (IHn Hwfp' (Empty_set svar) (Ensembles.Singleton svar V) HrbV).
                specialize (IHn (update_svar_val X' x0 ρ) V).
                destruct IHn as [IHam IHmo].
                apply IHmo. constructor. assumption.
          }
    Qed.

    Lemma is_monotonic : forall (phi : Pattern)
                                (X : svar)
                                (ρ : Valuation),
        well_formed_positive (mu, phi) ->
        svar_is_fresh_in X phi ->
        @MonotonicFunction A OS
                           (fun S : propset (Domain M) =>
                              (@eval Σ M (update_svar_val X S ρ)
                                                       (phi^{svar: 0 ↦ X}))).
    Proof.
      simpl. intros phi X ρ Hwfp Hfr.
      pose proof (Hrb := mu_wellformed_respects_blacklist phi X Hwfp Hfr).
      simpl in Hrb.
      inversion Hwfp.
      remember (phi^{svar: 0 ↦ X}) as phi'.
      assert (Hsz : size phi' <= size phi').
      { lia. }
      pose proof (Hmono := respects_blacklist_implies_monotonic (size phi') phi').
      assert (Hwfp' : well_formed_positive phi').
      { subst. apply wfp_svar_open.
        apply andb_true_iff in Hwfp.
        apply (proj2 Hwfp).
      }
      specialize (Hmono Hsz Hwfp').
      specialize (Hmono (Empty_set svar) (Ensembles.Singleton svar X)).
      specialize (Hmono Hrb ρ X).
      destruct Hmono as [Hantimono Hmono].
      apply Hmono.
      constructor.
    Qed.
  End with_model.

End monotonic.


(* Full safety for STLC *)
(* values well-typed with respect to runtime environment *)
(* inversion lemma structure *)
(* subtyping (in addition to nano2.v) *)
(* singleton types (in addtion to nano4-1.v *)

(* full proof for singleton types! *)
(* added stp_vary rule *)

(* TODO: type members *)
(* TODO: dependent application *)

(* small-step style !! *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Lt.

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBot   : ty
  | TTop   : ty
  | TBool  : ty
  | TFun   : ty -> ty -> ty
  | TVar   : bool -> id -> ty
  | TVarB  : id -> ty
  | TMem   : ty -> ty -> ty (* intro *)
  | TSel   : ty -> ty (* elim *)
  | TBind  : ty -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : tm -> tm -> tm (* f(x) *)
  | tabs : tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
  | vbool : bool -> vl
  | vabs  : list vl -> tm -> vl
  | vty   : list vl -> ty -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Definition aenv := list (venv*ty).

Hint Unfold venv.
Hint Unfold tenv.
Hint Unfold aenv.

Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

(* closed j k means normal variables < j, bound variables < k *)
Inductive closed: nat -> nat -> nat -> ty -> Prop :=
| cl_bot: forall i j k,
    closed i j k TBot
| cl_top: forall i j k,
    closed i j k TTop
| cl_bool: forall i j k,
    closed i j k TBool
| cl_fun: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TFun T1 T2)
| cl_var0: forall i j k x,
    i > x ->
    closed i j k (TVar false x)
| cl_var1: forall i j k x,
    j > x ->
    closed i j k (TVar true x)
| cl_varB: forall i j k x,
    k > x ->
    closed i j k (TVarB x)
| cl_mem: forall i j k T1 T2,
    closed i j k T1 ->
    closed i j k T2 ->
    closed i j k (TMem T1 T2)
| cl_sel: forall i j k T1,
    closed i j k T1 ->
    closed i j k (TSel T1)
| cl_bind: forall i j k T1,
    closed i j (S k) T1 ->
    closed i j k (TBind T1)
.

Fixpoint open (k: nat) (u: ty) (T: ty) { struct T }: ty :=
  match T with
    | TVar b x => TVar b x (* free var remains free. functional, so we can't check for conflict *)
    | TVarB x => if beq_nat k x then u else TVarB x
    | TTop        => TTop
    | TBot        => TBot
    | TBool       => TBool
    | TSel T1     => TSel (open k u T1)
    | TFun T1 T2  => TFun (open k u T1) (open k u T2)
    | TMem T1 T2  => TMem (open k u T1) (open k u T2)
    | TBind T1    => TBind (open (S k) u T1)
  end.

Fixpoint subst (k: nat) (U : ty) (T : ty) {struct T} : ty :=
  match T with
    | TTop         => TTop
    | TBot         => TBot
    | TBool        => TBool
    | TMem T1 T2   => TMem (subst k U T1) (subst k U T2)
    | TSel T1      => TSel (subst k U T1)
    | TVarB i      => TVarB i
    | TVar true i  => TVar true i
    | TVar false i =>
      match nat_compare i k with
        | Lt => TVar false i
        | Eq => U
        | Gt => TVar false (i-1)
      end
    | TFun T1 T2   => TFun (subst k U T1) (subst k U T2)
    | TBind T2     => TBind (subst k U T2)
  end.

(*
Fixpoint nosubst (T : ty) {struct T} : Prop :=
  match T with
    | TTop         => True
    | TBot         => True
    | TBool        => True
    | TMem m T1 T2   => nosubst T1 /\ nosubst T2
    | TSel (varB i) m => True
    | TSel (varF i) m => True
    | TSel (varH i) m => i <> 0
    | TAll m T1 T2   => nosubst T1 /\ nosubst T2
    | TBind T2     => nosubst T2
    | TAnd T1 T2   => nosubst T1 /\ nosubst T2
    | TOr  T1 T2   => nosubst T1 /\ nosubst T2
  end.
*)

Inductive real: ty -> Prop :=
| real_var: forall b x,
    real (TVar b x)
| real_mem: forall T,
    real (TMem T T)
.

Inductive stp: tenv -> ty -> ty -> Prop :=
| stp_bool: forall G1,
    stp G1 TBool TBool
| stp_fun: forall G1 T1 T2 T3 T4,
    stp G1 T3 T1 ->
    stp G1 T2 T4 ->
    stp G1 (TFun T1 T2) (TFun T3 T4)
| stp_varx: forall G1 x,
    x < length G1 ->
    stp G1 (TVar false x) (TVar false x)
| stp_vary: forall G1 x y,
    index x G1 = Some (TVar false y) ->
    y < length G1 ->
    stp G1 (TVar false y) (TVar false x)
| stp_var1: forall G1 x T1,
    index x G1 = Some T1 ->
    closed (length G1) 0 0 T1 ->
    stp G1 (TVar false x) T1
| stp_mem: forall G1 T1 T2 T3 T4,
    stp G1 T3 T1 ->
    stp G1 T2 T4 ->
    stp G1 (TMem T1 T2) (TMem T3 T4)
| stp_sel: forall G1 T1 T2,
    stp G1 T1 T2 ->
    stp G1 T2 T1 ->
    stp G1 (TSel T1) (TSel T2)
| stp_red: forall G1 T1 T2,
    stp G1 T1 (TMem TBot T2) ->
    stp G1 (TSel T1) T2
| stp_red2: forall G1 T1 T2 T0,
    real T0 ->
    stp G1 T0 T2 -> (* this is the main trick ... *)
    stp G1 T2 (TMem T1 TTop) ->
    stp G1 T1 (TSel T2)

(* bind! *)
.

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
    has_type env ttrue TBool
| t_false: forall env,
    has_type env tfalse TBool
| t_varx: forall x env T1,
    index x env = Some T1 -> (* could use closed *)
    has_type env (tvar x) (TVar false x)
(*| t_var: forall x env T1,
    index x env = Some T1 ->
    has_type env (tvar x) T1*)
| t_app: forall env f x T1 T2,
    has_type env f (TFun T1 T2) ->
    has_type env x T1 ->
    has_type env (tapp f x) T2
| t_abs: forall env y T1 T2,
    has_type (T1::(TFun T1 T2)::env) y T2 ->
    closed (length env) 0 0 (TFun T1 T2) ->
    has_type env (tabs y) (TFun T1 T2)
| t_sub: forall env x T1 T2,
    has_type env x T1 ->
    stp env T1 T2 ->
    has_type env x T2
.

Inductive stp2: nat -> bool -> tenv -> venv -> ty -> ty -> nat -> Prop :=
| stp2_bot: forall m GH G1 T n1,
    closed (length GH) (length G1) 0  T ->
    stp2 m true GH G1 TBot T (S n1)
| stp2_top: forall m GH G1 T n1,
    closed (length GH) (length G1) 0 T ->
    stp2 m true GH G1 T  TTop (S n1)
| stp2_bool: forall m GH G1 n1,
    stp2 m true GH G1 TBool TBool (S n1)
| stp2_fun: forall m GH G1 T1 T2 T3 T4 n1 n2,
    stp2 m false GH G1 T3 T1 n1 ->
    stp2 m false GH G1 T2 T4 n2 ->
    stp2 m true GH G1 (TFun T1 T2) (TFun T3 T4) (S (n1+n2))

| stp2_varx: forall m GH G1 x n1,
    x < length G1 ->
    stp2 m true GH G1 (TVar true x) (TVar true x) (S n1)
| stp2_var1: forall m GH G1 TX x T2 v n1,
    index x G1 = Some v ->
    val_type0 G1 v TX -> (* slack for: val_type G2 v T2 *)
    stp2 m true GH G1 TX T2 n1 ->
    stp2 m true GH G1 (TVar true x) T2 (S n1)
| stp2_var1b: forall m GH G1 TX x T2 v n1 n2,
    index x G1 = Some v ->
    val_type0 G1 v TX -> (* slack for: val_type G2 v T2 *)
    stp2 0 true ((TVar true x)::GH) G1 TX (open 0 (TVar false (length GH)) T2) n1 ->
    stp2 0 true GH G1 TX (open 0 (TVar true x) T2) n2 ->
    stp2 (S m) true GH G1 (TVar true x) (TBind T2) (S (n1+n2))

| stp2_varax: forall m GH G1 x n1,
    x < length GH ->
    stp2 m true GH G1 (TVar false x) (TVar false x) (S n1)
| stp2_varay: forall m GH G1 TX x1 x2 n1,
    index x1 GH = Some TX ->
    stp2 m false GH G1 TX (TVar false x2) n1 ->
    stp2 m true GH G1 (TVar false x2) (TVar false x1) (S n1)
| stp2_vary: forall m GH G1 x1 x2 n1,
    index x1 GH = Some (TVar true x2) ->
    x2 < length G1 ->
    stp2 m true GH G1 (TVar true x2) (TVar false x1) (S n1)
| stp2_vara1: forall m GH G1 TX x T2 n1,
    index x GH = Some TX ->
    stp2 m true GH G1 TX T2 n1 ->
    stp2 m true GH G1 (TVar false x) T2 (S n1)

| stp2_mem: forall m GH G1 T1 T2 T3 T4 n1 n2,
    stp2 m false GH G1 T3 T1 n2 ->
    stp2 m true GH G1 T2 T4 n1 ->
    stp2 m true GH G1 (TMem T1 T2) (TMem T3 T4) (S (n1+n2))
| stp2_sel: forall m GH G1 T1 T2 n1 n2,
    stp2 m false GH G1 T2 T1 n2 ->
    stp2 m true GH G1 T1 T2 n1 ->
    stp2 m true GH G1 (TSel T1) (TSel T2) (S (n1+n2))
| stp2_red: forall m GH G1 T1 T2 n1,
    stp2 m true GH G1 T1 (TMem TBot T2) n1 ->
    stp2 m true GH G1 (TSel T1) T2 (S n1)
| stp2_red2: forall m GH G1 TX T1 T2 T0 n0 n1 n2 n3,
(* long form of:
    stp2 true GY (TVar y) G2 T2 n0 ->
    stp2 true G2 T2 G1 (TMem T1 TTop) n1 -> *)
    real T0 ->
    stp2 m true GH G1 T0 T2 n0 ->
    stp2 m false GH G1 T2 (TMem TX TTop) n1 ->
    stp2 m true GH G1 T0 (TMem TX TTop) n3 ->
    stp2 m false GH G1 T1 TX n2 ->
    stp2 m true GH G1 T1 (TSel T2) (S (n0+n1+n2+n3))

| stp2_bind1: forall m GH G1 T1 T2 n1,
    stp2 m true ((open 0 (TVar false (length GH)) T1)::GH) G1 (TVar false (length GH)) T2 n1 ->
    stp2 (S m) true GH G1 (TBind T1) T2 (S n1)

| stp2_bind2: forall m GH G1 TX x T2 n1 n2,
    index x GH = Some TX ->
    stp2 0 true ((TVar false x)::GH) G1 TX (open 0 (TVar false (length GH)) T2) n1 ->
    stp2 0 true GH G1 TX (open 0 (TVar false x) T2) n2 ->
    stp2 (S m) true GH G1 (TVar false x) (TBind T2) (S (n1+n2))

| stp2_wrapf: forall m GH G1 T1 T2 n1,
    stp2 m true GH G1 T1 T2 n1 ->
    stp2 m false GH G1 T1 T2 (S n1)
| stp2_transf: forall m GH G1 T1 T2 T3 n1 n2,
    stp2 m true GH G1 T1 T2 n1 ->
    stp2 m false GH G1 T2 T3 n2 ->
    stp2 m false GH G1 T1 T3 (S (n1+n2))

with wf_env : venv -> tenv -> Prop :=
| wfe_nil : wf_env nil nil
| wfe_cons : forall v t vs ts,
    val_type (v::vs) v t ->
    wf_env vs ts ->
    wf_env (cons v vs) (cons t ts)

with val_type0 : venv -> vl -> ty -> Prop :=
| v_bool: forall b,
    val_type0 [] (vbool b) TBool
| v_abs: forall venv tenv y T1 T2,
    wf_env venv tenv ->
    has_type (T1::(TFun T1 T2)::tenv) y T2 ->
    val_type0 venv (vabs venv y) (TFun T1 T2)
(* | v_var: forall venv x v,
    index x venv = Some v ->
    val_type0 venv v (TVar x) *)
| v_ty: forall venv T1,
    val_type0 venv (vty venv T1) (TMem T1 T1)

with val_type : venv -> vl -> ty -> Prop :=
| v_sub: forall G1 T1 T2 v,
    val_type0 G1 v T1 ->
    (exists n, stp2 0 true [] G1 T1 T2 n) ->
    val_type G1 v T2
.

Definition stpd2 m b GH G1 T1 T2 := exists n, stp2 m b GH G1 T1 T2 n.

Hint Constructors stp2.

Ltac ep := match goal with
             | [ |- stp2 ?M ?B ?GH ?G1 ?T1 ?T2 ?N ] => assert (exists (n:nat), stp2 M B GH G1 T1 T2 n) as EEX
           end.

Ltac eu := match goal with
             | H: stpd2 _ _ _ _ _ _ |- _ => destruct H as [? H]
           end.

Lemma stpd2_bot: forall m GH G1 T,
    closed (length GH) (length G1) 0 T ->
    stpd2 m true GH G1 TBot T.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_top: forall m GH G1 T,
    closed (length GH) (length G1) 0 T ->
    stpd2 m true GH G1 T TTop.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_bool: forall m GH G1,
    stpd2 m true GH G1 TBool TBool.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_fun: forall m GH G1 T1 T2 T3 T4,
    stpd2 m false GH G1 T3 T1 ->
    stpd2 m false GH G1 T2 T4 ->
    stpd2 m true  GH G1 (TFun T1 T2) (TFun T3 T4).
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_varx: forall m GH G1 x,
    x < length G1 ->
    stpd2 m true GH G1 (TVar true x) (TVar true x).
Proof. intros. repeat eu. exists 1. eauto. Qed.
Lemma stpd2_var1: forall m GH G1 TX x T2 v,
    index x G1 = Some v ->
    val_type0 G1 v TX -> (* slack for: val_type G2 v T2 *)
    stpd2 m true GH G1 TX T2 ->
    stpd2 m true GH G1 (TVar true x) T2.
Proof. intros. repeat eu. eexists. eauto. Qed.
(*Lemma stpd2_var1b: forall m GH G1 GX TX G2 x x2 T2 v,
    index x G1 = Some v ->
    index x2 G2 = Some v ->
    val_type0 GX v TX -> (* slack for: val_type G2 v T2 *)
    stpd2 m true GH GX TX G2 (open 0 (TVar true x2) T2) ->
    stpd2 m true GH G1 (TVar true x) G2 (TBind T2).
Proof. intros. repeat eu. eexists. eauto. Qed.*)
Lemma stpd2_mem: forall m GH G1 T1 T2 T3 T4,
    stpd2 m false GH G1 T3 T1 ->
    stpd2 m true  GH G1 T2 T4 ->
    stpd2 m true  GH G1 (TMem T1 T2) (TMem T3 T4).
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_sel: forall m GH G1 T1 T2,
    stpd2 m false GH G1 T2 T1 ->
    stpd2 m true  GH G1 T1 T2 ->
    stpd2 m true  GH G1 (TSel T1) (TSel T2).
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_red: forall m GH G1 T1 T2,
    stpd2 m true GH G1 T1 (TMem TBot T2) ->
    stpd2 m true GH G1 (TSel T1) T2.
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_red2: forall m GH G1 TX T1 T2 T0,
    real T0 ->
    stpd2 m true GH G1 T0 T2 ->
    stpd2 m false GH G1 T2 (TMem TX TTop) ->
    stpd2 m true GH G1 T0 (TMem TX TTop) ->
    stpd2 m false GH G1 T1 TX ->
    stpd2 m true GH G1 T1 (TSel T2).
Proof. intros. repeat eu. eexists. eauto. Qed.

(*
Lemma stpd2_bindI: forall G1 G2 T2 x,
    stpd2 true G1 (TVar x) G2 (open 0 (TVar x) T2) ->
    stpd2 true G1 (TVar x) G2 (TBind T2).
Proof. intros. repeat eu. eexists. eauto. Qed. *

Lemma stpd2_bindE: forall G1 G2 T2 x,
    stpd2 true G1 (TVar x) G2 (TBind T2) ->
    stpd2 true G1 (TVar x) G2 (open 0 (TVar x) T2).
Proof. intros. repeat eu. eexists. eauto. Qed.
*)

(*Lemma stpd2_bind1: forall m GH G1 T1 T2,
    closed (length GH) (length G2) 0 T2 ->
    stpd2 m true ((G1,(open 0 (TVar false (length GH)) T1))::GH)
          G1 (TVar false (length GH)) G2 T2 ->
    stpd2 m true GH G1 (TBind T1) G2 T2.
Proof. intros. repeat eu. eexists. eauto. Qed.
*)

Lemma stpd2_wrapf: forall m GH G1 T1 T2,
    stpd2 m true GH G1 T1 T2 ->
    stpd2 m false GH G1 T1 T2.
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_transf: forall m GH G1 T1 T2 T3,
    stpd2 m true GH G1 T1 T2 ->
    stpd2 m false GH G1 T2 T3 ->
    stpd2 m false GH G1 T1 T3.
Proof. intros. repeat eu. eexists. eauto. Qed.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v

Could use do-notation to clean up syntax.
*)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (index x env)
        | tabs y     => Some (Some (vabs env y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vbool _)) => Some None
                | Some (Some (vty _ _)) => Some None
                | Some (Some (vabs env2 ey)) =>
                  teval n (vx::(vabs env2 ey)::env2) ey
              end
          end
      end
  end.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.
Hint Constructors stp2.
Hint Constructors val_type.
Hint Constructors wf_env.

Hint Unfold stpd2.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.

Hint Resolve ex_intro.

Ltac ev := repeat match goal with
                    | H: exists _, _ |- _ => destruct H
                    | H: _ /\  _ |- _ => destruct H
           end.

Lemma wf_length : forall vs ts,
                    wf_env vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  assert ((length (v::vs)) = 1 + length vs). constructor.
  assert ((length (t::ts)) = 1 + length ts). constructor.
  rewrite IHwf_env in H1. auto.
Qed.

Hint Immediate wf_length.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  case_eq (beq_nat n (length vs)); intros E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

Lemma index_exists : forall X vs n,
                       n < length vs ->
                       exists (T:X), index n vs = Some T.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  SCase "hit".
  assert (beq_nat n (length vs) = true) as E. eapply beq_nat_true_iff. eauto.
  simpl. subst n. rewrite E. eauto.
  SCase "miss".
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff. omega.
  simpl. rewrite E. eapply IHvs. eauto.
Qed.

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. reflexivity.
Qed.

Lemma closed_extend : forall T X (a:X) i k G,
                       closed i (length G) k T ->
                       closed i (length (a::G)) k T.
Proof.
  intros T. induction T; intros; inversion H;  econstructor; eauto.
  simpl. omega.
Qed.

(*
Lemma stp2_extend : forall m b GH  v1 G1 G2 T1 T2 n,
                      stp2 m b GH G1 T1 G2 T2 n ->
                      stp2 m b GH (v1::G1) T1 G2 T2 n /\
                      stp2 m b GH G1 T1 (v1::G2) T2 n /\
                      stp2 m b GH (v1::G1) T1 (v1::G2) T2 n.
Proof.
  intros. induction H; try solve [repeat split; econstructor; try eauto;
          try eapply index_extend; eauto; try eapply closed_extend; eauto;
          try eapply IHstp2; eauto;
          try eapply IHstp2_1; try eapply IHstp2_2;
            try eapply IHstp2_3; try eapply IHstp2_4].
(*
  repeat split; eapply stp2_var1b. eapply index_extend; eauto. eauto. eauto.
  eauto. eauto. eapply index_extend; eauto. eauto. eapply IHstp2. eapply index_extend; eauto.
  eapply index_extend; eauto. eauto.
  eapply IHstp2.
*)
  admit. (* bind1 *)
  admit.
  admit.

  repeat split; eapply stp2_transf; try eapply IHstp2_1; eauto; try eapply IHstp2_2; eauto.
Qed.

Lemma stpd2_extend : forall m b GH v1 G1 G2 T1 T2,
                      stpd2 m b GH G1 T1 G2 T2 ->
                      stpd2 m b GH (v1::G1) T1 G2 T2 /\
                      stpd2 m b GH G1 T1 (v1::G2) T2 /\
                      stpd2 m b GH (v1::G1) T1 (v1::G2) T2.
Proof.
  intros. repeat eu. repeat split; eexists; eapply stp2_extend; eauto.
Qed.

Lemma stp2_extend1 : forall m b GH v1 G1 G2 T1 T2 n, stp2 m b GH G1 T1 G2 T2 n -> stp2 m b GH (v1::G1) T1 G2 T2 n.
Proof. intros. eapply stp2_extend. eauto. Qed.

Lemma stp2_extend2 : forall m b GH v1 G1 G2 T1 T2 n, stp2 m b GH G1 T1 G2 T2 n -> stp2 m b GH G1 T1 (v1::G2) T2 n.
Proof. intros. eapply stp2_extend. eauto. Qed.

Lemma stpd2_extend1 : forall m b GH v1 G1 G2 T1 T2, stpd2 m b GH G1 T1 G2 T2 -> stpd2 m b GH (v1::G1) T1 G2 T2.
Proof. intros. eapply stpd2_extend. eauto. Qed.

Lemma stpd2_extend2 : forall m b GH v1 G1 G2 T1 T2, stpd2 m b GH G1 T1 G2 T2 -> stpd2 m b GH G1 T1 (v1::G2) T2.
Proof. intros. eapply stpd2_extend. eauto. Qed.
*)

Lemma stp_closed : forall G1 T1 T2,
                      stp G1 T1 T2 ->
                      closed (length G1) 0 0 T1 /\
                      closed (length G1) 0 0 T2.
Proof.
  intros. induction H; repeat split; try  econstructor; try eapply IHstp1; try eapply IHstp2; eauto; try eapply IHstp; eauto; try eapply index_max; eauto.
  destruct IHstp. inversion H1. eauto.
  destruct IHstp2. inversion H3. eauto.
Qed.

Lemma stpd2_closed : forall m b GH G1 T1 T2,
                      stpd2 m b GH G1 T1 T2 ->
                      closed (length GH) (length G1) 0 T1 /\
                      closed (length GH) (length G1) 0 T2.
Proof.
  admit. (*
  intros. eu. induction H; repeat split; try  econstructor; try eapply IHstp2_1; try eapply IHstp2_2; eauto; try eapply IHstp2; eauto; try eapply index_max; eauto.
  destruct IHstp2. inversion H1. eauto.
  eapply IHstp2_4. *)

Qed.

Lemma stpd2_closed1 : forall m b GH G1 T1 T2,
                      stpd2 m b GH G1 T1 T2 ->
                      closed (length GH) (length G1) 0 T1.
Proof. intros. eapply (stpd2_closed m b GH G1 T1 T2); eauto. Qed.

Lemma stpd2_closed2 : forall m b GH G1 T1 T2,
                      stpd2 m b GH G1 T1 T2 ->
                      closed (length GH) (length G1) 0 T2.
Proof. intros. eapply (stpd2_closed m b GH G1); eauto. Qed.

Lemma valtp_extend : forall vs v v1 T,
                       val_type vs v T ->
                       val_type (v1::vs) v T.
Proof.
  admit.
  (*intros. induction H; econstructor; eauto; try eapply stpd2_extend; eauto; try eapply index_extend; eauto.
   *)
Qed.

Lemma index_safe_ex: forall H1 G1 TF i,
             wf_env H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
       Case "nil". inversion H0.
       Case "cons". inversion H0.
         case_eq (beq_nat i (length ts)).
           SCase "hit".
             intros E.
             rewrite E in H3. inversion H3. subst t.
             assert (beq_nat i (length vs) = true). eauto.
             assert (index i (v :: vs) = Some v). eauto.  unfold index. rewrite H2. eauto.
             eauto.
           SCase "miss".
             intros E.
             assert (beq_nat i (length vs) = false). eauto.
             rewrite E in H3.
             assert (exists v0, index i vs = Some v0 /\ val_type vs v0 TF) as HI. eapply IHwf_env. eauto.
           inversion HI as [v0 HI1]. inversion HI1.
           eexists. econstructor. eapply index_extend; eauto. eapply valtp_extend; eauto.
Qed.

Inductive res_type: venv -> option vl -> ty -> Prop :=
| not_stuck: forall venv v T,
      val_type venv v T ->
      res_type venv (Some v) T.

Hint Constructors res_type.
Hint Resolve not_stuck.

Lemma stpd2_refl: forall m GH G1 T1,
  closed (length GH) (length G1) 0 T1 ->
  stpd2 m true GH G1 T1 T1.
Proof.
  intros. induction T1; inversion H.
  - Case "bot". exists 1. eauto.
  - Case "top". exists 1. eauto.
  - Case "bool". eapply stpd2_bool; eauto.
  - Case "fun". eapply stpd2_fun; try eapply stpd2_wrapf; eauto.
  - Case "var0". exists 1. eauto.
  - Case "var1".
    assert (exists v, index i G1 = Some v) as E. eapply index_exists; eauto.
    destruct E.
    eapply stpd2_varx; eauto.
  - Case "varb". inversion H4.
  - Case "mem". eapply stpd2_mem; try eapply stpd2_wrapf; eauto.
  - Case "sel". eapply stpd2_sel; try eapply stpd2_wrapf; eauto.
  - Case "bind".
    admit.

    (* don't have index & val_type0 evidence *)

    (*exists 3. eapply stp2_bind1. eauto.
    eapply stp2_bind2.
    simpl. eauto.

    eapply stp2_vara1. simpl. rewrite <-beq_nat_refl. eauto. *)

    (* TODO:
       stp2 m true ((G1, open 0 (TVar false (length GH)) T1) :: GH) G1
     (open 0 (TVar false (length GH)) T1) G1
     (open 0 (TVar false (length GH)) T1) 0
     *)

Qed.

Lemma stpd2_reg1 : forall m b GH G1 T1 T2,
                      stpd2 m b GH G1 T1 T2 ->
                      stpd2 m true GH G1 T1 T1.
Proof.
  intros. eapply stpd2_refl. eapply (stpd2_closed m b GH G1 T1 T2). eauto.
Qed.

Lemma stpd2_reg2 : forall m b GH G1 T1 T2,
                      stpd2 m b GH G1 T1 T2 ->
                      stpd2 m true GH G1 T2 T2.
Proof.
  intros. eapply stpd2_refl. eapply (stpd2_closed m b GH G1). eauto.
Qed.

(*

Lemma invert_bind1: forall n, forall venv vf T1 GX TX n1,
  val_type0 GX vf TX -> stp2 true GX TX venv (TBind T1) n1 -> n1 < n ->
  exists x n2,
    index x venv = Some vf ->
    n2 < n1 ->
    stp2 true GX TX venv (open 0 (TVar x) T1) n2.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H; subst.
  - Case "bool". solve by inversion.
  - Case "fun". solve by inversion.
(*   - Case "var". subst. inversion H0; subst.
    + SCase "normal".
    assert (vf = v) as A. rewrite H2 in H4. inversion H4. eauto.
    rewrite A. assert (n0 < n) as B. omega.
    specialize (IHn venv0 v T1 GX0 TX n0 H5 H6 B).
    ev. repeat eexists; eauto.
  (* repeat eapply IHn; eauto. omega. *)
    + SCase "bindE". eauto.
    + eauto.      *)
  - Case "mem". solve by inversion.
Qed.
*)

Lemma invert_mem1: forall n, forall m venv GH vf T1 T2 GX TX n1,
  val_type0 GX vf TX -> stp2 m true GH GX TX (TMem T1 T2) n1 -> n1 < n ->
  exists T3 n2 n3,
    vf = (vty [] T3) /\
    (n2 + n3) < n /\
    stp2 m false GH venv T1 T3 n2 /\
    stp2 m true GH venv T3 T2 n3.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H; subst.
  - Case "bool". solve by inversion.
  - Case "fun". solve by inversion.
(*  - Case "var". subst. inversion H0; subst.
    + SCase "normal".
    assert (vf = v) as A. rewrite H2 in H4. inversion H4. eauto.
    rewrite A. assert (n0 < n) as B. omega.
    specialize (IHn venv0 v T1 T2 GX0 TX n0 H5 H6 B).
    ev. repeat eexists; eauto.
  (* repeat eapply IHn; eauto. omega. *)
    + SCase "bindE".
      destruct T0; simpl in H6; try destruct i; inversion H6.

  - Case "mem". inversion H0. subst. repeat eexists; eauto. omega.
 *)
- admit.
Qed.

(*
Lemma invert_mem: forall venv vf T1 T2,
  val_type venv vf (TMem T1 T2) ->
  exists env T3,
    vf = (vty env T3) /\
    stpd2 false venv T1 env T3 /\
    stpd2 true env T3 venv T2.
Proof.
  intros. inversion H. ev. assert (x < S x) as E. omega.
  specialize (invert_mem1 (S x) venv0 vf T1 T2 G1 T0 x H0 H1 E). intros IH.
  ev. repeat eexists; eauto.
Qed.
*)

Lemma stpd2_trans_axiom_aux: forall n, forall m GH G1 T1 T2 T3 n1,
  stp2 m false GH G1 T1 T2 n1 -> n1 < n ->
  stpd2 m false GH G1 T2 T3 ->
  stpd2 m false GH G1 T1 T3.
Proof.
  intros n. induction n; intros; try omega; repeat eu; subst; inversion H; clear H; subst.
  - Case "wrapf". eapply stpd2_transf. eexists. eauto. eexists. eauto.
  - Case "transf". eapply stpd2_transf. eexists. eauto. eapply IHn. eauto. omega. eexists. eauto.
Qed.

Lemma stp2_trans_axiom: forall m b GH G1 T1 T2 T3,
  stpd2 m b GH G1 T1 T2 ->
  stpd2 m false GH G1 T2 T3 ->
  stpd2 m false GH G1 T1 T3.
Proof.
  intros. destruct b; eu; eu; eapply stpd2_trans_axiom_aux; eauto.
Qed.

Ltac index_subst := match goal with
                      | H1: index ?x ?G = ?V1 , H2: index ?x ?G = ?V2 |- _ => rewrite H1 in H2; inversion H2; subst
                      | _ => idtac
                    end.

Ltac invty := match goal with
                | H1: TBot     = _ |- _ => inversion H1
                | H1: TBool    = _ |- _ => inversion H1
                | H1: TSel _   = _ |- _ => inversion H1
                | H1: TMem _ _ = _ |- _ => inversion H1
                | H1: TVar _ _ = _ |- _ => inversion H1
                | H1: TFun _ _ = _ |- _ => inversion H1
                | H1: TBind  _ = _ |- _ => inversion H1
                | _ => idtac
              end.

Ltac invstp_var := match goal with
  | H1: stp2 _ true _ _ TBot        (TVar _ _) _ |- _ => inversion H1
  | H1: stp2 _ true _ _ TTop        (TVar _ _) _ |- _ => inversion H1
  | H1: stp2 _ true _ _ TBool       (TVar _ _) _ |- _ => inversion H1
  | H1: stp2 _ true _ _ (TFun _ _)  (TVar _ _) _ |- _ => inversion H1
  | H1: stp2 _ true _ _ (TMem _ _)  (TVar _ _) _ |- _ => inversion H1
  | H1: val_type0 _ _ _ |- _ => inversion H1
  | _ => idtac
end.

(*
Lemma stp2_substitute_aux: forall ni nj, forall d m G1 G2 T1 T2 GH n1,
   stp2 (S d) m G1 T1 G2 T2 GH n1 -> n1 < nj ->
   forall GH0 GH0' GX TX TX' l T1' T2' V,
     GH = (GH0 ++ [(0,(GX, TX))]) ->
     val_type GX V (subst TX' TX) ni ->
     (* When we're replacing binds from a pack/unpack sequence, the
        type in GH may refer to itself (contain TSelH 0).
        It should be safe for TX to refer to itself. *)
     closed 0 1 TX ->
     closed 0 0 (TSel TX' l) ->
     compat GX TX TX' (Some V) G1 T1 T1' ->
     compat GX TX TX' (Some V) G2 T2 T2' ->
     Forall2 (compat2 GX TX TX' (Some V)) GH0 GH0' ->
     compat GX TX TX' (Some V) GX TX (subst TX' TX) ->
     exists n1', stp2 (S d) m G1 T1' G2 T2' GH0' n1'.
*)

Lemma closed_no_subst: forall T i j k TX,
   closed i j k T ->
   subst i TX T = T.
Proof.
  admit.
(*  intros T. induction T; intros; inversion H; simpl; eauto;
    try rewrite (IHT (S j) TX); eauto;
    try rewrite (IHT2 (S j) TX); eauto;
    try rewrite (IHT j TX); eauto;
    try rewrite (IHT1 j TX); eauto;
    try rewrite (IHT2 j TX); eauto.

  eapply closed_upgrade. eauto. eauto.
  subst. omega.
  subst. eapply closed_upgrade. eassumption. omega.
  subst. eapply closed_upgrade. eassumption. omega. *)
Qed.

Lemma stp2_subst: forall m b GH G1 T1 T2 TX n1,
   stp2 m b (TX::GH) G1 T1 T2 n1 ->
   stpd2 m b GH G1 (subst (length GH) TX T1) (subst (length GH) TX T2).
Proof.
  admit.
Qed.

Lemma stp2_narrow: forall m b GH GX1 TX1 TX2 G1 T1 T2 n1 n2,
  stp2 0 true (TX1::GH) GX1 TX1 TX2 n1 ->
  stp2 m b (TX2::GH) G1 T1 T2 n2 ->
  stpd2 m b (TX1::GH) G1 T1 T2.
Proof.
  admit.
Qed.

Lemma stp2_downgrade: forall m b GH G1 T1 T2 n1,
  stp2 m b GH G1 T1 T2 n1 ->
  stp2 (S m) b GH G1 T1 T2 n1.
Proof.
  admit.
Qed.

Lemma stp2_trans: forall l, forall n, forall m b GH G1 T1 T2 T3 n1 n2,
  stp2 m b GH G1 T1 T2 n1 ->
  stp2 m true GH G1 T2 T3 n2 ->
  n1 < n -> m < l ->
  stpd2 m true GH G1 T1 T3.
Proof.
  intros l. induction l. intros. solve by inversion.
  intros n. induction n; intros. solve by inversion.
  inversion H.
  - Case "bot". eapply stpd2_bot; eauto. eapply stpd2_closed2; eauto.
  - Case "top". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
(*    + SCase "bind2". invstp_var. *)
  - Case "bool". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto.
    + SCase "bool". eapply stpd2_bool; eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
  - Case "fun". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "fun". invty. subst. eapply stpd2_fun; eapply stp2_trans_axiom; eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
  - Case "varx". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto.
    + SCase "varx". eauto.
    + SCase "var1". eauto.
    + SCase "var1b". eauto.
    + SCase "vary". eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
  - Case "var1".
    eapply stpd2_var1; eauto. eapply IHn; eauto. omega.
  - Case "var1b". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.
    + SCase "bind1".
      inversion H15. subst.

      assert (stpd2 m0 true (TVar true x::GH) G1
                    (TVar false (length GH)) T3) as NRW.
      eapply stp2_narrow. eapply stp2_var1. eauto. eauto. eauto. eauto.

      (* result may be false but we can call untrans on it using outer induction on m! *)

      assert (closed (length GH) (length G1) 0 T3). eapply stpd2_closed2; eauto.
      assert (closed (length GH) (length G1) 0 (TVar true x)). eapply stpd2_closed1; eauto.

      destruct NRW as [? NRW]. eapply stp2_subst in NRW.
      simpl in NRW. assert (nat_compare (length GH) (length GH) = Eq). eapply nat_compare_eq_iff. eauto. rewrite H9 in NRW.
      rewrite (closed_no_subst _ (length GH) (length G1) 0) in NRW.
      destruct NRW as [? NRW].
      eexists. eapply stp2_downgrade. eauto. eauto.

  - Case "varax". subst. inversion H0; subst; invty; eauto.
  - Case "varay". subst. inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top. eapply stpd2_closed1; eauto.
    + SCase "varax". eauto.
    + SCase "varay". index_subst.
        assert (stpd2 m true GH G1 TX (TVar false x2)) as L. admit. (* untrans / regularity *)
        destruct L as [n4 L].
        assert (stpd2 m false GH G1 TX0 (TVar false x2)) as R.
          eapply stp2_trans_axiom. eauto. eexists. eapply stp2_wrapf. eapply stp2_vara1. eauto. apply L.
        destruct R as [n5 R]. eexists. eapply stp2_varay. eauto. apply R.

    + SCase "vara1". index_subst.

      assert (exists TY, index x2 GH = Some TY). eapply index_exists. admit. (* length *)
      ev.
      eexists. eapply stp2_vara1. eauto.

  - Case "vary". inversion H2.
  - Case "vara1". inversion H2.

  - Case "mem". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "mem". subst. eapply stpd2_mem. eapply stp2_trans_axiom; eauto. eapply IHn; eauto; try omega.
    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.

  - Case "sel". inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "sel". subst. eapply stpd2_sel. eapply stp2_trans_axiom; eauto. eapply IHn; eauto; try omega.
    + SCase "red". subst. eapply stpd2_red. eapply IHn. eauto. eauto. omega.
    + SCase "red2". subst. eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.

  - Case "red".
    eapply stpd2_red. eauto. eapply IHn; eauto. repeat econstructor. eauto. omega.
  - Case "red2".
    inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "sel". subst.
      eapply stpd2_red2. eauto.
      eapply IHn. eapply H3. eauto. omega. eapply stp2_trans_axiom; eauto. eauto. eauto.
    + SCase "red". clear H. subst.
      (* pull this out as stp2_trans_cross lemma? *)

      assert (stp2 m true [] G1 T5 T4 n0) as A0. eauto.
      assert (stp2 m true [] G1 T5 (TMem TX TTop) n5) as A1. eauto.
      assert (stpd2 m true [] G1 T5 (TMem TBot T3)) as A2. eapply IHn. eapply A0. eauto. omega. eu.

      destruct H2; inversion A1; inversion A2; subst. (* could pull out into a lemma: invert_real *)
      * SSCase "var".
        index_subst.

        assert (exists TX1 m1 m2, v0 = (vty [] TX1) /\ m1 + m2 < S n1 /\
          stp2 m false [] G1 TX TX1 m1 /\ stp2 m true [] G1 TX1 TTop m2) as B1.
        eapply invert_mem1. eapply H9. eauto. eauto.

        assert (exists TX2 m3 m4, v0 = (vty [] TX2) /\ m3 + m4 < S n2 /\
          stp2 m false [] G1 TBot TX2 m3 /\ stp2 m true [] G1 TX2 T3 m4) as B2.
        eapply invert_mem1. eapply H21. eauto. eauto.

        destruct B1 as [TZ1 [m1 [m2 [V1 [M1 [B1 _]]]]]].
        destruct B2 as [TZ2 [m3 [m4 [V2 [M2 [_ B2 ]]]]]].

        subst v0. inversion V2. subst.

        assert (stpd2 m true [] G1 TX T3) as S3. eapply IHn. eapply B1. eapply B2. omega. eu.
        assert (stpd2 m true [] G1 T1 T3) as S1. eapply IHn. eauto. eapply S3. omega.
        eapply S1.

      * SSCase "?". inversion H16.
      * SSCase "?". inversion H15.
      * SSCase "?". inversion H8.
      * SSCase "mem".

        assert (stp2 m false [] G1 TX T n2) as B1. eauto.
        assert (stp2 m true [] G1 T T3 n7) as B2. eauto.

        assert (stpd2 m true [] G1 TX T3) as S3. eapply IHn. eapply B1. eapply B2. omega. eu.
        assert (stpd2 m true [] G1 T1 T3) as S1. eapply IHn. eauto. eapply S3. omega.
        eapply S1.

    + SCase "red2". eapply stpd2_red2. eauto. eauto. eauto. eauto. eapply stp2_trans_axiom; eauto.

  - Case "bind1". subst.
    eexists. eapply stp2_bind1.

    inversion H0; subst; invty.
    + SCase "top". eapply stpd2_top; eauto.
    + SCase "red2". eapply stpd2_red2; eauto.
    + SCase "bind2". invstp_var.
    + SCase "bind".
      (* cross, between v and v0 *)
      assert (stp2 m true GH G1 T1 (v :: G2) (TVar (length G2)) n0) as ST. assumption.
      (* to be narrowed *)
      assert (stp2 m true GH (v0 :: G2) (TVar (length G2)) G3 T3 n3) as A1. assumption.
      (* narrowed *)
      assert (stp2 m true GH (v :: G2) (TVar (length G2)) G3 T3 n3) as A2. admit.
      (* result *)
      eapply IHn. eauto. eauto. omega.

  - Case "bind1". subst.
    eapply stpd2_bind1. eapply stpd2_closed2; eauto. eauto. eapply IHn; eauto. omega.

  - Case "wrapf".
    subst. eapply IHn. eapply H2. eapply H0. omega.
  - Case "transf".
    assert (stpd2 m true GH G4 T4 G3 T3). eapply IHn. eapply H3. eapply H0. omega.
    eu. subst. eapply IHn. eapply H2. eauto. omega.
Grab Existential Variables.
apply 0. apply 0. apply []. apply 0.
Qed.

(* idea: can we use the same strong_sel as before, and just translate the new rules? *)

Lemma stpd2_trans: forall m b GH G1 G2 G3 T1 T2 T3,
  stpd2 m b GH G1 T1 G2 T2 ->
  stpd2 m true GH G2 T2 G3 T3 ->
  stpd2 m true GH G1 T1 G3 T3.
Proof.
  intros. repeat eu. eapply stp2_trans; eauto.
Qed.

Lemma invert_var1: forall n, forall venv v x GX TX n1,
  val_type0 GX v TX -> stp2 true GX TX venv (TVar x) n1 -> n1 < n ->
  index x venv = Some v.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H; subst.
  - Case "bool". solve by inversion.
  - Case "fun". solve by inversion.
  - Case "var". subst. inversion H0; subst.
    + SCase "varx".
      assert (v = v0) as A. rewrite H2 in H5. inversion H5. eauto.
      rewrite A. eauto.
    + SCase "var1".
      assert (v = v0) as A. rewrite H2 in H4. inversion H4. eauto.
      rewrite A. eapply IHn; eauto. omega.
  - Case "mem". solve by inversion.
Qed.

Lemma invert_var: forall venv v x,
  val_type venv v (TVar x) ->
  index x venv = Some v.
Proof.
  intros. inversion H. ev. eapply invert_var1; eauto.
Qed.

Lemma stp_to_stpd2: forall G1 T1 T2,
  stp G1 T1 T2 ->
  forall GX, wf_env GX G1 ->
  stpd2 true GX T1 GX T2.
Proof.
  intros G1 T1 T2 H. induction H; intros.
  - Case "bool". eapply stpd2_bool; eauto.
  - Case "fun".  eapply stpd2_fun; eapply stpd2_wrapf; eauto.
  - Case "varx".
    assert (exists v, index x GX = Some v) as E. eapply index_exists. rewrite (wf_length GX G1). eauto. eauto.
    destruct E.
    eapply stpd2_varx; eauto.
  - Case "vary".
    assert (exists v, index x GX = Some v /\ val_type GX v (TVar y)) as E. eapply index_safe_ex; eauto.
    destruct E. destruct H2. inversion H3. subst.
    eapply stpd2_varx. eapply invert_var. eauto. eauto.
  - Case "var1".
    assert (exists v, index x GX = Some v /\ val_type GX v T1) as E. eapply index_safe_ex; eauto.
    destruct E. destruct H2. destruct H3.
    eapply stpd2_var1. eauto. eauto. eauto.
  - Case "mem". eapply stpd2_mem; try eapply stpd2_wrapf; eauto.
  - Case "sel". eapply stpd2_sel; eauto; try eapply stpd2_wrapf; eauto.
  - Case "red". eapply stpd2_red. eauto.
  - Case "red2". eapply stpd2_red2. eauto.
    eapply IHstp1. eauto. eapply stpd2_wrapf.
    eapply IHstp2. eauto.
    eapply stpd2_trans. eapply IHstp1. eauto. eapply IHstp2. eauto.
    assert (closed (length G1) (TMem T1 TTop)) as C. eapply stp_closed; eauto.
    eapply stpd2_wrapf. eapply stpd2_refl. rewrite (wf_length GX G1). inversion C. eauto. eauto.
Qed.

Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stpd2 true H1 T1 H2 T2 ->
  val_type H2 vf T2.
Proof.
  intros.  inversion H.
  - econstructor; eauto. eapply stpd2_trans; eauto.
Qed.

Lemma restp_widen: forall vf H1 H2 T1 T2,
  res_type H1 vf T1 ->
  stpd2 true H1 T1 H2 T2 ->
  res_type H2 vf T2.
Proof.
  intros. inversion H. eapply not_stuck. eapply valtp_widen; eauto.
Qed.

Lemma invert_abs1: forall n, forall venv vf T1 T2 GX TX n1,
  val_type0 GX vf TX -> stp2 true GX TX venv (TFun T1 T2) n1 -> n1 < n ->
  exists env tenv y T3 T4,
    vf = (vabs env y) /\
    wf_env env tenv /\
    has_type (T3::(TFun T3 T4)::tenv) y T4 /\
    stpd2 true venv T1 env T3 /\
    stpd2 true env T4 venv T2.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H; subst.
  - Case "bool". solve by inversion.
  - Case "fun". subst. inversion H0. subst.
    eexists. eexists. eexists. eexists. eexists. repeat split; eauto.
    eapply stpd2_trans. eauto. eapply stpd2_reg2. eauto.
    eapply stpd2_trans. eauto. eapply stpd2_reg2. eauto.
  - Case "var". subst. inversion H0. subst.
    assert (vf = v) as A. rewrite H2 in H4. inversion H4. eauto.
    rewrite A. eapply IHn; eauto. omega.
  - Case "mem". solve by inversion.
Qed.

Lemma invert_abs: forall venv vf T1 T2,
  val_type venv vf (TFun T1 T2) ->
  exists env tenv y T3 T4,
    vf = (vabs env y) /\
    wf_env env tenv /\
    has_type (T3::(TFun T3 T4)::tenv) y T4 /\
    stpd2 true venv T1 env T3 /\
    stpd2 true env T4 venv T2.
Proof.
  intros. inversion H. ev. eapply invert_abs1; eauto.
Qed.

(* if not a timeout, then result not stuck and well-typed *)

Theorem full_safety : forall n e tenv venv res T,
  teval n venv e = Some res -> has_type tenv e T -> wf_env venv tenv ->
  res_type venv res T.

Proof.
  intros n. induction n.
  (* 0 *)   intros. inversion H.
  (* S n *) intros. destruct e; inversion H.

  - Case "True".
    remember (ttrue) as e. induction H0; inversion Heqe; subst.
    + eapply not_stuck. eapply v_sub; eauto. eapply v_bool; eauto.
    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stpd2; eauto.

  - Case "False".
    remember (tfalse) as e. induction H0; inversion Heqe; subst.
    + eapply not_stuck. eapply v_sub; eauto. eapply v_bool; eauto.
    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stpd2; eauto.

  - Case "Var".
    remember (tvar i) as e. induction H0; inversion Heqe; subst.
    + destruct (index_safe_ex venv0 env T1 i) as [v [I V]]; eauto. (* Var *)
      rewrite I. eapply not_stuck. destruct V. eapply v_sub. eapply v_var. eauto. eapply stpd2_varx. eauto. eauto.
    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stpd2; eauto.

  - Case "App".
    remember (tapp e1 e2) as e. induction H0; inversion Heqe; subst.
    +
      remember (teval n venv0 e1) as tf.
      remember (teval n venv0 e2) as tx.

      destruct tx as [rx|]; try solve by inversion.
      assert (res_type venv0 rx T1) as HRX. SCase "HRX". subst. eapply IHn; eauto.
      inversion HRX as [? vx].

      destruct tf as [rf|]; subst rx; try solve by inversion.
      assert (res_type venv0 rf (TFun T1 T2)) as HRF. SCase "HRF". subst. eapply IHn; eauto.
      inversion HRF as [? vf].

      destruct (invert_abs venv0 vf T1 T2) as
          [env1 [tenv [y0 [T3 [T4 [EF [WF [HTY [STX STY]]]]]]]]]. eauto.
      (* now we know it's a closure, and we have has_type evidence *)

      assert (res_type (vx::vf::env1) res T4) as HRY.
        SCase "HRY".
          subst. eapply IHn. eauto. eauto.
          (* wf_env f x *) econstructor. eapply valtp_widen; eauto. eapply stpd2_extend2; eauto. eapply stpd2_extend2; eauto.
          (* wf_env f   *) econstructor. eapply v_sub. eapply v_abs; eauto. eapply stpd2_extend2. eapply stpd2_fun. eapply stpd2_wrapf. eapply stpd2_reg2; eauto. eapply stpd2_wrapf. eapply stpd2_reg1; eauto.
          eauto.

      inversion HRY as [? vy].

      eapply not_stuck. eapply valtp_widen; eauto. eapply stpd2_extend1. eapply stpd2_extend1. eauto.

    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stpd2; eauto.

  - Case "Abs".
    remember (tabs e) as xe. induction H0; inversion Heqxe; subst.
    + eapply not_stuck. eapply v_sub. eapply v_abs; eauto. eapply stpd2_refl. rewrite (wf_length venv0 env). eauto. eauto.
    + eapply restp_widen. eapply IHhas_type; eauto. eapply stp_to_stpd2; eauto.

Grab Existential Variables.
apply 0. apply 0.
Qed.

End STLC.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O A0 A1 B P Q R : Universe, ((wd_ B A0 /\ (wd_ A0 A1 /\ (wd_ A0 O /\ (wd_ A1 O /\ (wd_ P Q /\ (wd_ R Q /\ (wd_ O B /\ (col_ P Q R /\ (col_ A0 A1 B /\ col_ O A0 A1))))))))) -> col_ O A0 B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.EnsemblesProperties.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.

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

Section ContextProperties.

Context {L: Language}
        {minL: MinimumLanguage L}
        {sepconL: SepconLanguage L}
        {GammaP: Provable L}
        {GammaD: Derivable L}.

Definition context_sepcon (Phi Psi: context): context :=
  fun z => exists x y, z = x * y /\ Phi |-- x /\ Psi |-- y.

Definition context_sepcon_included_l (Phi2 Psi: context): context -> Prop :=
  fun Phi1 => Included _ (context_sepcon Phi1 Phi2) Psi.

Definition context_sepcon_included_r (Phi1 Psi: context): context -> Prop :=
  fun Phi2 => Included _ (context_sepcon Phi1 Phi2) Psi.

Context {pL: PropositionalLanguage L}
        {wandL: WandLanguage L}
        {SC: NormalSequentCalculus L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {fwSC: FiniteWitnessedSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {ipSC: IntuitionisticPropositionalSequentCalculus L GammaD}
        {AX: NormalAxiomatization L GammaP GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {ipAX: IntuitionisticPropositionalLogic L GammaP}
        {sepconAX: SepconAxiomatization L GammaP}
        {wandAX: WandAxiomatization L GammaP}
        {sepcon_orp_AX: SepconOrAxiomatization L GammaP}
        {sepcon_falsep_AX: SepconFalseAxiomatization L GammaP}.

Lemma context_sepcon_derivable:
  forall (Phi Psi: context) z,
    context_sepcon Phi Psi |-- z ->
    exists x y, |-- x * y --> z /\ Phi |-- x /\ Psi |-- y.
Proof.
  intros.
  rewrite derivable_provable in H.
  destruct H as [xs [? ?]].
  revert z H0; induction H; intros.
  + exists TT, TT.
    split; [| split].
    - apply aux_minimun_rule00; auto.
    - apply derivable_impp_refl.
    - apply derivable_impp_refl.
  + pose proof provable_multi_imp_arg_switch1 l x z.
    pose proof modus_ponens _ _ H2 H1.
    specialize (IHForall _ H3); clear H1 H2 H3.
    destruct H as [x' [y' [? [? ?]]]]; subst x.
    destruct IHForall as [x [y [? [? ?]]]].
    exists (x && x'), (y && y').
    split; [| split].
    - clear l H0 H1 H2 H3 H4.
      rewrite (provable_sepcon_andp_right (x && x') y y').
      rewrite (provable_sepcon_andp_left x x' y).
      rewrite (provable_sepcon_andp_left x x' y').
      rewrite (andp_elim1 (x * y) _).
      rewrite (andp_elim2 _ (x' * y')).
      rewrite <- impp_curry_uncurry.
      auto.
    - apply deduction_andp_intros; auto.
    - apply deduction_andp_intros; auto.
Qed.

Lemma context_sepcon_consistent_rev_left:
  forall (Phi1 Phi2 Psi: context),
    Included _ (context_sepcon Phi1 Phi2) Psi ->
    consistent Psi ->
    consistent Phi1.
Proof.
  intros.
  rewrite consistent_spec in H0 |- *.
  intro; apply H0; clear H0.
  rewrite <- (falsep_sepcon TT).
  apply derivable_assum.
  apply H; exists FF, TT; split; [| split]; auto.
  apply derivable_impp_refl.
Qed.

Lemma context_sepcon_included_l_derivable_subset_preserved: forall Phi2 Psi,
  derivable_subset_preserved (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  unfold context_sepcon_included_l.
  hnf; intros Phi1 Phi1' ? ?.
  eapply Included_trans; [clear Psi H0 | exact H0].
  unfold Included, Ensembles.In; intros z ?.
  destruct H0 as [x [y [? [? ?]]]].
  exists x, y; split; [| split]; auto.
  apply H; auto.
Qed.

Lemma context_sepcon_included_l_subset_preserved: forall Phi2 Psi,
  subset_preserved (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  apply derivable_subset_preserved_subset_preserved.
  apply context_sepcon_included_l_derivable_subset_preserved.
Qed.

Lemma context_sepcon_included_l_finite_captured: forall Phi2 Psi,
  finite_captured (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  unfold context_sepcon_included_l.
  hnf; intros.
  unfold Included, Ensembles.In; intros z ?.
  destruct H0 as [x [y [? [? ?]]]].
  apply derivable_finite_witnessed in H1.
  destruct H1 as [xs [? ?]].
  specialize (H _ H1).
  subst z.
  apply H; auto; unfold Ensembles.In.
  exists x, y; split; [| split]; auto.
Qed.

Lemma context_sepcon_included_l_context_orp_captured: forall Phi2 Psi
      (DC: derivable_closed Psi)
      (OW: orp_witnessed Psi),
  context_orp_captured (context_sepcon_included_l Phi2 Psi).
Proof.
  intros.
  unfold context_sepcon_included_l.
  hnf; intros Phi1 Phi1' ?.
  assert (forall z1 z2,
            context_sepcon Phi1 Phi2 z1  ->
            ~ Psi z1 ->
            context_sepcon Phi1' Phi2 z2 ->
            ~ Psi z2 ->
            False) as HH.
  2: {
    clear - HH; unfold Included, Ensembles.In.
    apply NNPP; intro.
    apply not_or_and in H; destruct H.
    apply not_all_ex_not in H.
    apply not_all_ex_not in H0.
    destruct H as [z1 ?], H0 as [z2 ?].
    specialize (HH z1 z2).
    tauto.
  }
  intros.
  destruct H0 as [x1 [y1 [? [? ?]]]], H2 as [x2 [y2 [? [? ?]]]].
  subst z1 z2.
  assert (context_orp Phi1 Phi1' (x1 || x2));
  [| assert (context_sepcon (context_orp Phi1 Phi1') Phi2 ((x1 || x2) * (y1 && y2)));
     [| assert (Psi |-- (x1 * y1) || (x2 * y2))]].
  + exists x1, x2.
    split; [| split]; auto.
  + exists (x1 || x2), (y1 && y2).
    split; [| split]; auto.
    - apply derivable_assum; auto.
    - apply deduction_andp_intros; auto.
  + apply H in H2.
    apply derivable_assum in H2.
    rewrite sepcon_orp_distr_r in H2.
    rewrite (andp_elim1 y1 y2) in H2 at 1.
    rewrite (andp_elim2 y1 y2) in H2 at 1.
    auto.
  + rewrite <- derivable_closed_element_derivable in H8 by auto.
    apply OW in H8.
    tauto.
Qed.

Lemma wand_deduction_theorem:
  forall (Phi: context) x y,
    context_sepcon Phi (Union _ empty_context (Singleton _ x)) |-- y <->
    Phi |-- x -* y.
Proof.
  intros.
  split; intros.
  + apply context_sepcon_derivable in H.
    destruct H as [x' [y' [? [? ?]]]].
    rewrite deduction_theorem, <- provable_derivable in H1.
    rewrite <- H1 in H.
    apply wand_sepcon_adjoint in H.
    rewrite H in H0; auto.
  + rewrite <- (provable_wand_sepcon_modus_ponens1 x y).
    apply derivable_assum.
    exists (x -* y), x.
    split; [| split]; auto.
    rewrite deduction_theorem.
    apply derivable_impp_refl.
Qed.

Lemma context_sepcon_included_equiv: forall Phi Psi,
  derivable_closed Psi ->
  Same_set _ (context_sepcon_included_l Phi Psi) (context_sepcon_included_r Phi Psi).
Proof.
  intros.
  rewrite Same_set_spec; intros Phi'; split; intros.
  + hnf; intros.
    destruct H1 as [y [z [? [? ?]]]].
    subst x.
    apply H.
    rewrite <- sepcon_comm_impp.
    apply derivable_assum.
    apply H0.
    exists z, y; split; [| split]; auto.
  + hnf; intros.
    destruct H1 as [y [z [? [? ?]]]].
    subst x.
    apply H.
    rewrite <- sepcon_comm_impp.
    apply derivable_assum.
    apply H0.
    exists z, y; split; [| split]; auto.
Qed.

End ContextProperties.


Set Warnings "-notation-overridden".

Require Import Category.Theory.
Require Import Category.Structure.Monoidal.
Require Import Category.Lib.
Require Import Category.Structure.Monoidal.Proofs.

Require Import Enriched.Category.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section One.
Context {V0: Category} {V : Monoidal}.

Program Definition E1 : EnrichedCategory := {|
  eobj     := Datatypes.unit;
  ehom     := fun _ _ => I;
  eid      := fun _ => id;
  ecompose := fun _ _ _ => unit_left
|}.
Next Obligation.
  normal.
  apply unit_identity.
Qed.
Next Obligation.
  rewrite id_unit_left.
  rewrite triangle_identity_left.
  apply comp_assoc.
Qed.
End One.

Notation "1" := E1 : enriched_category_scope.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                               sigma_lift.v                               *)
(****************************************************************************)

(*****************************************************************************)
(*          Projet Coq  - Calculus of Inductive Constructions V5.8           *)
(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

                    (* Systeme sigma-lift *)

Require Import TS.
Require Import sur_les_relations.

(* regles de reecriture *)

Inductive reg_app : terms -> terms -> Prop :=
    reg1_app :
      forall (a b : terms) (s : sub_explicits),
      reg_app (env (app a b) s) (app (env a s) (env b s)).
Hint Resolve reg1_app.

Inductive reg_lambda : terms -> terms -> Prop :=
    reg1_lambda :
      forall (a : terms) (s : sub_explicits),
      reg_lambda (env (lambda a) s) (lambda (env a (lift s))).
Hint Resolve reg1_lambda.

Inductive reg_clos : terms -> terms -> Prop :=
    reg1_clos :
      forall (a : terms) (s t : sub_explicits),
      reg_clos (env (env a s) t) (env a (comp s t)).
Hint Resolve reg1_clos.

Inductive reg_varshift1 : terms -> terms -> Prop :=
    reg1_varshift1 :
      forall n : nat, reg_varshift1 (env (var n) shift) (var (S n)).
Hint Resolve reg1_varshift1.

Inductive reg_varshift2 : terms -> terms -> Prop :=
    reg1_varshift2 :
      forall (n : nat) (s : sub_explicits),
      reg_varshift2 (env (var n) (comp shift s)) (env (var (S n)) s).
Hint Resolve reg1_varshift2.

Inductive reg_fvarcons : terms -> terms -> Prop :=
    reg1_fvarcons :
      forall (a : terms) (s : sub_explicits),
      reg_fvarcons (env (var 0) (cons a s)) a.
Hint Resolve reg1_fvarcons.

Inductive reg_fvarlift1 : terms -> terms -> Prop :=
    reg1_fvarlift1 :
      forall s : sub_explicits, reg_fvarlift1 (env (var 0) (lift s)) (var 0).
Hint Resolve reg1_fvarlift1.

Inductive reg_fvarlift2 : terms -> terms -> Prop :=
    reg1_fvarlift2 :
      forall s t : sub_explicits,
      reg_fvarlift2 (env (var 0) (comp (lift s) t)) (env (var 0) t).
Hint Resolve reg1_fvarlift2.

Inductive reg_rvarcons : terms -> terms -> Prop :=
    reg1_rvarcons :
      forall (n : nat) (a : terms) (s : sub_explicits),
      reg_rvarcons (env (var (S n)) (cons a s)) (env (var n) s).
Hint Resolve reg1_rvarcons.

Inductive reg_rvarlift1 : terms -> terms -> Prop :=
    reg1_rvarlift1 :
      forall (n : nat) (s : sub_explicits),
      reg_rvarlift1 (env (var (S n)) (lift s)) (env (var n) (comp s shift)).
Hint Resolve reg1_rvarlift1.

Inductive reg_rvarlift2 : terms -> terms -> Prop :=
    reg1_rvarlift2 :
      forall (n : nat) (s t : sub_explicits),
      reg_rvarlift2 (env (var (S n)) (comp (lift s) t))
        (env (var n) (comp s (comp shift t))).
Hint Resolve reg1_rvarlift2.

Inductive reg_assenv : sub_explicits -> sub_explicits -> Prop :=
    reg1_assenv :
      forall s t u : sub_explicits,
      reg_assenv (comp (comp s t) u) (comp s (comp t u)).
Hint Resolve reg1_assenv.

Inductive reg_mapenv : sub_explicits -> sub_explicits -> Prop :=
    reg1_mapenv :
      forall (a : terms) (s t : sub_explicits),
      reg_mapenv (comp (cons a s) t) (cons (env a t) (comp s t)).
Hint Resolve reg1_mapenv.

Inductive reg_shiftcons : sub_explicits -> sub_explicits -> Prop :=
    reg1_shiftcons :
      forall (a : terms) (s : sub_explicits),
      reg_shiftcons (comp shift (cons a s)) s.
Hint Resolve reg1_shiftcons.

Inductive reg_shiftlift1 : sub_explicits -> sub_explicits -> Prop :=
    reg1_shiftlift1 :
      forall s : sub_explicits,
      reg_shiftlift1 (comp shift (lift s)) (comp s shift).
Hint Resolve reg1_shiftlift1.

Inductive reg_shiftlift2 : sub_explicits -> sub_explicits -> Prop :=
    reg1_shiftlift2 :
      forall s t : sub_explicits,
      reg_shiftlift2 (comp shift (comp (lift s) t)) (comp s (comp shift t)).
Hint Resolve reg1_shiftlift2.

Inductive reg_lift1 : sub_explicits -> sub_explicits -> Prop :=
    reg1_lift1 :
      forall s t : sub_explicits,
      reg_lift1 (comp (lift s) (lift t)) (lift (comp s t)).
Hint Resolve reg1_lift1.

Inductive reg_lift2 : sub_explicits -> sub_explicits -> Prop :=
    reg1_lift2 :
      forall s t u : sub_explicits,
      reg_lift2 (comp (lift s) (comp (lift t) u)) (comp (lift (comp s t)) u).
Hint Resolve reg1_lift2.

Inductive reg_liftenv : sub_explicits -> sub_explicits -> Prop :=
    reg1_liftenv :
      forall (a : terms) (s t : sub_explicits),
      reg_liftenv (comp (lift s) (cons a t)) (cons a (comp s t)).
Hint Resolve reg1_liftenv.

Inductive reg_idl : sub_explicits -> sub_explicits -> Prop :=
    reg1_idl : forall s : sub_explicits, reg_idl (comp id s) s.
Hint Resolve reg1_idl.

Inductive reg_idr : sub_explicits -> sub_explicits -> Prop :=
    reg1_idr : forall s : sub_explicits, reg_idr (comp s id) s.
Hint Resolve reg1_idr.

Inductive reg_liftid : sub_explicits -> sub_explicits -> Prop :=
    reg1_liftid : reg_liftid (lift id) id.
Hint Resolve reg1_liftid.

Inductive reg_id : terms -> terms -> Prop :=
    reg1_id : forall a : terms, reg_id (env a id) a.
Hint Resolve reg1_id.

(* systeme sigma-lift *)

Inductive e_systemSL : forall b : wsort, TS b -> TS b -> Prop :=
  | regle_app : forall a b : terms, reg_app a b -> e_systemSL wt a b
  | regle_lambda : forall a b : terms, reg_lambda a b -> e_systemSL wt a b
  | regle_clos : forall a b : terms, reg_clos a b -> e_systemSL wt a b
  | regle_varshift1 :
      forall a b : terms, reg_varshift1 a b -> e_systemSL wt a b
  | regle_varshift2 :
      forall a b : terms, reg_varshift2 a b -> e_systemSL wt a b
  | regle_fvarcons :
      forall a b : terms, reg_fvarcons a b -> e_systemSL wt a b
  | regle_fvarlift1 :
      forall a b : terms, reg_fvarlift1 a b -> e_systemSL wt a b
  | regle_fvarlift2 :
      forall a b : terms, reg_fvarlift2 a b -> e_systemSL wt a b
  | regle_rvarcons :
      forall a b : terms, reg_rvarcons a b -> e_systemSL wt a b
  | regle_rvarlift1 :
      forall a b : terms, reg_rvarlift1 a b -> e_systemSL wt a b
  | regle_rvarlift2 :
      forall a b : terms, reg_rvarlift2 a b -> e_systemSL wt a b
  | regle_assenv :
      forall s t : sub_explicits, reg_assenv s t -> e_systemSL ws s t
  | regle_mapenv :
      forall s t : sub_explicits, reg_mapenv s t -> e_systemSL ws s t
  | regle_shiftcons :
      forall s t : sub_explicits, reg_shiftcons s t -> e_systemSL ws s t
  | regle_shiftlift1 :
      forall s t : sub_explicits, reg_shiftlift1 s t -> e_systemSL ws s t
  | regle_shiftlift2 :
      forall s t : sub_explicits, reg_shiftlift2 s t -> e_systemSL ws s t
  | regle_lift1 :
      forall s t : sub_explicits, reg_lift1 s t -> e_systemSL ws s t
  | regle_lift2 :
      forall s t : sub_explicits, reg_lift2 s t -> e_systemSL ws s t
  | regle_liftenv :
      forall s t : sub_explicits, reg_liftenv s t -> e_systemSL ws s t
  | regle_idl : forall s t : sub_explicits, reg_idl s t -> e_systemSL ws s t
  | regle_idr : forall s t : sub_explicits, reg_idr s t -> e_systemSL ws s t
  | regle_liftid :
      forall s t : sub_explicits, reg_liftid s t -> e_systemSL ws s t
  | regle_id : forall a b : terms, reg_id a b -> e_systemSL wt a b.

Notation systemSL := (e_systemSL _) (only parsing).
(* <Warning> : Syntax is discontinued *)

Hint Resolve regle_app regle_lambda regle_clos regle_varshift1
  regle_varshift2 regle_fvarcons regle_fvarlift1 regle_fvarlift2
  regle_rvarcons regle_rvarlift1 regle_rvarlift2 regle_assenv regle_mapenv
  regle_shiftcons regle_shiftlift1 regle_shiftlift2 regle_lift1 regle_lift2
  regle_liftenv regle_idl regle_idr regle_liftid regle_id.

(* relation engendree par le systeme sigma-lift *)

Inductive e_relSL : forall b : wsort, TS b -> TS b -> Prop :=
  | SL_one_regle :
      forall (b : wsort) (M N : TS b), e_systemSL _ M N -> e_relSL b M N
  | SL_context_app_l :
      forall a a' b : terms,
      e_relSL wt a a' -> e_relSL wt (app a b) (app a' b)
  | SL_context_app_r :
      forall a b b' : terms,
      e_relSL wt b b' -> e_relSL wt (app a b) (app a b')
  | SL_context_lambda :
      forall a a' : terms,
      e_relSL wt a a' -> e_relSL wt (lambda a) (lambda a')
  | SL_context_env_t :
      forall (a a' : terms) (s : sub_explicits),
      e_relSL wt a a' -> e_relSL wt (env a s) (env a' s)
  | SL_context_env_s :
      forall (a : terms) (s s' : sub_explicits),
      e_relSL ws s s' -> e_relSL wt (env a s) (env a s')
  | SL_context_cons_t :
      forall (a a' : terms) (s : sub_explicits),
      e_relSL wt a a' -> e_relSL ws (cons a s) (cons a' s)
  | SL_context_cons_s :
      forall (a : terms) (s s' : sub_explicits),
      e_relSL ws s s' -> e_relSL ws (cons a s) (cons a s')
  | SL_context_comp_l :
      forall s s' t : sub_explicits,
      e_relSL ws s s' -> e_relSL ws (comp s t) (comp s' t)
  | SL_context_comp_r :
      forall s t t' : sub_explicits,
      e_relSL ws t t' -> e_relSL ws (comp s t) (comp s t')
  | SL_context_lift :
      forall s s' : sub_explicits,
      e_relSL ws s s' -> e_relSL ws (lift s) (lift s').

Notation relSL := (e_relSL _) (only parsing).
(* <Warning> : Syntax is discontinued *)

Hint Resolve SL_one_regle SL_context_app_l SL_context_app_r SL_context_lambda
  SL_context_env_t SL_context_env_s SL_context_cons_t SL_context_cons_s
  SL_context_comp_l SL_context_comp_r SL_context_lift.

(* fermeture reflexive-transitive de la relation sigma-lift *)

Definition e_relSLstar (b : wsort) := explicit_star _ (e_relSL b).

Notation relSLstar := (e_relSLstar _) (only parsing).
(* <Warning> : Syntax is discontinued *)

Hint Unfold e_relSLstar.

(* *)

Goal
forall a a' b : terms,
e_relSLstar _ a a' -> e_relSLstar _ (app a b) (app a' b).
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (app y b); auto.
Save SLstar_context_app_l.
Hint Resolve SLstar_context_app_l.

Goal
forall a b b' : terms,
e_relSLstar _ b b' -> e_relSLstar _ (app a b) (app a b').
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (app a y); auto.
Save SLstar_context_app_r.
Hint Resolve SLstar_context_app_r.

Goal
forall a a' : terms,
e_relSLstar _ a a' -> e_relSLstar _ (lambda a) (lambda a').
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (lambda y); auto.
Save SLstar_context_lambda.
Hint Resolve SLstar_context_lambda.

Goal
forall (a a' : terms) (s : sub_explicits),
e_relSLstar _ a a' -> e_relSLstar _ (env a s) (env a' s).
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (env y s); auto.
Save SLstar_context_env_t.
Hint Resolve SLstar_context_env_t.

Goal
forall (a : terms) (s s' : sub_explicits),
e_relSLstar _ s s' -> e_relSLstar _ (env a s) (env a s').
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (env a y); auto.
Save SLstar_context_env_s.
Hint Resolve SLstar_context_env_s.

Goal
forall (a a' : terms) (s : sub_explicits),
e_relSLstar _ a a' -> e_relSLstar _ (cons a s) (cons a' s).
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (cons y s); auto.
Save SLstar_context_cons_t.
Hint Resolve SLstar_context_cons_t.

Goal
forall (a : terms) (s s' : sub_explicits),
e_relSLstar _ s s' -> e_relSLstar _ (cons a s) (cons a s').
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (cons a y); auto.
Save SLstar_context_cons_s.
Hint Resolve SLstar_context_cons_s.

Goal
forall s s' t : sub_explicits,
e_relSLstar _ s s' -> e_relSLstar _ (comp s t) (comp s' t).
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (comp y t); auto.
Save SLstar_context_comp_l.
Hint Resolve SLstar_context_comp_l.

Goal
forall s t t' : sub_explicits,
e_relSLstar _ t t' -> e_relSLstar _ (comp s t) (comp s t').
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (comp s y); auto.
Save SLstar_context_comp_r.
Hint Resolve SLstar_context_comp_r.

Goal
forall s s' : sub_explicits,
e_relSLstar _ s s' -> e_relSLstar _ (lift s) (lift s').
red in |- *; simple induction 1; intros.
auto.
apply star_trans1 with (lift y); auto.
Save SLstar_context_lift.
Hint Resolve SLstar_context_lift.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

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


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Monad.
Require Export Category.Adjunction.Natural.Transformation.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section AdjunctionMonad.

Context {C : Category}.
Context {D : Category}.
Context {F : D ⟶ C}.
Context {U : C ⟶ D}.

(* Every adjunction gives rise to a monad. However, for the reverse direction,
   just knowing that the monad is formed from the product of two functors is
   not enough information, since one could always just compose [Id] to some
   monad [M], and this would not give an adjoint. *)

Theorem Adjunction_Monad : F ∹ U -> @Monad D (U ○ F).
Proof.
  intros.
  unshelve econstructor; simpl; intros.
  - exact (transform[unit] _).
  - exact (fmap (transform[counit] _)).
  - symmetry.
    apply (naturality[unit]).
  - rewrite <- !fmap_comp.
    apply fmap_respects.
    symmetry.
    apply (naturality[counit]).
  - rewrite <- !fmap_comp.
    srewrite (@counit_fmap_unit); cat.
  - simpl.
    srewrite (@fmap_counit_unit); cat.
  - rewrite <- !fmap_comp.
    srewrite (naturality[counit]); cat.
Qed.

End AdjunctionMonad.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.UpwardsClosure.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.
Require Import Logic.SeparationLogic.Semantics.DownwardsSemantics.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Module Down2Flat.
Section Down2Flat.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {po_R: PreOrder Krelation}
        {J: Join (Kworlds M)}
        {SA: SeparationAlgebra (Kworlds M)}
        {dSA: DownwardsClosedSeparationAlgebra (Kworlds M)}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD M SM}
        {dsepconSM: DownwardsSemantics.SepconSemantics L MD M SM}
        {dwandSM: DownwardsSemantics.WandSemantics L MD M SM}.

Definition fsepconSM: @FlatSemantics.SepconSemantics L _ MD _ M _ UpwardsClosure_J SM.
Proof.
  hnf; intros.
  unfold WeakSemantics.sepcon.
  split; unfold Included, Ensembles.In; intros m ?.
  + rewrite (app_same_set (DownwardsSemantics.denote_sepcon _ _) m) in H.
    destruct H as [m0 [m1 [m2 [? [? [? ?]]]]]].
    exists m1, m2.
    split; [| split]; auto.
    exists m0; split; auto.
  + rewrite (app_same_set (DownwardsSemantics.denote_sepcon _ _) m).
    destruct H as [m1 [m2 [[n [? ?]] [? ?]]]].
    exists n, m1, m2.
    split; [| split; [| split]]; auto.
Qed.

Definition fwandSM: @FlatSemantics.WandSemantics L _ MD _ M _ UpwardsClosure_J SM.
Proof.
  hnf; intros.
  unfold WeakSemantics.wand.
  split; unfold Included, Ensembles.In; intros m ?.
  + rewrite (app_same_set (DownwardsSemantics.denote_wand _ _) m) in H.
    intros.
    destruct H0 as [m2' [? ?]].
    eapply sat_mono; eauto.
    eapply H; eauto.
  + rewrite (app_same_set (DownwardsSemantics.denote_wand _ _) m).
    hnf; intros.
    apply (H m1 m2); auto.
    exists m2; split; auto.
    reflexivity.
Qed.

Definition feSM {empL: EmpLanguage L} {USA: UnitalSeparationAlgebra (Kworlds M)} {dempSM: DownwardsSemantics.EmpSemantics L MD M SM}: @FlatSemantics.EmpSemantics L _ MD _ M _ UpwardsClosure_J SM.
Proof.
  split; intros m; unfold Ensembles.In; unfold WeakSemantics.emp;
  rewrite <- UpwardsClosure_increasing;
  apply DownwardsSemantics.denote_emp.
Qed.

End Down2Flat.
End Down2Flat.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal84.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (z:natural) (IHx:@eq natural (mult (plus x y) z) (plus (mult x z) (mult y z))):@eq natural (plus (plus (mult x z) (mult y z)) z)
  (plus (plus (mult x z) z) (mult y z)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal84_distrib_96_plus_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) (z:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y z.
QuickChick collect_data.
Success.