Require Import SecOrder Modal ST_setup p_is_pos P_occurs_in_alpha p_occurs_in.
Require Import P_occurs_in_alpha nList_egs Occ_In_Alpha.
Require Import Arith.EqNat my_bool pos_SO2 neg_SO2 my_arith__my_leb_nat.

(* ---------------------------------------------------------------------------- *)
(* Monotonicity *)

Definition Ip_extends (W : Set) (Ip Ip' : predicate -> W -> Prop)
                     (P : predicate) :=
  (forall (w : W), (Ip P w) -> (Ip' P w))
    /\ forall (Q : predicate),
         (match P, Q with
            Pred n, Pred m =>
              ~(n = m) -> (Ip Q = Ip' Q)
          end).

Definition alpha_upward_monotone_P (alpha : SecOrder) (P : predicate) :=
    forall (W : Set) (Iv : FOvariable -> W) (R : W -> W -> Prop)
           (Ip Ip' : predicate -> W -> Prop),
   Ip_extends W Ip Ip' P
      -> (SOturnst W Iv Ip R alpha) ->
                          (SOturnst W Iv Ip' R alpha).

Definition alpha_downward_monotone_P (alpha : SecOrder) (P : predicate) :=
    forall (W : Set) (Iv : FOvariable -> W) (R : W -> W -> Prop)
           (Ip Ip' : predicate -> W -> Prop),
   Ip_extends W Ip' Ip P
      -> (SOturnst W Iv Ip R alpha) ->
                          (SOturnst W Iv Ip' R alpha).

Definition ST_p (p : propvar) : predicate :=
  match p with
    pv n => Pred n
  end.

(* ---------------------------------------------------------------------------- *)

Lemma up_not_occ_SO : forall (alpha : SecOrder) (P : predicate),
  P_occurs_in_alpha alpha P = false ->
    (alpha_upward_monotone_P alpha P /\ alpha_downward_monotone_P alpha P).
Proof.
  intros alpha P; induction alpha;
  unfold alpha_upward_monotone_P in *;
  unfold alpha_downward_monotone_P in *;
    intros Hocc.
    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    unfold P_occurs_in_alpha in Hocc;
    unfold Ip_extends in Ipext;
    destruct Ipext as [l r];
    destruct P as [Pn]; destruct p as [Qm];
    destruct f as [xn];
      simpl in *;
      case_eq (beq_nat Pn Qm); intros Hbeq; rewrite Hbeq in *;
        try discriminate;
      apply beq_nat_false in Hbeq;
      specialize (r (Pred Qm)); simpl in r;
      specialize (r Hbeq);
      apply equal_f with (x := (Iv (Var xn))) in r.
        rewrite r in SOt. assumption.
        rewrite r. assumption.

    destruct f; destruct f0.
    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    simpl in *; assumption.

    destruct f; destruct f0.
    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    simpl in *; assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
      rewrite SOturnst_allFO in *;
      intros d; specialize (SOt d);
      rewrite <- P_occurs_in_alpha_allFO in Hocc;
      destruct (IHalpha Hocc) as [l r].
      apply l with (Ip := Ip); assumption.
      apply r with (Ip := Ip); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
      rewrite SOturnst_exFO in *;
      destruct SOt as [d SOt]; exists d;
      rewrite <- P_occurs_in_alpha_exFO in Hocc;
      destruct (IHalpha Hocc) as [l r].
      apply l with (Ip := Ip); assumption.
      apply r with (Ip := Ip); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
      rewrite SOturnst_negSO in *;
      unfold not in *; intros H;
      apply SOt;
      destruct (IHalpha Hocc) as [l r].
      apply r with (Ip := Ip'); assumption.
      apply l with (Ip := Ip'); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    rewrite SOturnst_conjSO in *;
    pose proof (P_occurs_in_alpha_conjSO alpha1 alpha2 P) as H;
    apply contrapos_bool_or in H;
    apply H in Hocc;
    destruct Hocc as [H1 H2]; destruct SOt as [Ha Hb];
    apply conj.
      destruct (IHalpha1 H1) as [l r].
      apply l with (Ip := Ip); assumption.

      destruct (IHalpha2 H2) as [l r].
      apply l with (Ip := Ip); assumption.

      destruct (IHalpha1 H1) as [l r].
      apply r with (Ip := Ip); assumption.

      destruct (IHalpha2 H2) as [l r].
      apply r with (Ip := Ip); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    rewrite SOturnst_disjSO in *;
    pose proof (P_occurs_in_alpha_disjSO alpha1 alpha2 P) as H;
    apply contrapos_bool_or in H;
    apply H in Hocc;
    destruct Hocc as [H1 H2]; destruct SOt as [Ha | Hb].
      left; destruct (IHalpha1 H1) as [l r].
      apply l with (Ip := Ip); assumption.

      right; destruct (IHalpha2 H2) as [l r].
      apply l with (Ip := Ip); assumption.

      left; destruct (IHalpha1 H1) as [l r].
      apply r with (Ip := Ip); assumption.

      right; destruct (IHalpha2 H2) as [l r].
      apply r with (Ip := Ip); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt SOt1;
    rewrite SOturnst_implSO in *;
    pose proof (P_occurs_in_alpha_implSO alpha1 alpha2 P) as H;
    apply contrapos_bool_or in H;
    apply H in Hocc;
    destruct Hocc as [H1 H2]; destruct (IHalpha1 H1) as [l r];
      destruct (IHalpha2 H2) as [l2 r2].
      apply l2 with (Ip := Ip);
      try assumption; apply SOt; apply r with (Ip := Ip'); assumption.

      apply r2 with (Ip := Ip); try assumption.
      apply SOt; apply l with (Ip := Ip'); assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    rewrite SOturnst_allSO in *;
    intros pa; specialize (SOt pa);
    pose proof P_occurs_in_alpha_allSO as H;
    specialize (H alpha p P);
    destruct p as [Qm]; destruct P as [Pn];
    apply contrapos_bool_or in H ;
    apply H in Hocc;
    destruct Hocc as [Hbeq Hocc];
    clear H;
    destruct (IHalpha Hocc) as [l r].
    apply l with (Ip := alt_Ip Ip pa (Pred Qm)).
      unfold Ip_extends.
      apply conj.
        intros w H.
        simpl; simpl in H.
        rewrite beq_nat_comm. rewrite beq_nat_comm in H.
        rewrite Hbeq in *.
        unfold Ip_extends in Ipext.
        apply Ipext; assumption.

        intros Q; destruct Q as [Rm]; intros Heq.
        simpl.
        case_eq (beq_nat Qm Rm); intros Hbeq2.
          reflexivity.

          unfold Ip_extends in Ipext.
          destruct Ipext as [H1 H2].
          specialize (H2 (Pred Rm)).
          simpl in H2.
          apply H2; assumption.

        assumption.

      apply r with (Ip := alt_Ip Ip pa (Pred Qm)).
        unfold Ip_extends in *.
        apply conj.
          simpl.
          rewrite beq_nat_comm.
          intros w H.
          rewrite Hbeq in *.
          apply Ipext; assumption.

          intros Q; destruct Q as [Rn].
          intros Heq.
          simpl.
          case (beq_nat Qm Rn).
            reflexivity.

            destruct Ipext as [H1 H2].
            specialize (H2 (Pred Rn)).
            apply H2; assumption.

        assumption.

    apply conj; intros W Iv R Ip Ip' Ipext SOt;
    rewrite SOturnst_exSO in *;
    destruct SOt as [pa SOt]; exists pa;
    pose proof P_occurs_in_alpha_exSO as H;
    specialize (H alpha p P);
    destruct p as [Qm]; destruct P as [Pn];
    apply contrapos_bool_or in H ;
    apply H in Hocc;
    destruct Hocc as [Hbeq Hocc];
    clear H;
    destruct (IHalpha Hocc) as [l r].
    apply l with (Ip := alt_Ip Ip pa (Pred Qm)).
      unfold Ip_extends.
      apply conj.
        intros w H.
        simpl; simpl in H.
        rewrite beq_nat_comm. rewrite beq_nat_comm in H.
        rewrite Hbeq in *.
        unfold Ip_extends in Ipext.
        apply Ipext; assumption.

        intros Q; destruct Q as [Rm]; intros Heq.
        simpl.
        case_eq (beq_nat Qm Rm); intros Hbeq2.
          reflexivity.

          unfold Ip_extends in Ipext.
          destruct Ipext as [H1 H2].
          specialize (H2 (Pred Rm)).
          simpl in H2.
          apply H2; assumption.

        assumption.

      apply r with (Ip := alt_Ip Ip pa (Pred Qm)).
        unfold Ip_extends in *.
        apply conj.
          simpl.
          rewrite beq_nat_comm.
          intros w H.
          rewrite Hbeq in *.
          apply Ipext; assumption.

          intros Q; destruct Q as [Rn].
          intros Heq.
          simpl.
          case (beq_nat Qm Rn).
            reflexivity.

            destruct Ipext as [H1 H2].
            specialize (H2 (Pred Rn)).
            apply H2; assumption.

        assumption.
Qed.

(* -------------------------------------------------------------------- *)

Lemma up_negSO : forall (alpha: SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha P ->
    alpha_downward_monotone_P (negSO alpha) P.
Proof.
  intros alpha P H.
  case_eq (P_occurs_in_alpha (negSO alpha) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext.
  simpl in *.
  unfold not; intros SOt' H2; apply SOt'.
  apply H with (Ip := Ip'); assumption.
Qed.

Lemma up_conjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (conjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (conjSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  apply conj; [apply H1 with (Ip := Ip) | apply H2 with (Ip := Ip)];
   try apply SOt; try assumption.
Qed.

Lemma up_disjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (disjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (disjSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  destruct SOt as [SOt | SOt];
    [left ;apply H1 with (Ip := Ip) |
    right ; apply H2 with (Ip := Ip)]; assumption.
Qed.

Lemma up_implSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_upward_monotone_P alpha2 P ->
      alpha_upward_monotone_P (implSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (implSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *; intros H.
  apply H2 with (Ip := Ip); try assumption.
  apply SOt.
  apply H1 with (Ip := Ip'); assumption.
Qed.

Lemma up_allFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (allFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; intros d.
  specialize (SOt d).
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma up_exFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (exFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; destruct SOt as [d SOt].
  exists d.
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma Ip_ext_alt_Ip : forall (W : Set) (Ip Ip' : predicate -> W -> Prop)
                             (pa : W -> Prop) (P Q : predicate),
  Ip_extends W Ip Ip' P ->
  Ip_extends W (alt_Ip Ip pa Q) (alt_Ip Ip' pa Q) P.
Proof.
  intros W Ip Ip' pa P Q Ipext.
  unfold Ip_extends in *.
  destruct Ipext as [Ipext1 Ipext2].
  destruct P as [Pn]; destruct Q as [Qm].
  apply conj.
    intros w Halt.
    simpl in *.
    case_eq (beq_nat Qm Pn); intros Hbeq; rewrite Hbeq in *.
      assumption.

      apply Ipext1.
      assumption.

    intros R; destruct R as [Rn].
    intros Hneq.
    simpl.
    case_eq (beq_nat Qm Rn); intros Hbeq2.
      reflexivity.

      specialize (Ipext2 (Pred Rn)).
      simpl in *.
      apply Ipext2.
      assumption.
Qed.

Lemma up_allSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (allSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  intros pa.
  specialize (SOt pa).
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

Lemma up_exSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_upward_monotone_P alpha P) ->
     (alpha_upward_monotone_P (exSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_upward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  destruct SOt as [pa SOt].
  exists pa.
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

(*
Lemma up_allFOx : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
  P_is_pos_SO alpha P ->
  (alpha_upward_monotone_P (allFO x alpha) P <->
    alpha_upward_monotone_P alpha P).
Proof.
  intros alpha x P Hpos.
  split; intros H.
    unfold alpha_upward_monotone_P in *.
    intros W Iv R Ip Ip' Ipext SOt.
    specialize (H W Iv R Ip Ip' Ipext).
    simpl in H.
    destruct x as [xn].
    simpl in *.
*)

(* -------------------------------------------------------------------- *)

Lemma down_negSO : forall (alpha: SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha P ->
    alpha_upward_monotone_P (negSO alpha) P.
Proof.
  intros alpha P H.
  case_eq (P_occurs_in_alpha (negSO alpha) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext.
  simpl in *.
  unfold not; intros SOt' H2; apply SOt'.
  apply H with (Ip := Ip'); assumption.
Qed.

Lemma down_conjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (conjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (conjSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  apply conj; [apply H1 with (Ip := Ip) | apply H2 with (Ip := Ip)];
   try apply SOt; try assumption.
Qed.

Lemma down_disjSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_downward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (disjSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (disjSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_downward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *.
  destruct SOt as [SOt | SOt];
    [left ;apply H1 with (Ip := Ip) |
    right ; apply H2 with (Ip := Ip)]; try assumption.
Qed.

Lemma down_implSO12 : forall (alpha1 alpha2 : SecOrder) (P : predicate),
  alpha_upward_monotone_P alpha1 P ->
    alpha_downward_monotone_P alpha2 P ->
      alpha_downward_monotone_P (implSO alpha1 alpha2) P.
Proof.
  intros alpha1 alpha2 P H1 H2.
  case_eq (P_occurs_in_alpha (implSO alpha1 alpha2) P); intros Hocc;
    [ | apply up_not_occ_SO; exact Hocc].
  unfold alpha_upward_monotone_P in *.
  intros W Iv Ir Ip Ip' Ipext SOt.
  simpl in *; intros H.
  apply H2 with (Ip := Ip); try assumption.
  apply SOt.
  apply H1 with (Ip := Ip'); assumption.
Qed.

Lemma down_allFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (allFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; intros d.
  specialize (SOt d).
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma down_exFO : forall (alpha : SecOrder) (x : FOvariable)
                         (P : predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (exFO x alpha) P)).
Proof.
  intros alpha x P Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct x as [xn]; destruct SOt as [d SOt];
  exists d.
  specialize (Hmono W (alt_Iv Iv d (Var xn)) R Ip Ip' Ipext).
  apply Hmono.
  assumption.
Qed.

Lemma down_allSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (allSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  intros pa.
  specialize (SOt pa).
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip  Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

Lemma down_exSO : forall (alpha : SecOrder) (P Q: predicate),
    ((alpha_downward_monotone_P alpha P) ->
     (alpha_downward_monotone_P (exSO Q alpha) P)).
Proof.
  intros alpha P Q Hmono.
  unfold alpha_downward_monotone_P in *.
  intros W Iv R Ip Ip' Ipext SOt.
  simpl in *.
  destruct Q as [Qm]; destruct P as [Pn].
  destruct SOt as [pa SOt].
  exists pa.
  specialize (Hmono W Iv R (alt_Ip Ip pa (Pred Qm))
        (alt_Ip Ip' pa (Pred Qm))).
  apply Hmono.
  apply Ip_ext_alt_Ip; assumption.

  assumption.
Qed.

(* ------------------------------------------------------------- *)
(* Outdated coment: Can't prove this using induction since the negSO case requires
   the downward_monotone IH. So it is true and is okay to assume,
   but need to prove downward for is_neg at the same time. *)
Lemma monotonicity_SO_predSO : forall (P Q : predicate) (x : FOvariable),
  P_occurs_in_alpha (predSO Q x) P = true ->
  (P_is_pos_SO (predSO Q x) P -> alpha_upward_monotone_P (predSO Q x) P) /\
  (P_is_neg_SO (predSO Q x) P -> alpha_downward_monotone_P (predSO Q x) P).
Proof.
  intros P Q x HPocc.
  apply conj; intros H.
    unfold alpha_upward_monotone_P.
    intros W Iv R Ip Ip' Ipext SOt.
    simpl in *.
    destruct Q as [Qm]; destruct P as [Pn];
    destruct x as [xn].
    unfold Ip_extends in Ipext.
    destruct Ipext as [Ha Hb].
    case_eq (beq_nat Pn Qm); intros Hbeq.
      rewrite (beq_nat_true _ _ Hbeq) in *.
      apply Ha.
      assumption.

      specialize (Hb (Pred Qm) (beq_nat_false _ _ Hbeq)).
      apply equal_f with (x := (Iv (Var xn))) in Hb.
      rewrite Hb in *.
      assumption.

    unfold alpha_downward_monotone_P.
    intros W Iv R Ip Ip' Ipext SOt.
    simpl in *.
    destruct Q as [Qm]; destruct P as [Pn];
    destruct x as [xn].
    unfold Ip_extends in Ipext.
    destruct Ipext as [Ha Hb].
    case_eq (beq_nat Pn Qm); intros Hbeq.
      rewrite (beq_nat_true _ _ Hbeq) in *.
      unfold P_is_neg_SO in H.
      simpl in H.
      destruct H as [H _].
      specialize (H HPocc 1).
      simpl in H.
      unfold occ_in_alpha in H.
      simpl in *.
      specialize (H (eq_refl _) (eq_refl _)); discriminate.

      unfold P_occurs_in_alpha in HPocc.
      simpl in *.
      rewrite Hbeq in *.
      discriminate.
Qed.

Lemma monotonicity_SO_relatSO : forall (P: predicate) (x y : FOvariable),
  P_occurs_in_alpha (relatSO x y) P = true ->
  (P_is_pos_SO (relatSO x y) P -> alpha_upward_monotone_P (relatSO x y) P) /\
  (P_is_neg_SO (relatSO x y) P -> alpha_downward_monotone_P (relatSO x y) P).
Proof.
  intros P  x y HPocc.
  unfold P_occurs_in_alpha in HPocc.
  destruct x; destruct y.
  simpl in *.
  discriminate.
Qed.

Lemma monotonicity_SO_eqFO : forall (P: predicate) (x y : FOvariable),
  P_occurs_in_alpha (eqFO x y) P = true ->
  (P_is_pos_SO (eqFO x y) P -> alpha_upward_monotone_P (eqFO x y) P) /\
  (P_is_neg_SO (eqFO x y) P -> alpha_downward_monotone_P (eqFO x y) P).
Proof.
  intros P  x y HPocc.
  unfold P_occurs_in_alpha in HPocc.
  destruct x; destruct y.
  simpl in *.
  discriminate.
Qed.

Lemma monotonicity_SO_allFO : forall (alpha : SecOrder) (P: predicate)
                                     (x : FOvariable),
  (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  P_occurs_in_alpha (allFO x alpha) P = true ->
    (P_is_pos_SO (allFO x alpha) P -> alpha_upward_monotone_P (allFO x alpha) P) /\
    (P_is_neg_SO (allFO x alpha) P -> alpha_downward_monotone_P (allFO x alpha) P).
Proof.
  intros alpha P x IHalpha HPocc.
  rewrite <- P_occurs_in_alpha_allFO with (x := x) in HPocc.
  specialize (IHalpha HPocc).
  apply conj; intros H.
    rewrite P_is_pos_SO_allFO in H.
    apply up_allFO; apply IHalpha;
      assumption.

    rewrite P_is_neg_SO_allFO in H.
    apply down_allFO; apply IHalpha;
      assumption.
Qed.

Lemma monotonicity_SO_exFO : forall (alpha : SecOrder) (P: predicate)
                                     (x : FOvariable),
  (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  P_occurs_in_alpha (exFO x alpha) P = true ->
    (P_is_pos_SO (exFO x alpha) P -> alpha_upward_monotone_P (exFO x alpha) P) /\
    (P_is_neg_SO (exFO x alpha) P -> alpha_downward_monotone_P (exFO x alpha) P).
Proof.
  intros alpha P x IHalpha HPocc.
  rewrite <- P_occurs_in_alpha_exFO with (x := x) in HPocc.
  specialize (IHalpha HPocc).
  apply conj; intros H.
    rewrite P_is_pos_SO_exFO in H.
    apply up_exFO; apply IHalpha;
      assumption.

    rewrite P_is_neg_SO_exFO in H.
    apply down_exFO; apply IHalpha;
      assumption.
Qed.

Lemma monotonicity_SO_negSO : forall (alpha : SecOrder) (P: predicate),
    (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
     P_occurs_in_alpha (negSO alpha) P = true ->
    ((P_is_pos_SO (negSO alpha) P -> alpha_upward_monotone_P (negSO alpha) P) /\
     (P_is_neg_SO (negSO alpha) P -> alpha_downward_monotone_P (negSO alpha) P)).
Proof.
  intros alpha P IHalpha Hpocc.
  rewrite <- P_occurs_in_alpha_negSO in Hpocc.
  specialize (IHalpha Hpocc).
  split; intros H.
    apply down_negSO.
    apply IHalpha.
    apply P_pos_negSO.
    assumption.

    apply up_negSO.
    apply IHalpha.
    apply P_neg_negSO.
    assumption.
Qed.

Lemma monotonicity_SO_conjSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (P_occurs_in_alpha alpha1 P = true ->
           (P_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (P_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (P_occurs_in_alpha alpha2 P = true ->
           (P_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (P_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  P_occurs_in_alpha (conjSO alpha1 alpha2) P = true ->
  (P_is_pos_SO (conjSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (conjSO alpha1 alpha2) P) /\
  (P_is_neg_SO (conjSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (conjSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  case_eq (P_occurs_in_alpha alpha1 P); intros Hpocc1.
      apply conj; intros H.
        apply up_conjSO12.
          apply P_is_pos_SO_conjSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_pos_SO_conjSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

        apply down_conjSO12.
          apply P_is_neg_SO_conjSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_neg_SO_conjSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
      apply conj; intros H.
        apply up_conjSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_pos_SO_conjSO_r in H;
          try apply IHalpha2; try assumption.

        apply down_conjSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_neg_SO_conjSO_r in H;
          try apply IHalpha2; try assumption.

      apply conj; intros H.
        apply up_conjSO12; apply up_not_occ_SO;
          assumption.

        apply down_conjSO12; apply up_not_occ_SO;
          assumption.
Qed.

Lemma monotonicity_SO_disjSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (P_occurs_in_alpha alpha1 P = true ->
           (P_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (P_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (P_occurs_in_alpha alpha2 P = true ->
           (P_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (P_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  P_occurs_in_alpha (disjSO alpha1 alpha2) P = true ->
  (P_is_pos_SO (disjSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (disjSO alpha1 alpha2) P) /\
  (P_is_neg_SO (disjSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (disjSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  case_eq (P_occurs_in_alpha alpha1 P); intros Hpocc1.
      apply conj; intros H.
        apply up_disjSO12.
          apply P_is_pos_SO_conjSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_pos_SO_conjSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

        apply down_disjSO12.
          apply P_is_neg_SO_conjSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_neg_SO_conjSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
      apply conj; intros H.
        apply up_disjSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_pos_SO_conjSO_r in H;
          try apply IHalpha2; try assumption.

        apply down_disjSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_neg_SO_conjSO_r in H;
          try apply IHalpha2; try assumption.

      apply conj; intros H.
        apply up_disjSO12; apply up_not_occ_SO;
          assumption.

        apply down_disjSO12; apply up_not_occ_SO;
          assumption.
Qed.

Lemma monotonicity_SO_implSO : forall (alpha1 alpha2 : SecOrder) (P: predicate),
  (P_occurs_in_alpha alpha1 P = true ->
           (P_is_pos_SO alpha1 P -> alpha_upward_monotone_P alpha1 P) /\
           (P_is_neg_SO alpha1 P -> alpha_downward_monotone_P alpha1 P)) ->
  (P_occurs_in_alpha alpha2 P = true ->
           (P_is_pos_SO alpha2 P -> alpha_upward_monotone_P alpha2 P) /\
           (P_is_neg_SO alpha2 P -> alpha_downward_monotone_P alpha2 P)) ->
  P_occurs_in_alpha (implSO alpha1 alpha2) P = true ->
  (P_is_pos_SO (implSO alpha1 alpha2) P ->
   alpha_upward_monotone_P (implSO alpha1 alpha2) P) /\
  (P_is_neg_SO (implSO alpha1 alpha2) P ->
   alpha_downward_monotone_P (implSO alpha1 alpha2) P).
Proof.
  intros alpha1 alpha2 P IHalpha1 IHalpha2 Hpocc.
  case_eq (P_occurs_in_alpha alpha1 P); intros Hpocc1.
      apply conj; intros H.
        apply up_implSO12.
          apply P_is_pos_SO_implSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_pos_SO_implSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

        apply down_implSO12.
          apply P_is_neg_SO_implSO_l in H;
            try apply IHalpha1; try assumption.
    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
          apply P_is_neg_SO_implSO_r in H;
            try apply IHalpha2; try assumption.

      apply up_not_occ_SO in Hpocc2.
      apply Hpocc2.

    case_eq (P_occurs_in_alpha alpha2 P); intros Hpocc2.
      apply conj; intros H.
        apply up_implSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_pos_SO_implSO_r in H;
          try apply IHalpha2; try assumption.

        apply down_implSO12.
          apply up_not_occ_SO in Hpocc1.
          apply Hpocc1.

          apply P_is_neg_SO_implSO_r in H;
          try apply IHalpha2; try assumption.

      apply conj; intros H.
        apply up_implSO12; apply up_not_occ_SO;
          assumption.

        apply down_implSO12; apply up_not_occ_SO;
          assumption.
Qed.

Lemma monotonicity_SO_allSO : forall (alpha : SecOrder) (P Q: predicate),
  (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  P_occurs_in_alpha (allSO Q alpha) P = true ->
  (P_is_pos_SO (allSO Q alpha) P -> alpha_upward_monotone_P (allSO Q alpha) P) /\
  (P_is_neg_SO (allSO Q alpha) P -> alpha_downward_monotone_P (allSO Q alpha) P).
Proof.
  intros alpha P Q IHalpha Hpocc.
  destruct P as [Pn]; destruct Q as [Qm].
  apply conj; intros H.
    apply up_allSO.
    case_eq (P_occurs_in_alpha alpha (Pred Pn)); intros Hpocc2.
      apply IHalpha; try assumption.
      apply P_is_pos_SO_allSO in H; assumption.

      apply up_not_occ_SO.
      assumption.

    apply down_allSO.
    case_eq (P_occurs_in_alpha alpha (Pred Pn)); intros Hpocc2.
      apply IHalpha; try assumption.
      apply P_is_neg_SO_allSO in H; assumption.

      apply up_not_occ_SO.
      assumption.
Qed.

Lemma monotonicity_SO_exSO : forall (alpha : SecOrder) (P Q: predicate),
  (P_occurs_in_alpha alpha P = true ->
          (P_is_pos_SO alpha P -> alpha_upward_monotone_P alpha P) /\
          (P_is_neg_SO alpha P -> alpha_downward_monotone_P alpha P)) ->
  P_occurs_in_alpha (allSO Q alpha) P = true ->
  (P_is_pos_SO (exSO Q alpha) P -> alpha_upward_monotone_P (exSO Q alpha) P) /\
  (P_is_neg_SO (exSO Q alpha) P -> alpha_downward_monotone_P (exSO Q alpha) P).
Proof.
  intros alpha P Q IHalpha Hpocc.
  destruct P as [Pn]; destruct Q as [Qm].
  apply conj; intros H.
    apply up_exSO.
    case_eq (P_occurs_in_alpha alpha (Pred Pn)); intros Hpocc2.
      apply IHalpha; try assumption.
      apply P_is_pos_SO_exSO in H; assumption.

      apply up_not_occ_SO.
      assumption.

    apply down_exSO.
    case_eq (P_occurs_in_alpha alpha (Pred Pn)); intros Hpocc2.
      apply IHalpha; try assumption.
      apply P_is_neg_SO_exSO in H; assumption.

      apply up_not_occ_SO.
      assumption.
Qed.

Lemma monotonicity_SO : forall (alpha : SecOrder) (P : predicate),
  P_occurs_in_alpha alpha P = true ->
    (P_is_pos_SO alpha P ->
      alpha_upward_monotone_P alpha P) /\
    (P_is_neg_SO alpha P ->
      alpha_downward_monotone_P alpha P).
Proof.
  intros alpha P.
  induction alpha.
    apply monotonicity_SO_predSO.
    apply monotonicity_SO_relatSO.
    apply monotonicity_SO_eqFO.
    apply monotonicity_SO_allFO; assumption.
    apply monotonicity_SO_exFO; assumption.
    apply monotonicity_SO_negSO; assumption.
    apply monotonicity_SO_conjSO; assumption.
    apply monotonicity_SO_disjSO; assumption.
    apply monotonicity_SO_implSO; assumption.
    apply monotonicity_SO_allSO; assumption.
    apply monotonicity_SO_exSO; assumption.
Qed.

(* ---------------------------------------------------------------------------- *)

Lemma Ip_ext_pa_f : forall (W : Set)
                    (Ip : predicate -> W -> Prop)
                    (P : predicate)
                    (pa : W -> Prop),
  Ip_extends W (alt_Ip Ip pa_f P) (alt_Ip Ip pa P) P.
Proof.
  intros W Ip P pa.
  unfold Ip_extends.
  apply conj.
    intros w H.
    unfold pa_f in *.
    destruct P.
    simpl in *.
    rewrite <- beq_nat_refl in *.
    contradiction.

    intros Q.
    destruct P as [Pn]; destruct Q as [Qm].
    intros H.
    unfold not in *.
    unfold pa_f.
    simpl.
    case_eq (beq_nat Pn Qm); intros Hbeq.
      specialize (H (beq_nat_true _ _ Hbeq)).
      contradiction.

      reflexivity.
Qed.


Require Import ssreflect.
Require Import Coq.Classes.EquivDec.
Require Import Metalib.Metatheory.

Require Import Coq.Structures.Orders.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Program.Equality.
Require Import Coq.Classes.RelationClasses.

Require Import dqtt_ott.
Require Import dqtt_inf.
Require Import usage.
Require Import dctx.
Require Import dctx_sub.
Require Import semimodule.
Require Import tactics.
Require Import structural.

Require Export beta.

(* Lemma 6.1 *)
Lemma Typing_regularity :
  forall {D G a B}, Typing D G a B -> exists G', Typing D G' B a_Type.
Proof.
  intros. induction H.
  all: try destruct IHTyping as [G' h].
  all: try destruct IHTyping1 as [G1' h1].
  all: try destruct IHTyping2 as [G2' h2].

  all: try solve [eexists; eauto].
  all: try solve [eexists; eapply T_weak; eauto].
  - pick fresh x for (L \u fv_tm_tm B \u dom D5).
    specialize (H x ltac:(auto)).
    specialize (H0 x ltac:(auto)).
    destruct H0 as [G0 h0].
    move: (Typing_ctx h0) => C0.
    destruct_ctx.
    eexists.
    eapply (T_pi_exists x); eauto.
    asimpl in h0.
    eapply h0.
  - apply invert_pi in h1.
    move: h1 => [_ [G1'' [G2'' [r [? [? hb]]]]]].
    pick fresh x for (dom D5 \u fv_tm_tm B).
    specialize (hb x ltac:(auto)).
    move: (substitution _ nil _ nil _ _ _ _ _ hb _ _ H0) => hs.
    asimpl in hs.
    erewrite <- subst_tm_tm_intro in hs; auto.
    eauto.
  - (* UnitE *)
    pick_fresh x.
    specialize (H2 x ltac:(auto)).
    have LC: lc_tm a. { eapply Typing_lc; eauto. }
    move: (fun x y => substitution x nil y nil) => s.
    eapply s in H. 2: { simpl_env. apply H2. }
    simpl_env in H.
    rewrite subst_tm_tm_open_tm_wrt_tm in H; auto.
    rewrite subst_tm_same in H; auto.
    simpl in H.
    rewrite subst_tm_tm_fresh_eq in H. fsetdec.
    eexists. eauto.
  - (* unbox *)
    pick_fresh x.
    specialize (H2 x ltac:(auto)).
    have LC: lc_tm a. { eapply Typing_lc; eauto. }
    move: (fun x y => substitution x nil y nil) => s.
    eapply s in H. 2: { simpl_env. apply H2. }
    simpl_env in H.
    rewrite subst_tm_tm_open_tm_wrt_tm in H; auto.
    rewrite subst_tm_same in H; auto.
    simpl in H.
    rewrite subst_tm_tm_fresh_eq in H. fsetdec.
    eexists. eauto.
  - (* inj1 *)
    eexists. eapply T_sum; eauto.
  - (* inj2 *)
    eexists. eapply T_sum; eauto.
  - (* case *)
    pick fresh x.
    repeat match goal with [H : forall x, x `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : forall y, y `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : exists G' , Typing _ _ _ _ |- _ ] => destruct H end.
    move: (fun y => substitution D5 nil y nil) => s.
    match goal with [H5 : Typing _ _ (open_tm_wrt_tm ?B _) a_Type |- _ ] =>
                    eapply s in H5; eauto; clear s;
                    asimpl in H5;
                    rewrite subst_tm_tm_open_tm_wrt_tm in H5; eauto using Typing_lc;
                    rewrite subst_tm_same in H5; auto;
                    rewrite subst_tm_tm_fresh_eq in H5; eauto
    end.
  - pick fresh x for (L \u fv_tm_tm B \u dom D5).
    specialize (H1 x ltac:(auto)).
    specialize (H2 x ltac:(auto)).
    destruct H2 as [G0 h0].
    move: (Typing_ctx h0) => C0.
    destruct_ctx.
    eexists.
    eapply (T_Sigma_exists x); eauto.
  - (* spread *)
    subst A.
    pick fresh x.
    repeat match goal with [H : forall x, x `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : forall y, y `notin` ?L -> _ |- _ ] => specialize (H x ltac:(auto)) end.
    repeat match goal with [H : exists G' , Typing _ _ _ _ |- _ ] => destruct H end.
    move: (fun y => substitution D5 nil y nil) => s.
    match goal with [H5 : Typing _ _ (open_tm_wrt_tm ?B _) a_Type |- _ ] =>
                    eapply s in H5; eauto; clear s;
                    asimpl in H5;
                    rewrite subst_tm_tm_open_tm_wrt_tm in H5; eauto using Typing_lc;
                    rewrite subst_tm_same in H5; auto;
                    rewrite subst_tm_tm_fresh_eq in H5; eauto
    end.
Qed.

Lemma invert_Lam D G q a A C :
  Typing D G (a_Lam q A a) C ->
     (forall x, x `notin` fv_tm_tm a `union` dom G `union` dom D ->
           exists B,  Beta C (a_Pi q A B) /\
           exists G1, Typing D G1 (a_Pi q A B) a_Type /\
           Typing
             (x ~ Tm A ++ D)
             ([(x, (q, Tm A))] ++ G) (open_tm_wrt_tm a (a_Var_f x))
                                     (open_tm_wrt_tm B (a_Var_f x))).
Proof.
  intros HA.
  dependent induction HA; intros y Fr.
  - have D: dom G1 = dom G2. eapply dom_ctx_sub; eauto.
    rewrite <- D in Fr.
    specialize (IHHA q a A ltac:(auto) y ltac:(auto)).
    move: IHHA => [B [HB [GA [hA HT]]]].
    exists B. split; auto.
    exists GA. split; auto.
    eapply T_sub. eauto. econstructor; eauto. reflexivity.
  - specialize (IHHA1 _ _ _  ltac:(auto) y ltac:(auto)).
    clear IHHA2.
    move: IHHA1 => [B0 [HB [GA [hA  HT]]]].
    exists B0. split. auto.
    exists (x ~ (0, Tm A0) ++ GA). split.
    eapply T_weak; eauto.
    eapply weakening. eauto. eclarify_ctx. solve_uniq. eauto.
  - (* lam *)
    clear IHHA. clear H0.
    exists B. split.
    + eapply B_Refl.
      pick fresh z.
      move: (Typing_regularity (H z ltac:(auto))) => [GG TB].
      eapply (lc_a_Pi_exists z);
      eapply Typing_lc; eauto.
    + pick fresh z.
      move: (H z ltac:(auto)) => h.
      move: (Typing_regularity h) => [G h1].
      move: (Typing_ctx h1) => C1.
      destruct_ctx.
      eexists. split.
      eapply (T_pi_exists z); eauto.
      eapply h1.
      move: (Typing_rename _ _ _ z y _ _ _ _ HA h ltac:(auto)) => rn.
      rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
      rewrite subst_tm_same in rn. auto.
      rewrite subst_tm_tm_fresh_eq in rn. fsetdec.
      rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
      rewrite subst_tm_same in rn. auto.
      rewrite subst_tm_tm_fresh_eq in rn. fsetdec.
      eapply rn.
  - (* conv *)
    specialize (IHHA1 _ _ _ ltac:(reflexivity) y Fr).
    destruct IHHA1 as [B0 [BB [G2' [T1 T2]]]]. clear IHHA2.
    exists B0.
    split. eapply B_Trans. eapply B_Sym. eauto. eauto.
    exists G2'. split. eauto.
    eauto.
Qed.

Lemma invert_Unit {D G A} :
  Typing D G a_TmUnit A ->
  exists G1, Beta A a_TyUnit /\ ctx_mul 0 G1 = G1 /\ ctx_sub D G1 G.
Proof.
  intros HA.
  dependent induction HA.
  - destruct IHHA as [G3 [h0 [ h1 h2]]]; auto.
    exists G3. subst. repeat split; auto. transitivity G1; auto.
  - destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto. clear IHHA2.
    exists (x ~ (0, Tm A) ++ G3). repeat split; auto. simpl.  ring_simpl. f_equal.  auto.
    econstructor; auto. reflexivity.
  - destruct IHHA1 as [G3 [h0 [h1 h2]]]; auto.
    exists G3. repeat split; auto.
    eapply B_Trans. eapply B_Sym. eauto. eauto.
  - exists nil. repeat split; auto.
Qed.

Lemma invert_box {D G q a A} :
 Typing D G (a_box q a) A ->
 exists A0,
   Beta A (a_Box q A0) /\
   exists G0, ctx_sub D (ctx_mul q G0) G /\ Typing D G0 a A0.
Proof.
  intros HA.
  dependent induction HA.
  + edestruct IHHA as [A0 [HB [G0 [SS TA]]]]. eauto.
    eexists. split. eauto.
    exists G0. split.
    transitivity G1; auto. auto.
  + clear IHHA2.
    specialize (IHHA1 q a ltac:(auto)).
    move: IHHA1 => [A0 [HB [G0 [SS TA]]]].
    eexists. split. eauto.
    exists (x ~ (0, Tm A) ++ G0). split.
    econstructor. auto. rewrite qmul_0_r. reflexivity.
    eauto. eauto.
    eapply T_weak. eauto. auto. eauto.
  + clear IHHA2.
    specialize (IHHA1 q a ltac:(auto)).
    move: IHHA1 => [A0 [HB [G0 [SS TA]]]].
    eexists.  split. eapply B_Trans. eapply B_Sym; eauto. eauto.
    eexists. split. eauto. auto.
  + clear IHHA.
    move: (Typing_regularity HA) => [GA TA].
    eexists.  split. eapply B_Refl. econstructor. eapply Typing_lc; eauto.
    exists G. split.
    eapply ctx_sub_refl. eclarify_ctx.
    auto.
Qed.

Lemma invert_Box {D G q A B} :
   Typing D G (a_Box q A) B ->
   Beta B a_Type /\ Typing D G A a_Type.
Proof.
  intros HA.
  dependent induction HA; intros.
  + specialize (IHHA _ _ ltac:(auto)). destruct IHHA.
    split. auto.
    eapply T_sub; eauto.
  + specialize (IHHA1 _ _ ltac:(auto)). destruct IHHA1.
    split. auto.
    eapply T_weak; eauto.
  + specialize (IHHA1 _ _ ltac:(auto)). destruct IHHA1.
    split. eapply B_Trans. eapply B_Sym. eauto. eauto. auto.
  + clear IHHA.
    split. eapply B_Refl. eauto. eauto.
Qed.

Lemma invert_inj1 :
       forall {D G a A}, Typing D G (a_Inj1 a) A ->
                    exists A1, exists A2, exists G1, Beta (a_Sum A1 A2) A /\
                                Typing D G a A1 /\ Typing D G1 A2 a_Type.
Proof. intros D G a A TA. dependent induction TA.
       - destruct (IHTA _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         exists A1. exists A2. eexists. split. auto. split.
         eapply T_sub; eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eauto. split.
         eapply T_weak; auto. eauto.
         eapply T_weak; auto. eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eapply B_Trans. eauto. eauto.
         split; eauto.
       - eexists. eexists. eexists.
         split. eapply B_Refl. econstructor. eapply Typing_lc2; eauto. eapply Typing_lc; eauto.
         split; eauto.
Qed.

Lemma invert_inj2 :
       forall {D G a A}, Typing D G (a_Inj2 a) A ->
                    exists A1, exists A2, exists G1, Beta (a_Sum A1 A2) A /\
                                Typing D G a A2 /\ Typing D G1 A1 a_Type.
Proof. intros D G a A TA. dependent induction TA.
       - destruct (IHTA _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         exists A1. exists A2. eexists. split. auto. split.
         eapply T_sub; eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eauto. split.
         eapply T_weak; auto. eauto.
         eapply T_weak; auto. eauto. eauto.
       - destruct (IHTA1 _ ltac:(auto)) as [A1 [A2 [G1' [BA [T1 T2]]]]].
         eexists. eexists. eexists.
         split. eapply B_Trans. eauto. eauto.
         split; eauto.
       - eexists. eexists. eexists.
         split. eapply B_Refl. econstructor. eapply Typing_lc; eauto. eapply Typing_lc2; eauto.
         split; eauto.
Qed.

Lemma invert_Sum : forall {D G A1 A2 B},
       Typing D G (a_Sum A1 A2) B ->
       Beta B a_Type /\
       exists G1, exists G2, ctx_sub D (ctx_plus G1 G2) G /\ Typing D G1 A1 a_Type /\ Typing D G2 A2 a_Type.
Proof.
       intros. dependent induction H.
       - destruct (IHTyping _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. auto. exists G1'. exists G2'.
         split. transitivity G1; auto.
         split; auto.
       - destruct (IHTyping1 _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. auto. exists (x ~ (0, Tm A) ++ G1'). exists (x ~ (0, Tm A) ++ G2').
         split. econstructor; eauto. ring_simpl; reflexivity.
         split. eapply T_weak; eauto.
                eapply T_weak; eauto.
       - destruct (IHTyping1 _ _ ltac:(auto)) as [Be [G1' [G2' [S [T1 T2]]]]].
         split. eapply B_Trans. eapply B_Sym. eauto. auto.
         exists G1'. exists G2'. split. eauto. split. eauto. eauto.
       - split. eapply B_Refl. auto.
         exists G1. exists G2. split. eapply ctx_sub_refl. eclarify_ctx.
         split; auto.
Qed.

Lemma invert_Tensor : forall {D G a1 a2 B},
       Typing D G (a_Tensor a1 a2) B ->
       exists A1, exists A2, exists q, Beta B (a_Sigma q A1 A2) /\
       exists G1, exists G2, exists G3, exists r,
             ctx_sub D (ctx_plus (ctx_mul q G1) G2) G
             /\ Typing D G1 a1 A1
             /\ Typing D G2 a2 (open_tm_wrt_tm A2 a1)
             /\ (forall x, x `notin` dom D ->
                    Typing (x ~ Tm A1 ++ D) (x ~ (r, Tm A1) ++ G3) (open_tm_wrt_tm A2 (a_Var_f x)) a_Type).
Proof.
  intros. dependent induction H.
  - destruct (IHTyping a1 a2 ltac:(auto)) as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. auto.
    exists G1'. exists G2'. exists G3. exists r.
    repeat split; auto. transitivity G1; auto.
  - destruct (IHTyping1 _ _ ltac:(auto))  as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. auto.
    exists (x ~ (0, Tm A) ++ G1'). exists (x ~ (0, Tm A) ++ G2'). exists (x ~ (0, Tm A) ++ G3). exists r.
    repeat split; auto. econstructor; eauto.  ring_simpl; reflexivity.
    eapply T_weak; eauto.
    eapply T_weak; eauto.
    intros. simpl in H2.
    move: (U x0 ltac:(auto)) => TB.
    eapply weakening; eauto.
    move: (Typing_ctx TB) => C. destruct_ctx.
    solve_ctx.
  - destruct (IHTyping1 _ _ ltac:(auto))  as [A1 [A2 [q [BA [G1' [G2' [G3 [r [SS [Ta1 [Ta2 U]]]]]]]]]]].
    exists A1. exists A2. exists q. split. eapply B_Trans. eapply B_Sym. eauto. auto.
    exists G1'. exists G2'. exists G3. exists r.
    repeat split; eauto.
  -  clear H2 IHTyping1 IHTyping2.
     move: (Typing_ctx H) => C1. move: (Typing_ctx H0) => C2.
     have LC: lc_tm (a_Sigma q A B). {
       pick fresh z.
       eapply lc_a_Sigma_exists. eapply Typing_lc2; eauto.
       eapply Typing_lc; eauto.
     }
     exists A. exists B. exists q. split. apply B_Refl; auto.
     exists G1. exists G2. exists G3. exists r.
     repeat split; eauto.
     eapply ctx_sub_refl. solve_ctx.
     pick fresh z.
     intros x Frx.
     move: (Typing_regularity H) => [GA TA].
     move: (H1 z ltac:(auto)) => h.
     move: (Typing_regularity h) => [G h1].
     move: (Typing_ctx h1) => C3.
     destruct_ctx.
     move: (Typing_rename _ _ _ z x _ _ _ _ TA h ltac:(auto)) => rn.
     rewrite subst_tm_tm_open_tm_wrt_tm in rn. auto.
     rewrite subst_tm_same in rn. auto.
     rewrite subst_tm_tm_fresh_eq in rn. fsetdec.
     asimpl in rn.
     eapply rn.
Qed.

(* Theorem 6.4 *)
Lemma preservation: forall D G a A, Typing D G a A -> forall a', Step a a' -> Typing D G a' A.
Proof.
  induction 1; intros a' St.
  all: try solve [inversion St].
  - (* sub *) eapply T_sub; eauto.
  - (* weak *) eapply T_weak; eauto.
  - (* app *)
    inversion St; subst.
    + eapply T_app. eauto. auto.
    + (* beta *)
      clear IHTyping1. clear IHTyping2.
      move: (Typing_regularity  H) => [GP TP].
      move: (Typing_regularity  H0) => [GA TA].
      move: (invert_pi _ _ _ _ _ _ TP) => [M [G1' [G2' [r [S1 [T1 U]]]]]].

      pick fresh x for (fv_tm_tm a0 `union` dom D5 `union` fv_tm_tm B \u dom G1).
      move: (U x ltac:(auto)) => UU.

      rewrite (subst_tm_tm_intro x a0). fsetdec.
      rewrite (subst_tm_tm_intro x B). fsetdec.

      eapply invert_Lam with (x:=x) in H. 2: fsetdec.
      move: H => [B0 [EQ [GA0 [TP0 Ta]]]].
      move: (invert_Beta_a_Pi0 EQ) => h0.
      move: (invert_Beta_a_Pi1 EQ) => h1.
      move: (invert_Beta_a_Pi2 EQ) => h2.
      move: (invert_pi _ _ _ _ _ _ TP0) => [? [G3 [G4 [r1 [h3 [h4 h5]]]]]].
      subst q.
      move: (Typing_ctx_fv x TP0 ltac:(auto)) => FV. asimpl in FV.
      have h00: Typing D5 G2 b A0. eapply T_conv; eauto.
      move: (substitution _ nil _ nil _ _ _ _ _ Ta _ _ h00) => SS.
      asimpl in SS.
      move: (Typing_regularity  SS) => [G0 TB0].
      move: (substitution _ nil _ nil _ _ _ _ _ UU _ _ H0) => SU. asimpl in SU.
      eapply T_conv. eauto. eauto.
      move: (h2 x ltac:(auto)) => BV.
      apply subst_Beta1. eapply Typing_lc; eauto.
      eapply B_Sym. auto.
 - (* beta *)
   eapply T_conv; eauto.
 - (* letunit *)
   inversion St; subst.
   + (* cong *)
     eapply T_conv.
     eapply T_UnitE; eauto.
     ++ pick fresh x.
       move: (H2 x ltac:(auto)) => h1.
       move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H) => SU. asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
       rewrite subst_tm_tm_fresh_eq in SU. eauto.
       rewrite subst_tm_same in SU. auto. eauto.
     ++ pick fresh x. rewrite (subst_tm_tm_intro x). eauto. rewrite (subst_tm_tm_intro x B a). eauto.
        eapply subst_Beta2.
        move: (H3 x ltac:(auto)) => h. eapply Typing_lc. eauto.
        eapply B_Sym.
        eapply B_Step.
        auto.
   + (* beta *)
     move: (invert_Unit H) => [G4 [h0 [h1 h2]]].
     eapply T_sub. eauto.
     rewrite (ctx_plus_comm _ D5); eclarify_ctx.
     eapply ctx_plus_sub; eclarify_ctx.
     auto.
 - (* let box *)
   inversion St; subst.
   + (* Cong *)
     clear H1 H3.
     eapply T_conv.
     ++ eapply T_letbox with (L := L).
        eapply IHTyping. auto.
        move=> x Fr.
        eapply H0. auto.
        move=> x Fr.
        eapply H2. auto.
     ++ pick fresh x.
        move: (H2 x ltac:(auto)) => TB.
        move: (substitution _ nil _ nil _ _ _ _ _ TB _ _ H) => SU. asimpl in SU.
        rewrite subst_tm_tm_open_tm_wrt_tm in SU.
        eapply Typing_lc; eauto.
        rewrite subst_tm_same in SU. auto.
        rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
        eauto.
     ++ pick fresh x.
        move: (H2 x ltac:(auto)) => TB.
        rewrite (subst_tm_tm_intro x). eauto.
        rewrite (subst_tm_tm_intro x B a). eauto.
        eapply subst_Beta2.
        eapply Typing_lc. eauto.
        eapply B_Sym.
        eapply B_Step.
        auto.
   + (* beta *)
     clear H3. clear H1.
     pick fresh x.
     move: (H0 x ltac:(auto)) => h1.
     move: (Typing_ctx h1) => CA. destruct_ctx.
     move: (invert_box H) => [A0 [BB [G [T1 T2]]]].
     move: (invert_Beta_Box1 BB) => BA.
     move: (invert_Beta_Box2 BB) => eq. subst q0.
     move: (Typing_regularity  H) => [GA TBA].
     move: (invert_Box TBA) => [h0 h2].
     have Ta0: (Typing D5 G a0 A). eapply T_conv. eapply T2. eauto. eapply B_Sym. eauto.
     move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ Ta0) => SU. asimpl in SU.
     rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
     rewrite subst_tm_same in SU. auto.
     rewrite subst_tm_tm_open_tm_wrt_tm in SU. eapply Typing_lc; eauto.
     simpl in SU. rewrite eq_dec_refl in SU.
     rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
     rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
     eapply T_sub. eauto.
     erewrite ctx_plus_comm; eclarify_ctx.
     eapply ctx_sub_ctx_plus. auto.
     eapply ctx_sub_refl. auto.
 - (* case *)
   inversion St; subst.
   + (* case cong *)
     have TBa : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }
     eapply T_conv.
     eapply T_case; auto.
     eauto.
     pick fresh x.
     rewrite (subst_tm_tm_intro x B a'0); auto.
     rewrite (subst_tm_tm_intro x B a); auto.
     eapply subst_Beta2.
     eapply Typing_lc. eauto.
     eapply B_Sym.
     eapply B_Step.
     auto.
   + (* case Beta1 *)
     match goal with [H0 : Typing ?D ?G  _ (a_Sum _ _) |- _ ] =>
        move: (invert_inj1 H0) => [A1' [A2' [G1' [Be [T1 T2]]]]];
        move: (Typing_regularity H0) => [Gr TS]
     end.
     move: (invert_Beta_Sum1 Be) => Be1.
     move: (invert_Sum TS) => [BB [G3' [G4' [S [Ta Tb]]]]].
     eapply Typing_e.
     eapply T_app. eauto.
     eapply T_conv; eauto.
     eapply ctx_plus_comm; eclarify_ctx.
     match goal with [H1 : forall x, x `notin` ?L -> (open_tm_wrt_tm B1 (a_Var_f x)) = _ |- _ ] =>
        pick fresh x;
        move: (H1 x ltac:(auto)) => E
     end.
     apply (cong (subst_tm_tm a0 x)) in E.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     simpl in E.  destruct (x == x) eqn:E1. rewrite E1 in E.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     done.
   + (* case Beta1 *)
     match goal with [H0 : Typing ?D ?G  _ (a_Sum _ _) |- _ ] =>
        move: (invert_inj2 H0) => [A1' [A2' [G1' [Be [T1 T2]]]]];
        move: (Typing_regularity H0) => [Gr TS]
     end.
     move: (invert_Beta_Sum2 Be) => Be1.
     move: (invert_Sum TS) => [BB [G3' [G4' [S [Ta Tb]]]]].
     eapply Typing_e.
     eapply T_app. eauto.
     eapply T_conv; eauto.
     eapply ctx_plus_comm; eclarify_ctx.
     match goal with [H1 : forall x, x `notin` ?L -> (open_tm_wrt_tm B2 (a_Var_f x)) = _ |- _ ] =>
        pick fresh x;
        move: (H1 x ltac:(auto)) => E
     end.
     apply (cong (subst_tm_tm a0 x)) in E.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     rewrite subst_tm_tm_open_tm_wrt_tm in E; eauto using Typing_lc.
     simpl in E.  destruct (x == x) eqn:E1. rewrite E1 in E.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     rewrite subst_tm_tm_fresh_eq in E; auto.
     done.
 - (* Spread *)
   inversion St; subst.
   + (* case cong *)
     have Ta0 : Typing D5 G1 a'0 (a_Sigma q A1 A2).
     { eapply IHTyping. eauto. }
     have TBa0 : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a'0) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a'0 _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }

     have TBa : Typing D5 (ctx_plus G3 (ctx_mul r G1)) (open_tm_wrt_tm B a) a_Type.
     {
       pick fresh x.
       match goal with [H5 : forall y, y `notin` L -> _ ,
                        H0  : Typing ?D ?G a _  |- _ ] =>
          move: (H5 x ltac:(auto)) => h1;
          move: (substitution _ nil _ nil _ _ _ _ _ h1 _ _ H0) => SU
       end.
       asimpl in SU.
       rewrite subst_tm_tm_open_tm_wrt_tm in SU.
       eapply Typing_lc; eauto.
       rewrite subst_tm_same in SU. auto.
       rewrite subst_tm_tm_fresh_eq in SU. fsetdec.
       eauto.
     }

     eapply T_conv with (A := open_tm_wrt_tm B a'0).
     eapply T_Spread; auto.
     eauto.
     pick fresh x.
     rewrite (subst_tm_tm_intro x B a); auto.
     rewrite (subst_tm_tm_intro x B a'0); auto.
     eapply subst_Beta2.
     eapply Typing_lc. eauto.
     eapply B_Sym.
     eapply B_Step.
     auto.

   + (* case beta *)
     move: (invert_Tensor H0) => [A1' [A2' [q1 [Be [G1' [G2' [G3' [r' ?]]]]]]]].
     move: (Typing_regularity H0) => [G' TS].
     move: (invert_Sigma _ _ _ _ _ _ TS) => [_ [G1'' [G2'' [r'' ?]]]].
     repeat match goal with [H : _ /\ _ |- _ ] => destruct H  end.
     move: (invert_Beta_a_Sigma1 Be) => Be1.
     move: (invert_Beta_a_Sigma2 Be) => Be2.
     move: (invert_Beta_a_Sigma0 Be) => Be3.
     subst.

     pick fresh x. pick fresh y.
     specialize (H1 x ltac:(auto) y ltac:(auto)). move: H1 => Tb.
     move: (Typing_ctx Tb) => C1.

     eapply substitution with (D2 := nil) (G2 := nil) (a := a0) in Tb.
     2: { eapply T_conv. eauto. eauto. eapply B_Sym. eauto. }
     asimpl in Tb.
     erewrite subst_tm_tm_open_tm_wrt_tm in Tb; eauto using Typing_lc.
     erewrite subst_tm_tm_close_tm_wrt_tm in Tb; eauto using Typing_lc.
     erewrite (subst_tm_tm_open_tm_wrt_tm B) in Tb; eauto using Typing_lc.
     simpl in Tb. destruct (x == x) eqn:E; rewrite E in Tb. 2: { done. } clear E e.
     destruct (y == x) eqn:E. { subst. clear Fr. solve_notin. }
     rewrite E in Tb. clear E n.
     rewrite subst_tm_tm_fresh_eq in Tb. { clear Fr0. fsetdec. }
     eapply Typing_e.
     eapply T_sub.
     3: { eauto. }
     eapply T_app.
     ++ eapply Tb.
     ++ eapply T_conv. eauto.
        replace a_Type with (subst_tm_tm a0 x a_Type).
        eapply substitution with (D2 := nil) (G2 := nil) (a := a0). simpl_env.
        eapply H6. { clear Fr0. fsetdec. } eapply T_conv. eauto. eauto. eapply B_Sym. auto. reflexivity.
        rewrite (subst_tm_tm_intro x). { clear Fr0. fsetdec. }
        eapply subst_Beta1; eauto using Typing_lc.
     ++ destruct_ctx.
        simpl_env; eclarify_ctx.
        erewrite (ctx_plus_assoc _ _ G2); eclarify_ctx.
        erewrite ctx_plus_comm; eclarify_ctx.
        eapply ctx_sub_ctx_plus; eclarify_ctx.
        eapply ctx_sub_refl; eclarify_ctx.
     ++ rewrite subst_tm_tm_fresh_eq. { clear Fr0. fsetdec. }
        rewrite <- subst_tm_tm_spec.
        rewrite subst_tm_tm_open_tm_wrt_tm. eauto using Typing_lc.
        rewrite subst_tm_tm_fresh_eq. { clear Fr. fsetdec. }
        f_equal.
        simpl.
        destruct (y == y) eqn:E. 2: { done. } rewrite E.
        rewrite subst_tm_tm_fresh_eq. { clear Fr. fsetdec. }
        auto.
Qed.

Ltac invert_value :=
  match goal with [ H : value ?a|- _ ]=> inversion H end;
  try match goal with [ H : ty ?a |- _ ] => inversion H end.

Ltac inconsistent :=
  match goal with [ H : Beta ?a ?b |- _ ] =>
     apply Beta_consistent in H; eauto; inversion H
  end.

Lemma canonical_Type : forall a A, Typing nil nil a A -> Beta a a_Type -> value a -> ty a.
Proof.
  intros a A h.
  dependent induction h; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H. subst. auto.
Qed.

Lemma canonical_Pi : forall a A q B1 B2, Typing nil nil a A -> Beta A (a_Pi q B1 B2) -> value a -> exists q1 a1 A1, a = a_Lam q1 A1 a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0; subst; eauto.
Qed.

Lemma canonical_Sigma : forall a A q B1 B2, Typing nil nil a A -> Beta A (a_Sigma q B1 B2) -> value a ->
                                       exists a1 b1, a = a_Tensor a1 b1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

Lemma canonical_Unit : forall a A, Typing nil nil a A -> Beta A a_TyUnit -> value a -> a = a_TmUnit.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

Lemma canonical_Box : forall a A q B, Typing nil nil a A -> Beta A (a_Box q B) -> value a -> exists a1, a = a_box q a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. destruct IHTyping; auto. eauto.
  - move: (invert_Beta_Box2 H0) => h0. subst. eauto.
Qed.

Lemma canonical_Sum : forall a A B1 B2, Typing nil nil a A -> Beta A (a_Sum B1 B2) -> value a -> exists a1, a = a_Inj1 a1 \/ a = a_Inj2 a1.
Proof.
  intros. dependent induction H; intros; try solve [inconsistent]; try solve [invert_value]; eauto.
  - inversion H0. subst. auto.
Qed.

(* Theorem 6.5 *)
Lemma progress : forall a A,
  Typing nil nil a A -> value a \/ exists a', Step a a'.
Proof.
  intros a A H. dependent induction H; eauto.
  - inversion H0. subst. eauto.
  - move: (Typing_ctx H) => C. move: (Typing_ctx H0) => C0. destruct_ctx.
    destruct IHTyping1; auto.
    + (* fun is a value *)
      have LC: lc_tm a. eapply Typing_lc; eauto.
      eapply canonical_Pi in H; auto. 2: { eapply B_Refl; eauto using Typing_lc2.  }
      destruct H as [q1 [A1 [a1' E]]]; auto. subst.
      inversion LC. subst.
      right. eexists.
      eapply S_Beta; eauto using Typing_lc.
    + (* fun steps *)
      destruct H1 as [a' SS].
      right. eexists. eauto using Typing_lc.
  - move: (Typing_ctx H) => C. move: (Typing_ctx H1) => C0. destruct_ctx.
    destruct IHTyping1; auto.
    + eapply canonical_Unit in H; auto. subst.
      right. eexists.
      eapply S_UnitBeta; eauto using Typing_lc.
    + destruct H0 as [a' SS].
      right. eexists.
      eapply S_UnitCong; eauto using Typing_lc.
  - move: (Typing_ctx H) => C. destruct_ctx.
    destruct IHTyping; auto.
    + have LC: lc_tm a. eauto using Typing_lc.
      pick fresh y.
      repeat match goal with [H : forall x, x `notin` ?L -> Typing _ _ _ _ |- _ ] => specialize (H y ltac:(auto)) end.
      move: (canonical_Box _ _ q A H) => h.
      destruct h as [a1 E]; auto.
      eapply B_Refl; eauto using Typing_lc2.
      subst.
      right. eexists.
      inversion LC.
      eapply S_BoxBeta; eauto using Typing_lc.
      eapply (lc_a_LetBoxB_exists y); eauto using Typing_lc.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc, Typing_lc2.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc2, Typing_lc2.
      eauto using Typing_lc.
    + destruct H4 as [a1 E]; auto.
      right. eexists.
      pick fresh y.
      eapply S_BoxCong; eauto using Typing_lc.
      eapply (lc_a_LetBoxB_exists y); eauto using Typing_lc.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc, Typing_lc2.
      eapply (lc_a_Lam_exists y); eauto using Typing_lc2, Typing_lc2.
      eauto using Typing_lc.
  - move: (Typing_ctx H0) => C. destruct_ctx.
    have LC: lc_tm a. eapply Typing_lc; eauto.
    have LC2: lc_tm (a_Sum A1 A2). eapply Typing_lc2; eauto.
    destruct IHTyping1; auto.
    + eapply canonical_Sum in H0; auto.
      destruct H0 as [a0 [V1 | V2]]; subst.
      ++ right.
         eexists.
         inversion LC.
         eapply S_Case1Beta; eauto using Typing_lc.
      ++ right.
         eexists.
         inversion LC.
         eapply S_Case2Beta; eauto using Typing_lc.
    + destruct H7 as [a' SS].
      right. eexists.
      eapply S_CaseCong; eauto using Typing_lc.
  - right.
    move: (Typing_ctx H0) => C. destruct_ctx.
    have L1: lc_tm a by eauto using Typing_lc.
    have L2: lc_tm (a_Sigma q A1 A2) by eauto using Typing_lc2.
    have L4: lc_tm (a_Lam r (a_Sigma q A1 A2) B).
    { pick fresh y.
      move: (H3 y ltac:(auto)) => h.
      move: (Typing_lc h) => LB.
      eapply lc_a_Lam_exists. auto. eauto.
    }
    have L3: lc_tm (a_Spread a b (a_Lam r (a_Sigma q A1 A2) B)).
    {
      pick fresh y. pick fresh z.
      move: (H1 y ltac:(auto) z ltac:(auto)) => Tb.
      move: (Typing_lc Tb) => LB.
      eapply lc_a_Spread_exists; eauto.
    }
    destruct IHTyping; eauto.
    + have BB: Beta (a_Sigma q A1 A2) (a_Sigma q A1 A2).
      { eapply B_Refl; eauto. }
      move: (canonical_Sigma a _ q A1 A2 H0 BB H) => h.
      move: h => [a1 [b1 EQ]]. subst a.
      inversion L1. subst.
      eexists.
      eapply S_SpreadBeta; eauto using Typing_lc.
    + move: H => [a' SS].
      eexists.
      eapply S_SpreadCong; eauto.
Qed.


(** * DSL benchmark: Gates *)

Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.PrimeFieldTheorems Crypto.Algebra.Field.
Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.

From Circom Require Import Circom Util Default Tuple LibTactics Simplify Repr.
From Circom.CircomLib Require Import Bitify.

Local Coercion N.of_nat : nat >-> N.
Local Coercion Z.of_nat : nat >-> Z.

Local Open Scope F_scope.

Definition f_and (x: F) (y: F) := x = 1%F /\ y = 1%F.
Definition f_or (x: F) (y: F) := x = 1%F \/ y = 1%F.
Definition f_not (x: F) := x = 0%F.
Definition f_nand (x: F) (y: F) := ~(x = 1%F /\ y = 1%F).
Definition f_nor (x: F) (y: F) := ~(x = 1%F \/ y = 1%F).
Definition f_xor (x: F) (y: F) := x <> y.

(** ** NOT *)

(* print_endline (generate_lemmas cnot (typecheck_circuit d_empty cnot));; *)

Lemma Not_obligation0: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = _in)) -> True).
Proof. intuition. Qed.

Lemma Not_obligation1: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = 1%F) -> True).
Proof. intuition. Qed.

Lemma Not_obligation2: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = (_in + 1%F)%F) -> True).
Proof. intuition. Qed.

Lemma Not_obligation3: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = 2%F) -> True).
Proof. Admitted.

Lemma Not_obligation4: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = _in)) -> True).
Proof. intuition. Qed.

Lemma Not_obligation5: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = (2%F * _in)%F) -> True).
Proof. Admitted.

Lemma Not_obligation6: forall (_in : F) (v : F), ((_in = 0%F) \/ (_in = 1%F)) -> True -> ((v = ((_in + 1%F)%F - (2%F * _in)%F)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_not _in)) /\ ((v = 0%F) -> ~(f_not _in))))).
Proof. Admitted.

(** ** XOR *)

(* print_endline (generate_lemmas cxor (typecheck_circuit d_empty cxor));; *)

Lemma Xor_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a + b)%F) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation3: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = 2%F) -> True).
Proof. Admitted.

Lemma Xor_obligation4: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation5: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation6: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> True).
Proof. intuition. Qed.

Lemma Xor_obligation7: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (2%F * (a * b)%F)%F) -> True).
Proof. Admitted.

Lemma Xor_obligation8: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = ((a + b)%F - (2%F * (a * b)%F)%F)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_xor a b)) /\ ((v = 0%F) -> ~(f_xor a b))))).
Proof. Admitted.

(** ** AND *)

(* print_endline (generate_lemmas cand (typecheck_circuit d_empty cand));; *)

Lemma And_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma And_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma And_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_and a b)) /\ ((v = 0%F) -> ~(f_and a b))))).
Proof.
  unwrap_C. unfold f_and. intros.
  intuit; try fqsatz.
  - left; fqsatz.
  - left; fqsatz.
  - left; fqsatz.
  - right; fqsatz.
Qed.

(** ** NAND *)

(* print_endline (generate_lemmas cnand (typecheck_circuit d_empty cnand));; *)

Lemma Nand_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = 1%F) -> True).
Proof. intuition. Qed.

Lemma Nand_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Nand_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Nand_obligation3: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> True).
Proof. intuition. Qed.

Lemma Nand_obligation4: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (1%F - (a * b)%F)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_nand a b)) /\ ((v = 0%F) -> ~(f_nand a b))))).
Proof.
  unwrap_C. unfold f_nand. intros.
  intuit; try fqsatz.
  - right; fqsatz.
  - right; fqsatz.
  - right; fqsatz.
  - left; fqsatz.
Qed.

(** ** OR *)

(* print_endline (generate_lemmas cor (typecheck_circuit d_empty cor));; *)

Lemma Or_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Or_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Or_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a + b)%F) -> True).
Proof. intuition. Qed.

Lemma Or_obligation3: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Or_obligation4: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Or_obligation5: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> True).
Proof. intuition. Qed.

Lemma Or_obligation6: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = ((a + b)%F - (a * b)%F)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_or a b)) /\ ((v = 0%F) -> ~(f_or a b))))).
Proof.
  unwrap_C. unfold f_or. intros.
  intuit; try fqsatz.
  - left; fqsatz.
  - right; fqsatz.
  - right; fqsatz.
  - right; fqsatz.
Qed.

(** ** NOR *)

(* print_endline (generate_lemmas cnor (typecheck_circuit d_empty cnor));; *)

Lemma Nor_obligation0: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation1: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation2: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (a * b)%F) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation3: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = 1%F) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation4: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = ((a * b)%F + 1%F)%F) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation5: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = a)) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation6: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = (((a * b)%F + 1%F)%F - a)%F) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation7: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((((v = 0%F) \/ (v = 1%F)) /\ (v = b)) -> True).
Proof. intuition. Qed.

Lemma Nor_obligation8: forall (a : F) (b : F) (v : F), ((a = 0%F) \/ (a = 1%F)) -> ((b = 0%F) \/ (b = 1%F)) -> True -> ((v = ((((a * b)%F + 1%F)%F - a)%F - b)%F) -> (((v = 0%F) \/ (v = 1%F)) /\ (((v = 1%F) -> (f_nor a b)) /\ ((v = 0%F) -> ~(f_nor a b))))).
Proof.
  unwrap_C. unfold f_nor. intros.
  intuit; try fqsatz.
  - right; fqsatz.
  - left; fqsatz.
  - left; fqsatz.
  - left; fqsatz.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* File created for Coq V5.10.14b, Oct 1995, by duplication of
   Classical_Pred_Type.v *)

(** This file is obsolete, use Classical_Pred_Type.v via Classical.v
instead *)

(** Classical Predicate Logic on Set*)

Require Import Classical_Pred_Type.

Section Generic.
Variable U : Set.

(** de Morgan laws for quantifiers *)

Lemma not_all_ex_not :
 forall P:U -> Prop, ~ (forall n:U, P n) ->  exists n : U, ~ P n.
Proof (Classical_Pred_Type.not_all_ex_not U).

Lemma not_all_not_ex :
 forall P:U -> Prop, ~ (forall n:U, ~ P n) ->  exists n : U, P n.
Proof (Classical_Pred_Type.not_all_not_ex U).

Lemma not_ex_all_not :
 forall P:U -> Prop, ~ (exists n : U, P n) -> forall n:U, ~ P n.
Proof (Classical_Pred_Type.not_ex_all_not U).

Lemma not_ex_not_all :
 forall P:U -> Prop, ~ (exists n : U, ~ P n) -> forall n:U, P n.
Proof (Classical_Pred_Type.not_ex_not_all U).

Lemma ex_not_not_all :
 forall P:U -> Prop, (exists n : U, ~ P n) -> ~ (forall n:U, P n).
Proof (Classical_Pred_Type.ex_not_not_all U).

Lemma all_not_not_ex :
 forall P:U -> Prop, (forall n:U, ~ P n) -> ~ (exists n : U, P n).
Proof (Classical_Pred_Type.all_not_not_ex U).

End Generic.


Require Export CatSem.CAT.cat_TYPE_option.
Require Export CatSem.CAT.rmonad.
Require Export CatSem.CAT.rmodule_TYPE.
Require Export CatSem.ULC.ULC_semantics.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Automatic Introduction.

Obligation Tactic := fin.

Program Instance ULCBETA_s : RMonad_struct (SM_po) ULCBETA := {
   rweta := VAR;
   rkleisli a b f := SUBST f
}.
Next Obligation.
Proof.
  unfold Proper;
  red;
  fin.
Qed.

Definition ULCBETA : RMonad (SM_po) := Build_RMonad ULCBETA_s.

Lemma rename_lift V (v : ULC V) W (f : V ---> W) :
       v //- f = rlift ULCBETA f v.
Proof.
  unfold lift;
  fin.
Qed.

Section app_po.

Obligation Tactic := idtac.

Program Instance app_po_mors c : PO_mor_struct
  (a := PO_product (ULCBETA c )  (ULCBETA c))
  (b := ULCBETA c)
  (fun z => App (fst z) (snd z)).
Next Obligation.
Proof.
  intros c.
  unfold Proper;
  red.
  intros x y H.
  destruct H.
  simpl in *.
  transitivity (App v' w).
    apply cp_App1; auto.
    apply cp_App2; auto.
Qed.

Definition app_po_mor c := Build_PO_mor (app_po_mors c).

Obligation Tactic := fin.

Program Instance ulc_app_s  : RModule_Hom_struct
  (M:=product (C:=RMOD _ Ord) ULCBETA ULCBETA)
  (N:=ULCBETA) (app_po_mor).

Definition ulc_app := Build_RModule_Hom ulc_app_s.

End app_po.

Section abs_po.

Obligation Tactic := unfold Proper; red;
        simpl; intros; apply cp_Abs; auto.

Program Instance abs_po_mors c : PO_mor_struct
  (a := (ULCBETA (option c)))
  (b := (ULCBETA c)) (@Abs _ ).

Definition abs_po_mor c := Build_PO_mor (abs_po_mors c).

Obligation Tactic := idtac.

Program Instance ulc_abs_s : RModule_Hom_struct
 (M:= DER_RMOD_not _ _  ULCBETA)
 (N:=ULCBETA) abs_po_mor.
Next Obligation.
Proof.
  fin.
  apply f_equal.
  apply subst_eq.
  intros.
  match goal with [H:option _ |- _ ]=> destruct H end;
  simpl; fin.
Qed.

Definition ulc_abs := Build_RModule_Hom ulc_abs_s.

End abs_po.


From Coq Require Import String.

From Coq Require Import ssreflect ssrfun ssrbool. (* <- needed for mlAssert *)
From stdpp Require Import list. (* <- needed for mlRevertLast *)
From MatchingLogic Require Import
    Logic
    DerivedOperators_Syntax
    ProofSystem
    ProofMode.MLPM
.

Import
  MatchingLogic.Logic.Notations
  MatchingLogic.DerivedOperators_Syntax.Notations
.

Open Scope string_scope.
Open Scope list_scope.
Open Scope ml_scope.

From Coq Require Import ssreflect ssrfun ssrbool.

Open Scope string_scope.
Open Scope list_scope.
Open Scope ml_scope.

Local Lemma Private_revert_forall_iter {Σ : Signature} (Γ : Theory) :
  forall (l : list Pattern) (ϕ : Pattern) x,
  Pattern.wf l ->
  well_formed ϕ ->
  Γ ⊢i foldr patt_imp (all , ϕ^{{evar: x ↦ 0}}) l ---> foldr patt_imp ϕ l
    using BasicReasoning.
Proof.
  intros l ϕ x Wfl Wfϕ. apply prf_weaken_conclusion_iter_meta. 1-3: wf_auto2.
  mlIntro "H".
  mlSpecialize "H" with x.
  rewrite evar_open_evar_quantify. wf_auto2.
  mlAssumption.
Qed.

Section compute.
  From MatchingLogic.Theories Require Import Definedness_Syntax
                                             Definedness_Semantics
                                             Sorts_Syntax
                                             Sorts_Semantics
                                             Definedness_ProofSystem.
  From stdpp Require Import base fin_sets sets propset finite.

  Inductive Symbols :=
    | sym_import_definedness (d : Definedness_Syntax.Symbols)
    | Zero | Succ (* constructors for Nats *)
    | TT | FF
    | even
  .

  Instance Symbols_eqdec : EqDecision Symbols.
  Proof. solve_decision. Defined.

  #[local]
  Program Instance Symbols_fin : Finite Symbols :=
  {|
    enum := [Zero; Succ; TT ; FF; even;
      sym_import_definedness Definedness_Syntax.definedness] ;
  |}.
  Next Obligation.
    repeat constructor; set_solver.
  Qed.
  Next Obligation.
    destruct x; try set_solver.
    destruct d; set_solver.
  Qed.

  Instance signature : Signature :=
    {| variables := StringMLVariables ;
       ml_symbols := {|
          symbols := Symbols ;
        |}
    |}.

  Instance definedness_syntax : Definedness_Syntax.Syntax :=
    {|
       Definedness_Syntax.inj := sym_import_definedness;
    |}.

  Open Scope string_scope.
  Let X0 := patt_free_evar "X0".
  Let X := patt_free_evar "X".
  Let sym_even := patt_sym even.
  Let sym_succ := patt_sym Succ.
  Let sym_zero := patt_sym Zero.
  Let sym_tt := patt_sym TT.
  Let sym_ff := patt_sym FF.
  (* axioms *)
  Definition defined : Pattern := Definedness_Syntax.axiom AxDefinedness.

  Definition A : Pattern :=
    sym_zero.
  Definition B : Pattern :=
    patt_app sym_succ sym_zero.

Definition private_test_revert_1 :=
  (Private_revert_forall_iter ∅ [] patt_bott (fresh_evar patt_bott)
    ltac:(wf_auto2) ltac:(wf_auto2)).
Definition private_test_revert_2 :=
  (revert_forall_iter ∅ [] patt_bott (fresh_evar patt_bott)
    ltac:(wf_auto2) ltac:(wf_auto2)).
Definition private_test_revert_3 :=
  (Private_revert_forall_iter ∅ [A;B;A;B;A;B] patt_bott (fresh_evar patt_bott)
    ltac:(wf_auto2) ltac:(wf_auto2)).
Definition private_test_revert_4 :=
  (revert_forall_iter ∅ [A;B;A;B;A;B] patt_bott (fresh_evar patt_bott)
    ltac:(wf_auto2) ltac:(wf_auto2)).

    (*
  Compute proof_size_info (ex1_low ∅ A B ltac:(wf_auto2) ltac:(wf_auto2)).
  Compute proof_size_info (ex1_pm ∅ A B ltac:(wf_auto2) ltac:(wf_auto2)). *)

End compute.


From trillium.traces Require Export trace infinite_trace.
From trillium.program_logic Require Import language.

Import InfListNotations.

Definition execution_trace Λ := finite_trace (cfg Λ) (option (locale Λ)).

Record Model : Type := MkModel {
  mstate:> Type;
  mlabel: Type;
  mtrans: mstate -> mlabel -> mstate -> Prop;
}.

Arguments mtrans {_} _ _ _.

Notation olocale Λ := (option (locale Λ)).

Notation auxiliary_trace m := (finite_trace m.(mstate) m.(mlabel)).

Section execution_trace.
  Context {Λ : language}.

  Implicit Types c : cfg Λ.

  Definition valid_exec (ex : execution_trace Λ) : Prop := trace_steps locale_step ex.

  Lemma valid_singleton_exec c : valid_exec (trace_singleton c).
  Proof. constructor. Qed.

  Lemma extend_valid_exec ex c ζ c':
    valid_exec ex →
    trace_ends_in ex c →
    locale_step c ζ c' →
    valid_exec (ex :tr[ζ]: c').
  Proof. econstructor; done. Qed.

  Lemma valid_exec_exec_extend_inv ex ζ c':
    valid_exec (trace_extend ex ζ c') →
    valid_exec ex ∧
    ∃ c, trace_ends_in ex c ∧ locale_step c ζ c'.
  Proof. apply trace_steps_step_inv. Qed.

End execution_trace.

Section system_trace.
  Context {Λ : language} {M : Model}.

  Implicit Types ex : execution_trace Λ.
  Implicit Types atr : auxiliary_trace M.
  Implicit Types ζ : olocale Λ.
  Implicit Types ℓ : mlabel M.

  Inductive valid_system_trace : execution_trace Λ → auxiliary_trace M → Prop :=
  | valid_system_trace_singleton c δ :
      valid_system_trace (trace_singleton c) (trace_singleton δ)
  | valid_system_trace_step ex atr c c' δ' ζ ℓ:
      trace_ends_in ex c →
      locale_step c ζ c' →
      valid_system_trace ex atr →
      valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ').

  Lemma valid_system_trace_valid_exec_trace ex atr :
    valid_system_trace ex atr → valid_exec ex.
  Proof. induction 1; econstructor; eauto. Qed.

  Lemma valid_system_trace_singletons c δ :
    valid_system_trace (trace_singleton c) (trace_singleton δ).
  Proof. constructor. Qed.

  Lemma valid_system_trace_extend ex atr c c' δ' ζ ℓ:
    valid_system_trace ex atr →
    trace_ends_in ex c →
    locale_step c ζ c' →
    valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ').
  Proof.
    intros Heatr; revert c c' δ' ζ ℓ.
    induction ex; econstructor; eauto.
  Qed.

  Lemma valid_system_trace_extend_inv ex atr c' δ' ζ ℓ:
    valid_system_trace (trace_extend ex ζ c') (trace_extend atr ℓ δ') →
    ∃ c,
      valid_system_trace ex atr ∧
      trace_ends_in ex c ∧
      locale_step c ζ c'.
  Proof. inversion 1; eauto. Qed.

  Lemma valid_system_trace_ends_in ex atr :
    valid_system_trace ex atr → ∃ c δ, trace_ends_in ex c ∧ trace_ends_in atr δ.
  Proof.
    inversion 1;
      eauto using trace_extend_ends_in, trace_singleton_ends_in,
      trace_extend_ends_in, trace_singleton_ends_in.
  Qed.

  Lemma trace_steps2_trace_steps (R : M -> mlabel M -> M -> Prop) :
    (∀ ex atr c δ c' δ' ζ ℓ,
        trace_ends_in ex c →
        trace_ends_in atr δ →
        locale_step c ζ c' →
        R δ ℓ δ') →
    ∀ ex atr, valid_system_trace ex atr → valid_exec ex ∧ trace_steps R atr.
  Proof.
    intros HR ex ex' Hexs.
    induction Hexs as [|?????????? []].
    - split; constructor.
    - split; econstructor; [done|done|done|done|eapply HR=>//|done].
  Qed.

End system_trace.

Section simulation.
  Context {Λ : language} {M : Model}.
  Variable (labels_match : olocale Λ → mlabel M → Prop).

  Implicit Types ex : execution_trace Λ.
  Implicit Types atr : auxiliary_trace M.

  Definition continued_simulation_pre
             (φ : execution_trace Λ → auxiliary_trace M → Prop)
             (continued_simulation :
                execution_trace Λ → auxiliary_trace M → Prop) :
    execution_trace Λ → auxiliary_trace M → Prop :=
    λ ex atr,
      φ ex atr ∧
      ∀ c c' ζ,
        trace_ends_in ex c →
        locale_step c ζ c' →
        ∃ δ' ℓ, continued_simulation (trace_extend ex ζ c') (trace_extend atr ℓ δ').

  Local Definition continued_simulation_pre_curried
        (φ : execution_trace Λ → auxiliary_trace M → Prop) :
    (execution_trace Λ * auxiliary_trace M → Prop) →
    (execution_trace Λ * auxiliary_trace M → Prop) :=
    λ ψ (exatr : execution_trace Λ * auxiliary_trace M),
    (continued_simulation_pre φ (λ ex atr, ψ (ex, atr)) exatr.1 exatr.2).

  Lemma continued_simulation_pre_curried_mono
        (φ : execution_trace Λ → auxiliary_trace M → Prop) :
    monotone (continued_simulation_pre_curried φ).
  Proof.
    intros P Q HPQ [ex atr].
    intros [? HP]. split; [done|].
    intros ?????.
    edestruct HP as (?&?&?); eauto.
  Qed.

  Definition continued_simulation (φ : execution_trace Λ → auxiliary_trace M → Prop) :=
    λ ex atr, GFX (continued_simulation_pre_curried φ) (ex, atr).

  Lemma continued_simulation_unfold
        (φ : execution_trace Λ → auxiliary_trace M → Prop) ex atr :
    continued_simulation φ ex atr ↔
    continued_simulation_pre φ (continued_simulation φ) ex atr.
  Proof.
    symmetry; rewrite /continued_simulation /=.
    apply (λ H, GFX_fixpoint (continued_simulation_pre_curried φ) H (_, _)).
    apply continued_simulation_pre_curried_mono.
  Qed.

  Lemma continued_simulation_rel Φ ex tr:
    continued_simulation Φ ex tr → Φ ex tr.
  Proof.
    rewrite continued_simulation_unfold /continued_simulation_pre; intuition.
  Qed.

  Lemma continued_simulation_next_aux_state_exists
             (φ : execution_trace Λ → auxiliary_trace M → Prop)
             (ex : execution_trace Λ) (atr : auxiliary_trace M)
             (c : cfg Λ) ζ:
    continued_simulation φ ex atr →
    valid_exec (trace_extend ex ζ c) →
    ∃ δℓ, continued_simulation φ (trace_extend ex ζ c) (trace_extend atr δℓ.2 δℓ.1).
  Proof.
    rewrite continued_simulation_unfold /continued_simulation_pre.
    intros (HΦ & Hext) Hvex.
    apply valid_exec_exec_extend_inv in Hvex as [Hvex (c1 & Hc1 & Hstep)].
    edestruct Hext as (?&?&?); [done..|].
    by eexists (_,_).
  Qed.

  Lemma simulation_does_continue e σ δ φ :
    continued_simulation φ (trace_singleton ([e], σ)) (trace_singleton δ) →
    ∀ ex, trace_starts_in ex ([e], σ) →
          valid_exec ex →
          ∃ atr, trace_starts_in atr δ ∧ continued_simulation φ ex atr.
  Proof.
    intros Hsm ex Hexstr Hex.
    induction Hex as [|? ? ? ? ? ? ? IHex].
    - apply trace_singleton_starts_in_inv in Hexstr as ->.
      exists (trace_singleton δ). done.
    - destruct IHex as [atr [Hstarts Hsim]].
      { eapply trace_extend_starts_in_inv; eauto. }
      edestruct (continued_simulation_next_aux_state_exists φ ex atr) as ([??]&?);
        [done| |].
      { econstructor; eauto. }
      eexists. split; [|done].
      by apply trace_extend_starts_in.
  Qed.

  Lemma continued_simulation_impl (Φ Ψ: execution_trace Λ → auxiliary_trace M → Prop) ex tr:
    (∀ ex tr, Φ ex tr → Ψ ex tr) →
    continued_simulation Φ ex tr → continued_simulation Ψ ex tr.
  Proof.
    intros Himpl Hphi.
    rewrite /continued_simulation /GFX.
    exists (λ '(ex, atr), continued_simulation Φ ex atr).
    split; [done|].
    intros [? ?] ?.
    rewrite /continued_simulation_pre_curried /continued_simulation_pre /=.
    split.
    { by eapply Himpl, continued_simulation_rel. }
    intros c c' ζ ? ?.
    move: H.
    rewrite continued_simulation_unfold /continued_simulation_pre.
    intros [? ?]. eauto.
  Qed.

End simulation.

Definition inf_execution_trace Λ := inflist (olocale Λ * cfg Λ).

Section inf_execution_trace.
  Context {Λ : language}.

  Definition inf_exec_prepend ζ (c : cfg Λ)
             (iex : inf_execution_trace Λ) : inf_execution_trace Λ :=
    ((ζ, c) :: iex)%inflist.

  CoInductive valid_inf_exec :
    execution_trace Λ → inf_execution_trace Λ → Prop :=
  | valid_inf_exec_singleton ex :
      valid_exec ex → valid_inf_exec ex []%inflist
  | valid_inf_exec_step ex c c' iex ζ:
      valid_exec ex →
      trace_ends_in ex c →
      locale_step c ζ c' →
      valid_inf_exec (trace_extend ex ζ c') iex →
      valid_inf_exec ex (inf_exec_prepend ζ c' iex).

End inf_execution_trace.

Definition inf_auxiliary_trace (M : Model) := inflist ((mlabel $ M) * M).

Definition inf_auxtr_prepend {M : Model} ℓ (δ : M) (atr : inf_auxiliary_trace M) :=
  infcons (ℓ,δ) atr.

CoInductive valid_inf_system_trace {Λ M}
            (Ψ : execution_trace Λ → auxiliary_trace M → Prop) :
  execution_trace Λ → auxiliary_trace M →
  inf_execution_trace Λ → inf_auxiliary_trace M → Prop :=
| valid_inf_system_trace_singleton ex atr :
    Ψ ex atr →
    valid_inf_system_trace Ψ ex atr []%inflist []%inflist
| valid_inf_system_trace_step ex atr c c' δ' iex iatr ζ ℓ:
    Ψ ex atr →
    trace_ends_in ex c →
    locale_step c ζ c' →
    valid_inf_system_trace
      Ψ (trace_extend ex ζ c') (trace_extend atr ℓ δ') iex iatr →
    valid_inf_system_trace
      Ψ ex atr (inf_exec_prepend ζ c' iex) (inf_auxtr_prepend ℓ δ' iatr).

Lemma valid_inf_system_trace_inv {Λ M}
      (Ψ : execution_trace Λ → auxiliary_trace M → Prop) ex atr iex itr :
  valid_inf_system_trace Ψ ex atr iex itr →
  Ψ ex atr.
Proof. by inversion 1. Qed.

Section simulation.
  Context {Λ : language} {M : Model}
          (φ : execution_trace Λ → auxiliary_trace M → Prop).

  Implicit Types ex : execution_trace Λ.
  Implicit Types iex : inf_execution_trace Λ.
  Implicit Types atr : auxiliary_trace M.
  Implicit Types ζ : olocale Λ.
  Implicit Types ℓ : mlabel M.

  Lemma valid_system_trace_start_or_contract ex atr :
    valid_system_trace ex atr →
    (ex = {tr[trace_first ex]} ∧ atr = {tr[trace_first atr]}) ∨
    (∃ ex' atr' oζ ℓ, trace_contract ex oζ ex' ∧ trace_contract atr ℓ atr').
  Proof. rewrite /trace_contract; inversion 1; simplify_eq; eauto 10. Qed.

  Lemma valid_inf_exec_prepend_valid_exec_extend ex c iex ζ:
    valid_inf_exec ex (inf_exec_prepend ζ c iex) →
    valid_exec (trace_extend ex ζ c).
  Proof.
    inversion 1 as [|???????? Hex]; simplify_eq.
    inversion Hex; done.
  Qed.

  Lemma produce_inf_aux_trace_next_aux_state_exists
        (ex : execution_trace Λ) (atr : auxiliary_trace M)
        (Hcsm : continued_simulation φ ex atr)
        (c : cfg Λ)
        (ζ: olocale Λ)
        (iex : inf_execution_trace Λ)
        (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) :
    ∃ δℓ, continued_simulation φ (trace_extend ex ζ c) (trace_extend atr δℓ.2 δℓ.1).
  Proof.
    eapply continued_simulation_next_aux_state_exists; first done.
    eapply valid_inf_exec_prepend_valid_exec_extend; eauto.
  Qed.

  Definition produce_inf_aux_trace_next_aux_state
             (ex : execution_trace Λ) (atr : auxiliary_trace M)
             (Hcsm : continued_simulation φ ex atr)
             (c : cfg Λ)
             (ζ: olocale Λ)
             (iex : inf_execution_trace Λ)
             (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex))
    : (M * mlabel M)%type :=
    epsilon
      (produce_inf_aux_trace_next_aux_state_exists ex atr Hcsm c ζ iex Hvex).

  Definition trace_extend_uncurry (tr: auxiliary_trace M) xy := trace_extend tr xy.2 xy.1.

  Lemma produce_inf_aux_trace_next_aux_state_continued_simulation
        (ex : execution_trace Λ) (atr : auxiliary_trace M)
        (Hcsm : continued_simulation φ ex atr)
        (c : cfg Λ)
        (ζ: olocale Λ)
        (iex : inf_execution_trace Λ)
        (Hvex : valid_inf_exec ex (inf_exec_prepend ζ c iex)) :
    continued_simulation
      φ
      (trace_extend ex ζ c)
      (trace_extend_uncurry
         atr (produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex Hvex)).
  Proof.
    rewrite /produce_inf_aux_trace_next_aux_state.
    apply epsilon_correct.
  Qed.

  Local Lemma valid_inf_exec_adjust {ex c iex ζ} :
    valid_inf_exec ex ((ζ, c) :: iex)%inflist →
    valid_inf_exec (trace_extend ex ζ c) iex.
  Proof. inversion 1; done. Qed.

  Lemma valid_inf_exe_valid_exec ex iex :
    valid_inf_exec ex iex → valid_exec ex.
  Proof. by destruct 1. Qed.
  Lemma valid_inf_exe_take_drop ex iex n :
    valid_inf_exec ex iex → valid_inf_exec (ex +trl+ inflist_take n iex) (inflist_drop n iex).
  Proof.
    revert ex iex; induction n as [|n IHn]; intros ex iex Hvl; simpl; first done.
    destruct iex as [|[??]]; simpl; first done.
    apply IHn.
    apply valid_inf_exec_adjust; done.
  Qed.

  CoFixpoint produce_inf_aux_trace
          (ex : execution_trace Λ) (atr : auxiliary_trace M)
          (Hcsm : continued_simulation φ ex atr)
          (iex : inf_execution_trace Λ)
          (Hvex : valid_inf_exec ex iex) :
    inf_auxiliary_trace M :=
    match iex as l return valid_inf_exec ex l → inf_auxiliary_trace M with
    | [] => λ _, []
    | (ζ, c) :: iex' =>
      λ Hvex',
      let δℓ :=
          produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex' Hvex'
      in
      (δℓ.2, δℓ.1) :: (produce_inf_aux_trace
              (trace_extend ex ζ c)
              (trace_extend atr δℓ.2 δℓ.1)
              (produce_inf_aux_trace_next_aux_state_continued_simulation
                 ex atr Hcsm c ζ iex' Hvex')
              iex'
              (valid_inf_exec_adjust Hvex'))
    end%inflist Hvex.

  Theorem produced_inf_aux_trace_valid_inf
          (ex : execution_trace Λ) (atr : auxiliary_trace M)
          (Hst : valid_system_trace ex atr)
          (Hcsm : continued_simulation φ ex atr)
          (iex : inf_execution_trace Λ)
          (Hvex : valid_inf_exec ex iex)
    : valid_inf_system_trace
        (continued_simulation φ)
        ex atr
        iex
        (produce_inf_aux_trace ex atr Hcsm iex Hvex).
  Proof.
    revert ex atr Hcsm Hst iex Hvex; cofix CIH; intros ex atr Hcsm Hst iex Hvex.
    destruct iex as [|[ζ c] iex].
    - rewrite [produce_inf_aux_trace _ _ _ _ _]inflist_unfold_fold /=.
      constructor; trivial.
    - rewrite [produce_inf_aux_trace _ _ _ _ _]inflist_unfold_fold /=.
      pose proof (produce_inf_aux_trace_next_aux_state_continued_simulation
                    ex atr Hcsm c ζ iex Hvex) as Hcsm'.
      assert (valid_system_trace
                (ex :tr[ζ]: c)
                (trace_extend_uncurry
                   atr (produce_inf_aux_trace_next_aux_state ex atr Hcsm c ζ iex Hvex)))
             as Hst'.
      { inversion Hvex; simplify_eq.
        econstructor; try done. }
      apply valid_system_trace_extend_inv in Hst' as (?&?&?&?).
      econstructor; eauto using valid_system_trace_step.
  Qed.

End simulation.