(** Type-safety proofs.

    Authors: Steve Zdancewic and Karl Mazurak.

    Table of contents:
      - #Properties of subtyping#
      - #Properties of typing#
      - #Preservation#
      - #Progress# *)

Require Export LinF_Lemmas.
Require Import Omega.

(* ********************************************************************** *)
(** * Weakening *)

Lemma wf_lenv_disjoint: forall G D,
  wf_lenv G D ->
  disjoint G D.
Proof.
  induction D; simpl_env; intros.
  SCase "nil".
    unfold disjoint. fsetdec.
  SCase "con".
    inversion H; subst.
    solve_uniq.
Qed.

Lemma wf_lenv_weakening: forall E F G D,
  wf_lenv (G ++ E) D ->
  wf_env (G ++ F ++ E) ->
  disjoint F D ->
  wf_lenv (G ++ F ++ E) D.
Proof.
  intros E F G D WFL.
  remember (G ++ E) as G0.
  generalize dependent G.
  (wf_lenv_cases (induction WFL) Case);
    intros G EQ WFE NIN; subst; simpl_env in *; auto.
  Case "wf_lenv_typ".
    apply wf_lenv_typ; auto.
      apply IHWFL; auto.
       intros. solve_uniq.

      repeat rewrite dom_app.
      assert (x `notin` dom F) as J.
        solve_uniq.
      fsetdec.

      eapply wf_typ_weakening; auto.
Qed.

Lemma lenv_split_weakening: forall E F G D1 D2 D3,
  lenv_split (E ++ G) D1 D2 D3 ->
  wf_env (E ++ F ++ G) ->
  disjoint F D3 ->
  lenv_split (E ++ F ++ G) D1 D2 D3.
Proof.
  intros E F G D1 D2 D3 S.
  remember (E ++ G) as G0.
  generalize dependent E. generalize dependent G. generalize dependent F.
  (lenv_split_cases (induction S) Case); intros F1 G1 E1 EQ WFE NIN; auto.
  Case "lenv_split_left".
    apply lenv_split_left; subst; auto using wf_typ_weakening.
      apply IHS; auto.
        solve_uniq.
      simpl; solve_uniq.
  Case "lenv_split_right".
    apply lenv_split_right; subst; auto using wf_typ_weakening.
      apply IHS; auto.
        solve_uniq.
      simpl; solve_uniq.
Qed.

Lemma typing_weakening: forall E F G D e T,
  typing (G ++ E) D e T ->
  wf_lenv (G ++ F ++ E) D ->
  typing (G ++ F ++ E) D e T.
Proof with simpl_env;
           eauto using wf_typ_weakening,
                       wf_typ_from_wf_env_typ.
  intros E F G D e T Typ.
  remember (G ++ E) as H.
  generalize dependent G. generalize dependent E.
  (typing_cases (induction Typ) Case); intros E0 G EQ WFL; subst...
  Case "typing_abs".
    pick fresh x and apply typing_abs; subst; auto.
      apply wf_typ_weakening; auto.

      lapply (H1 x); intros; auto.
      rewrite <- app_assoc.
      eapply H3; eauto.
      simpl_env. rewrite_env (nil ++ [(x, bind_typ T1)] ++ G ++ F ++ E0).
      eapply wf_lenv_weakening; auto.
        apply wf_env_typ; auto.
          apply wf_typ_weakening; eauto.
  Case "typing_labs".
    pick fresh x and apply typing_labs; subst; auto.
      apply wf_typ_weakening; auto.

      eapply (H1 x); auto.
        apply wf_lenv_typ; auto.
          apply wf_typ_weakening; auto.
  Case "typing_app".
    eapply typing_app.
      eapply IHTyp1; eauto.
        eapply wf_lenv_split_left.
          apply lenv_split_weakening; eauto.
            apply wf_lenv_disjoint in WFL. solve_uniq.
      eapply IHTyp2; eauto.
        eapply wf_lenv_split_right.
          apply lenv_split_weakening; eauto.
            apply wf_lenv_disjoint in WFL. solve_uniq.
      eapply lenv_split_weakening; auto.
        apply wf_lenv_disjoint in WFL. solve_uniq.
  Case "typing_tabs".
    pick fresh X and apply typing_tabs; auto.
    lapply (H1 X); [intros Q | auto].
    rewrite <- app_assoc.
    apply H1...
      rewrite_env (nil ++ [(X, bind_kn K)] ++ G ++ F ++ E0).
      apply wf_lenv_weakening; auto.
        simpl_env. apply wf_env_kn; auto.
Qed.

(************************************************************************ *)
(** * Type substitution preserves typing *)

Lemma lenv_split_subst_tb : forall G1 G2 D1 D2 D3 X K P,
  lenv_split (G1 ++ [(X, bind_kn K)] ++ G2) D1 D2 D3 ->
  wf_typ G2 P K ->
  lenv_split (map (subst_tb X P) G1 ++ G2)
             (map (subst_tlb X P) D1)
             (map (subst_tlb X P) D2)
             (map (subst_tlb X P) D3).
Proof.
  intros G1 G2 D1 D2 D3 X K P S.
  remember (G1 ++ [(X, bind_kn K)] ++ G2) as G.
  generalize dependent G1. generalize dependent G2.
  (lenv_split_cases (induction S) Case);
    intros G2 G1 EQ WFT; subst; simpl_env in *; auto.
  Case "lenv_split_empty".
    apply lenv_split_empty; auto.
      eapply wf_env_subst_tb; eauto.
  Case "lenv_split_left".
    apply lenv_split_left; auto.
      eapply wf_typ_subst_tb; eauto.
  Case "lenv_split_right".
    apply lenv_split_right; auto.
      eapply wf_typ_subst_tb; eauto.
Qed.

Lemma value_through_subst_te : forall e Z P,
  type P ->
  value e ->
  value (subst_te Z P e).
Proof.
  intros e Z P Typ H.
  (value_cases (induction H) Case); simpl; auto using subst_te_expr.
  Case "value_abs".
    assert (expr (subst_te Z P (exp_abs K T e1))) as J.
      apply subst_te_expr; auto.
    apply value_abs; auto.
  Case "value_tabs".
    assert (expr (subst_te Z P (exp_tabs K e1))) as J.
      apply subst_te_expr; auto.
    apply value_tabs; auto.
Qed.

Lemma typing_through_subst_te : forall K E F D Z e T P,
  typing (F ++ [(Z, bind_kn K)] ++ E) D e T ->
  wf_typ E P K ->
  typing (map (subst_tb Z P) F ++ E) (map (subst_tlb Z P) D) (subst_te Z P e) (subst_tt Z P T).
Proof with simpl_env;
           eauto 6 using wf_env_subst_tb,
                         wf_typ_subst_tb.
  intros K E F D Z e T P Typ PsubK.
  remember (F ++ [(Z, bind_kn K)] ++ E) as G.
  generalize dependent F. generalize dependent E.
  (typing_cases (induction Typ) Case); intros E0 WFT F EQ; subst;
    simpl subst_te in *; simpl subst_tt in *...
  Case "typing_var".
    apply typing_var...
    rewrite (map_subst_tb_id E0 Z P).
      analyze_binds_uniq H0...

      eapply wf_env_strengthening_tail.
      eapply wf_env_strengthening_tail; eauto.

      assert (wf_env ([(Z, bind_kn K)] ++ E0)) as J.
        eapply wf_env_strengthening_tail; eauto.
      inversion J; auto.
  Case "typing_lvar".
     simpl. apply typing_lvar.
     assert ([(x, lbind_typ (subst_tt Z P T))] =
             map (subst_tlb Z P) [(x, lbind_typ T)]) as J. auto.
     simpl_env. rewrite J.
     eapply wf_lenv_subst_tb; eauto.
  Case "typing_abs".
    pick fresh y and apply typing_abs...
    rewrite subst_te_open_ee_var...
    rewrite_env (map (subst_tb Z P) ([(y, bind_typ T1)] ++ F) ++ E0).
    simpl in H1.
    apply H1...
    intros. rewrite H2; auto.
  Case "typing_labs".
    pick fresh y and apply typing_labs...
    rewrite subst_te_open_ee_var...
    rewrite_env (map (subst_tlb Z P) ([(y, lbind_typ T1)] ++ D)).
    apply H1...
    intros. rewrite H2; auto.
  Case "typing_app".
    eapply typing_app; eauto.
      eapply lenv_split_subst_tb; eauto.
  Case "typing_tabs".
    pick fresh Y and apply typing_tabs.
      rewrite subst_tt_fresh with (T:=Y) (Z:=Z) (U:=P); auto.
      rewrite <- subst_te_open_te; auto.
        apply value_through_subst_te; auto.
          eapply type_from_wf_typ; eauto.
        eapply type_from_wf_typ; eauto.
      rewrite subst_te_open_te_var; eauto using type_from_wf_typ.
      rewrite subst_tt_open_tt_var; eauto using type_from_wf_typ.
      rewrite_env (map (subst_tb Z P) ([(Y, bind_kn K0)] ++ F) ++ E0); eauto.
  Case "typing_tapp".
    rewrite subst_tt_open_tt...
      eapply type_from_wf_typ; eauto.
Qed.

(************************************************************************ *)
(** * Substitution preserves typing *)

Lemma value_through_open_te: forall e1 T,
  value e1 ->
  value (open_te e1 T).
Proof.
  intros e1 T H.
  unfold open_te.
  rewrite <- open_te_rec_expr; auto.
Qed.

Lemma typing_fv: forall E D e T x,
  typing E D e T ->
  x `notin` dom E ->
  x `notin` dom D ->
  x `notin` fv_ee e.
Proof.
  intros E D e T x H.
  (typing_cases (induction H) Case); intros NIE NID; simpl; auto.
  Case "typing_var".
    assert (x0 `in` dom E) as J.
      eapply binds_In; eauto.
    fsetdec.
  Case "typing_abs".
    pick fresh y.
    lapply (H1 y); intros; auto.
    simpl in H3. unfold not. intros. apply H3; auto.
    assert (x `notin` singleton y) as J. destruct_notin; auto.
    unfold open_ee. apply fv_in_open_ee; auto.
  Case "typing_labs".
    pick fresh y.
    lapply (H1 y); intros; auto.
    simpl in H3. unfold not. intros. apply H3; auto.
    assert (x `notin` singleton y) as J. destruct_notin; auto.
    unfold open_ee. apply fv_in_open_ee; auto.
  Case "typing_app".
    assert (x `notin` fv_ee e1) as J1.
      apply IHtyping1; auto.
        rewrite (dom_lenv_split E D1 D2 D3) in NID; auto.
    assert (x `notin` fv_ee e2) as J2.
      apply IHtyping2; auto.
        rewrite (dom_lenv_split E D1 D2 D3) in NID; auto.
    fsetdec.
  Case "typing_tabs".
    pick fresh y. lapply (H1 y); intros; auto.
    unfold not. intros. apply H2; auto.
    unfold open_te. apply fv_in_open_te. auto.
Qed.

Lemma non_subst: forall E D e T x u,
  typing E D e T ->
  x `notin` dom E ->
  x `notin` dom D ->
  e = subst_ee x u e.
Proof.
  intros E D e T x y H1 H2 H3.
  apply subst_ee_fresh.
  eapply typing_fv; eauto.
Qed.

Lemma lenv_split_strengthening: forall G2 G1 x T D1 D2 D3,
  lenv_split (G2 ++ [(x, bind_typ T)] ++ G1) D1 D2 D3 ->
  lenv_split (G2 ++ G1) D1 D2 D3.
Proof.
  intros G2 G1 x T D1 D2 D3 S.
  remember (G2 ++ [(x, bind_typ T)] ++ G1) as G.
  generalize dependent G1. generalize dependent G2.
  (lenv_split_cases (induction S) Case);
    intros G2 G1 EQ; simpl_env in *; subst; auto.
  Case "lenv_split_empty".
    apply lenv_split_empty.
      eapply wf_env_strengthening; eauto.
  Case "lenv_split_left".
    apply lenv_split_left; auto.
      simpl_env in *.
      eapply wf_typ_strengthening; eauto.
  Case "lenv_split_right".
    apply lenv_split_right; auto.
      simpl_env in *.
      eapply wf_typ_strengthening; eauto.
Qed.

Lemma value_through_subst_ee: forall e1 x u,
  expr u ->
  value e1 ->
  value (subst_ee x u e1).
Proof.
  intros e1 x u EX V.
  (value_cases (induction V) Case); simpl; auto.
  Case "value_abs".
    inversion H; subst.
    apply value_abs.
      pick fresh z and apply expr_abs; auto.
        rewrite subst_ee_open_ee_var; auto.
  Case "value_tabs".
    inversion H; subst.
    apply value_tabs.
      pick fresh X and apply expr_tabs.
        rewrite subst_ee_open_te_var; auto.
Qed.

Lemma typing_through_subst_ee_nonlin: forall G2 G1 x U0 D e T u,
  typing (G2 ++ [(x, bind_typ U0)] ++ G1) D e T ->
  typing G1 lempty u U0 ->
  value u ->
  typing (G2 ++ G1) D (subst_ee x u e) T.
Proof.
  intros G2 G1 x U0 D e T u Typ.
  remember (G2 ++ [(x, bind_typ U0)] ++ G1) as G.
  generalize dependent G2. generalize dependent G1.
  (typing_cases (induction Typ) Case);
    intros G1 G2 EQ TYP V; simpl_env in *; simpl; subst; eauto.
  Case "typing_var".
    destruct (x0 == x); subst.
    SCase "x0 == x".
      rewrite_env (nil ++ G2 ++ G1).
      apply typing_weakening; auto.
        assert (bind_typ T = bind_typ U0) as J.
          eauto using binds_mid_eq.
       inversion J; subst; auto.

       simpl_env. apply wf_lenv_empty.
       eapply wf_env_strengthening; eauto.
    SCase "x0 <> x".
      apply typing_var; auto.
        eapply wf_env_strengthening; eauto.
        analyze_binds_uniq H0.
  Case "typing_lvar".
    destruct (x0 == x); subst.
    SCase "x0 == x".
      inversion H; subst.
      assert False as J.
        apply H5.
        repeat rewrite dom_app.
        simpl. fsetdec.
      tauto.
    SCase "x0 <> x".
      apply typing_lvar.
        eapply wf_lenv_strengthening; eauto.
  Case "typing_abs".
    pick fresh y and apply typing_abs; auto.
      eapply wf_typ_strengthening; eauto.

      rewrite_env (([(y, bind_typ T1)] ++ G2) ++ G1).
      rewrite subst_ee_open_ee_var; auto.
  Case "typing_labs".
    pick fresh y and apply typing_labs; auto.
      eapply wf_typ_strengthening; eauto.
      rewrite subst_ee_open_ee_var; eauto.
  Case "typing_app".
    eapply typing_app; eauto.
      eapply lenv_split_strengthening; eauto.
  Case "typing_tabs".
    pick fresh X and apply typing_tabs; auto.
      rewrite <- subst_ee_open_te; auto.
      apply value_through_subst_ee; auto.

      rewrite_env (([(X, bind_kn K)] ++ G2) ++ G1).
      rewrite subst_ee_open_te_var; eauto.
  Case "typing_tapp".
    eapply typing_tapp. eapply IHTyp; auto.
    eapply wf_typ_strengthening; eauto.
Qed.

Lemma typing_through_subst_ee_nonlin2: forall G2 G1 x U0 D e T u,
  typing (G2 ++ [(x, bind_typ U0)] ++ G1) D e T ->
  typing G1 lempty u U0 ->
  typing (G2 ++ G1) D (subst_ee x u e) T.
Proof.
  intros G2 G1 x U0 D e T u Typ.
  remember (G2 ++ [(x, bind_typ U0)] ++ G1) as G.
  generalize dependent G2. generalize dependent G1.
  (typing_cases (induction Typ) Case);
    intros G1 G2 EQ TYP; simpl_env in *; simpl; subst; eauto.
  Case "typing_var".
    destruct (x0 == x); subst.
    SCase "x0 == x".
      rewrite_env (nil ++ G2 ++ G1).
      apply typing_weakening; auto.
        assert (bind_typ T = bind_typ U0) as J.
          eauto using binds_mid_eq.
       inversion J; subst; auto.

       simpl_env. apply wf_lenv_empty.
       eapply wf_env_strengthening; eauto.
    SCase "x0 <> x".
      apply typing_var; auto.
        eapply wf_env_strengthening; eauto.
        analyze_binds_uniq H0.
  Case "typing_lvar".
    destruct (x0 == x); subst.
    SCase "x0 == x".
      inversion H; subst.
      assert False as J.
        apply H5.
        repeat rewrite dom_app.
        simpl. fsetdec.
      tauto.
    SCase "x0 <> x".
      apply typing_lvar.
        eapply wf_lenv_strengthening; eauto.
  Case "typing_abs".
    pick fresh y and apply typing_abs; auto.
      eapply wf_typ_strengthening; eauto.

      rewrite_env (([(y, bind_typ T1)] ++ G2) ++ G1).
      rewrite subst_ee_open_ee_var; auto.
  Case "typing_labs".
    pick fresh y and apply typing_labs; auto.
      eapply wf_typ_strengthening; eauto.
      rewrite subst_ee_open_ee_var; eauto.
  Case "typing_app".
    eapply typing_app; eauto.
      eapply lenv_split_strengthening; eauto.
  Case "typing_tabs".
    pick fresh X and apply typing_tabs; auto.
      rewrite <- subst_ee_open_te; auto.
      apply value_through_subst_ee; auto.

      rewrite_env (([(X, bind_kn K)] ++ G2) ++ G1).
      rewrite subst_ee_open_te_var; eauto.
  Case "typing_tapp".
    eapply typing_tapp. eapply IHTyp; auto.
    eapply wf_typ_strengthening; eauto.
Qed.

Lemma contraction: forall G2 G1 x y U0 D e T,
  typing (G2 ++ [(y, bind_typ U0)] ++ [(x, bind_typ U0)] ++ G1) D e T ->
  typing (G2 ++ [(x, bind_typ U0)] ++ G1) D (subst_ee y x e) T.
Proof.
  intros G2 G1 x y U0 D e T Typ.
  remember (G2 ++ [(y, bind_typ U0)] ++ [(x, bind_typ U0)] ++ G1) as G.
  generalize dependent G2. generalize dependent G1.
  (typing_cases (induction Typ) Case);
    intros G1 G2 EQ; simpl_env in *; simpl; subst; eauto.
  Case "typing_var".
    destruct (x0 == y); subst.
    SCase "x0 == y".
      simpl_env. apply typing_var.
       eapply wf_env_strengthening; eauto.
       assert (bind_typ T = bind_typ U0) as J.
          eauto using binds_mid_eq.
       inversion J; subst; auto.
    SCase "x0 <> x".
      simpl_env.
      apply typing_var; auto.
      eapply wf_env_strengthening; eauto.
      analyze_binds_uniq H0.
  Case "typing_lvar".
    destruct (x0 == y); subst.
    SCase "x0 == y".
      inversion H; subst.
      assert False as J.
        apply H5.
        repeat rewrite dom_app.
        simpl. fsetdec.
      tauto.
    SCase "x0 <> y".
      apply typing_lvar.
        eapply wf_lenv_strengthening; eauto.
  Case "typing_abs".
    pick fresh z and apply typing_abs; auto.
      eapply wf_typ_strengthening; eauto.

      rewrite_env (([(z, bind_typ T1)] ++ G2) ++ [(x, bind_typ U0)] ++ G1).
      rewrite subst_ee_open_ee_var; auto.
  Case "typing_labs".
    pick fresh z and apply typing_labs; auto.
      eapply wf_typ_strengthening; eauto.
      rewrite subst_ee_open_ee_var; eauto. simpl_env. eauto.
  Case "typing_app".
    simpl_env.
    eapply typing_app; eauto.
      eapply lenv_split_strengthening; eauto.
  Case "typing_tabs".
    simpl_env.
    pick fresh X and apply typing_tabs; auto.
      rewrite <- subst_ee_open_te; auto.
      apply value_through_subst_ee; auto.

      rewrite_env (([(X, bind_kn K)] ++ G2) ++ [(x, bind_typ U0)] ++ G1).
      rewrite subst_ee_open_te_var; eauto.
  Case "typing_tapp".
    simpl_env.
    eapply typing_tapp. eapply IHTyp; auto.
    eapply wf_typ_strengthening; eauto.
  Case "typing_apair".
    simpl_env. apply typing_apair. eauto. eauto.
  Case "typing_fst".
    simpl_env. eapply typing_fst; eauto.
  Case "typing_snd".
    simpl_env. eapply typing_snd; eauto.
Qed.

Lemma lenv_split_cases_mid: forall G D1 D2 DL x T DR,
  lenv_split G D1 D2 (DL ++ [(x, lbind_typ T)] ++ DR) ->
  (exists D1L, exists D1R, exists D2L, exists D2R,
    D1 = D1L ++ [(x, lbind_typ T)] ++ D1R /\
    D2 = D2L ++ D2R /\
    lenv_split G D1L D2L DL /\
    lenv_split G D1R D2R DR) \/
  (exists D1L, exists D1R, exists D2L, exists D2R,
    D1 = D1L ++ D1R /\
    D2 = D2L ++ [(x, lbind_typ T)] ++ D2R /\
    lenv_split G D1L D2L DL /\
    lenv_split G D1R D2R DR).
Proof.
  intros G D1 D2 DL x T DR S.
  remember (DL ++ [(x, lbind_typ T)] ++ DR) as D3.
  generalize dependent DR. generalize dependent DL.
  (lenv_split_cases (induction S) Case);
    intros DL DR EQ; subst; simpl_env in *.
  Case "lenv_split_empty".
    destruct DL; inversion EQ.
  Case "lenv_split_left".
    destruct DL; simpl in *; inversion EQ; subst; simpl_env in *.
    SCase "nil".
      left.
      exists lempty. exists D1. exists lempty. exists D2.
      simpl_env.
      repeat split; auto.
        apply lenv_split_empty.
          eapply wf_env_from_wf_lenv.
            eapply wf_lenv_split_left; eauto.
    SCase "con".
      lapply (IHS DL DR); auto.
      intros J.
      destruct J as [J | J].
      SSCase "left".
        destruct J as [D1L [D1R [D2L [D2R [Q1 [Q2 [S1 S2]]]]]]].
        left. exists ([(x0, lbind_typ T0)] ++ D1L).
        exists D1R. exists D2L. exists D2R.
        simpl_env in *.
        repeat split; subst; auto.
      SSCase "right".
        destruct J as [D1L [D1R [D2L [D2R [Q1 [Q2 [S1 S2]]]]]]].
        right. exists ([(x0, lbind_typ T0)] ++ D1L).
        exists D1R. exists D2L. exists D2R.
        simpl_env in *.
        repeat split; subst; auto.
  Case "lenv_split_right".
    destruct DL; simpl in *; inversion EQ; subst; simpl_env in *.
    SCase "nil".
      right.
      exists lempty. exists D1. exists lempty. exists D2.
      simpl_env in *.
      repeat split; auto.
        apply lenv_split_empty.
          eapply wf_env_from_wf_lenv.
            eapply wf_lenv_split_left; eauto.
    SCase "con".
      lapply (IHS DL DR); auto.
      intros J.
      destruct J as [J | J].
      SSCase "left".
        destruct J as [D1L [D1R [D2L [D2R [Q1 [Q2 [S1 S2]]]]]]].
        left. exists D1L.
        exists D1R. exists ([(x0, lbind_typ T0)] ++ D2L). exists D2R.
        simpl_env in *. repeat split; subst; auto.

      SSCase "right".
        destruct J as [D1L [D1R [D2L [D2R [Q1 [Q2 [S1 S2]]]]]]].
        right. exists D1L.
        exists D1R. exists ([(x0, lbind_typ T0)] ++ D2L). exists D2R.
        subst. simpl_env in *. repeat split; auto.
Qed.

Lemma lenv_split_not_in_left: forall G D1 D2 D3 x,
  lenv_split G D1 D2 D3 ->
  x `in` dom D1 ->
  x `notin` (dom D2 `union` dom G).
Proof.
  intros G D1 D2 D3 x S.
  (lenv_split_cases (induction S) Case);
    intros; simpl_env in *; try fsetdec.
  Case "lenv_split_left".
    rewrite (dom_lenv_split E D1 D2 D3) in H0; auto.
      fsetdec.
  Case "lenv_split_right".
    rewrite (dom_lenv_split E D1 D2 D3) in H0; auto.
      fsetdec.
Qed.

Lemma lenv_split_not_in_right: forall G D1 D2 D3 x,
  lenv_split G D1 D2 D3 ->
  x `in` dom D2 ->
  x `notin` (dom D1 `union` dom G).
Proof.
  intros.
  eapply lenv_split_not_in_left.
    eapply lenv_split_commute; eauto.
    auto.
Qed.

Lemma lenv_split_lin_weakening_left: forall E F D1 D2 D3,
  lenv_split E D1 D2 D3 ->
  wf_lenv E (F ++ D3) ->
  lenv_split E (F ++ D1) D2 (F ++ D3).
Proof.
  intros E F.
  induction F; intros D1 D2 D3 S WFL; simpl_env in *; auto.
  Case "con".
    destruct a. simpl_env in *.
    inversion WFL; subst.
    apply lenv_split_left; auto.
Qed.

Lemma lenv_split_sub_left: forall E D1L D1R D2 DL DR x U F,
   lenv_split E
        (D1L ++ [(x, lbind_typ U)] ++ D1R)
        D2
        (DL ++ [(x, lbind_typ U)] ++ DR) ->
   wf_lenv E (DL ++ F ++ DR) ->
   lenv_split E
        (D1L ++ F ++ D1R)
        D2
        (DL ++ F ++ DR).
Proof.
  intros E D1L D1R D2 DL DR x U F S.
  remember (D1L ++ [(x, lbind_typ U)] ++ D1R) as D1.
  remember (DL ++ [(x, lbind_typ U)] ++ DR) as D3.
  generalize dependent D1R. generalize dependent D1L.
  generalize dependent DR. generalize dependent DL.
  (lenv_split_cases (induction S) Case);
    intros DL DR EQ1 D1L D1R EQ2 WFL; subst; auto.
  Case "lenv_split_empty".
    destruct DL; inversion EQ1.
  Case "lenv_split_left".
    destruct DL; inversion EQ1; subst.
    SCase "nil".
      destruct D1L; inversion EQ2; subst; simpl_env in *.
      SSCase "nil".
        apply lenv_split_lin_weakening_left; auto.
      SSCase "con".
        rewrite (dom_lenv_split E (D1L ++ [(x, lbind_typ U)] ++ D1R) D2 DR) in H0; auto.
          simpl_env in *.
          assert False as J. fsetdec.
          tauto.
    SCase "nil".
      destruct D1L; inversion EQ2; subst; simpl_env in *.
      SSCase "nil".
        assert False. fsetdec.
        tauto.
      SSCase "con".
        inversion WFL; subst.
        apply lenv_split_left; auto.
  Case "lenv_split_right".
    destruct DL; inversion EQ1; subst; simpl_env in *.
    SCase "nil".
      rewrite (dom_lenv_split E (D1L ++ [(x, lbind_typ U)] ++ D1R) D2 DR) in H0; auto.
        simpl_env in *.
        assert False. fsetdec.
        tauto.
    SCase "con".
      inversion WFL; subst.
      apply lenv_split_right; auto.
Qed.

Lemma lenv_split_sub_right: forall E D1 D2L D2R DL DR x U F,
   lenv_split E
        D1
        (D2L ++ [(x, lbind_typ U)] ++ D2R)
        (DL ++ [(x, lbind_typ U)] ++ DR) ->
   wf_lenv E (DL ++ F ++ DR) ->
   lenv_split E
        D1
        (D2L ++ F ++ D2R)
        (DL ++ F ++ DR).
Proof.
  intros.
  apply lenv_split_commute.
  eapply lenv_split_sub_left; eauto.
    apply lenv_split_commute; eauto.
Qed.

Lemma wf_lenv_lin_strengthening: forall G D1 D2 D3,
  wf_lenv G (D1 ++ D2 ++ D3) ->
  wf_lenv G D2.
Proof.
  intros.
  remember (D1 ++ D2 ++ D3) as D.
  generalize dependent D1. generalize dependent D2. generalize dependent D3.
  (wf_lenv_cases (induction H) Case);
    intros D3 D2 D1 EQ.
  Case "wf_lenv_empty".
    destruct D1; destruct D2; destruct D3; inversion EQ; auto.
  Case "wf_lenv_typ".
    destruct D1; destruct D2; simpl_env in *; inversion EQ; subst; auto.
    SCase "D1=nil, D2=con".
      apply wf_lenv_typ; auto.
        apply (IHwf_lenv D3 D2 lempty); auto.
    SCase "D1=con, D2=con".
      apply (IHwf_lenv D3 (p0 :: D2) D1); auto.
Qed.

Lemma typing_through_subst_ee_lin: forall G D2 x U D1 e T F u,
  typing G (D2 ++ [(x, lbind_typ U)] ++ D1) e T ->
  typing G F u U ->
  wf_lenv G (D2 ++ F ++ D1) ->
  typing G (D2 ++ F ++ D1) (subst_ee x u e) T.
Proof.
  intros G D2 x U D1 e T F u TYP.
  remember (D2 ++ [(x, lbind_typ U)] ++ D1) as D.
  generalize dependent D2. generalize dependent D1.
  (typing_cases (induction TYP) Case);
    intros DR DL EQ TYPU WFL; subst; simpl_env in *; simpl; eauto.
  Case "typing_var".
    destruct DL; inversion EQ.
  Case "typing_lvar".
    destruct DL; inversion EQ; subst.
    SCase "DL=nil".
      simpl_env in *. simpl.
      destruct (x == x); tauto.
    SCase "DL=con".
      destruct DL; inversion EQ.
  Case "typing_abs".
    pick fresh y and apply typing_abs; auto.
      rewrite subst_ee_open_ee_var; auto.
      apply H1; auto.
        rewrite_env (nil ++ [(y, bind_typ T1)] ++ E).
        apply typing_weakening; auto.
          apply wf_lenv_weakening; simpl_env; auto.
        rewrite_env (nil ++ [(y, bind_typ T1)] ++ E).
        apply wf_lenv_weakening; auto.
          simpl_env; apply wf_env_typ; auto.
      intros. lapply H2; auto.
      intros. destruct DL; inversion H4.
  Case "typing_labs".
    pick fresh y and apply typing_labs; auto.
      rewrite_env (([(y, lbind_typ T1)] ++ DL) ++ F ++ DR).
      rewrite subst_ee_open_ee_var; auto.
      apply H1; simpl_env; auto.
      intros. lapply H2; auto.
      intros. destruct DL; inversion H4.
  Case "typing_app".
    lapply (lenv_split_cases_mid E D1 D2 DL x U DR); auto.
    intros C.
    destruct C as [LEFT | RIGHT].
    SCase "left".
      destruct LEFT as [D1L [D1R [D2L [D2R [Q1 [Q2 [S1 S2]]]]]]]; subst.
      lapply (IHTYP1 D1R D1L); auto.
      intros I.
      assert (x `notin` (dom (D2L++D2R) `union` dom E)) as J.
        eapply lenv_split_not_in_left; eauto.
          simpl_env. fsetdec.
      lapply I; auto. intros TYPE1.
      rewrite <- (non_subst E (D2L++D2R) e2 T1 x u); auto.
        apply (typing_app T1 K E (D1L ++ F ++ D1R) (D2L ++ D2R)); auto.
          assert (wf_lenv E (D1L ++ F ++ D1R)) as JJ.
            eapply wf_lenv_split_left.
              eapply lenv_split_sub_left; eauto.
          apply TYPE1; auto.

          eapply lenv_split_sub_left; eauto.
    SCase "right".
      destruct RIGHT as [D1L [D1R [D2L [D2R [Q1 [Q2 [S1 S2]]]]]]]; subst.
      lapply (IHTYP2 D2R D2L); auto.
      intros I.
      assert (x `notin` (dom (D1L++D1R) `union` dom E)) as J.
        eapply lenv_split_not_in_right; eauto.
          simpl_env. fsetdec.
      lapply I; auto. intros TYPE2.
      rewrite <- (non_subst E (D1L ++ D1R) e1 (typ_arrow K T1 T2) x u); auto.
        apply (typing_app T1 K E (D1L ++ D1R) (D2L ++ F ++ D2R)); auto.
          assert (wf_lenv E (D2L ++ F ++ D2R)) as JJ.
            eapply wf_lenv_split_right.
              eapply lenv_split_sub_right; eauto.
          apply TYPE2; auto.

          eapply lenv_split_sub_right; eauto.
  Case "typing_tabs".
    pick fresh X and apply typing_tabs.
      rewrite <- subst_ee_open_te; auto.
      apply value_through_subst_ee; auto.

      rewrite subst_ee_open_te_var; auto.
      apply H1; auto.
        rewrite_env (nil ++ [(X, bind_kn K)] ++ E).
        apply typing_weakening; auto.
          eapply wf_lenv_weakening; eauto.
            simpl_env. eapply wf_env_kn; eauto.
          rewrite_env (nil ++ [(X, bind_kn K)] ++ E).
          apply wf_lenv_weakening; auto.
            simpl_env. apply wf_env_kn; auto.
Qed.

(* ********************************************************************** *)
(* ********************************************************************** *)
(** * Preservation *)

Lemma value_nonlin_inversion: forall E D e T,
  typing E D e T ->
  value e ->
  wf_typ E T kn_nonlin ->
  D = lempty.
Proof.
  intros E D e T Typ.
  (typing_cases (induction Typ) Case);
    intros V WFT;
    try solve [ auto |
                inversion V |
                inversion WFT; subst; auto].
  Case "typing_tabs".
    inversion V; subst.
    inversion WFT; subst.
    pick fresh X.
    apply (H1 X); auto.
Qed.

Lemma lenv_split_weakening_left: forall E D1L D1R D2L D2R D3L D3R x T,
  lenv_split E (D1L ++ D1R) (D2L ++ D2R) (D3L ++ D3R) ->
  lenv_split E D1L D2L D3L ->
  lenv_split E D1R D2R D3R ->
  wf_lenv E (D3L ++ [(x, lbind_typ T)] ++ D3R) ->
  lenv_split E (D1L ++ [(x, lbind_typ T)] ++ D1R) (D2L ++ D2R) (D3L ++ [(x, lbind_typ T)]++ D3R).
Proof.
  intros E D1L D1R D2L D2R D3L D3R x T S.
  remember (D1L ++ D1R) as D1.
  remember (D2L ++ D2R) as D2.
  remember (D3L ++ D3R) as D3.
  generalize dependent D1L. generalize dependent D1R.
  generalize dependent D2L. generalize dependent D2R.
  generalize dependent D3L. generalize dependent D3R.
  (lenv_split_cases (induction S) Case);
    intros D3R D3L EQ3 D2R D2L EQ2 D1R D1L EQ1 SL SR WFL; subst; simpl_env in *.
  Case "lenv_split_empty".
    destruct D3L; destruct D3R; inversion EQ3; subst; simpl_env.
    destruct D2L; destruct D2R; inversion EQ2; subst; simpl_env.
    destruct D1L; destruct D1R; inversion EQ1; subst; simpl_env.
    rewrite_env ([(x, lbind_typ T)] ++ nil).
    simpl_env in WFL. inversion WFL; subst.
    apply lenv_split_left; auto.
  Case "lenv_split_left".
    destruct D3L; inversion EQ3.
    SCase "D3L=nil".
      destruct D1L; inversion EQ1.
      SSCase "D1L=nil".
        destruct D3R; simpl_env in EQ3; inversion EQ3.
        SSSCase "D3R=con".
          destruct D1R; simpl_env in EQ1; inversion EQ1.
          SSSSCase "D1R=con"; subst; simpl_env in *.
            inversion WFL; subst.
            apply lenv_split_left; auto.
      SSCase "D1L=con".
        inversion SL.
    SCase "D3L=con".
      destruct D1R; simpl_env in EQ1; inversion EQ1; subst.
      SSCase "D2R=nil".
        simpl_env in *.
        inversion WFL; subst.
        apply lenv_split_left; auto.
          rewrite_env (D1 ++ [(x, lbind_typ T)] ++ nil).
          eapply IHS; auto.
          inversion SL; auto. subst.
          rewrite (dom_lenv_split E ([(x0, lbind_typ T0)] ++ D1) D2 D3L) in H0; auto.
          simpl in H0.
          assert False. fsetdec. tauto.
      SSCase "D2R=con".
        inversion SL; subst; simpl_env in *.
        SSSCase "SL1".
          inversion WFL; subst.
          apply lenv_split_left; auto.
            eapply IHS; auto.
              inversion EQ1; auto.
        SSSCase "SL2".
          assert (dom (D3L ++ D3R) [=] dom D3L `union` dom D3R) as J.
            rewrite dom_app; auto. fsetdec.
          rewrite <- J in H0.
          rewrite (dom_lenv_split E D1 ([(x0, lbind_typ T0)] ++ D2 ++ D2R) (D3L ++ D3R)) in H0; auto.
          simpl in H0; auto.
          assert False. fsetdec. tauto.
  Case "lenv_split_right".
    destruct D3L; inversion EQ3.
    SCase "D3L=nil".
      destruct D2L; inversion EQ2.
      SSCase "D2L=nil".
        destruct D3R; inversion EQ3.
        SSSCase "D3R=con".
          destruct D2R; inversion EQ2.
          SSSSCase "D2R=con"; subst; simpl_env in *.
            inversion SL; simpl_env in *.
            inversion WFL; subst.
            apply lenv_split_left; auto.
      SSCase "D2L=con".
        inversion SL.
    SCase "D3L=con".
      subst. simpl_env in *.
      destruct D2L; inversion EQ2.
      SSCase "D2L=nil".
        destruct D2R; inversion EQ2.
        SSSCase "D2R=con".
          subst. simpl_env in *.
          rewrite (dom_lenv_split E D1R ([(x0, lbind_typ T0)] ++ D2R) D3R) in H0; auto.
          simpl in H0.
          assert False. fsetdec. tauto.
      SSCase "D2L=con".
        inversion WFL; subst.
        apply lenv_split_right; subst; auto.
          eapply IHS; auto.
          inversion SL; subst; simpl_env in *.
          SSSCase "SL1".
            assert (dom (D3L ++ D3R) [=] dom D3L `union` dom D3R) as J.
              rewrite dom_app; fsetdec.
            rewrite <- J in H0.
            rewrite (dom_lenv_split E ([(x0, lbind_typ T0)] ++ D1 ++ D1R)
               (D2L ++ D2R) (D3L ++ D3R)) in H0; auto.
            simpl in H0; auto.
            assert False. fsetdec. tauto.
          SSSCase "SL2".
            inversion WFL; auto.
Qed.

Lemma lenv_split_weakening_right: forall E D1L D1R D2L D2R D3L D3R x T,
  lenv_split E (D1L ++ D1R) (D2L ++ D2R) (D3L ++ D3R) ->
  lenv_split E D1L D2L D3L ->
  lenv_split E D1R D2R D3R ->
  wf_lenv E (D3L ++ [(x, lbind_typ T)] ++ D3R) ->
  lenv_split E (D1L ++ D1R) (D2L ++ [(x, lbind_typ T)] ++ D2R) (D3L ++ [(x, lbind_typ T)]++ D3R).
Proof.
  intros.
  apply lenv_split_commute.
  apply lenv_split_weakening_left; try (apply lenv_split_commute; auto); auto.
Qed.

Lemma wf_lenv_lin_weakening: forall E D1 D2 x TX,
  wf_typ E TX kn_lin ->
  wf_lenv E (D1 ++ D2) ->
  x `notin` dom E ->
  x `notin` dom (D1 ++ D2) ->
  wf_lenv E (D1 ++ [(x, lbind_typ TX)] ++ D2).
Proof.
  intros E D1 D2 x TX WFT WFL.
  remember (D1 ++ D2) as D.
  generalize dependent D1. generalize dependent D2.
  (wf_lenv_cases (induction WFL) Case);
    intros D2 D1 EQ NIN1 NIN2.
  Case "wf_lenv_empty".
   destruct D1; destruct D2; inversion EQ; subst; simpl_env in *.
   rewrite_env ([(x, lbind_typ TX)] ++ nil).
   apply wf_lenv_typ; auto.
  Case "wf_lenv_typ".
    destruct D1; destruct D2; inversion EQ; subst; simpl_env in *.
    SCase "D1=nil, D2=con".
      apply wf_lenv_typ; auto.
    SCase "D1=con, D2=nil".
      rewrite_env (D1 ++ [(x, lbind_typ TX)] ++ nil); auto.
    SCase "D1=con, D2=con".
      apply wf_lenv_typ; auto.
Qed.

Lemma lenv_split_cases_app: forall E DL D1 D2 DR,
  lenv_split E D1 D2 (DL ++ DR) ->
  exists D1L, exists D1R, exists D2L, exists D2R,
    lenv_split E D1L D2L DL /\
    lenv_split E D1R D2R DR /\
    D1L ++ D1R = D1 /\
    D2L ++ D2R = D2.
Proof.
  intros E DL.
  induction DL; intros D1 D2 DR S.
  Case "empty".
    exists lempty. exists D1. exists lempty. exists D2.
    simpl_env in *; repeat split; auto.
    apply lenv_split_empty.
      eapply wf_env_from_wf_lenv; eauto.
  Case "cons".
    destruct a. simpl_env in S.
    inversion S; subst.
    SCase "left".
      lapply (IHDL D0 D2 DR); auto.
      intros.
      destruct H as [D1L [D1R [D2L [D2R [S2 [S3 [Q1 Q2]]]]]]].
      exists ([(a, lbind_typ T)] ++ D1L).
      exists D1R.
      exists D2L.
      exists D2R.
      subst; simpl_env in *; repeat split; auto.
    SCase "right".
      lapply (IHDL D1 D3 DR); auto.
      intros.
      destruct H as [D1L [D1R [D2L [D2R [S2 [S3 [Q1 Q2]]]]]]].
      exists D1L.
      exists D1R.
      exists ([(a, lbind_typ T)] ++ D2L).
      exists D2R.
      subst; simpl_env in *; repeat split; auto.
Qed.

Lemma eq_kn_dec: forall (k1 k2:kn), {k1 = k2} + {~k1 = k2}.
Proof.
  decide equality.
Qed.

Lemma eq_typ_dec: forall (t1 t2:typ), {t1 = t2} + {~t1 = t2}.
Proof.
  decide equality.
    apply eq_nat_dec.
    apply eq_kn_dec.
    apply eq_kn_dec.
Qed.

Lemma eq_lbnd_dec: forall (a b:lbinding), {a = b}+{~a=b}.
Proof.
  decide equality.
    apply eq_typ_dec.
Qed.

Lemma eq_lbinding_dec: forall (x y:(atom * lbinding)%type), {x = y}+{~x = y}.
Proof.
  decide equality.
    apply eq_lbnd_dec.
Qed.

Lemma lenv_split_permute: forall E D1 D2 D3,
  lenv_split E D1 D2 D3 ->
  permute D3 (D1 ++ D2).
Proof.
  intros E D1 D2 D3 S.
  (lenv_split_cases (induction S) Case); simpl_env; auto.
  Case "lenv_split_empty".
    apply permute_empty.
  Case "lenv_split_left".
    rewrite_env (lempty ++ [(x, lbind_typ T)] ++ (D1 ++ D2)).
    apply permute_cons; auto.
  Case "lenv_split_right".
    apply permute_cons; auto.
Qed.

Lemma lenv_split_exists_permute: forall E D1 D2 D3 DX,
  lenv_split E D1 D2 D3 ->
  permute D3 DX ->
  exists D1P, exists D2P,
    permute D1 D1P /\
    permute D2 D2P /\
    lenv_split E D1P D2P DX.
Proof.
  intros E D1 D2 D3 DX.
  intros S.
  generalize dependent DX.
  (lenv_split_cases (induction S) Case);
    intros DX PERM; inversion PERM; subst.
  Case "lenv_split_empty".
    exists lempty. exists lempty.
    repeat split; try apply permute_empty; try apply lenv_split_empty.
    auto.
  Case "lenv_split_left".
    lapply (IHS (DL ++ DR)); auto.
    intros EX.
    destruct EX as [D1P [D2P [PERM1 [PERM2 S2]]]].
    lapply (lenv_split_cases_app E DL D1P D2P DR); intros; auto.
    destruct H2 as [D1l [D1R [D2L [D2R [S3 [S4 [Q1 Q2]]]]]]]; subst.
    exists (D1l ++ [(x, lbind_typ T)] ++ D1R).
    exists (D2L ++ D2R).
    repeat split; auto.
      apply permute_cons. auto.
      apply lenv_split_weakening_left; auto.
        apply wf_lenv_lin_weakening; auto.
          rewrite (dom_permute _ D3 (DL ++ DR)) in H0; auto.
  Case "lenv_split_right".
    lapply (IHS (DL ++ DR)); auto.
    intros EX.
    destruct EX as [D1P [D2P [PERM1 [PERM2 S2]]]].
    lapply (lenv_split_cases_app E DL D1P D2P DR); intros; auto.
    destruct H2 as [D1l [D1R [D2L [D2R [S3 [S4 [Q1 Q2]]]]]]]; subst.
    exists (D1l ++ D1R).
    exists (D2L ++ [(x, lbind_typ T)] ++ D2R).
    repeat split; auto.
      apply permute_cons; auto.
      apply lenv_split_weakening_right; auto.
        apply wf_lenv_lin_weakening; auto.
          rewrite (dom_permute _ D3 (DL ++ DR)) in H0; auto.
Qed.

Lemma typing_permute: forall E D1 D2 e t,
  typing E D1 e t ->
  permute D1 D2 ->
  typing E D2 e t.
Proof.
  intros E D1 D2 e t TYP PERM.
  generalize dependent D2.
  (typing_cases (induction TYP) Case);
    intros DX PERM; eauto.
  Case "typing_var".
    inversion PERM; subst; auto.
  Case "typing_lvar".
    inversion PERM; subst.
    inversion H4; subst.
    destruct DL; destruct DR; subst; simpl_env in *;
      try solve [inversion H0].
      apply typing_lvar; auto.
  Case "typing_abs".
    pick fresh x and apply typing_abs; auto.
      intros. lapply H2; intros; auto. subst.
      inversion PERM; auto.
  Case "typing_labs".
    pick fresh x and apply typing_labs; auto.
      apply (H1 x); auto.
        rewrite_env (lempty ++ [(x, lbind_typ T1)] ++ DX).
        apply permute_cons; auto.

        intros. lapply H2; intros; auto. subst.
        inversion PERM; auto.
  Case "typing_app".
    assert (exists D1P, exists D2P,
      permute D1 D1P /\
      permute D2 D2P /\
      lenv_split E D1P D2P DX) as J.
      eapply lenv_split_exists_permute; eauto.
    destruct J as [D1P [D2P [PERM2 [PERM3 S]]]].
    apply (typing_app T1 K E D1P D2P DX); auto.
  Case "typing_tabs".
    pick fresh X and apply typing_tabs; eauto.
Qed.

Lemma typing_split: forall E D3 e T D1 D2,
  typing E (D1 ++ D2) e T ->
  lenv_split E D1 D2 D3 ->
  typing E D3 e T.
Proof.
  intros.
  apply (typing_permute E (D1 ++ D2) D3); auto.
    apply permute_sym; eauto.
      apply eq_lbinding_dec.
      eapply lenv_split_permute; eauto.
Qed.

Lemma wf_lenv_split_both: forall E D1 D2 D3,
  lenv_split E D1 D2 D3 ->
  wf_lenv E (D1 ++ D2).
Proof.
  intros E D1 D2 D3 S.
  (lenv_split_cases (induction S) Case); simpl_env in *; auto.
  Case "lenv_split_left".
    apply wf_lenv_typ; auto.
      rewrite (dom_lenv_split E D1 D2 D3) in H0; auto.
  Case "lenv_split_right".
    apply wf_lenv_lin_weakening; auto.
      rewrite (dom_lenv_split E D1 D2 D3) in H0; auto.
Qed.

Lemma subst_tlb_identity: forall D X T,
  X `notin` fv_lenv D ->
  D = (map (subst_tlb X T) D).
Proof.
  intros D X T H.
  induction D; simpl; auto.
  Case "D=con".
    destruct a. destruct l.
    simpl; simpl in H.
    rewrite <- IHD; auto.
    rewrite <- subst_tt_fresh; auto.
Qed.

Lemma preservation : forall E D e e' T,
  typing E D e T ->
  red e e' ->
  typing E D e' T.
Proof with simpl_env; eauto.
  intros E D e e' T Typ.
  generalize dependent e'.
  (typing_cases (induction Typ) Case);
    intros e' Red; try solve [ inversion Red; subst; eauto ].
  Case "typing_app".
    inversion Red; subst...
    inversion Typ1; subst.
    SCase "typing_abs".
      pick fresh x.
      rewrite (subst_ee_intro x); auto.
      assert (D2 = lempty) as J.
        apply (value_nonlin_inversion E D2 e2 T1); auto.
      subst D2.
      lapply (H11 x); auto.
        intros H0.
        assert (D1 = D3) as J.
          apply (lenv_split_empty_right E D1 D3); auto.
        subst D1.
        rewrite_env (nil ++ E).
        eapply typing_through_subst_ee_nonlin; eauto.
    SCase "typing_labs".
      pick fresh x.
      rewrite (subst_ee_intro x); auto.
      apply (typing_split E D3 (subst_ee x e2 (open_ee e0 x)) T2 D2 D1); auto.
        rewrite_env (lempty ++ D2 ++ D1).
        apply (typing_through_subst_ee_lin E lempty x T1 D1); simpl_env; auto.
          eapply wf_lenv_split_both.
            eapply lenv_split_commute; eauto.
          apply lenv_split_commute; auto.
  Case "typing_tapp".
    inversion Red; subst...
    inversion Typ. subst.
    pick fresh X.
    lapply (H9 X); auto.
      intros.
      rewrite (subst_te_intro X)...
      rewrite (subst_tt_intro X)...
      rewrite_env (map (subst_tb X T) nil ++ E).
      rewrite (subst_tlb_identity D X T); auto.
      apply (typing_through_subst_te K)...
  Case "typing_fst".
    inversion Red; subst...
    inversion Typ; subst...
  Case "typing_snd".
    inversion Red; subst...
    inversion Typ; subst...
Qed.

(* ********************************************************************** *)
(** * Canonical forms *)

Lemma canonical_form_abs : forall e K U1 U2,
  value e ->
  typing nil lempty e (typ_arrow K U1 U2) ->
  exists K1, exists V, exists e1, (e = exp_abs K1 V e1) /\ (K = kn_nonlin -> K1 = kn_nonlin).
Proof.
  intros e K U1 U2 Val Typ.
  remember LinF_Definitions.empty as E.
  remember lempty as D.
  remember (typ_arrow K U1 U2) as T.
  revert U1 U2 HeqT HeqE HeqD.
  (typing_cases (induction Typ) Case);
    intros U1 U2 EQT EQE EQD; subst;
    try solve [ inversion Val | inversion EQT | eauto ].
  Case "typing_abs".
    inversion EQT. subst.
    exists K. exists U1. exists e1. tauto.
  Case "typing_labs".
    inversion EQT. subst.
    exists K. exists U1. exists e1. tauto.
Qed.

Lemma canonical_form_tabs : forall e Q U1,
  value e ->
  typing nil lempty e (typ_all Q U1) ->
  exists V, exists e1, e = exp_tabs V e1.
Proof.
  intros e Q U1 Val Typ.
  remember LinF_Definitions.empty as E.
  remember (typ_all Q U1) as T.
  revert Q U1 HeqT HeqE.
  (typing_cases (induction Typ) Case);
    intros Q U1 EQT EQE; subst;
    try solve [ inversion Val | inversion EQT | eauto ].
Qed.

Lemma canonical_form_with : forall e U1 U2,
  value e ->
  typing nil lempty e (typ_with U1 U2) ->
  exists e1, exists e2, e = exp_apair e1 e2.
Proof.
  intros e U1 U2 Val Typ.
  remember LinF_Definitions.empty as E.
  remember (typ_with U1 U2) as T.
  revert U1 U2 HeqT HeqE.
  (typing_cases (induction Typ) Case);
    intros U1 U2 EQT EQE; subst;
    try solve [ inversion Val | inversion EQT | eauto ].
Qed.

(* ********************************************************************** *)
(** * Progress *)

Lemma progress : forall e T,
  typing nil lempty e T ->
  value e \/ exists e', red e e'.
Proof with eauto.
  intros e T Typ.
  remember LinF_Definitions.empty as E.
  remember lempty as D. generalize dependent HeqE.
  generalize dependent HeqD.
  assert (Typ' : typing E D e T)...
  (typing_cases (induction Typ) Case); intros EQD EQE; subst...
  Case "typing_var".
    inversion H0.
  Case "typing_lvar".
    inversion EQD.
  Case "typing_app".
    right.
    inversion H; subst.
    destruct IHTyp1 as [Val1 | [e1' Rede1']]...
    SCase "Val1".
      destruct IHTyp2 as [Val2 | [e2' Rede2']]...
      SSCase "Val2".
        destruct (canonical_form_abs _ _ _ _ Val1 Typ1) as [K1 [S [e3 [EQE EQK]]]]; subst.
        exists (open_ee e3 e2)...
  Case "typing_tapp".
    right.
    destruct IHTyp as [Val1 | [e1' Rede1']]...
    SCase "Val1".
      destruct (canonical_form_tabs _ _ _ Val1 Typ) as [S [e3 EQ]]; subst.
      exists (open_te e3 T)...
      apply red_tabs; eauto using type_from_wf_typ.
    SCase "e1' Rede1'".
      exists (exp_tapp e1' T)...
      apply red_tapp; eauto using type_from_wf_typ.
  Case "typing_fst".
    right.
    destruct IHTyp as [Val | [e' Rede']]...
    SCase "Val".
      destruct (canonical_form_with _ _ _ Val Typ) as [e1 [e2 EQE]]; subst.
      apply value_regular in Val. inversion Val; subst.
      exists e1...
  Case "typing_snd".
    right.
    destruct IHTyp as [Val | [e' Rede']]...
    SCase "Val".
      destruct (canonical_form_with _ _ _ Val Typ) as [e1 [e2 EQE]]; subst.
      apply value_regular in Val. inversion Val; subst.
      exists e2...
Qed.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-I" "../../../metatheory") ***
*** End: ***
 *)


(*

  Copyright 2016 University of Luxembourg

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

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

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

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

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export String.
Require Export Reals.
Require Export Coq.Lists.List.
Export List.ListNotations.
Require Export Reals.

(**

  This file implements ddl syntax for Terms, Formulas, Hybrid programs and ODEs.
  This is version which works with sorts (KSort).
  This implementation has restriction on KeYmaera core, such that functions can have only one argument.

*)

  (** sorts *)
  Inductive KSort :=
  | KUnit : KSort  (* unit type *)
  | KBool : KSort  (* booleans *)
  | KReal : KSort  (* real numbers *)
  | KProg : KSort  (* programs *)
  | KTuple  (left : KSort) (right : KSort) : KSort (* tuples *)
  | KObject (name : String.string) : KSort. (* user defined object (e.g., lane) *)

  (** variable symbol *)
  Inductive KVariable : (*KSort ->*) Type :=
  | variable (name : String.string) : KVariable(* KReal*).

  (** communication channel *)
  Inductive KChannel : (*KSort ->*) Type :=
  | channel (name : String.string) : KChannel (*KReal*).

  (** program symbol *)
  Definition ProgramConstName := String.string.

  (** function symbol *)
  Definition FunctionSymbol := String.string.

  (** function *)
  Inductive KFunction (domain : KSort) (codomain : KSort) : Type :=
  | function (name : FunctionSymbol) : KFunction domain codomain.

  (** differential symbol *)
  Record KDifferentialSymbol : Type :=
    differentialSymbol
      {
        differentialSymbol_variable :> KVariable
      }.

  (** x or x' *)
  Inductive KAssignable : Type :=
  | KAssignVar     (variable : KVariable)                    : KAssignable
  | KAssignDiffSym (differentialSymbol: KDifferentialSymbol) : KAssignable.

  (** Terms --- see Definition 1, Section 2.1 *)
  (*
     [sd] is the sort of the dot terms occurring (if any) in the term
     Here we assume that all dot terms in a term/formula/program are supposed to
     have the same type.  The idea is that the uniform substitution
       f(.) -> . + h(.)
     where h takes a pair is not supposed to be well-formed because all dots
     should have the same sort as the sort of f's domain.
     Therefore, . + h(.) shouldn't be a well-formed term.
   *)
  Inductive Term (sd : KSort) : KSort -> Type :=
  | KTdot                                                         : Term sd sd        (* dot symbol for terms *)
  | KTnothing                                                     : Term sd KUnit        (* unit term *)
  | KTanything                                                    : Term sd KReal        (* all (reals) term *)
  | KTfuncOf      (d s : KSort)
                  (f : KFunction d s)
                  (a : Term sd d)                                 : Term sd s            (* application of function symbol *)
  | KTnumber      (r : R)                                         : Term sd KReal        (* number constant *)
  | KTread        (var : KAssignable)                             : Term sd KReal        (* read variable x or diff. symbol x' *)
  | KTneg         (child : Term sd KReal)                         : Term sd KReal        (* negation       -x *)
  | KTplus        (left : Term sd KReal)(right : Term sd KReal)   : Term sd KReal        (* addition       x+y *)
  | KTminus       (left : Term sd KReal)(right : Term sd KReal)   : Term sd KReal        (* subtraction    x-y *)
  | KTtimes       (left : Term sd KReal)(right : Term sd KReal)   : Term sd KReal        (* multiplication x*y *)
  | KTdivide      (left : Term sd KReal)(right : Term sd KReal)   : Term sd KReal        (* division       x/y *)
  | KTpower       (left : Term sd KReal)(right : Term sd KReal)   : Term sd KReal        (* power          x^y *)
  | KTdifferential(child : Term sd KReal)                         : Term sd KReal        (* differential   x'  *)
  | KTpair        (s r : KSort)
                  (left : Term sd s)
                  (right : Term sd r)                             : Term sd (KTuple s r)  (* pair          (x,y) *)

  (** Formula --- see Definition 2, Section 2.1 *)
  with Formula (sd : KSort) : Type :=
  | KFdot                                                           : Formula sd           (* dot symbol for formulas *)
  | KFtrue                                                           : Formula sd           (* true *)
  | KFfalse                                                          : Formula sd           (* false *)
  | KFequal       (s : KSort) (left : Term sd s) (right : Term sd s) : Formula sd           (* x == y *)
  | KFnotequal    (s : KSort) (left : Term sd s) (right : Term sd s) : Formula sd           (* x != y *)
  | KFgreaterEqual(left : Term sd KReal)(right : Term sd KReal)      : Formula sd           (* x >= y *)
  | KFgreater     (left : Term sd KReal)(right : Term sd KReal)      : Formula sd           (* x > y  *)
  | KFlessEqual   (left : Term sd KReal)(right : Term sd KReal)      : Formula sd           (* x =< y *)
  | KFless        (left : Term sd KReal)(right : Term sd KReal)      : Formula sd           (* x < y  *)
  | KFpredOf      (d : KSort)
                  (f : KFunction d KBool)
                  (a : Term sd d)                                    : Formula sd           (* appliction of predicate symbol *)
    (* predicational or quantifier symbol applied to argument formula child *)
  | KFpredicationalOf(f : KFunction KBool KBool)(a : Formula sd)  : Formula sd
  | KFnot         (child : Formula sd)                            : Formula sd           (* ~p *)
  | KFand         (left : Formula sd)(right : Formula sd)            : Formula sd           (* p /\ q *)
  | KFor          (left : Formula sd)(right : Formula sd)            : Formula sd           (* p \/ q *)
  | KFimply       (left : Formula sd)(right : Formula sd)            : Formula sd           (* p -> q *)
  | KFequiv       (left : Formula sd)(right : Formula sd)            : Formula sd           (* p <-> q *)
    (* quantifiers *)
  | KFforallVars  (vars : list KVariable) (child : Formula sd)    : Formula sd           (* Forall x,y,z. p *)
  | KFexistsVars  (vars : list KVariable) (child : Formula sd)    : Formula sd           (* Exists x,y,z. p *)
    (* modal formulas *)
  | KFbox         (prog : Program sd) (child : Formula sd)           : Formula sd           (* [alpha] p *)
  | KFdiamond     (prog : Program sd) (child : Formula sd)           : Formula sd           (* <alpha> p *)
    (* differential formula (p)' *)
  | KFdifferentialFormula (child : Formula sd)                     : Formula sd           (* (p)' *)

  (** Hybrid program --- see Definition 3, Section 2.1 *)
  with Program (sd : KSort) : Type :=
  | KPconstant     (name : ProgramConstName)                      : Program sd           (* program constant e.g., alpha *)
  | KPassign       (x : KAssignable) (s : KSort) (e : Term sd s)  : Program sd           (* x := e or x' := e *)
  | KPassignAny    (x : KAssignable)                              : Program sd           (* x := * or x' := * *)
  | KPtest         (cond : Formula sd)                            : Program sd           (* ?cond *)
  | KPchoice       (left : Program sd)(right : Program sd)        : Program sd           (* alpha u beta *)
  | KPcompose      (left : Program sd)(right : Program sd)        : Program sd           (* alpha ; beta *)
  | KPparallel     (Cl : list KChannel)(Cr : list KChannel)
                   (left : Program sd)(right : Program sd)        : Program sd           (* alpha Cl_||_Cr beta *)
  | KPloop         (child : Program sd)                           : Program sd           (* alpha* *)
    (* communication *)
  | KPsend         (c : KChannel) (s : KSort) (e : Term sd s)     : Program sd           (* c!e *)
  | KPreceive      (c : KChannel) (vars : list KVariable)         : Program sd           (* c?X *)
  | KPbroadcast    (c : KChannel)
                   (s : KSort)
                   (e : Term sd s)
                   (vars : list KVariable)                        : Program sd     (* B^c(e,X) *)
  (* todo games *)
  | KPodeSystem (ode : DifferentialProgram sd)(constraint : Formula sd) : Program sd

  (** differential programs *)
  with DifferentialProgram (sd : KSort) : Type :=
  | differentialProgramConst (name : String.string)                                : DifferentialProgram sd (* constant *)
  | atomicODE (xp : KDifferentialSymbol) (s : KSort) (e : Term sd s)                  : DifferentialProgram sd (* x' = e *)
  | differentialProduct (left : DifferentialProgram sd) (right : DifferentialProgram sd) : DifferentialProgram sd (* . , . *)
  (* todo: left associative form of differential product (i.e.: (. , .) , .) -> (. , (. , .)) *)
  .

  (** expressions of dL *)
  Inductive Expression (sd : KSort) : KSort -> Type :=
  | term    (s : KSort) : Term sd s  -> Expression sd s     (* terms *)
  | program             : Program sd -> Expression sd KProg (* programs *)
  | formula             : Formula sd -> Expression sd KBool (* formulas *)
  .


(** * Hoare: Hoare Logic, Part I *)

Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
From PLF Require Import Imp.
From PLF Require Import Maps.

Hint Constructors ceval.

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Definition assert_frame_within_vars_implies (P Q : Assertion) (vars: list string) : Prop :=
  forall st, P st -> exists st', Q st' /\ frame_within_vars st st' vars.

Definition assert_frame_within_vars (P Q : Assertion) (vars: list string) : Prop :=
  assert_frame_within_vars_implies P Q vars /\ assert_frame_within_vars_implies Q P vars.

Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80) : under_spec_scope.
Notation "'D<' vars 'D>' P ->> Q" := (assert_frame_within_vars P Q vars)
                      (at level 10, P at next level, vars at next level, Q at next level) : under_spec_scope.
Open Scope under_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : under_spec_scope.

Definition under_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st', Q st' -> exists st,
      P st /\ c / st \\ st'.

Notation "[[ P ]]  c [[ Q ]]" :=
  (under_triple P c Q) (at level 90, c at next level)
  : under_spec_scope.

Theorem under_post_false : forall (P Q : Assertion) c,
  (forall st, ~ (Q st)) ->
  [[P]] c [[Q]].
Proof.
  intros P Q c H. unfold under_triple.
  intros st' HQ.
  assert (~ (Q st')). auto.
  exfalso. auto.
Qed.

Definition assn_v_n X v P :=
  fun (st : state) =>
    (snd st) X = v /\ P (remove_n st X).

Definition assn_v_l X v P : Assertion :=
  fun (st : state) =>
    (fst st) X = v /\ P (remove_l st X).

Definition assn_sub_n X a P :=
  fun (st : state) =>
    (snd st) X = neval (remove_n st X) a /\ P (remove_n st X).

Definition assn_sub_l X a P : Assertion :=
  fun (st : state) =>
    (fst st) X = leval (remove_l st X) a /\ P (remove_l st X).

Notation "P { X N-> a }" := (assn_v_n X a P) (at level 10).
Notation "P { X L-> a }" := (assn_v_l X a P) (at level 10).
Notation "P { X |N-> a }" := (assn_sub_n X a P) (at level 10).
Notation "P { X |L-> a }" := (assn_sub_l X a P) (at level 10).

Theorem under_asgn_n : forall (P: Assertion) (X: string) (a:nexp) ,
    (forall st, P st -> ((snd st) X = None)) ->
    [[P]] (X N= a) [[P { X |N-> a}]].
Proof.
  unfold under_triple.
  intros P X a HFresh st' HP.
  unfold assn_sub_n in HP.
  destruct HP as [HP1 HP2].
  exists (remove_n st' X).
  split.
  - auto.
  - assert (st' = update_n (remove_n st' X) X (snd st' X)).
    rewrite -> update_after_remove_n. auto.
    rewrite HP1 in H.
    rewrite H at 2.
    apply E_AssN.
    auto.
Qed.

Theorem under_asgn_l : forall (P: Assertion) (X: string) (a:lexp),
    (forall st, P st -> ((fst st) X = None)) ->
    [[P]] (X L= a) [[P { X |L-> a}]].
Proof.
  unfold under_triple.
  intros P X a HFresh st' HP.
  unfold assn_sub_l in HP.
  destruct HP as [HP1 HP2].
  exists (remove_l st' X).
  split.
  - auto.
  - assert (st' = update_l (remove_l st' X) X (fst st' X)).
    rewrite -> update_after_remove_l. auto.
    rewrite HP1 in H.
    rewrite H at 2.
    apply E_AssL.
    auto.
Qed.

Definition assertion_same_besides (P Q: Assertion) (x: string) :=
  (forall st, Q st -> exists nu, (fst st x) = Some nu /\ P (remove_l st x)) /\
    (forall st, P st -> exists nu, P (update_l st x (Some nu))).

Definition frame_pre (P P': Assertion) (arg1 arg2: string) :=
  forall st, P st ->
        exists st' s1 s2,
          P' st'
          /\ (fst st' arg1 = Some s1)
          /\ (fst st' arg2 = Some s2)
          /\ (fst st S1 = Some s1)
          /\ (fst st S2 = Some s2).

Definition frame_post (Q Q': Assertion) (arg1 arg2 ret: string) :=
  forall st', Q' st' ->
         exists st s1 s2 nu,
           Q st
           /\ (fst st' arg1 = Some s1)
           /\ (fst st' arg2 = Some s2)
           /\ (fst st' ret = Some nu)
           /\ (fst st S1 = Some s1)
           /\ (fst st S2 = Some s2)
           /\ (fst st NU = Some nu).

Definition assertion_elim_vars (P P': Assertion) :=
  fun st =>
    P st <-> (exists s1 s2 st',
               st = ({S1 --> s1; S2 --> s2}, empty) /\
                 fst st' S1 = Some s1 /\
                 fst st' S2 = Some s2 /\
                 P' st'
           ).

Definition assertion_clean_pre (P: Assertion) :=
  forall st,
    P st ->
    (forall s,
      ((~(s = S1)) /\ (~(s = S2))) -> fst st s = None) /\ (forall s, snd st s = None).

Definition frame_implies2 (P SpecP: Assertion) (arg1 arg1' arg2 arg2': string) :=
  (forall st, SpecP st ->
         (exists st' s1 s2,
             P st' /\
               fst st arg1 = Some s1 /\
               fst st arg2 = Some s2 /\
               fst st' arg1' = Some s1 /\
               fst st' arg2' = Some s2
  )).

Definition frame_implies3 (P SpecP: Assertion) (arg1 arg1' arg2 arg2' ret ret': string) :=
  (forall st, SpecP st ->
         (exists st' s1 s2 nu,
             P st' /\
               fst st arg1 = Some s1 /\
               fst st arg2 = Some s2 /\
               fst st ret = Some nu /\
               fst st' arg1' = Some s1 /\
               fst st' arg2' = Some s2 /\
               fst st' ret' = Some nu
  )).

Definition pre_apply_frame (P SpecP: Assertion) (arg1 arg1' arg2 arg2': string) :=
  frame_implies2 P SpecP arg1 arg1' arg2 arg2' /\ frame_implies2 SpecP P arg1' arg1 arg2' arg2.

Definition post_apply_frame (P SpecP: Assertion) (arg1 arg1' arg2 arg2' ret ret': string) :=
  frame_implies3 P SpecP arg1 arg1' arg2 arg2' ret ret' /\ frame_implies3 SpecP P arg1' arg1 arg2' arg2 ret' ret.

Definition assertion_forget (Q: Assertion) (x: string) :=
  fun st => fst st x = None /\ (exists nu, Q (update_l st x (Some nu))).

Lemma functional_execution (st st': state) (c: com):
  c / st \\ st' ->
  (forall x v, (fst st x = Some v) -> (fst st' x = Some v)) /\
     (forall x v, (snd st x = Some v) -> (snd st' x = Some v)).
Proof.
Admitted.

Theorem under_asgn_assn : forall (P Q Q': Assertion) (ret arg1 arg2: string) (c: com),
    pre_apply_frame P (assertion_forget Q ret) arg1 S1 arg2 S2 ->
    post_apply_frame Q Q' arg1 S1 arg2 S2 ret NU ->
    [[P]] c [[Q]] ->
    [[assertion_forget Q' ret]] (CAssApply ret c arg1 arg2) [[Q']].
Proof.
  fold under_triple.
  intros P Q Q' ret arg1 arg2 c (_ & HPre) (HPost & _) HC st' HQ.
  unfold frame_implies3 in HPost.
  assert (Q' st') as HQ_dup. auto.
  apply HPost in HQ.
  destruct HQ as (cst' & s1 & s2 & nu & Hspec & Hs1 & Hs2 & Hnu & Hs1' & Hs2' & Hnu').
  exists (remove_l st' ret).
  split.
  - split.
    + admit.
    + exists nu. rewrite <- Hnu. rewrite update_after_remove_l. auto.
  - rewrite <- update_after_remove_l with (x := ret). rewrite Hnu.
    apply HC in Hspec.
    destruct Hspec as (cst & HcP & Hc).
    assert (c / cst \\ cst') as Hc_dup. auto.
    apply functional_execution in Hc.
    destruct Hc as (Hc & _).
    apply HPre in HcP.
    destruct HcP as (_ & s1' & s2' & _ & Hcs1 & Hcs2 & _ & _).
    apply E_AssApply with (s1 := s1) (s2 := s2) (cst := cst) (cst':= cst'); auto.
    + rewrite Hcs1. apply Hc in Hcs1. rewrite <- Hs1'. rewrite Hcs1. auto.
    + rewrite Hcs2. apply Hc in Hcs2. rewrite <- Hs2'. rewrite Hcs2. auto.
    + admit.
    + admit.
    + admit.
Admitted.

(* Theorem under_asgn_assn : forall (P Q P' Q': Assertion) (ret arg1 arg2: string) (c: com), *)
(*     frame_pre P P' arg1 arg2 -> *)
(*     assertion_clean_pre P -> *)
(*     assertion_same_besides P Q ret -> *)
(*     [[P]] c [[Q]] -> *)
(*     frame_post Q Q' arg1 arg2 ret -> *)
(*     assertion_same_besides P' Q' ret -> *)
(*     [[P']] (CAssApply ret c arg1 arg2) [[Q']]. *)
(* Proof. *)
(*   unfold under_triple. *)
(*   intros P Q P' Q' ret arg1 arg2 c HFramePre HCleanPre (HcSame1 & HcSame2) HC HFramePost (HSame1 & HSame2) st' HQ. *)
(*   assert (exists nu, (fst st' ret) = Some nu /\ P' (remove_l st' ret)) as HP'; auto. *)
(*   destruct HP' as (nu & Hst' & HP'). *)
(*   exists (remove_l st' ret). *)
(*   split; auto. *)
(*   rewrite <- update_after_remove_l with (x := ret). *)
(*   rewrite Hst'. *)
(*   apply HFramePost in HQ. *)
(*   destruct HQ as (cst' & s1 & s2 & nu' & HcQ & Harg1 & Harg2 & Hret & Hs1 & Hs2 & Hnu). *)
(*   rewrite Hst' in Hret. subst. *)
(*   inversion Hret. subst. clear Hret. *)
(*   apply HC in HcQ. *)
(*   destruct HcQ as (cst & HP & Hcst). *)
(*   apply HFramePre in HP. *)
(*   destruct HP as (st_dup & s1' & s2' & Hstdup & Harg1' & Harg2' & Hs1' & Hs2'). *)
(*   assert (s1 = s1'). admit. *)
(*   assert (s2 = s2'). admit. *)
(*   subst. *)
(*   assert (cst = ({S1 --> s1'; S2 --> s2'}, empty)). admit. *)
(*   apply E_AssApply with (s1 := s1') (s2 := s2') (cst := cst) (cst':= cst'); auto. *)
(*   admit. *)
(*   admit. *)
(*   admit. *)
(* Admitted. *)

Theorem under_consequence : forall (P P' Q Q' : Assertion) c,
  [[P]] c [[Q]] ->
  P ->> P' ->
  Q' ->> Q ->
  [[P']] c [[Q']].
Proof.
  unfold under_triple.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  intros st' Qst'.
  apply HQ'Q in Qst'.
  assert (exists st : state, P st /\ c / st \\ st'); auto.
  destruct H as [st H].
  destruct H as [H1 H2].
  exists st.
  split; auto. Qed.

(** ** Skip *)

Theorem under_skip : forall P,
     [[P]] SKIP [[P]].
Proof.
  intros P st' HQ.
  exists st'.
  split; auto.
Qed.
(** ** Sequencing *)

Theorem under_seq : forall P Q R c1 c2,
     [[Q]] c2 [[R]] ->
     [[P]] c1 [[Q]] ->
     [[P]] c1;;c2 [[R]].
Proof.
  unfold under_triple.
  intros P Q R c1 c2 H1 H2 st HR.
  apply H1 in HR.
  destruct HR as [st' HQ].
  destruct HQ as [HQ1 HQ2].
  apply H2 in HQ1.
  destruct HQ1 as [st'' HP].
  destruct HP as [HP1 HP2].
  exists st''.
  split; auto.
  eapply E_Seq; eauto.
  Qed.

Definition bassn_true b : Assertion :=
  fun st => (beval st b = Some true).

Definition bassn_false b : Assertion :=
  fun st => (beval st b = Some false).

Lemma bexp_eval_true : forall b st,
  beval st b = Some true -> (bassn_true b) st.
Proof.
  intros b st Hbe.
  unfold bassn_true. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = Some false -> ~ ((bassn_true b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn_true in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

Theorem under_if_true : forall P Q b c1 c2,
  [[fun st => P st /\ bassn_true b st]] c1[[Q]] ->
  [[P]] (IFB b THEN c1 ELSE c2 FI) [[Q]].
Proof.
  intros P Q b c1 c2 HTrue st HQ.
  apply HTrue in HQ.
  destruct HQ as [st' HQ].
  exists st'.
  destruct HQ as [HQ1 HQ2].
  destruct HQ1 as [HQ11 HQ12].
  split; auto.
Qed.

Theorem under_if_false : forall P Q b c1 c2,
    [[fun st => P st /\ bassn_false b st]] c2 [[Q]] ->
    [[P]] (IFB b THEN c1 ELSE c2 FI) [[Q]].
Proof.
  intros P Q b c1 c2 HTrue st HQ.
  apply HTrue in HQ.
  destruct HQ as [st' HQ].
  exists st'.
  destruct HQ as [HQ1 HQ2].
  destruct HQ1 as [HQ11 HQ12].
  split; auto.
Qed.

Definition spec_to_P (spec: list nat -> list nat -> list nat -> Prop) (arg1 arg2: string) : Assertion :=
  fun st =>
    exists s1 s2 nu, spec s1 s2 nu /\ st = ({arg1 --> s1; arg2 --> s2}, empty).

Definition spec_to_Q (spec: list nat -> list nat -> list nat -> Prop) (arg1 arg2 ret: string) : Assertion :=
  fun st =>
    exists s1 s2 nu, spec s1 s2 nu /\ st = ({arg1 --> s1; arg2 --> s2; ret --> nu}, empty).

Theorem under_spec : forall (spec: list nat -> list nat -> list nat -> Prop),
    [[spec_to_P spec S1 S2]] (CSpec spec) [[ spec_to_Q spec S1 S2 NU ]].
Proof.
  unfold spec_to_P, spec_to_Q.
  intros spec st HQ.
  destruct HQ as (s1 & s2 & nu & Hspec & Hst). subst.
  exists ({S1 --> s1; S2 --> s2}, empty).
  split; auto.
  - exists s1, s2, nu. split; auto.
Qed.

(** ** Loops *)

Theorem under_fix : forall P Q (spec: list nat -> list nat -> list nat -> Prop) c,
    pre_apply_frame P (spec_to_P spec S1 S2) S1 S1 S2 S2 ->
    post_apply_frame Q (spec_to_Q spec S1 S2 NU) S1 S1 S2 S2 NU NU ->
    [[P]] subst_self (CSpec spec) c [[Q]] ->
    [[P]] CFix c [[Q]].
Proof.
  intros P Q spec c HPre (_ & Hpost) HC st' HQ.
  apply Hpost in HQ.
  destruct HQ as (cst' & s1 & s2 & nu & Hspec & Hs1 & Hs2 & Hnu & Hs1' & Hs2' & Hnu').
  exists st'.
  split.
  + admit.
  + apply E_Fix.
Admitted.

Fixpoint mem (l : list nat) (x: nat) :=
  match l with
  | nil => false
  | cons h t => (if Nat.eqb h x then true else mem t x)
  end.

Fixpoint dup (l : list nat) :=
  match l with
  | nil => false
  | cons h t =>
      if mem t h then true else dup t
  end.

Fixpoint twice (l : list nat) (x: nat) :=
  match l with
  | nil => false
  | cons h t => (if Nat.eqb h x then mem t x else twice t x)
  end.

Fixpoint dup3 (l : list nat) :=
  match l with
  | nil => false
  | cons h t =>
      if twice t h then true else dup3 t
  end.

Definition concat_spec1 := fun (s1 s2 nu: list nat) => s1 = nil /\ nu = s2.
Definition concat_spec2 := fun (s1 s2 nu: list nat) =>
                             (~ (s1 = nil)) /\ (dup s1 = false) /\ (dup s2 = false) /\
                               (forall x, ~ (mem s1 x = true /\ mem s2 x = true)) /\
dup nu .

Definition concat_spec :=
  fun (s1 s2 nu: list nat) =>
    (dup s1 = false) /\ (dup s2 = false) /\ (forall x, ~ (mem s1 x = true /\ mem s2 x = true)) /\.

Definition concat_P1: Assertion :=
  fun st =>
    exists s1 s2,
      concat_pre1 s1 s2 /\ st = ({S1 --> s1; S2 --> s2}, empty).

Definition concat_Q1: Assertion :=
  fun st =>
    (exists s1 s2,
      concat_post1 s1 s2 s2
      /\ st = ({S1 --> s1 ; S2 --> s2 ; NU --> s2}, empty))
      \/
    (exists s1 s2 nu h t s3,
      concat_post1 s1 s2 nu
      /\ st = ({S1 --> s1; S2 --> s2; T --> t; S3 --> s3; NU --> nu}, {H --> h})
      /\ s1 = (cons h t) /\ nu = (cons h s3)).

Theorem concat_verification: [[concat_P1]] concat_program  [[concat_Q1]].
Proof.
  unfold concat_P1.
  unfold concat_Q1.
  unfold concat_program.
  remember concat_pre1 as Pre.
  remember concat_post1 as Post.
  (* unfold concat_pre1 in HeqPre. *)
  (* unfold concat_post1 in HeqPost. *)
  apply under_fix with (Pre:= Pre) (Post:= Post).
  - assert (assertion_clean_pre (fun st : state => exists s1 s2 : list nat, Pre s1 s2 /\ st = ({S1 --> s1; S2 --> s2}, empty))).
    { unfold assertion_clean_pre.
      intros st (s1 & s2 & HPre & H). subst. split; auto. admit. }
    unfold pre_is_assertion. split. auto. split.
    intros st H0.
    destruct H0 as (s1 & s2 & HPre & H0); subst. exists s1, s2. split; auto.
    intros s1 s2 H0.
    exists ({S1 --> s1; S2 --> s2}, empty). split; auto. split; auto.
    exists s1, s2. split; auto.
 - unfold post_is_assertion. split.
   + intros. destruct H.
     destruct H as (s1 & s2 & H1 & H2); subst. exists s1, s2, s2. split; auto.
     destruct H as (s1 & s2 & nu & h & t & s3 & H1 & H2 & H3 & H4). subst. exists (cons h t), s2, (cons h s3). split; auto.
   + intros s1 s2 nu HPost.
     assert ()

    destruct H0 as (s1 & s2 & H1 & H2 & HPre). exists s1, s2. split; auto.
    unfold assertion_clean_pre in H.


(*
Copyright © 2007-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

(* Backwards compatibility for Typeclasses Transparent locality attributes *)
Set Warnings "-unsupported-attributes".

Set Implicit Arguments.

Require Export Coq.Setoids.Setoid.
Require Import MathClasses.interfaces.abstract_algebra.

(**
* Classic Setoids presented in a bundled way.
*
* THIS NOTION IS OBSOLETE AND SHOULD NOT BE USED ANYMORE
* Use [abstract_algebra.Setoid] instead
*)

Structure RSetoid: Type :=
{ st_car :> Type;
  st_eq : Equiv st_car ;
  st_isSetoid : Setoid st_car
}.

#[global]
Typeclasses Transparent Equiv.
#[global]
Hint Extern 10 (Equiv _) => apply @st_eq : typeclass_instances.
#[global]
Hint Extern 10 (Setoid _) => apply @st_isSetoid  : typeclass_instances.

Arguments st_eq [r].

Definition mcSetoid_as_RSetoid X {e : Equiv X} {setoid : Setoid X} : RSetoid := Build_RSetoid setoid.
Arguments mcSetoid_as_RSetoid X {e setoid}.

(* Canonical Structure mcSetoid_as_RSetoid. *)
(* If we make this a canonical structure StepQsec will break: investigate *)

(** Propositions form a setoid under iff *)
Definition iffSetoid : RSetoid.
Proof.
 eexists Prop iff.
 firstorder.
Defined.

(**
** Morhpisms between Setoids
*)
Record Morphism (X Y : RSetoid) :=
{evalMorphism :> X -> Y
;Morphism_prf : forall x1 x2, (st_eq x1 x2) -> (st_eq (evalMorphism x1) (evalMorphism x2))
}.

Definition extEq (X:Type) (Y : RSetoid) (f g:X -> Y) := forall x, st_eq (f x) (g x).
Definition extSetoid (X Y : RSetoid) : RSetoid.
Proof.
 eexists (Morphism X Y) (extEq Y).
 split.
   intros x y; reflexivity.
  intros x y H a; symmetry; auto.
 intros x y z Hxy Hyz a; transitivity (y a); auto.
Defined.

Notation "x --> y" := (extSetoid x y) (at level 55, right associativity) : setoid_scope.

Local Open Scope setoid_scope.
(**
** Basic Combinators for Setoids
*)

Definition id (X : RSetoid) : X-->X.
Proof.
 eexists (fun x => x).
 abstract (auto).
Defined.
(* begin hide *)
Arguments id {X}.
(* end hide *)
Definition compose0 X Y Z (x : Y ->Z) (y:X -> Y) z := x (y z).

Definition compose1 (X Y Z : RSetoid) : (Y-->Z) -> (X --> Y) -> X --> Z.
Proof.
 intros f0 f1.
 exists (compose0 f0 f1).
 abstract ( destruct f0 as [f0 Hf0]; destruct f1 as [f1 Hf1]; intros x1 x2 Hx; apply Hf0; apply Hf1;
   assumption).
Defined.

Definition compose2 (X Y Z : RSetoid) : (Y-->Z) -> (X --> Y) --> X --> Z.
Proof.
 intros f0.
 eexists (compose1 f0).
 abstract ( destruct f0 as [f0 Hf0]; intros x1 x2 H y; apply Hf0; apply H).
Defined.

Definition compose (X Y Z : RSetoid) : (Y-->Z) --> (X --> Y) --> X --> Z.
Proof.
 exists (@compose2 X Y Z).
 abstract ( intros x1 x2 H y z; apply H).
Defined.
(* begin hide *)
Arguments compose {X Y Z}.
(* end hide *)
Definition const0 (X Y : RSetoid) : X->Y-->X.
Proof.
 intros x.
 eexists (fun y => x).
 abstract reflexivity.
Defined.

Definition const (X Y : RSetoid) : X-->Y-->X.
Proof.
 exists (@const0 X Y).
 abstract ( intros x1 x2 Hx y; assumption).
Defined.
(* begin hide *)
Arguments const {X Y}.
(* end hide *)
Definition flip0 (X Y Z : RSetoid) : (X-->Y-->Z)->Y->X-->Z.
Proof.
 intros f y.
 exists (fun x => f x y).
 abstract ( destruct f as [f Hf]; intros x1 x2 H; apply Hf; auto).
Defined.

Definition flip1 (X Y Z : RSetoid) : (X-->Y-->Z)->Y-->X-->Z.
Proof.
 intros f.
 exists (flip0 f).
 abstract ( destruct f as [f Hf]; intros x1 x2 H y; simpl; destruct (f y) as [g Hg]; apply Hg; auto).
Defined.

Definition flip (X Y Z : RSetoid) : (X-->Y-->Z)-->Y-->X-->Z.
Proof.
 exists (@flip1 X Y Z).
 abstract ( intros x1 x2 H y z; apply H).
Defined.
(* begin hide *)
Arguments flip {X Y Z}.
(* end hide *)
Definition join0 (X Y : RSetoid) : (X-->X-->Y)->X-->Y.
Proof.
 intros f.
 exists (fun y => f y y).
 abstract ( destruct f as [f Hf]; intros x1 x2 H; simpl; transitivity (f x1 x2);
   [destruct (f x1) as [g Hg]; apply Hg; auto |apply Hf; auto]).
Defined.

Definition join (X Y : RSetoid) : (X-->X-->Y)-->X-->Y.
Proof.
 exists (@join0 X Y).
 abstract ( intros x1 x2 H y; apply H).
Defined.
(* begin hide *)
Arguments join {X Y}.
(* end hide *)
Definition ap (X Y Z : RSetoid) : (X --> Y --> Z) --> (X --> Y) --> (X --> Z)
:= compose (compose (compose (@join _ _)) (@flip _ _ _)) (compose (@compose _ _ _)).
(* begin hide *)
Arguments ap {X Y Z}.
(* end hide *)

Definition bind (X Y Z : RSetoid) : (X--> Y) --> (Y --> X--> Z) --> (X--> Z):=
(compose (compose (@join _ _)) (flip (@compose X Y (X-->Z)))).

Definition bind_compose (X Y Z W : RSetoid) :
 (W--> X--> Y) --> (Y --> X--> Z) --> (W--> X--> Z):=
 (flip (compose (@compose W _ _) ((flip (@bind X Y Z))))).
(* begin hide *)
Arguments bind {X Y Z}.
Arguments bind_compose {X Y Z W}.
(* end hide *)


(** * ImpProp: DEFUNCT? *)
Require Import Equalities Arith.
Require Import Vminus.Atom Vminus.Env.
Require Import Vminus.Sequences.

Require Import Vminus.Imp.

Local Open Scope imp_scope.

(* ################################################################# *)
(** * Old Stuff *)
Lemma imp_step_star_seq_append:
  forall p1 p2, imp_step_star p1 p2 ->
           forall c1 c2 c st1 st2,
             p1 = (c1, st1) -> p2 = (c2, st2) ->
             imp_step_star (c1 ;; c, st1) (c2 ;; c, st2).
Proof.
  intros p1 p2 imp_step_p1.
  induction imp_step_p1 as
      [[c1' st1'] | [c1' st1'] [c_step st_step] [c_final st_final]];
    intros c1 c2 c st st2 p1_eq p2_eq; inversion p1_eq; inversion p2_eq; subst.
  - apply star_refl.
  - apply star_step with (b := (c_step ;; c, st_step)).
    apply S_Seq.
    trivial.
    apply IHimp_step_p1; reflexivity.
Qed.

Lemma imp_step_star_trans: forall c1 c2 st1 st2 st,
  imp_step_star (c1, st1) (SKIP, st) ->
  imp_step_star (c2, st) (SKIP, st2) ->
  imp_step_star (c1 ;; c2, st1) (SKIP, st2).
Proof.
  intros c1 c2 st1 st2 st imp1 imp2; unfold imp_step_star in *.
  inversion imp1; subst.
  - eapply star_step.
    apply S_SeqSkip.
    trivial.
  - apply star_trans with (b := (SKIP ;; c2, st)).
    apply imp_step_star_seq_append with (p1 := (c1, st1)) (p2 := (SKIP, st));
      trivial.
    eapply star_step.
    apply S_SeqSkip.
    trivial.
Qed.

Lemma imp_step_star_seq_inversion:
  forall p1 p2, imp_step_star p1 p2 ->
           forall c1 c2 sta stc,
             p1 = (c1 ;; c2, sta) ->
             p2 = (SKIP, stc) ->
             exists stb, imp_step_star (c1, sta) (SKIP, stb) /\
                    imp_step_star (SKIP ;; c2, stb) (SKIP, stc).
Proof.
  intros p1 p2 imp_step_p1.
  induction imp_step_p1 as [| [cseq' sta'] p [skip' stc'] Hstep];
    intros c1 c2 sta stc p1_eq p2_eq;
    try solve [rewrite p1_eq in p2_eq; inversion p2_eq].
  inversion p1_eq; inversion p2_eq; subst.
  clear p1_eq; clear p2_eq.
  destruct c1.
  - inversion Hstep as
        [ | sta' ? ? ? ? H | sta' c2' [c2_eq sta_eq] p_eq | | | ];
      [inversion H | idtac].
    subst.
    exists sta.
    split; [apply star_refl | idtac].
    eapply star_step; [apply S_SeqSkip | trivial].
  - inversion Hstep.
    rename H3 into step_sta.
    inversion step_sta.
    exists (update sta i (aeval a sta)).
    subst.
    split; auto.
    eapply star_step; [apply step_sta | apply star_refl].
  - inversion Hstep.
    rename st' into one_step_after_sta;
      rename c1' into c11';
      rename H0 into p_eq;
      rename H3 into step_c1_1.
    rewrite <- p_eq in Hstep.
    clear H1 H2 c0.
    generalize
      (IHimp_step_p1 c11' c2 one_step_after_sta stc (symmetry p_eq) eq_refl);
      intros IH.
    inversion IH as [stb [imp1 imp2]].
    exists stb.
    split;
      [eapply star_step;
       [apply step_c1_1 | apply imp1] |
       apply imp2].
  - inversion Hstep.
    rename st' into one_step_after_sta;
      rename c1' into c1';
      rename H3 into step_c1;
      rename H0 into p_eq.
    clear H1 H2 c0.
    generalize
      (IHimp_step_p1 c1' c2 one_step_after_sta stc (symmetry p_eq) eq_refl);
      intros IH.
    inversion IH as [stb [imp1 imp2]].
    exists stb.
    split;
      [eapply star_step;
       [apply step_c1 | apply imp1] |
       apply imp2].
  - inversion Hstep.
    rename st' into one_step_after_sta;
      rename c1' into c1';
      rename H3 into step_c1;
      rename H0 into p_eq.
    clear H H1 H2 c0.
    generalize
      (IHimp_step_p1 c1' c2 one_step_after_sta stc (symmetry p_eq) eq_refl);
      intros IH.
    inversion IH as [stb [imp1 imp2]].
    exists stb.
    split;
      [eapply star_step;
       [apply step_c1 | apply imp1] |
       apply imp2].
Qed.

Ltac cases_on_imp_eval :=
  match goal with
  | H: match ?imp_eval with
          | Some _ => _
          | None => _
       end = _ |- _ =>
    destruct imp_eval as [middle_st | ] eqn:middle_st_eq;
    try solve [inversion H]
  end.

Theorem imp_eval_sound: forall fuel c st st',
    imp_eval c st fuel = Some st' -> imp_step_star (c, st) (SKIP, st').
Proof.
  induction fuel as [| n]; intros c st st' eval_ok;
    try solve [inversion eval_ok].
  destruct c.
  { simpl in eval_ok; inversion eval_ok; apply star_refl. }
  { simpl in eval_ok; inversion eval_ok; subst.
    eapply star_step.
    apply S_Ass.
    reflexivity.
    apply star_refl.
  }
  { simpl in eval_ok.
    destruct c1;
      try solve [eapply star_step;
                 [apply S_SeqSkip |
                  apply IHn;
                  trivial]];
      try solve [cases_on_imp_eval;
                 generalize (IHn _ _ _ middle_st_eq); intros imp_single_step;
                 eapply imp_step_star_trans;
                 [apply imp_single_step |
                  apply IHn;
                  trivial]].
  }
  { simpl in eval_ok.
    destruct (beval b st) eqn:eval_b;
      apply IHn in eval_ok.
    - eapply star_step; [apply S_IfTrue; trivial | trivial].
    - eapply star_step; [apply S_IfFalse; trivial | trivial].
  }
  { simpl in eval_ok.
    destruct (beval b st) eqn:eval_b;
      try solve [inversion eval_ok].
    apply IHn in eval_ok.
    eapply (imp_step_star_seq_inversion _ _) in eval_ok;
      [idtac | reflexivity | reflexivity].
    inversion eval_ok as [st_after_iter [after_one_iter the_rest]].
    eapply star_trans; [idtac | apply the_rest].
    eapply star_step; [apply S_While | idtac].
    eapply star_step; [apply S_IfTrue; trivial | idtac].
    apply (imp_step_star_seq_append _ _ after_one_iter); reflexivity.
  }
Qed.


(* Sequent Calculus for First-Order Additive Linear Logic *)

From Coq Require Import Wf_nat Lia.
From Quantifiers Require Import foformulas_ext.

Set Implicit Arguments.

Parameter vatom : DecType.
Parameter tatom : Type.
Parameter fatom : Type.
Inductive Ncon := top_con.
Inductive Bcon := wth_con.
Inductive Qcon := frl_con.

Notation term := (@term vatom tatom nat).
Notation closed t := (tvars t = nil).
Notation rclosed r := (forall n, closed (r n)).
Notation "↑ r" := (felift (evar 0) r) (at level 25, format "↑ r").
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").
Notation "A ⟦ r ⟧" := (esubs r A) (at level 8, left associativity, format "A ⟦ r ⟧").
Notation "A [ u // x ]" := (subs x u A) (at level 8, format "A [ u // x ]").
Notation "⇑" := fup.
Notation "A ↑" := (A⟦⇑⟧) (at level 8, format "A ↑").
Notation "x ∈ A" := (In x (freevars A)) (at level 30).
Notation "x ∉ A" := (~ In x (freevars A)) (at level 30).

Notation formula := (@formula vatom tatom fatom Ncon Nocon Bcon Qcon nat).
(*
Notation top := (fnul nat top_con).
Notation wth := (fbin wth_con).
Notation frl := (fqtf frl_con).
*)
Notation "⟙" := (fnul nat top_con).
Infix "﹠" := (fbin wth_con) (at level 50).
Notation "∀" := (fqtf frl_con).

#[local] Hint Rewrite (@felift_esubs vatom tatom fatom Ncon Nocon Bcon Qcon) : term_db.
#[local] Hint Rewrite (@freevars_fup vatom tatom fatom Ncon Nocon Bcon Qcon) : term_db.
#[local] Hint Rewrite (@esubs_fup vatom tatom fatom Ncon Nocon Bcon Qcon) : term_db.
#[local] Hint Rewrite (@nfree_subs vatom tatom fatom Ncon Nocon Bcon Qcon nat) using intuition; fail : term_db.

#[local] Hint Resolve closed_fesubs : term_db.
#[local] Hint Resolve closed_felift : term_db.
#[local] Hint Rewrite (@subs_esubs vatom tatom fatom Ncon Nocon Bcon Qcon nat)
                        using try (intuition; fail);
                              try apply no_ecapture_not_egenerated; try (intuition; fail);
                              try apply closed_no_ecapture; intuition; fail : term_db.

(** * Proofs *)

(** Proofs *)
(** two-sided sequent calculus for first-order (additive) linear logic with connectives:
    top, with, forall *)
Inductive prove : formula -> formula -> Type :=
| ax : forall A, prove A A
| topr : forall C, prove C ⟙
| wdgr { C A B } : prove C A -> prove C B -> prove C (A﹠B)
| wdgll { A C } : forall B, prove A C -> prove (A﹠B) C
| wdglr { A C } : forall B, prove A C -> prove (B﹠A) C
| frlr { x C A } : prove C↑ A↑[evar 0//x] -> prove C (∀x A)
| frll { x A C } : forall u, closed u -> prove A[u//x] C -> prove (∀x A) C.
#[local] Hint Constructors prove : term_db.

(** height of proofs *)
Fixpoint psize {A B} (pi : prove A B) : nat :=
match pi with
| ax _ => 1
| topr _ => 1
| wdgr pi1 pi2 => S (max (psize pi1) (psize pi2))
| wdgll _ pi1 => S (psize pi1)
| wdglr _ pi1 => S (psize pi1)
| frlr pi1 => S (psize pi1)
| frll _ _ pi1 => S (psize pi1)
end.

(** apply [r] in proof [pi] *)
Theorem pesubs r (Hc : rclosed r) C A (pi : prove C A) :
  { pi' : prove C⟦r⟧ A⟦r⟧ & psize pi' = psize pi }.
Proof.
revert r Hc; induction pi; intros r Hc;
  try (destruct (IHpi r) as [pi' Hs]);
  try (destruct (IHpi1 r) as [pi1' Hs1]);
  try (destruct (IHpi2 r) as [pi2' Hs2]); intuition.
- now exists (ax _).
- now exists (topr _).
- exists (wdgr pi1' pi2') ; simpl ; auto.
- exists (wdgll _ pi') ; simpl ; auto.
- exists (wdglr _ pi') ; simpl ; auto.
- clear pi' Hs; destruct (IHpi (↑r)) as [pi' Hs]; intuition.
  cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  exists (frlr pi'). reflexivity.
- cbn. rewrite <- Hs. clear Hs.
  rnow revert pi'.
  rewrite <- (tvars_tesubs_closed r _ Hc) in e.
  exists (frll _ e pi'). reflexivity.
Qed.

(** * Cut Elimination *)

Theorem cutr : forall A B C, prove A B -> prove B C -> prove A C.
Proof.
enough (IH : forall n, forall A B C (pi1 : prove A B) (pi2 : prove B C),
          n = psize pi1 + psize pi2 -> prove A C)
  by (intros A B C pi1 pi2 ; apply (IH _ _ _ _ pi1 pi2 eq_refl)).
induction n as [n IH0] using lt_wf_rect; intros; subst.
assert (IH : forall A B C (pi1' : prove A B) (pi2' : prove B C),
               psize pi1' + psize pi2' < psize pi1 + psize pi2 -> prove A C)
  by (intros; eapply IH0; [ eassumption | reflexivity ]); clear IH0.
destruct pi2; intuition.
- apply wdgr.
  + apply (IH _ _ _ pi1 pi2_1). cbn. lia.
  + apply (IH _ _ _ pi1 pi2_2). cbn. lia.
- enough (forall A D (pi1 : prove A D) A0 B C (pi2 : prove A0 C)
              (IH : forall A1 B0 C0 (pi1' : prove A1 B0) (pi2' : prove B0 C0),
                psize pi1' + psize pi2' < psize pi1 + psize (wdgll B pi2) -> prove A1 C0),
         D = A0﹠B -> prove A C)
    as IH2 by (eapply IH2; [ eassumption | reflexivity ]); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst;
    try (constructor ; apply (IH _ _ _ pi1 (wdgll _ pi2)); cbn; lia).
  + now apply wdgll.
  + apply (IH _ _ _ pi1_1 pi2). cbn. lia.
  + apply (frll u); [ assumption | ].
    apply (IH _ _ _ pi1 (wdgll _ pi2)). cbn. lia.
- enough (forall A D (pi1 : prove A D) A0 B C (pi2 : prove A0 C)
              (IH : forall A1 B0 C0 (pi1' : prove A1 B0) (pi2' : prove B0 C0),
                 psize pi1' + psize pi2' < psize pi1 + psize (wdglr B pi2) -> prove A1 C0),
         D = B﹠A0 -> prove A C)
    as IH2 by (eapply IH2; [ eassumption | reflexivity ]); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst;
    try (constructor; apply (IH _ _ _ pi1 (wdglr _ pi2)); cbn; lia).
  + now apply wdglr.
  + apply (IH _ _ _ pi1_2 pi2). cbn. lia.
  + apply (frll u); [ assumption | ].
    apply (IH _ _ _ pi1 (wdglr _ pi2)). cbn. lia.
- destruct (pesubs ⇑ closed_fup pi1) as [pi1' Hs].
  apply frlr.
  apply (IH _ _ _ pi1' pi2); simpl; lia.
- enough (forall A D (pi1 : prove A D) x A0 C u e (pi2 : prove A0[u//x] C)
              (IH : forall A1 B C0 (pi1' : prove A1 B) (pi2' : prove B C0),
                 psize pi1' + psize pi2' < psize pi1 + psize (frll u e pi2) -> prove A1 C0),
         D = ∀ x A0 -> prove A C)
    as IH2 by (eapply IH2; [ eassumption | reflexivity ]); clear.
  intros A D pi1; destruct pi1; intros; inversion H; subst;
    try (constructor; apply (IH _ _ _ pi1 (frll _ e pi2)); simpl; lia).
  + now apply (frll u).
  + destruct (pesubs (u⇓) (closed_fesubs _ e) pi1) as [pi1' Hs].
    simpl in IH; rewrite <- Hs in IH; clear Hs.
    revert pi1' IH; rnow idtac.
    apply (IH _ _ _ pi1' pi2); lia.
  + apply (frll u); [ assumption | ].
    apply (IH _ _ _ pi1 (frll _ e0 pi2)). cbn. lia.
Qed.

(** * Hilbert style properties *)

Lemma frl_elim : forall A u x, closed u -> prove (∀ x A) A[u//x].
Proof. intros A u x Hc; apply (frll u); auto with term_db. Qed.

Lemma frl_wth : forall A B x, prove (∀ x (A﹠B)) (∀ x A ﹠ ∀ x B).
Proof.
intros A B x.
repeat constructor; simpl;
  apply (frll (evar 0)); simpl; do 2 constructor.
Qed.

Lemma frl_nfree : forall A x, x ∉ A -> prove A (∀ x A).
Proof.
intros A x Hnf.
apply frlr.
rnow rewrite nfree_subs.
Qed.

(** * Other properties *)

(** Axiom expansion *)
Lemma ax_exp : forall A, prove A A.
Proof.
enough (Hn : forall n A, fsize A = n -> prove A A)
  by (intros A; eapply Hn; reflexivity).
induction n as [n IH] using lt_wf_rect; intros; subst.
destruct A; [ | destruct n | destruct n | destruct b | destruct q ].
- apply ax.
- apply topr.
- apply wdgr; [ apply wdgll | apply wdglr ]; (eapply IH; [ | reflexivity ]); simpl; lia.
- apply frlr; rnow apply (frll (evar 0)).
Qed.