(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** ** Completeness of Focusing
Here we prove the completeness theorem for the focused system
*)

Require Export SequentCalculi.
Require Export StructuralRules.
Require Export Permutation.
Require Import Coq.Relations.Relations.
Require Import Coq.Arith.EqNat.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sorting.PermutEq.
Require Import Coq.Program.Equality.

Set Implicit Arguments.

(* *** Invertibility lemmas
This module proves that the application of positive rules can be exchanged
*)
Module InvLemmas (DT : Eqset_dec_pol).
  Module Export SR := SRule DT.

  (*******************************************************************)
  (* Some automation *)
  Hint Rewrite Neg2pos Ng_involutive.
  Hint Constructors Asynchronous.
  Hint Constructors IsNegativeAtom.
  Hint Resolve l_nil l_sin l_cos.
  Hint Constructors NotAsynchronous.
  Hint Unfold Release.
  Hint Constructors release.
  (* End Automation section *)
  (*************************************************************)

  (* =============================================== *)
  (** Invertibility of Copy *)
  (* =============================================== *)
  Module InvCopy.

    Definition RUp (n:nat) := forall B L  F  M ,
      LexpPos M ->
      n |-F- B ++ [F] ;M ; UP (L ++ [F])  -> |-F- B ++ [F] ; M ; UP (L ).

    Definition RDown (n:nat) := forall B  F  M  H,
        LexpPos M -> ~ Asynchronous F ->
        n |-F- B ++ [F]; M ++ [F]  ; DW H -> |-F- B ++ [F] ; M  ; DW H.

    Definition RInd (n:nat) := RUp n /\ RDown (n -1).

    Lemma RDown0 : RDown 0.
    Proof with InvTac.
      unfold RDown.
      intros.
      inversion H2;subst ; try(contradiction_multiset).
      destruct M;  simpl in *.
      inversion H3 ...
      eapply tri_init2 ...
      inversion H3; contradiction_multiset.
    Qed.

    Lemma RUp0 : RUp 0.
    Proof with InvTac.
      unfold RUp.
      intros.
      destruct L.
      + inversion H0;subst.
        simpl.
        eapply tri_dec2 with (F:= ⊤) ...
      + inversion H0 ...
    Qed.

    (* =============================================== *)
    (* PROOF OF RUP *)
    (* =============================================== *)

    Theorem InvCopyUP: forall  n , (forall m : nat, m <= n -> RInd m) -> RUp (S n).
    Proof with InvTac.
      intros n IH.
      unfold RUp.  intros B L1 F M1 HM1pos HD1.
      destruct L1;simpl in *.
      + (* L1 is Empty *)
        inversion HD1;subst ...
        ++ (* bot *)
          eapply AdequacyTri1;eauto.
        ++ (* par *)
          eapply tri_dec2 with (F:=F0 $ G) ...
          eapply tri_rel ...  eapply tri_par ... eapply AdequacyTri1;eauto.
        ++ (* with *)
          eapply tri_dec2 with (F:=F0 & G) ...
          eapply tri_rel ...  eapply tri_with;eapply AdequacyTri1;eauto.
        ++ (* quest *)
          eapply tri_dec2 with (F:=? F0) ...
          eapply tri_rel ...  eapply tri_quest ... eapply AdequacyTri1;eauto.
        ++ (* store *)
          assert(RInd n) by ( apply IH;auto).
          destruct H as [HUp  HDown].
          inversion H5;subst ...
          +++ (* Decide 1 *)
            rewrite union_comm in H0.
            simpl_union_context;subst.
            rewrite <- HeqM in H1.
            eapply tri_dec2 with (F:= F0) ...
            eapply AdequacyTri1;eauto.

            rewrite H0 in H1. rewrite H2.

            assert( |-F- B ++ [F]; L1; DW F0).
            apply HDown ...
            rewrite H2 in HM1pos. inversion HM1pos; auto.

            assert (Hm : F :: L1 =mul= L1 ++ [F]) by  solve_permutation.
            rewrite <- Hm.
            auto.
            eapply tri_dec1 with (F:= F0) ...
          +++ (* Decide 2 *)
            assert( |-F- B ++ [F]; M1; DW F0).
            apply HDown ...
            eapply tri_dec2 with (F:=F0) ...
        ++ (* forall *)
          eapply tri_dec2 with (F:=F{ FX}) ...
          eapply tri_rel ...
          eapply tri_fx ...
          intro.
          generalize (H3 x);intro.
          eapply AdequacyTri1;eauto.
      + (* L is not empty *)
        inversion HD1;subst; try(
                                 assert(RInd n) by ( apply IH;auto);
                                 destruct H as [HUp  HDown]; clear HDown) ...

        ++ (* & *)
          assert(H: RInd n0) by ( apply IH;auto);
            destruct H as [HUp  HDown]; clear HDown.
          assert(H: RInd m) by ( apply IH;auto);
            destruct H as [HUp'  HDown']; clear HDown'.
          unfold RUp in HUp.
          eapply HUp with (L:= F0::L1) in H4 ...
        ++ (* ? *)
          unfold RUp in HUp.
          assert(Hm: (B ++ [F]) ++ [F0] =mul=  (B ++ [F0]) ++ [F]) by solve_permutation.
          rewrite Hm in H3.
          eapply HUp with (B:= B ++ [F0]) in H3 ...
          apply tri_quest ...
          rewrite Hm ...
        ++ (* store *)
          apply HUp in H5 ...
        ++ (* forall *)
          apply tri_fx;intro.
          generalize (H3 x);intro.
          unfold RUp in HUp.
          eapply HUp with (L:= Subst FX x :: L1) in H ...
    Qed.

    (* =============================================== *)
    (* PROOF OF RDOWN *)
    (* =============================================== *)

    Theorem InvCopyDW: forall  n , (forall m : nat, m <= n -> RInd m) -> RDown (n).
    Proof with InvTac.
      intros n IH.
      unfold RDown.  intros B F M H  HM1pos HPosF  HD1.
      caseLexp H;subst;InvTac; inversion HD1;subst ...
      ++ (* atom 1 *)
        eapply tri_init2 ...
      ++ (* atom 2 *)
        apply UpExtension in H5 ...
        destruct H5.
        destruct H.
        assert(HRI: RInd x)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown]. clear HDown.
        apply HUp in H2 ...
      ++ (* perp1 *)
        eapply tri_init2 ...
      ++ (* perp2 *)
        apply UpExtension in H5 ...
        destruct H5.
        destruct H.
        assert(HRI: RInd x)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown]. clear HDown.
        apply HUp in H2 ...
      ++ (* bbot *)
        apply UpExtension in H4 ...
        destruct H4 as [m H4]. destruct H4 as [H4 H4'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* tensor *)
        symmetry in H2.
        assert(HC: M ++ [F] =mul= [F] ++ M) by solve_permutation; rewrite HC in H2;clear HC.
        (* 2 choices: F is M0 or in N0 *)
        simpl_union_context.
        +++ rewrite union_comm in HL1.
            rewrite HL1 in H7. rewrite H.
            assert(HRI: RInd (S m)) by( apply IH; auto using le_n_S).
            destruct HRI as [HUp  HDown] ...
            apply HDown in H7 ...
            apply AdequacyTri1 in H3.
            eapply tri_tensor with (N:=N) (M:=L1) ...
            eapply LPos3 ;eauto.
        +++ rewrite union_comm in HL2.
            rewrite HL2 in H3. rewrite H.
            assert(HRI: RInd (S n0)) by( apply IH; auto using le_n_S).
            destruct HRI as [HUp  HDown] ...
            apply HDown in H3 ...
            apply AdequacyTri1 in H7.
            eapply tri_tensor with (M:=M0) (N:=L2) ...
            eapply LPos3 ;eauto.
      ++ (* Par *)
        apply UpExtension in H6 ...
        destruct H6 as [m H6]. destruct H6 as [H6 H6'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* oplus1 *)
        assert(HRI: RInd (S n0)) by (apply IH ; auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* oplus2 *)
        assert(HRI: RInd (S n0)) by (apply IH ; auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* with *)
        apply UpExtension in H6 ...
        destruct H6 as [m H6]. destruct H6 as [H6 H6'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* quest *)
        apply UpExtension in H5 ...
        destruct H5 as [m H5]. destruct H5 as [H5 H5'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* exists *)
        assert(HRI: RInd (S n0)) by ( apply IH;auto).
        destruct HRI as [HUp  HDown] ...
        apply HDown in H3 ...
        apply tri_ex with (t:=t) ...
      ++ (* forall *)
        apply UpExtension in H4 ...
        destruct H4 as [m H4]. destruct H4 as [H4 H4'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
    Qed.

    Theorem InvAux : forall n, RInd n.
      intro n.
      induction n using strongind.
      + unfold RInd.
        split; [apply RUp0 | apply RDown0].
      + unfold RInd in *.
        split.
        apply InvCopyUP. assumption.
        simpl.  rewrite Nat.sub_0_r.
        apply InvCopyDW. assumption.
    Qed.

    (* =============================================== *)
    (* MAIN INVERTIBILITY THEOREM *)
    (* =============================================== *)
    Theorem InvCopy : forall B L F  M,   |-F- B ++ [F]  ;M ; UP (F :: L) -> LexpPos M  ->|-F- B ++ [F] ; M  ; UP L .
      intros.
      apply EquivUpArrow2 with (L' := L ++ [F]) in H ;auto.
      assert(HRn:  forall n, RUp n) by (apply InvAux).
      apply AdequacyTri2 in H.
      destruct H.
      generalize (HRn x);intros;auto.
    Qed.

  End InvCopy.

  (* =============================================== *)
  (** Invertibility of Exists *)
  (* =============================================== *)
  Module InvExists.
    Definition RUp (n:nat) := forall B L M FX t,
      LexpPos M ->
      n |-F- B ;M ; UP (L ++ [Subst FX t])  -> |-F- B ; M ++ [Ex FX] ; UP L.

    Definition RDown (n:nat) := forall B M H FX t,
        LexpPos M -> PosOrNegAtom (Subst FX t) ->
        n |-F- B ; M ++ [Subst FX t]  ; DW H -> |-F- B ; M ++ [Ex FX]  ; DW H.

    Definition RInd (n:nat) := RUp n /\ RDown (n -1).

    Lemma RDown0 : RDown 0.
    Proof with InvTac.
      unfold RDown.
      intros.
      inversion H2;subst ...
      apply NegPosAtom in H6.
      rewrite H5 in H6.
      assert(False) by (eapply NegPosAtomContradiction;eauto).
      contradiction.
    Qed.

    Lemma RUp0 : RUp 0.
    Proof with InvTac.
      unfold RUp.
      intros.
      destruct L.
      + inversion H0;subst.
        eapply tri_dec1 with (F:= E{ FX}) ...
        apply tri_ex with (t:=t)...
        rewrite <- H1.
        apply tri_rel ...
      + inversion H0 ...
    Qed.

    (* =============================================== *)
    (* PROOF OF RUP *)
    (* =============================================== *)
    Theorem InvExUP: forall  n , (forall m : nat, m <= n -> RInd m) -> RUp (S n).
    Proof with InvTac.
      intros n IH.
      unfold RUp.  intros B L1  M1 FX t HM1pos HD1.
      destruct L1;simpl in *.
      + (* L1 is Empty *)
        inversion HD1;subst ...
        ++ (* bot *)
          eapply tri_dec1 with (F:=E{ FX});InvTac; eapply tri_ex with (t:=t);InvTac;
            rewrite <- H0; eapply tri_rel;InvTac;
              NegPhase; rewrite app_nil_r; eapply AdequacyTri1;eauto.
        ++ (* par *)
          eapply tri_dec1 with (F:=E{ FX}) ...
          eapply tri_ex with (t:=t) ...
          rewrite <- H0.
          eapply tri_rel ...
          NegPhase;
            rewrite app_nil_r;
            eapply AdequacyTri1;eauto.
        ++ (* with *)
          eapply tri_dec1 with (F:=E{ FX}) ...
          eapply tri_ex with (t:=t) ...
          rewrite <- H0.
          eapply tri_rel ...
          NegPhase;
            rewrite app_nil_r;
            eapply AdequacyTri1;eauto.
        ++ (* quest *)
          eapply tri_dec1 with (F:=E{ FX}) ...
          eapply tri_ex with (t:=t) ...
          rewrite <- H0.
          eapply tri_rel ...
          NegPhase;
            rewrite app_nil_r;
            eapply AdequacyTri1;eauto.
        ++ (* store *)
          assert(RInd n) by ( apply IH;auto).
          destruct H as [HUp  HDown].
          inversion H5;subst ...
          +++ (* Decide 1 *)
            rewrite union_comm in H0.
            simpl_union_context;subst.
            (* taking Subst FX t *)
            rewrite <- HeqM in H1.
            eapply tri_dec1 with (F:= E{ FX}) ...
            eapply tri_ex with (t:=t).
            rewrite app_nil_r;
              eapply AdequacyTri1;eauto.
            (* taking any other formula *)
            rewrite H0 in H1. rewrite H2.
            assert(HS : Subst FX t :: L1 =mul= L1 ++ [Subst FX t]) by solve_permutation ;rewrite HS in H1; clear HS.
            (* Subst must be: a negative atom, a positive atom or a positive formula *)
            apply NotAsynchronousPosAtoms in H4.
            destruct H4 as [H4 | [H4 | H4]].
            (* case PosFormula*)
            apply PosFormulaPosOrNegAtom in H4.
            apply HDown in H1 ...
            eapply tri_dec1 with (F:=F) ...

            (* case positive atom *)
            eapply tri_dec1 with (F:= E{ FX}) ... solve_permutation.
            eapply tri_ex with (t:=t).
            eapply tri_rel ...
            eapply tri_store ... apply IsPositiveAtomNotAssync;auto.
            eapply tri_dec1 with (F:= F) ...
            eapply AdequacyTri1;rewrite app_nil_r;eauto.

            (* case negative atom *)
            apply HDown in H1 ...
            eapply tri_dec1 with (F:=F) ...
            apply IsNegativePosOrNegAtom;auto.
          +++  (* Decide 2 *)
            (* Subst must be: a negative atom, a positive atom or a positive formula *)
            apply NotAsynchronousPosAtoms in H4.
            destruct H4 as [H4 | [H4 | H4]].
            (* case PosFormula*)
            apply PosFormulaPosOrNegAtom in H4.
            apply HDown in H1 ...
            eapply tri_dec2 with (F:=F) ...

            (* case positive atom *)
            eapply tri_dec1 with (F:= E{ FX}) ...
            eapply tri_ex with (t:=t).
            eapply tri_rel ...
            rewrite app_nil_r.
            eapply tri_store ... apply IsPositiveAtomNotAssync;auto.
            eapply tri_dec2 with (F:= F) ...
            eapply AdequacyTri1;eauto.

            (* case negative atom *)
            apply HDown in H1 ...
            eapply tri_dec2 with (F:=F) ...
            apply IsNegativePosOrNegAtom;auto.
        ++ (* forall *)
          eapply tri_dec1 with (F:=E{ FX}) ...
          eapply tri_ex with (t:=t) ...
          rewrite <- H0.
          eapply tri_rel ...
          NegPhase;
            rewrite app_nil_r;
            eapply AdequacyTri1;eauto.

      + (* L is not empty *)
        inversion HD1;subst; try(
                                 assert(RInd n) by ( apply IH;auto);
                                 destruct H as [HUp  HDown]; clear HDown) ...
        ++ (* bot *)
          NegPhase.
          apply HUp in H3 ...
        ++ (* par *)
          NegPhase.
          unfold RUp in HUp.
          apply HUp with (L:=  F :: G :: L1)in H3 ...
        ++ (* & *)
          assert(H: RInd n0) by ( apply IH;auto);
            destruct H as [HUp  HDown]; clear HDown.
          assert(H: RInd m) by ( apply IH;auto);
            destruct H as [HUp'  HDown']; clear HDown'.
          unfold RUp in HUp.
          eapply HUp with (L:= F::L1) in H4 ...
          unfold RUp in HUp'.
          eapply HUp' with (L:= G::L1) in H5 ...

        ++ (* ? *)
          apply HUp in H3 ...

        ++ (* store *)
          apply HUp in H5 ...
          apply tri_store ...
          assert(Hs : (M1 ++ [l]) ++ [E{ FX}] =mul= (M1 ++ [E{ FX}]) ++ [l]) by solve_permutation; rewrite Hs in H5.
          assumption.
        ++ (* forall *)
          apply tri_fx;intro.
          generalize (H3 x);intro.
          unfold RUp in HUp.
          eapply HUp with (L:= Subst FX0 x :: L1) in H ...
    Qed.

    (* =============================================== *)
    (* PROOF OF RDOWN *)
    (* =============================================== *)
    Theorem InvExDW: forall  n , (forall m : nat, m <= n -> RInd m) -> RDown (n).
    Proof with InvTac;auto using LexpPosOrNegAtomConc.
      intros n IH.
      unfold RDown.  intros B M  H  FX t HPosF HM1pos  HD1.
      caseLexp H;subst;InvTac; inversion HD1;subst ...
      ++ (* atom 1 *)
        (* HD1  + HM1Pos is inconsistent *)
        apply  NegPosAtom in H4.
        rewrite H2 in H4.
        assert(False) by (eapply NegPosAtomContradiction;eauto).
        contradiction.
      ++ (* atom 2 *)
        apply UpExtension in H5 ...
        destruct H5.
        destruct H.
        assert(HRI: RInd x)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown]. clear HDown.
        apply HUp in H2 ...
      ++ (* perp1 *)
        (* same inconsistency *)
        apply  NegPosAtom in H4.
        rewrite H2 in H4.
        assert(False) by (eapply NegPosAtomContradiction;eauto).
        contradiction.
      ++ (* perp2 *)
        apply UpExtension in H5 ...
        destruct H5.
        destruct H.
        assert(HRI: RInd x)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown]. clear HDown.
        apply HUp in H2 ...
      ++ (* bbot *)
        apply UpExtension in H4 ...
        destruct H4 as [m H4]. destruct H4 as [H4 H4'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
        apply HUp in H4' ...
      ++ (* tensor *)
        symmetry in H2.
        assert(HC: M ++ [Subst FX t] =mul= [Subst FX t] ++ M) by solve_permutation; rewrite HC in H2;clear HC.
        (* 2 choices: Subst FX t is M or in N *)
        simpl_union_context.
        +++ rewrite union_comm in HL1.
            rewrite HL1 in H7. rewrite H.
            assert(HRI: RInd (S m)) by( apply IH; auto using le_n_S).
            destruct HRI as [HUp  HDown] ...
            apply HDown in H7 ...
            apply AdequacyTri1 in H3.
            eapply tri_tensor with (N:=N) (M:=L1 ++ [E{ FX}]) ...
            eauto.
            eapply LPos3 ;eauto.
        +++ rewrite union_comm in HL2.
            rewrite HL2 in H3. rewrite H.
            assert(HRI: RInd (S n0)) by( apply IH; auto using le_n_S).
            destruct HRI as [HUp  HDown] ...
            apply HDown in H3 ...
            apply AdequacyTri1 in H7.
            eapply tri_tensor with (M:=M0) (N:=L2 ++ [E{ FX}]) ...
            eapply LPos3 ;eauto.
      ++ (* Par *)
        apply UpExtension in H6 ...
        destruct H6 as [m H6]. destruct H6 as [H6 H6'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
        apply HUp in H6' ...
      ++ (* oplus1 *)
        assert(HRI: RInd (S n0)) by (apply IH ; auto).
        destruct HRI as [HUp  HDown] ...
        apply HDown in H5 ...
      ++ (* oplus2 *)
        assert(HRI: RInd (S n0)) by (apply IH ; auto).
        destruct HRI as [HUp  HDown] ...
        apply HDown in H5 ...
      ++ (* with *)
        apply UpExtension in H6 ...
        destruct H6 as [m H6]. destruct H6 as [H6 H6'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
        apply HUp in H6' ...
      ++ (* quest *)
        apply UpExtension in H5 ...
        destruct H5 as [m H5]. destruct H5 as [H5 H5'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
        apply HUp in H5' ...
      ++ (* exists *)
        assert(HRI: RInd (S n0)) by ( apply IH;auto).
        destruct HRI as [HUp  HDown] ...
        apply HDown in H3 ...
        apply tri_ex with (t:=t0) ...
      ++ (* forall *)
        apply UpExtension in H4 ...
        destruct H4 as [m H4]. destruct H4 as [H4 H4'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
        apply HUp in H4' ...
    Qed.

    Theorem InvExAux : forall n, RInd n.
      intro n.
      induction n using strongind.
      + unfold RInd.
        split; [apply RUp0 | apply RDown0].
      + unfold RInd in *.
        split.
        apply InvExUP. assumption.
        simpl.  rewrite Nat.sub_0_r.
        apply InvExDW. assumption.
    Qed.

    (* =============================================== *)
    (* MAIN INVERTIBILITY THEOREM *)
    (* =============================================== *)

    Theorem InvEx : forall B L FX t  M,   |-F- B  ;M ; UP (Subst FX t :: L) -> LexpPos M  ->|-F- B ; M ++ [E{ FX}]  ; UP L .
      intros.
      apply EquivUpArrow2 with (L' := L ++ [Subst FX t]) in H ;eauto.
      assert(HRn:  forall n, RUp n) by (apply InvExAux).
      apply AdequacyTri2 in H.
      destruct H.
      generalize (HRn x);intros.
      apply H1 in H;auto.
    Qed.

  End InvExists.

  (* =============================================== *)
  (** Invertibility of OPlus *)
  (* =============================================== *)
  Module InvOPlus.

    Definition RUp (n:nat) := forall B L M F G,
      LexpPos M ->
      n |-F- B ;M ; UP (L ++ [F])  -> |-F- B ; M ++ [F ⊕ G] ; UP L.

    Definition RDown (n:nat) := forall B M H F G,
        LexpPos M -> PosOrNegAtom F ->
        n |-F- B ; M ++ [F]  ; DW H -> |-F- B ; M ++ [F ⊕ G]  ; DW H.

    Definition RInd (n:nat) := RUp n /\ RDown (n -1).

    Lemma RDown0 : RDown 0.
    Proof with InvTac.
      unfold RDown.
      intros.
      inversion H2;subst ...
      apply NegPosAtom in H6.
      assert(False) by (eapply NegPosAtomContradiction;eauto).
      contradiction.
    Qed.

    Lemma RUp0 : RUp 0.
    Proof with InvTac.
      unfold RUp.
      intros.
      destruct L.
      + inversion H0;subst.
        eapply tri_dec1 with (F:= ⊤ ⊕ G) ...
      + inversion H0 ...
    Qed.

    (* =============================================== *)
    (* PROOF OF RUP *)
    (* =============================================== *)
    Theorem InvPlusUP: forall  n , (forall m : nat, m <= n -> RInd m) -> RUp (S n).
    Proof with InvTac.
      intros n IH.
      unfold RUp.  intros B L1  M1 F  G HM1pos HD1.
      destruct L1;simpl in *.
      + (* L1 is Empty *)
        inversion HD1;subst ...
        ++ (* bot *)
          eapply tri_dec1 with (F:=⊥ ⊕ G) ...
          eapply tri_plus1 ...
          eapply tri_rel ...
          rewrite app_nil_r; eapply AdequacyTri1;eauto.
        ++ (* par *)
          eapply tri_dec1 with (F:=(F0 $ G0) ⊕ G) ...
          eapply tri_plus1 ...
          eapply tri_rel ...
          rewrite app_nil_r;
            eapply AdequacyTri1;eauto.
        ++ (* with *)
          eapply tri_dec1 with (F:=(F0 & G0) ⊕ G) ...
          eapply tri_plus1 ...
          eapply tri_rel ...
          NegPhase;
            rewrite app_nil_r;
            eapply AdequacyTri1;eauto.
        ++ (* quest *)
          eapply tri_dec1 with (F:=(? F0) ⊕ G) ...
          eapply tri_plus1 ...
          eapply tri_rel ...
          NegPhase;
            rewrite app_nil_r;
            eapply AdequacyTri1;eauto.
        ++ (* store *)
          assert(RInd n) by ( apply IH;auto).
          destruct H as [HUp  HDown].
          inversion H5;subst ...
          +++ (* Decide 1 *)
            rewrite union_comm in H0.
            simpl_union_context;subst.
            (* taking F0 *)
            rewrite <- HeqM in H1.
            eapply tri_dec1 with (F:= F0 ⊕ G) ...
            eapply tri_plus1 ...
            rewrite app_nil_r;
              eapply AdequacyTri1;eauto.
            (* taking any other formula *)
            rewrite H0 in H1. rewrite H2.
            assert(HS : F :: L1 =mul= L1 ++ [F]) by solve_permutation ;rewrite HS in H1; clear HS.
            (* Subst must be: a negative atom, a positive atom or a positive formula *)
            apply NotAsynchronousPosAtoms in H4.
            destruct H4 as [H4 | [H4 | H4]].
            (* case PosFormula*)
            apply PosFormulaPosOrNegAtom in H4.
            eapply tri_dec1 with (F:=F0) ...
            eapply HDown in H1 ...

            eauto.

            (* case positive atom *)
            eapply tri_dec1 with (F:= F ⊕ G) ... solve_permutation.
            eapply tri_plus1 ...
            eapply tri_rel ...
            eapply tri_store ... apply IsPositiveAtomNotAssync;auto.
            eapply tri_dec1 with (F:= F0) ...
            eapply AdequacyTri1;rewrite app_nil_r;eauto.

            (* case negative atom *)
            eapply HDown  in H1 ...
            eapply tri_dec1 with (F:=F0) ...
            eassumption.
            apply IsNegativePosOrNegAtom;auto.
          +++  (* Decide 2 *)
            (* Subst must be: a negative atom, a positive atom or a positive formula *)
            apply NotAsynchronousPosAtoms in H4.
            destruct H4 as [H4 | [H4 | H4]].
            (* case PosFormula*)
            apply PosFormulaPosOrNegAtom in H4.
            eapply HDown in H1 ...
            eapply tri_dec2 with (F:=F0) ...
            eassumption.

            (* case positive atom *)
            eapply tri_dec1 with (F:= F ⊕ G) ...
            eapply tri_plus1 ...
            eapply tri_rel ...
            rewrite app_nil_r.
            eapply tri_store ... apply IsPositiveAtomNotAssync;auto.
            eapply tri_dec2 with (F:= F0) ...
            eapply AdequacyTri1;eauto.

            (* case negative atom *)
            eapply HDown in H1 ...
            eapply tri_dec2 with (F:=F0) ...
            eassumption.
            apply IsNegativePosOrNegAtom;auto.
        ++ (* forall *)
          eapply tri_dec1 with (F:=F{ FX} ⊕ G) ...
          eapply tri_plus1.
          eapply tri_rel ...
          NegPhase;
            rewrite app_nil_r;
            eapply AdequacyTri1;eauto.

      + (* L is not empty *)
        inversion HD1;subst; try(
                                 assert(RInd n) by ( apply IH;auto);
                                 destruct H as [HUp  HDown]; clear HDown) ...
        ++ (* & *)
          assert(H: RInd n0) by ( apply IH;auto);
            destruct H as [HUp  HDown]; clear HDown.
          assert(H: RInd m) by ( apply IH;auto);
            destruct H as [HUp'  HDown']; clear HDown'.
          unfold RUp in HUp.
          eapply HUp with (L:= F0::L1) in H4 ...
          unfold RUp in HUp'.
          eapply HUp' with (L:= G0::L1) in H5 ...
          NegPhase;eauto.

        ++ (* store *)
          unfold RUp in HUp.
          apply HUp with (G:=G) in H5 ...
          apply tri_store ...
          assert(Hs : (M1 ++ [l]) ++ [F ⊕ G] =mul= (M1 ++ [F ⊕ G]) ++ [l]) by solve_permutation; rewrite Hs in H5.
          assumption.
        ++ (* forall *)
          apply tri_fx;intro.
          generalize (H3 x);intro.
          unfold RUp in HUp.
          eapply HUp with (L:= Subst FX x :: L1) in H ...
          eassumption.
    Qed.

    (* =============================================== *)
    (* PROOF OF RDOWN *)
    (* =============================================== *)
    Theorem InvPlusDW: forall  n , (forall m : nat, m <= n -> RInd m) -> RDown (n).
    Proof with InvTac;auto using LexpPosOrNegAtomConc.
      intros n IH.
      unfold RDown.  intros B M  H  F G HPosF HM1pos  HD1.
      caseLexp H;subst;InvTac; inversion HD1;subst ...
      ++ (* atom 1 *)
        (* HD1  + HM1Pos is inconsistent *)
        apply  NegPosAtom in H4.
        assert(False) by (eapply NegPosAtomContradiction;eauto).
        contradiction.
      ++ (* atom 2 *)
        apply UpExtension in H5 ...
        destruct H5.
        destruct H.
        assert(HRI: RInd x)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown]. clear HDown.
        eapply HUp in H2 ...
        eapply tri_rel ...
        eassumption.
      ++ (* perp1 *)
        (* same inconsistency *)
        apply  NegPosAtom in H4.
        assert(False) by (eapply NegPosAtomContradiction;eauto).
        contradiction.
      ++ (* perp2 *)
        apply UpExtension in H5 ...
        destruct H5.
        destruct H.
        assert(HRI: RInd x)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown]. clear HDown.
        eapply HUp in H2 ...
        eapply tri_rel ...
        eassumption.
      ++ (* bbot *)
        apply UpExtension in H4 ...
        destruct H4 as [m H4]. destruct H4 as [H4 H4'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* tensor *)
        symmetry in H2.
        assert(HC: M ++ [F] =mul= [F] ++ M) by solve_permutation; rewrite HC in H2;clear HC.
        (* 2 choices: F is M or in N *)
        simpl_union_context.
        +++ rewrite union_comm in HL1.
            rewrite HL1 in H7. rewrite H.
            assert(HRI: RInd (S m)) by( apply IH; auto using le_n_S).
            destruct HRI as [HUp  HDown] ...
            eapply tri_tensor with (N:=N) (M:=L1 ++ [F ⊕ G]) ...
            eauto.
            apply AdequacyTri1 in H3 ...
            eapply HDown in H7 ...
            eauto.
            eapply LPos3 ;eauto.

        +++ rewrite union_comm in HL2.
            rewrite HL2 in H3. rewrite H.
            assert(HRI: RInd (S n0)) by( apply IH; auto using le_n_S).
            destruct HRI as [HUp  HDown] ...
            eapply HDown in H3 ...
            apply AdequacyTri1 in H7.
            eapply tri_tensor with (M:=M0) (N:=L2 ++ [F ⊕ G]) ...
            eassumption.
            eapply LPos3 ;eauto.
      ++ (* Par *)
        apply UpExtension in H6 ...
        destruct H6 as [m H6]. destruct H6 as [H6 H6'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* oplus1 *)
        assert(HRI: RInd (S n0)) by (apply IH ; auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* oplus2 *)
        assert(HRI: RInd (S n0)) by (apply IH ; auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* with *)
        apply UpExtension in H6 ...
        destruct H6 as [m H6]. destruct H6 as [H6 H6'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* quest *)
        apply UpExtension in H5 ...
        destruct H5 as [m H5]. destruct H5 as [H5 H5'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
      ++ (* exists *)
        assert(HRI: RInd (S n0)) by ( apply IH;auto).
        destruct HRI as [HUp  HDown] ...
        apply tri_ex with (t:=t)... (* HDown in H3 ends *)

      ++ (* forall *)
        apply UpExtension in H4 ...
        destruct H4 as [m H4]. destruct H4 as [H4 H4'].
        assert(HRI: RInd m)  by (apply IH ;auto).
        destruct HRI as [HUp  HDown] ...
    Qed.

    Theorem InvPlusAux : forall n, RInd n.
      intro n.
      induction n using strongind.
      + unfold RInd.
        split; [apply RUp0 | apply RDown0].
      + unfold RInd in *.
        split.
        apply InvPlusUP. assumption.
        simpl.  rewrite Nat.sub_0_r.
        apply InvPlusDW. assumption.
    Qed.

    (* =============================================== *)
    (* MAIN INVERTIBILITY THEOREM *)
    (* =============================================== *)
    Theorem InvPlus : forall B L F G  M,   |-F- B  ;M ; UP (F :: L) -> LexpPos M  ->|-F- B ; M ++ [F ⊕ G]  ; UP L .
      intros.
      apply EquivUpArrow2 with (L' := L ++ [F]) in H ;eauto.
      assert(HRn:  forall n, RUp n) by (apply InvPlusAux).
      apply AdequacyTri2 in H.
      destruct H.
      generalize (HRn x);intros.
      eapply H1 in H;eauto.
    Qed.

    Lemma OPlusComm : forall B M F G X n, n |-F- B ; M ++ [F ⊕ G] ; X -> n |-F- B ; M ++ [G ⊕ F] ; X.
    Proof with InvTac.
      intros.
      generalize dependent B.
      generalize dependent M.
      generalize dependent X.
      generalize dependent n.
      induction n using strongind;intros.
      + inversion H ...
        inversion H1; rewrite <- H2 in H3 ...
      + inversion H0;subst ...
        ++ (* tensor *)
          symmetry in H2.
          assert(HS: M ++ [F ⊕ G] =mul=  [F ⊕ G] ++ M) by solve_permutation; rewrite HS in H2;clear HS.
          (* F+ G can be either in M0 or in N *)
          simpl_union_context.
          (* in M0 *)
          rewrite H1. rewrite HL1 in H4.
          apply trih_tensor with (N:= N) (M:=  [G ⊕ F] ++ L1) ...  solve_permutation.
          assert(HS: G ⊕ F :: L1 =mul=  L1  ++ [G ⊕ F]) by eauto;rewrite HS;clear HS.
          apply H;eauto.
          assert(HS:  L1 ++ [F ⊕ G] =mul=   [F ⊕ G] ++ L1) by eauto;rewrite HS.
          assumption.
          (* in N *)
          rewrite H1. rewrite HL2 in H3.
          apply trih_tensor with (N:= [G ⊕ F] ++ L2) (M:=  M0) ... solve_permutation.
          assert(HS: G ⊕ F :: L2 =mul=  L2  ++ [G ⊕ F]) by eauto;rewrite HS;clear HS.
          apply H;eauto.
          assert(HS:  L2 ++ [F ⊕ G] =mul=   [F ⊕ G] ++ L2) by eauto;rewrite HS.
          assumption.
        ++ (* store *)
          apply trih_store ...
          assert(HS:  (M ++ [G ⊕ F]) ++ [F0] =mul=  (M ++ [F0]) ++ [G ⊕ F]) by solve_permutation.
          rewrite HS.
          apply H;auto.
          assert(HS':  (M ++ [F ⊕ G]) ++ [F0] =mul=  (M ++ [F0]) ++ [F ⊕ G]) by solve_permutation.
          rewrite <- HS'.
          auto.
        ++ (* decide 1 *)
          rewrite union_comm in H3.
          simpl_union_context;subst.
          inversion H4 ...
          eapply trih_dec1 with (F:= G ⊕ F) ... apply trih_plus2. rewrite HeqM. rewrite app_nil_r. auto.
          eapply trih_dec1 with (F:= G ⊕ F) ... apply trih_plus1. rewrite HeqM. rewrite app_nil_r. auto.
          rewrite H3.
          eapply trih_dec1 with (F:= F0) ...
          apply H;auto. rewrite H1 in H4.
          assert(HS:  F ⊕ G :: L1 =mul=  L1 ++ [F ⊕ G ]) by eauto; rewrite HS in H4.
          assumption.
        ++  (* decide 2 *)
          eapply trih_dec2 with (F:=F0) ...
        ++ (* exists *)
          eapply trih_ex with (t:=t) ...
    Qed.

    (* =============================================== *)
    (* MAIN INVERTIBILITY THEOREM (FLIPPING F and G    *)
    (* =============================================== *)
    Theorem InvPlusComm: forall B L F G  M,   |-F- B  ;M ; UP (G :: L) -> LexpPos M  ->|-F- B ; M ++ [F ⊕ G]  ; UP L .
      intros.
      apply InvPlus with (G:=F)in H;auto.
      apply AdequacyTri2 in H.
      destruct H.
      apply OPlusComm in H.
      apply AdequacyTri1 with (n:=x);auto.
    Qed.
  End InvOPlus.

  (* =============================================== *)
  (** Invertibility of Tensor *)
  (* =============================================== *)
  Module InvTensor.

    Definition RUp (nm:nat) := forall B L M L' M' F G n m,
      nm = n + m -> LexpPos M -> LexpPos M' ->  n |-F- B ;M ; UP (L ++ [F])  -> m |-F- B ;M' ; UP (L' ++ [G])  -> |-F- B ; M ++ M' ++  [F ** G] ; UP (L ++ L').

    Definition RDown (nm:nat) := forall B M M' H F G n m,
        nm = n + m -> LexpPos M -> LexpPos M' -> PosOrNegAtom F ->
        n |-F- B ; M ++ [F]  ; DW H -> m |-F- B ; M' ; UP [G] -> |-F- B ; M ++ M' ++  [F ** G]  ; DW H.

    Definition RInd (n:nat) := RUp n /\ RDown (n -1).

    Lemma RDown0 : RDown 0.
    Proof with InvTac.
      unfold RDown.
      intros.
      symmetry in H0. apply plus_is_O in H0.
      destruct H0;subst.
      inversion H4 ...
      apply NegPosAtom in H8.
      assert(False) by (eapply NegPosAtomContradiction;eauto).
      contradiction.
    Qed.

    Lemma RUp0 : RUp 0.
    Proof with InvTac.
      unfold RUp.
      intros.
      symmetry in H. apply plus_is_O in H.
      destruct H;subst.
      inversion H2;subst ...
      destruct L;destruct L';simpl in *.
      + inversion H;subst.
        inversion H3;subst.
        eapply tri_dec1 with (F:= ⊤ ** ⊤) ... eauto.
        eapply tri_tensor with (N:=M) (M:=M') ...
      + inversion H3;subst ...
      + inversion H ...
      + inversion H ...
    Qed.

    (* =============================================== *)
    (* F ** G COMMUTES *)
    (* =============================================== *)
    Lemma TensorComm : forall B M F G X n, n |-F- B ; M ++ [F ** G] ; X -> n |-F- B ; M ++ [G ** F] ; X.
    Proof with InvTac.
      intros.
      generalize dependent B.
      generalize dependent M.
      generalize dependent X.
      generalize dependent n.
      induction n using strongind;intros.
      + inversion H ...
        inversion H1; rewrite <- H2 in H3 ...
      + inversion H0;subst ...
        ++ (* tensor *)
          symmetry in H2.
          assert(HS: M ++ [F ** G] =mul=  [F ** G] ++ M) by solve_permutation; rewrite HS in H2;clear HS.
          (* F ** G can be either in M0 or in N *)
          simpl_union_context.
          (* in M0 *)
          rewrite H1. rewrite HL1 in H4.
          apply trih_tensor with (N:= N) (M:=  [G ** F] ++ L1) ...  solve_permutation.
          assert(HS: G ** F :: L1 =mul=  L1  ++ [G ** F]) by eauto;rewrite HS;clear HS.
          apply H;eauto.
          assert(HS:  L1 ++ [F ** G] =mul=   [F ** G] ++ L1) by eauto;rewrite HS.
          assumption.
          (* in N *)
          rewrite H1. rewrite HL2 in H3.
          apply trih_tensor with (N:= [G ** F] ++ L2) (M:=  M0) ... solve_permutation.
          assert(HS: G ** F :: L2 =mul=  L2  ++ [G ** F]) by eauto;rewrite HS;clear HS.
          apply H;eauto.
          assert(HS:  L2 ++ [F ** G] =mul=   [F ** G] ++ L2) by eauto;rewrite HS.
          assumption.
        ++ (* store *)
          apply trih_store ...
          assert(HS:  (M ++ [G ** F]) ++ [F0] =mul=  (M ++ [F0]) ++ [G ** F]) by solve_permutation.
          rewrite HS.
          apply H;auto.
          assert(HS':  (M ++ [F ** G]) ++ [F0] =mul=  (M ++ [F0]) ++ [F ** G]) by solve_permutation.
          rewrite <- HS'.
          auto.
        ++ (* decide 1 *)
          rewrite union_comm in H3.
          simpl_union_context;subst.
          inversion H4 ...
          rewrite HeqM. rewrite H3.
          eapply trih_dec1 with (F:= G ** F) ...
          assert (Hmax: max n0 m = max m n0) by apply Nat.max_comm; rewrite Hmax; clear Hmax.
          apply trih_tensor with (N:=M0) (M:=N) ... eauto.

          rewrite H3.
          eapply trih_dec1 with (F:= F0) ...
          apply H;auto. rewrite H1 in H4.
          MReplaceIn ( F ** G :: L1) (L1 ++ [F **G]) H4.
          auto.

        ++  (* decide 2 *)
          eapply trih_dec2 with (F:=F0) ...
        ++ (* exists *)
          eapply trih_ex with (t:=t) ...
    Qed.

    Lemma TensorComm' : forall B M F G X , |-F- B ; M ++ [F ** G] ; X -> |-F- B ; M ++ [G ** F] ; X.
    Proof with InvTac.
      intros.
      apply AdequacyTri2 in H.
      destruct H.
      apply TensorComm in H.
      eapply AdequacyTri1;eauto.
    Qed.

    (* =============================================== *)
    (* PROOF OF RUP *)
    (* Cases when one of the lists is not empty *)
    (* =============================================== *)
    Lemma InvTensorConsNil (nm : nat) (IH : forall m : nat, m <= nm -> RInd m) (B L1 M1 : list Lexp)
          (l : Lexp) (L2  M2 : list Lexp) (F  G : Lexp) (n'  m' : nat) : S nm = n' + m' -> LexpPos M1 -> LexpPos M2 -> n' |-F- B; M1; UP (L1 ++ [F]) -> m' |-F- B; M2; UP (l :: L2 ++ [G]) -> |-F- B; M1 ++ M2 ++ [F ** G]; UP (L1 ++ l :: L2).
    Proof with InvTac.
      intros HNM  HM1pos HM2pos HD1 HD2.
      apply EquivUpArrow2 with (L':= L1 ++ l :: L2) (L := l:: L2 ++ L1);eauto ...
      inversion HD2;subst;NegPhase ...
      (* bot *)
      apply EquivUpArrow2 with (L:= L1 ++ L2) (L' := L2 ++ L1);eauto ...
      assert(HUp : RUp(n' + n)) by (apply IH;omega) ...
      eapply HUp with(n0:=n') (m:=n) ...
      (* par *)
      apply EquivUpArrow2 with (L:= L1 ++ F0 :: G0 :: L2) (L' := F0 :: G0 :: L2 ++ L1);eauto ...
      assert(HUp : RUp(n' + n)) by (apply IH;omega) ...
      eapply HUp with(n0:=n') (m:=n) ...
      (* with *)
      rewrite Nat.add_succ_r in HNM;inversion HNM;subst.
      assert(HUp1 : RUp(n' + n)). apply IH. apply Nat.add_le_mono;auto.
      apply EquivUpArrow2 with (L:= L1 ++ F0 :: L2) (L' := F0 :: L2 ++ L1);eauto ...
      rewrite Nat.add_succ_r in HNM;inversion HNM;subst.
      assert(HUp2 : RUp(n' + m)). apply IH. apply Nat.add_le_mono;auto.
      apply EquivUpArrow2 with (L:= L1 ++ G0 :: L2) (L' := G0 :: L2 ++ L1);eauto ...
      (* quest *)
      assert(HUp : RUp(n' + n)) by (apply IH;omega).
      apply EquivUpArrow2 with (L:= L1 ++ L2) (L' := L2 ++ L1);eauto ...
      eapply HUp with(n0:=n') (m:=n) ...
      eapply TriWeakening ...
      (*  store *)
      apply tri_store ...
      MReplace ( (M1 ++ M2 ++ [F ** G]) ++ [l])  (M1 ++ (M2 ++ [l]) ++ [F ** G] ).
      apply EquivUpArrow2 with (L:= L1 ++ L2) (L' := L2 ++ L1);eauto ...
      assert(HUp : RUp(n' + n)) by (apply IH;omega);
        eapply HUp with(n0:=n') (m:=n) ...
      (* forall *)
      generalize (H3 x);intro.
      assert(HUp : RUp(n' + n)) by (apply IH;omega).
      apply EquivUpArrow2 with (L:= L1 ++ Subst FX x ::L2) (L' := Subst FX x :: L2 ++ L1);eauto ...
    Qed.

    (* ================================================ *)
    (* PROOF OF RUP *)
    (* Case when the 2 formulas are async. or pos. atoms*)
    (* ================================================ *)

    Lemma ITCaseAsyncAsync:  forall n m B M1 M2 F G, (Asynchronous F \/  IsPositiveAtom F) ->  (Asynchronous G \/ IsPositiveAtom G) -> n |-F- B; M1; UP [F] -> m |-F- B; M2; UP [G] ->  |-F- B; M1 ++ M2 ++ [F ** G]; UP [].
    Proof with InvTac.
      intros.
      eapply tri_dec1 with (F:= F ** G) ...
      solve_permutation.
      rewrite app_nil_r.
      eapply tri_tensor with (N:=M1) (M:=M2);InvTac;
        eapply tri_rel ;auto using AsIsPosRelease;
          eapply AdequacyTri1;eauto.
    Qed.

    Lemma ITAsyncSync  : forall nm n m  B M1 M2 F G, (Asynchronous F \/ IsPositiveAtom F) ->  ~ Asynchronous G -> (forall m : nat, m <= nm -> RInd m) -> nm = n + m ->  LexpPos M1 -> LexpPos M2 -> n |-F- B; M1; UP [F] ->  m |-F- B; M2 ++ [G]; UP [] ->  |-F- B; M1 ++ M2 ++ [F ** G]; UP [].
    Proof with InvTac.
      intros nm n m  B M1 M2 F G AF AG IH Hnm HM1 HM2 HD1 HD2.
      apply NotAsynchronousPosAtoms' in AG; destruct AG as [AG | AG].

      (* G is a positive atom... then, release works (Lemma  ITCaseAsyncAsync) *)
      eapply ITCaseAsyncAsync;eauto. apply trih_store;auto using IsPositiveAtomNotAssync ... eauto.

      (* G cannot do release *)
      inversion HD2;subst.
      + (* Case DEC 1*)
        rewrite union_comm in H0;
          simpl_union_context;subst.

        (* case focus on F *)
        eapply tri_dec1 with (F:= F ** F0);InvTac;try(solve_permutation);
          eapply tri_tensor with (N:=M1) (M:=M2) ...
        solve_permutation.
        apply tri_rel;auto using AsyncRelease, AsIsPosRelease ... eapply AdequacyTri1;eauto.
        rewrite HeqM; eapply AdequacyTri1;eauto.

        (* case focus on other formula *)
        MReplaceIn L' (L1 ++ [G])  H1.
        rewrite H2.
        eapply tri_dec1 with (F:= F0) ...
        (* We use the HI on H1 and HD1 *)
        assert(IH2 : RInd(n + S n0)) by(  apply IH;auto); destruct IH2 as [HUp HDw].
        assert(Hn : n + S n0 -1 = n + n0) by omega;rewrite Hn in HDw;clear Hn.
        MReplace (M1 ++ L1 ++ [F ** G]) ( (L1 ++ M1) ++ [F ** G]).
        apply TensorComm'.
        MReplace ( (L1 ++ M1) ++ [G ** F] ) ( L1 ++ M1 ++ [G ** F] ).
        eapply HDw with (m:= n) (n1:= n0);try(omega);auto using PosFNegAtomPorOrNegAtom ...

      + (* Case DEC 2 *)
        assert(IH2 : RInd(n + S n0)) by(  apply IH;auto);
          destruct IH2 as [HUp HDw].
        assert(Hn : n + S n0 -1 = n + n0) by omega;rewrite Hn in HDw;clear Hn.
        eapply tri_dec2 with (F:=F0);InvTac ...
        unfold RDown in HDw.
        MReplace (M1 ++ M2 ++ [F ** G]) ( (M2 ++ M1) ++ [F ** G]).
        apply TensorComm'.
        MReplace ( (M2 ++ M1) ++ [G ** F]) ( M2 ++ M1 ++ [G ** F]).
        eapply HDw with (m:= n) (n1:= n0);try(omega);auto using PosFNegAtomPorOrNegAtom;InvTac.
    Qed.

    Ltac TensorFlip M1 M2 F G :=
      MReplace (M1 ++ M2 ++ [F ** G]) ((M2 ++ M1) ++ [F ** G] ); apply TensorComm'; MReplace ((M2 ++ M1) ++ [G ** F]) (M2 ++ M1 ++ [G ** F]).

    (* =============================================== *)
    (* PROOF OF RUP *)
    (* Case when both formulas are not Async *)
    (* =============================================== *)
    Lemma ITSyncSync : forall nm n m  B M1 M2 F G, ~ Asynchronous F -> ~ Asynchronous G ->  (forall m : nat, m <= nm -> RInd m) -> S nm = S n + S m -> LexpPos M1 -> LexpPos M2 -> S n |-F- B; M1 ; UP [F] -> S m |-F- B; M2 ; UP [G] ->  |-F- B; M1 ++ M2 ++ [F ** G]; UP [].
    Proof with InvTac.
      intros nm n m  B M1 M2 F G AF AG IH Hnm HM1 HM2 HD1 HD2.
      apply NotAsynchronousPosAtoms' in AF; destruct AF as [AF | AF];
        apply NotAsynchronousPosAtoms' in AG; destruct AG as [AG | AG].
      + (* Both are positive *)
        eapply ITCaseAsyncAsync;eauto.
      + (* F is a positive atom *)
        assert(~Asynchronous G) by auto using PosFIsNegAAsync.
        assert(~Asynchronous F) by auto using IsPositiveAtomNotAssync.
        inversion HD2;subst ...
        eapply ITAsyncSync with (nm:=nm) (n:= S n) (m:= m) ;eauto. omega.

      + (* G is a positive atom *)
        assert(~Asynchronous G) by auto using IsPositiveAtomNotAssync.
        assert(~Asynchronous F) by auto using PosFIsNegAAsync.
        inversion HD1;subst ...
        TensorFlip M1 M2 F G.
        eapply ITAsyncSync with (nm:=nm) (n:= S m) (m:= n) ;eauto. omega.
      +  (* F nor G can do release *)
        assert(HAG : ~Asynchronous G) by auto using PosFIsNegAAsync.
        assert(HAF : ~Asynchronous F) by auto using PosFIsNegAAsync.
        inversion HD1;subst ...
        inversion HD2;subst ...

        inversion H5;subst;inversion H7;subst ...
        ++ (* DEC1 DEC1 *)
          rewrite union_comm in H0.
          rewrite union_comm in H3.
          simpl_union_context;subst.
          apply DestructMSet in H0; destruct H0 as [Hten1' | Hten2' ];
            [ destruct Hten1' as [HeqE' HeqM'] | destruct Hten2' as [L1' Hten2']; destruct Hten2'];subst.
          (* F and G were chosen *)
          eapply tri_dec1 with (F:= F0 ** F1) ... solve_permutation.
          rewrite HeqM'. rewrite HeqM.
          apply tri_tensor with (N:= L') (M:= L'0);InvTac;try solve_permutation;
            eapply AdequacyTri1;eauto.
          (* G is chosen *)
          rewrite H3.
          eapply tri_dec1 with (F:= F0) ...
          MReplaceIn L' (L1' ++ [F]) H1.
          assert (IH' : RInd (S n0 + S (S n))) by ( apply IH; omega).
          destruct IH' as [HUp  HDw].
          assert(Hn : S n0 + S (S n) - 1 = n0 + S (S n)) by omega;rewrite Hn in HDw;clear Hn.
          eapply  HDw with (n1:= n0) (m:= S ( S n));auto using PosFNegAtomPorOrNegAtom ...
          (* Nor F nor G were chosen *)
          rewrite H9.
          eapply tri_dec1 with (F:= F1) ...
          MReplaceIn L'0 (L1 ++ [G]) H8.
          assert (IH' : RInd (S n + S (S n0))) by ( apply IH; omega).
          destruct IH' as [HUp  HDw].
          assert(Hn : S n + S (S n0) - 1 = n + S (S n0)) by omega;rewrite Hn in HDw;clear Hn.
          TensorFlip M1 L1 F G.
          eapply  HDw with (n1:= n) (m:= S ( S n0));auto using PosFNegAtomPorOrNegAtom ...
        ++ (* DEC 1 DEC 2 *)
          eapply tri_dec2 with (F:=F1) ...
          assert (IH' : RInd (S n + S (S n0))) by ( apply IH; omega).
          destruct IH' as [HUp  HDw].
          assert(Hn : S n + S (S n0) - 1 = n + S (S n0)) by omega;rewrite Hn in HDw;clear Hn.
          TensorFlip M1 M2 F G.
          eapply  HDw with (n1:= n) (m:= S ( S n0));auto using PosFNegAtomPorOrNegAtom ...
        ++ (* DEC 2 DEC 1 *)
          eapply tri_dec2 with (F:=F0) ...
          assert (IH' : RInd (S n0 + S (S n))) by ( apply IH; omega).
          destruct IH' as [HUp  HDw].
          assert(Hn : S n0 + S (S n) - 1 = n0 + S (S n)) by omega;rewrite Hn in HDw;clear Hn.
          eapply  HDw with (n1:= n0) (m:= S ( S n));auto using PosFNegAtomPorOrNegAtom ...
        ++ (* DEC 2 DEC 2 *)
          eapply tri_dec2 with (F:=F0) ...
          assert (IH' : RInd (S n0 + S (S n))) by ( apply IH; omega).
          destruct IH' as [HUp  HDw].
          assert(Hn : S n0 + S (S n) - 1 = n0 + S (S n)) by omega;rewrite Hn in HDw;clear Hn.
          eapply  HDw with (n1:= n0) (m:= S ( S n));auto using PosFNegAtomPorOrNegAtom ...

    Qed.

    (* =============================================== *)
    (* PROOF OF RUP *)
    (* =============================================== *)
    Theorem InvTensorUP: forall  nm , (forall m : nat, m <= nm-> RInd m) -> RUp (S nm).
    Proof with InvTac.
      intros nm IH.
      unfold RUp.  intros B L1  M1 L2 M2  F  G n' m' HNM HM1pos  HM2pos HD1 HD2.
      destruct L1;destruct L2;simpl in *.
      + (* L1 and L2 are Empty *)
        inversion HD1;inversion HD2;subst;InvTac;
          try(
              match goal with
              | [ |- |-F- ?B; ?M1 ++ ?M2 ++ [?F ** ?G]; UP [] ]
                => tryif (assert(HAFG :Asynchronous F /\ Asynchronous G) by (split;InvTac))
                then
                  eapply ITCaseAsyncAsync;eauto
                else idtac
              end).
        eapply ITAsyncSync with  (nm := nm) (n:= 0%nat) (m:=n) ;try omega;InvTac;eauto.
        apply ITAsyncSync with (nm:=nm) (n:= S n) (m:=n0);try omega;InvTac.
        apply ITAsyncSync with (nm:=nm) (n:= S n) (m:=n0);try omega;InvTac.
        apply ITAsyncSync with (nm:=nm) (n:= S (max n m)) (m:=n0);try omega;InvTac.
        apply ITAsyncSync with (nm:=nm) (n:= S n) (m:=n0);try omega;InvTac.
        TensorFlip M1 M2 F Top.  eapply ITAsyncSync with  (nm := nm) (n:= 0%nat) (m:=n) ;try omega;InvTac;eauto.
        TensorFlip M1 M2 F Bot.  eapply ITAsyncSync with  (nm := nm) (n:= S n0) (m:=n) ;try omega;InvTac;eauto.
        TensorFlip M1 M2 F (F1 $ G0).  eapply ITAsyncSync with  (nm := nm) (n:= S n0) (m:=n) ;try omega;InvTac;eauto.
        TensorFlip M1 M2 F (F1 & G0).  eapply ITAsyncSync with  (nm := nm) (n:= S (max n0 m)) (m:=n) ;try omega;InvTac;eauto.
        TensorFlip M1 M2 F (? F1).  eapply ITAsyncSync with  (nm := nm) (n:= S n0) (m:=n) ;try omega;InvTac;eauto.
        (* both F and G are not asynchronous formulas *)
        eapply  ITSyncSync with (nm := nm) (n:=n) (m:=n0)...

        TensorFlip M1 M2 F (F{ FX}).  eapply ITAsyncSync with  (nm := nm) (n:= S n0) (m:=n) ;try omega;InvTac;eauto.
        eapply ITAsyncSync with  (nm := nm) (n:= S n) (m:=n0) ;try omega;InvTac;eauto.

      + (* L1 is empty and L2 is not empty *)
        apply InvTensorConsNil with (nm:=nm) (n':=n') (m':=m') (L1 := [])...
      + (* L1 is not empty and L2 is empty *)
        assert( |-F- B; M2 ++ M1 ++ [G ** F]; UP ([] ++ l :: L1 )).
        eapply InvTensorConsNil with (nm:=nm) (n':=m') (m':=n') ... omega.
        apply AdequacyTri2 in H. destruct H.
        rewrite app_nil_r in *.
        MReplaceIn (M2 ++ M1 ++ [G ** F]) ((M2 ++ M1) ++ [G ** F]) H.
        apply TensorComm in H.
        MReplace (M1 ++ M2 ++ [F ** G]) ((M2 ++ M1) ++ [F ** G]).
        eapply AdequacyTri1;eauto.
      + (* L1 and L2 are not empty *)
        apply InvTensorConsNil with (nm:=nm) (n':=n') (m':=m') (L1 := l :: L1)...
    Qed.

    (* =============================================== *)
    (* PROOF OF RDOWN *)
    (* =============================================== *)
    Theorem InvTensorDW: forall  n , (forall m : nat, m <= n -> RInd m) -> RDown (n).
    Proof with InvTac;auto using LexpPosOrNegAtomConc.
      intros n IH.
      unfold RDown.  intros B M M'  H  F G n0 m Hnm  HM1pos HM2pos HPosF HD1 HD2.
      caseLexp H;subst;InvTac; inversion HD1;subst ...
      ++ (* atom 1 *)
        (* HD1  + HM1Pos is inconsistent *)
        apply  NegPosAtom in H4.
        assert(False) by (eapply NegPosAtomContradiction;eauto).
        contradiction.
      ++ (* atom 2 *)
        apply UpExtension in H5 ...
        destruct H5.
        destruct H.
        assert(HRI: RInd (m + x)). apply IH. omega.
        eapply tri_rel ...
        destruct HRI as [HUp  HDown]. clear HDown.
        assert(|-F- B; M ++ M' ++ [F ** G]; UP ([A3 ⁺] ++ [])).
        eapply HUp with (n:= x )(m0:= m) ... omega.
        eapply EquivUpArrow2;eauto.
      ++ (* perp1 *)
        (* same inconsistency *)
        apply  NegPosAtom in H4.
        assert(False) by (eapply NegPosAtomContradiction;eauto).
        contradiction.
      ++ (* perp2 *)
        apply UpExtension in H5 ...
        destruct H5.
        destruct H.
        assert(HRI: RInd (m + x)). apply IH. omega.
        eapply tri_rel ...
        destruct HRI as [HUp  HDown]. clear HDown.
        assert(|-F- B; M ++ M' ++ [F ** G]; UP ( [A3 ⁻] ++ [])).
        eapply HUp with (n:= x )(m0:= m) ... omega.
        eapply EquivUpArrow2;eauto.
      ++ (* bbot *)
        apply UpExtension in H4 ...
        destruct H4 as [m' H4]. destruct H4 as [H4 H4'].
        assert(HRI: RInd (m' + m))  by (apply IH ;omega).
        destruct HRI as [HUp  HDown] ...
        apply tri_rel ...
        assert(|-F- B; M ++ M' ++ [F ** G]; UP ( [⊥] ++ [])).
        eapply HUp with (n:= m' )(m0:= m) ...
        eapply EquivUpArrow2;eauto.
      ++ (* tensor *)
        symmetry in H2.
        assert(HC: M ++ [F] =mul= [F] ++ M) by solve_permutation; rewrite HC in H2;clear HC.
        (* 2 choices: F is M or in N *)
        simpl_union_context.
        +++ rewrite union_comm in HL1.
            rewrite HL1 in H7. rewrite H.
            assert(HRI: RInd (S m + m0)).  apply IH. simpl. apply le_n_S.
            rewrite Nat.add_comm. apply plus_le_compat_r ...
            destruct HRI as [HUp  HDown] ...
            eapply HDown in H7 ...
            apply AdequacyTri1 in H3.
            apply H7 in HD2.
            eapply tri_tensor with (N:=N ) (M:=L1 ++ M' ++ [F ** G]) ...
            eauto.
            omega.
            eapply LPos3 ;eauto.
            auto.
        +++ rewrite union_comm in HL2.
            rewrite HL2 in H3. rewrite H.
            assert(HRI: RInd (S m + n)).  apply IH. simpl. apply le_n_S.
            rewrite Nat.add_comm. apply plus_le_compat_r ...
            destruct HRI as [HUp  HDown] ...
            eapply HDown in H3 ...
            apply AdequacyTri1 in H7.
            apply H3 in HD2.
            eapply tri_tensor with (M:=M0 ) (N:=L2 ++ M' ++ [F ** G]) ...
            omega.
            eapply LPos3 ;eauto.
            auto.
      ++ (* Par *)
        apply UpExtension in H6 ...
        destruct H6 as [m' H6]. destruct H6 as [H6 H6'].
        assert(HRI: RInd (m' + m))  by (apply IH ;omega).
        destruct HRI as [HUp  HDown] ...
        apply tri_rel ...
        assert(|-F- B; M ++ M' ++ [F ** G]; UP ( [F0 $ G0] ++ [])).
        eapply HUp with (n:= m' )(m0:= m) ...
        eapply EquivUpArrow2;eauto.
      ++ (* oplus1 *)
        assert(HRI: RInd (S m +n)) by (apply IH ; omega).
        destruct HRI as [HUp  HDown] ...
        assert(Hn : S m + n -1 =  m + n) by omega;rewrite Hn in HDown;clear Hn.
        apply tri_plus1. auto.
        eapply HDown with (n0:=n) (m0:=m)...
        omega.

      ++ (* oplus2 *)
        assert(HRI: RInd (S m +n)) by (apply IH ; omega).
        destruct HRI as [HUp  HDown] ...
        assert(Hn : S m + n -1 =  m + n) by omega;rewrite Hn in HDown;clear Hn.
        apply tri_plus2. auto.
        eapply HDown with (n0:=n) (m0:=m)...
        omega.

      ++ (* with *)
        apply UpExtension in H6 ...
        destruct H6 as [m' H6]. destruct H6 as [H6 H6'].
        assert(HRI: RInd (m' + m))  by (apply IH ;omega).
        destruct HRI as [HUp  HDown] ...
        apply tri_rel ...
        assert(|-F- B; M ++ M' ++ [F ** G]; UP ( [F0 & G0] ++ [])).
        eapply HUp with (n:= m' )(m0:= m) ...
        eapply EquivUpArrow2;eauto.

      ++ (* quest *)
        apply UpExtension in H5 ...
        destruct H5 as [m' H5]. destruct H5 as [H5 H5'].
        assert(HRI: RInd (m' + m))  by (apply IH ;omega).
        destruct HRI as [HUp  HDown] ...
        apply tri_rel ...
        assert(|-F- B; M ++ M' ++ [F ** G]; UP ( [? F0] ++ [])).
        eapply HUp with (n:= m' )(m0:= m) ...
        eapply EquivUpArrow2;eauto.

      ++ (* exists *)
        assert(HRI: RInd (m + S n )) by ( apply IH;omega).
        destruct HRI as [HUp  HDown] ...
        eapply HDown in H3;eauto ...
        omega.
      ++ (* forall *)
        apply UpExtension in H4 ...
        destruct H4 as [m' H4]. destruct H4 as [H4 H4'].
        assert(HRI: RInd (m' + m))  by (apply IH ;omega).
        destruct HRI as [HUp  HDown] ...
        apply tri_rel ...
        assert(|-F- B; M ++ M' ++ [F ** G]; UP ( [F{ FX}] ++ [])).
        eapply HUp with (n:= m' )(m0:= m) ...
        eapply EquivUpArrow2;eauto.
    Qed.

    Theorem InvTensorAux : forall n, RInd n.
      intro n.
      induction n using strongind.
      + unfold RInd.
        split; [apply RUp0 | apply RDown0].
      + unfold RInd in *.
        split.
        apply InvTensorUP. assumption.
        simpl.  rewrite Nat.sub_0_r.
        apply InvTensorDW. assumption.
    Qed.

    (* =============================================== *)
    (* MAIN INVERTIBILITY THEOREM *)
    (* =============================================== *)

    Theorem InvTensor : forall B L L' F G  M M', LexpPos M  -> LexpPos M' ->  |-F- B  ;M ; UP (F :: L) -> |-F- B; M'; UP (G :: L') -> |-F- B ; M ++ M' ++ [F ** G]  ; UP (L ++ L') .
      intros.
      apply EquivUpArrow2 with (L' := L ++ [F]) in H1 ;eauto.
      apply EquivUpArrow2 with (L' := L' ++ [G]) in H2 ;eauto.
      assert(HRn:  forall n, RUp n) by (apply InvTensorAux).
      apply AdequacyTri2 in H1.
      apply AdequacyTri2 in H2.
      destruct H1.
      destruct H2.
      generalize (HRn (x + x0));intros.
      eapply H3 in H;eauto.
    Qed.

  End InvTensor.

  (* =============================================== *)
  (** Completeness Theorem *)
  (* =============================================== *)
  Module Completeness.

    Theorem CompletenessAux : forall B L n,  n |-- B ; L -> |-F- B ; empty ; UP L.
    Proof with InvTac;NegPhase.
      intros.
      generalize dependent B.
      generalize dependent L.
      induction n  using strongind; intros L  B H1.
      +  (* Base case *)
        inversion H1;subst;simpl.
        ++ (* Init *)
          generalize( ApropPosNegAtom A3);intro HA3.
          destruct HA3 as [HA3 | HA3];
            (* Positive Polarity *)
            apply EquivUpArrow2 with (L:= [A3 ⁺; A3 ⁻]);NegPhase ...
          eapply tri_dec1 with (F:=A3 ⁻) ...
          apply PositiveNegativeAtomNeg;auto.
          (* Negative Atom *)
          eapply tri_dec1 with (F:=A3 ⁺) ...
          apply NegativePositiveAtomNeg ...
        ++ (* one *)
          apply EquivUpArrow2 with (L:= [1]) ...
          eapply tri_dec1 with (F:=1) ...
        ++ (* top *)
          apply EquivUpArrow2 with (L:= ⊤ :: M) ...
      + (* Inductive Cases *)
        inversion H1;subst;InvTac;
          try(match goal with [H : ?L =mul= ?M |- |-F- _ ; _ ; UP ?L] =>
                              apply EquivUpArrow2 with (L:= M) end);auto ...
        ++ (* Bot *)
          eapply H with (m:=n) ...
        ++ (* PAR *)
          eapply H with (m:=n) ...
        ++ (* Tensor *)
          apply H in H3 ...
          apply H in H4 ...
          MReplace ([F ** G]) ( [] ++ [] ++ [F ** G]).
          apply InvTensor.InvTensor ...
        ++ (* OPLUS1 *)
          apply H in H3 ...
          MReplace ([F ⊕ G]) ( [] ++ [F ⊕ G]).
          apply InvOPlus.InvPlus ...
        ++ (* OPLUS2 *)
          apply H in H3 ...
          MReplace ([F ⊕ G]) ( [] ++ [F ⊕ G]).
          apply InvOPlus.InvPlusComm ...
        ++ (* With *)
          eapply H with (m0:=m)...
        ++ (* With2 *)
          eapply H with (m0:=n0)...
        ++ (* Copy *)
          apply H in H4 ...
          apply EquivUpArrow2 with (L':= F :: L) in H4...
          MReplaceIn (B) (B0 ++ [F]) H4.
          apply InvCopy.InvCopy in H4 ...
          MReplace (B) (B0 ++ [F])...
        ++ (* Quest *)
          apply H in H3 ...
          MReplace (B ++ [F]) (F :: B)...
        ++ (* Bang *)
          apply H in H3 ...
          eapply tri_dec1 with (F:=!F)...
        ++ (* exists *)
          apply H in H3 ...
          apply InvExists.InvEx in H3 ...
        ++ (* forall *)
          generalize (H3 x);intro H3'.
          apply H in H3' ...
    Qed.

    Theorem Completeness : forall B L M n,  n |-- B ; M ++ L -> LexpPos M -> |-F- B ; M ; UP L.
    Proof with InvTac.
      intros.
      apply CompletenessAux in H.
      apply AdequacyTri2 in H.
      destruct H.
      apply  StoreInversionL in H ...
      destruct H.
      eapply AdequacyTri1;eauto.
    Qed.

  End Completeness.

End InvLemmas.


(*
(C) Copyright 2011, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

This library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)
Require Import Reals.
Require Import Rpser_def Rpser_def_simpl.

Require Import Rinterval.
Require Import Rsequence_def Rsequence_base_facts Rsequence_subsequence Rsequence_rewrite_facts.
Require Import Rsequence_cv_facts Rsequence_facts Rsequence_bound_facts Rsequence_sums_facts.
Require Import Rpow_facts.
Require Import Max.
Require Import Lra MyRIneq MyNat MyNNR.

Local Open Scope R_scope.

(** ** Some lemmas manipulating the definitions. *)

(** * Extensionality of radiuses. *)

Section Radius_extensionality.

Variables An Bn : Rseq.
Hypothesis AnBn_ext : (An == Bn)%Rseq.

Lemma An_deriv_ext : (An_deriv An == An_deriv Bn)%Rseq.
Proof.
intro n ; unfold An_deriv, Rseq_mult, Rseq_shift ; rewrite AnBn_ext ; reflexivity.
Qed.

Lemma An_nth_deriv_ext : forall k, (An_nth_deriv An k == An_nth_deriv Bn k)%Rseq.
Proof.
intros n k ; unfold An_nth_deriv, Rseq_mult, Rseq_div, Rseq_shifts ;
rewrite AnBn_ext ; reflexivity.
Qed.

Lemma Cv_radius_weak_ext : forall r, Cv_radius_weak An r <-> Cv_radius_weak Bn r.
Proof.
intro r ; split ; intros [B HB] ; exists B ; intros x [i Hi] ; subst ;
 [rewrite <- (gt_abs_pser_ext  _ _ _ AnBn_ext) |
 rewrite (gt_abs_pser_ext _ _ _ AnBn_ext)] ; apply HB ; exists i ; reflexivity.
Qed.

Lemma finite_cv_radius_ext : forall r, finite_cv_radius An r <->
  finite_cv_radius Bn r.
Proof.
intro r ; split ; intros [rho_lb rho_ub] ; split ; intros r' Hr' ;
 [rewrite <- Cv_radius_weak_ext | rewrite <- Cv_radius_weak_ext
 | rewrite Cv_radius_weak_ext | rewrite Cv_radius_weak_ext] ; auto.
Qed.

Lemma infinite_cv_radius_ext : infinite_cv_radius An <->
  infinite_cv_radius Bn.
Proof.
split ; intros rho r ; [rewrite <- Cv_radius_weak_ext |
 rewrite Cv_radius_weak_ext] ; trivial.
Qed.

End Radius_extensionality.

(** Compatibility of gt_pser with common operations. *)

Lemma gt_pser_expand_compat : forall Un l x,
  forall n, gt_pser (An_expand Un l) x n = gt_pser Un (l * x) n.
Proof.
intros ; unfold gt_pser, An_expand, Rseq_mult, Rseq_pow ;
rewrite Rpow_mult_distr ; ring.
Qed.

Lemma gt_pser_scal_compat_l : forall Un (l : R) x,
  forall n, gt_pser (l * Un) x n = l * gt_pser Un x n.
Proof.
intros Un l x n ; unfold gt_pser, Rseq_mult, Rseq_constant ; ring.
Qed.

Lemma gt_pser_scal_compat_r : forall Un (l : R) x,
  forall n, gt_pser (Un * l) x n = gt_pser Un x n * l.
Proof.
intros Un l x n ; unfold gt_pser, Rseq_mult, Rseq_constant ; ring.
Qed.

Lemma gt_pser_opp_compat : forall Un x,
  gt_pser (- Un) x == - gt_pser Un x.
Proof.
intros Un x n ; unfold gt_pser, Rseq_opp, Rseq_mult ; ring.
Qed.

Lemma gt_pser_plus_compat : forall Un Vn x,
  gt_pser (Un + Vn) x == gt_pser Un x + gt_pser Vn x.
Proof.
intros Un Vn x n ; unfold gt_pser, Rseq_plus, Rseq_mult ; ring.
Qed.

Lemma gt_pser_minus_compat : forall Un Vn x,
  gt_pser (Un - Vn) x == gt_pser Un x - gt_pser Vn x.
Proof.
intros Un Vn x n ; unfold gt_pser, Rseq_minus, Rminus,
 Rseq_plus, Rseq_mult ; ring.
Qed.

Lemma gt_pser_mult_compat_l : forall Un Vn x,
  gt_pser (Un * Vn) x == Un * gt_pser Vn x.
Proof.
intros Un Vn x n ; unfold gt_pser, Rseq_mult ; ring.
Qed.

Lemma gt_pser_mult_compat_r : forall Un Vn x,
  gt_pser (Un * Vn) x == gt_pser Un x * Vn.
Proof.
intros Un Vn x n ; unfold gt_pser, Rseq_mult ; ring.
Qed.

Lemma gt_pser_prod_compat : forall Un Vn x,
  gt_pser (Un # Vn) x == (gt_pser Un x) # (gt_pser Vn x).
Proof.
intros Un Vn x n ; unfold gt_pser, Rseq_prod, Rseq_mult.
 assert (Hrew := Rseq_sum_scal_compat_r (pow x n)
 (fun n0 : nat => Un n0 * Vn (n - n0)%nat)%R n) ;
 unfold Rseq_mult, Rseq_constant in Hrew ;
 rewrite <- Hrew ; apply Rseq_sum_ext_strong.
 intros p p_bd ; replace (x ^ n) with (x ^ ((p + (n - p))%nat)).
 rewrite pow_add ; ring.
 replace (p + (n - p))%nat with n by omega ; reflexivity.
Qed.

(** Compatibility of gt_abs_pser with common operations. *)

Lemma gt_abs_pser_pos : forall An x n,
  0 <= gt_abs_pser An x n.
Proof.
intros ; unfold gt_abs_pser, Rseq_abs ; apply Rabs_pos.
Qed.

Lemma gt_abs_pser_scal_compat_l : forall Un (l : R) x,
  forall n, gt_abs_pser (l * Un) x n = Rabs l * gt_abs_pser Un x n.
Proof.
intros Un l x n ; unfold gt_abs_pser, Rseq_abs ;
 rewrite gt_pser_scal_compat_l ; apply Rabs_mult.
Qed.

Lemma gt_abs_pser_scal_compat_r : forall Un (l : R) x,
  forall n, gt_abs_pser (Un * l) x n = gt_abs_pser Un x n * Rabs l.
Proof.
intros Un l x n ; unfold gt_abs_pser, Rseq_abs ;
 rewrite gt_pser_scal_compat_r ; apply Rabs_mult.
Qed.

Lemma gt_abs_pser_opp_compat : forall Un x,
  gt_abs_pser (- Un) x == gt_abs_pser Un x.
Proof.
intros Un x n ; unfold gt_abs_pser, Rseq_abs ;
rewrite gt_pser_opp_compat ; unfold Rseq_opp ;
apply Rabs_Ropp.
Qed.

Lemma gt_abs_pser_mult_compat_l : forall Un Vn x,
  gt_abs_pser (Un * Vn) x == | Un | * gt_abs_pser Vn x.
Proof.
intros Un Vn x n ; unfold gt_abs_pser, Rseq_abs ;
rewrite gt_pser_mult_compat_l ; unfold Rseq_mult ;
apply Rabs_mult.
Qed.

Lemma gt_abs_pser_mult_compat_r : forall Un Vn x,
  gt_abs_pser (Un * Vn) x == gt_abs_pser Un x * | Vn |.
Proof.
intros Un Vn x n ; unfold gt_abs_pser, Rseq_abs ;
rewrite gt_pser_mult_compat_r ; unfold Rseq_mult ;
apply Rabs_mult.
Qed.

Lemma gt_abs_pser_prod_le_compat : forall Un Vn x n,
  gt_abs_pser (Un # Vn) x n <= ((gt_abs_pser Un x) # (gt_abs_pser Vn x)) n.
Proof.
intros Un Vn x n ; unfold gt_abs_pser, Rseq_abs ; rewrite gt_pser_prod_compat.
unfold Rseq_prod ; eapply Rle_trans ; [eapply Rseq_sum_triang |].
right ; apply Rseq_sum_ext ; intro p ; unfold gt_pser, Rseq_abs, Rseq_mult ;
apply Rabs_mult.
Qed.

(** Compatibility of An_deriv with the common operators. *)

Lemma An_deriv_opp_compat : forall An,
  An_deriv (- An) == - An_deriv An.
Proof.
intros An n ; unfold Rseq_opp, An_deriv, Rseq_mult,
Rseq_shift ; apply Ropp_mult_distr_r_reverse.
Qed.

Lemma An_deriv_plus_compat : forall An Bn,
  An_deriv (An + Bn) == (An_deriv An) + (An_deriv Bn).
Proof.
intros An Bn n ; unfold Rseq_opp, An_deriv, Rseq_mult,
 Rseq_shift, Rseq_plus ; apply Rmult_plus_distr_l.
Qed.

Lemma An_deriv_minus_compat : forall An Bn,
  An_deriv (An - Bn) == An_deriv An - An_deriv Bn.
Proof.
intros An Bn n ; unfold An_deriv, Rseq_shift,
Rseq_mult, Rseq_minus ; apply Rmult_minus_distr_l.
Qed.

Lemma An_deriv_abs_compat : forall An,
  An_deriv (| An |) == | An_deriv An |.
Proof.
intros An n ; unfold An_deriv, Rseq_shift, Rseq_mult, Rseq_abs ;
 rewrite Rabs_mult ; apply Rmult_eq_compat.
 symmetry ; apply Rabs_right, Rle_ge, pos_INR.
 reflexivity.
Qed.

Lemma An_deriv_alt_compat : forall An,
  An_deriv (Rseq_alt An) == - Rseq_alt (An_deriv An).
Proof.
intros An n ; unfold An_deriv, Rseq_shift, Rseq_alt, Rseq_mult, Rseq_opp ;
 simpl Rseq_pow ; ring.
Qed.

Lemma An_deriv_mult_compat_l : forall An Bn,
  An_deriv (An * Bn) == An_deriv An * Rseq_shift Bn.
Proof.
intros An Bn n ; unfold An_deriv, Rseq_mult, Rseq_shift ;
 ring.
Qed.

Lemma An_deriv_mult_compat_r : forall An Bn,
  An_deriv (An * Bn) == Rseq_shift An * An_deriv Bn.
Proof.
intros An Bn n ; unfold An_deriv, Rseq_mult, Rseq_shift ;
 ring.
Qed.

(** * Cv_radius_weak *)
(** There exists always a Cv_radius_weak. *)

Lemma Cv_radius_weak_0 : forall An, Cv_radius_weak An 0.
Proof.
intro An ; exists (Rabs(An O)) ; intros x [n Hn] ; subst ;
unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.
destruct n.
 simpl ; rewrite Rmult_1_r ; reflexivity.
 rewrite pow_i ; [| omega] ; rewrite Rmult_0_r, Rabs_R0 ;
 apply Rabs_pos.
Qed.

Lemma Cv_radius_weak_subseq_compat :
  forall An Bn r, 1 <= Rabs r -> subsequence Bn An ->
  Cv_radius_weak An r -> Cv_radius_weak Bn r.
Proof.
intros An Bn r Hr [[phi Hphi] HAB] [ub Hub].
 exists ub ; intros B [i Hi] ; subst ; transitivity (gt_abs_pser An r (phi i)).
  unfold gt_abs_pser, Rseq_abs, gt_pser, Rseq_mult ; do 2 rewrite Rabs_mult.
  apply Rmult_le_compat ; try (apply Rabs_pos).
  right ; apply Rabs_eq_compat, HAB.
  do 2 rewrite <- RPow_abs ; apply Rle_pow, Rsubseq_n_le_extractor_n ; assumption.
  apply Hub ; exists (phi i) ; reflexivity.
Qed.

(** Compatibility of the Cv_radius_weak concept with common operations. *)

Lemma Cv_radius_weak_Rabs : forall (An : Rseq) (r : R),
  Cv_radius_weak An (Rabs r) <-> Cv_radius_weak An r.
Proof.
intros An r ; split ; intros [B HB] ; exists B ; intros y [i Hi] ; subst ;
 apply HB ; exists i ; rewrite gt_abs_pser_Rabs_compat ; reflexivity.
Qed.

Lemma Rle_Cv_radius_weak_compat : forall (An Bn : nat -> R) (r : R),
      (forall n, Rabs (Bn n) <= Rabs (An n)) ->
      Cv_radius_weak An r ->
      Cv_radius_weak Bn r.
Proof.
intros An Bn r Bn_le_An [M HM] ; exists M ; intros x [n Hn] ; subst ;
 apply Rle_trans with (gt_abs_pser An r n) ;
 [| apply HM ; exists n ; reflexivity].
 unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult ; do 2 rewrite Rabs_mult ;
 apply Rmult_le_compat_r ; [apply Rabs_pos | apply Bn_le_An].
Qed.

Lemma Cv_radius_weak_le_compat : forall (An : nat -> R) (r r' : R),
       Rabs r' <= Rabs r -> Cv_radius_weak An r -> Cv_radius_weak An r'.
Proof.
intros An r r' r'_bd [B HB].
  exists B ; intros x [i Hi] ; subst ; apply Rle_trans with (gt_abs_pser An r i).
  apply gt_abs_pser_le_compat ; assumption.
  apply HB ; exists i ; reflexivity.
Qed.

Lemma Cv_radius_weak_shifts_compat : forall An r k,
  Cv_radius_weak An r <-> Cv_radius_weak (Rseq_shifts An k) r.
Proof.
intros An r k ; split ; intros [B HB].
destruct (Req_dec r 0) as [r_eq | r_neq].
 rewrite r_eq ; exists (Rabs (An k)) ; intros x [i Hi] ; subst ;
 rewrite <- (Rseq_shifts_O An) ; apply gt_abs_pser_0_ub.
 assert (Rabs (r ^ k) <> 0) by (apply Rabs_no_R0 ; apply pow_nonzero ; assumption).
 exists (B * (/ Rabs (r ^ k))) ; intros x [i Hi] ; subst.
 apply Rle_trans with (Rseq_shifts (gt_abs_pser An r) k i * / Rabs (r ^ k)).
 unfold gt_abs_pser, gt_pser, Rseq_shifts, Rseq_abs, Rseq_mult ; simpl ;
 rewrite plus_comm, pow_add, <- Rmult_assoc, (Rabs_mult (An (i + k)%nat * r ^ i)) ;
 right ; field ; assumption.
 apply Rmult_le_compat_r ; [left ; apply Rinv_0_lt_compat ;
  assert (T := Rabs_pos (r ^k)) ; apply Rle_neq_lt ; auto|].
 apply HB ; exists (k + i)%nat ; unfold Rseq_shifts ; reflexivity.
destruct (Rseq_partial_bound (gt_pser An r) k) as [C HC] ;
 exists (Rmax (B * Rabs (r ^ k)) C) ; intros u [i Hi] ; subst.
 destruct (le_lt_dec i k) as [k_lb | k_ub].
 apply Rle_trans with C ; [apply HC | apply RmaxLess2] ; assumption.
 apply Rle_trans with (B * Rabs (r ^ k))%R ; [| apply RmaxLess1].
 destruct (lt_exist k i k_ub) as [p Hp] ; subst ; unfold gt_abs_pser, gt_pser,
 Rseq_abs, Rseq_mult ; rewrite plus_comm, pow_add, plus_comm, <- Rmult_assoc,
 Rabs_mult ; apply Rmult_le_compat_r ; [apply Rabs_pos |] ; apply HB ; exists p ;
 unfold Rseq_shifts, gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult ; reflexivity.
Qed.

Lemma Cv_radius_weak_shift_compat : forall An r,
  Cv_radius_weak An r <-> Cv_radius_weak (Rseq_shift An) r.
Proof.
intros An r ; replace (Rseq_shift An) with (Rseq_shifts An 1) by reflexivity ;
 apply Cv_radius_weak_shifts_compat.
Qed.

Lemma Cv_radius_weak_expand_compat : forall An r l,
  Cv_radius_weak An (l * r) <-> Cv_radius_weak (An_expand An l) r.
Proof.
intros An r l ; split ; intros [B HB] ; exists B ; intros x [i Hi] ; subst ;
apply HB ; exists i ; unfold An_expand, gt_abs_pser, gt_pser, Rseq_mult, Rseq_abs, Rseq_pow ;
apply Rabs_eq_compat ; rewrite Rpow_mult_distr ; ring.
Qed.

(** Compatibility of Cv_radius_weak with common operators. *)

Lemma Cv_radius_weak_scal : forall (An : Rseq) (lambda r : R), lambda <> 0 ->
  (Cv_radius_weak An r <-> Cv_radius_weak (lambda * An)%Rseq r).
Proof.
intros An lam r lam_neq ; split ; intros [B HB] ;
 [exists (Rabs lam * B) | exists (B * / (Rabs lam))] ;
 intros x [n Hn] ; subst ; unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.

 do 2 rewrite Rabs_mult ; rewrite Rmult_assoc ;
  apply Rmult_le_compat_l ; [apply Rabs_pos |] ;
  rewrite <- Rabs_mult ; apply HB ; exists n ; reflexivity.

 apply Rle_trans with (Rabs lam * Rabs (An n * r ^ n) * / Rabs lam) ;
  [right ; field ; apply Rabs_no_R0 ; assumption |].
  rewrite <- Rabs_mult ; apply Rmult_le_compat_r ; [left ;
  apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption |].
  rewrite <- Rmult_assoc ; apply HB ; exists n ; reflexivity.
Qed.

Lemma Cv_radius_weak_abs : forall (An : Rseq) (r : R),
  Cv_radius_weak An r <-> Cv_radius_weak (| An |) r.
Proof.
intros An r ; split ; intros [B HB] ; exists B ; intros x [n Hn] ;
subst ; [rewrite gt_abs_pser_Rseq_abs_compat |
rewrite <- gt_abs_pser_Rseq_abs_compat] ; apply HB ; exists n ; reflexivity.
Qed.

Lemma Cv_radius_weak_plus : forall An Bn r1 r2,
  Cv_radius_weak An r1 -> Cv_radius_weak Bn r2 ->
  Cv_radius_weak (An + Bn)%Rseq (Rmin (Rabs r1) (Rabs r2)).
Proof.
intros An Bn r1 r2 RhoA RhoB.
assert (r''_bd1 : Rabs (Rmin (Rabs r1) (Rabs r2)) <= Rabs r1).
 unfold Rmin ; case (Rle_dec (Rabs r1) (Rabs r2)) ; intro H ;
 rewrite Rabs_Rabsolu ; intuition.
assert (r''_bd2 : Rabs (Rmin (Rabs r1) (Rabs r2)) <= Rabs r2).
 unfold Rmin ; case (Rle_dec (Rabs r1) (Rabs r2)) ; intro H ;
 rewrite Rabs_Rabsolu ; intuition.
assert (Rho'A := Cv_radius_weak_le_compat An _ _ r''_bd1 RhoA).
assert (Rho'B := Cv_radius_weak_le_compat Bn _ _ r''_bd2 RhoB).
 destruct Rho'A as (C, HC) ;
 destruct Rho'B as (C', HC') ;
 exists (C + C').
 intros x [i Hi] ; subst ; unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult, Rseq_plus.
 rewrite Rmult_plus_distr_r ; apply Rle_trans with (Rabs (An i *  Rmin (Rabs r1)
         (Rabs r2) ^ i) + Rabs (Bn i * Rmin (Rabs r1) (Rabs r2) ^ i)) ; [apply Rabs_triang |].
 apply Rle_trans with (Rabs (An i * Rmin (Rabs r1) (Rabs r2) ^ i) + C') ;
 [apply Rplus_le_compat_l ; apply HC' | apply Rplus_le_compat_r ; apply HC] ;
 exists i ; intuition.
Qed.

Lemma Cv_radius_weak_opp : forall (An : Rseq) (r : R),
  Cv_radius_weak An r <->
  Cv_radius_weak (- An)%Rseq r.
Proof.
intros An r ; split ; intros [B HB] ; exists B ; intros x [i Hi] ; subst ;
 unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.
 unfold Rseq_opp ; rewrite Ropp_mult_distr_l_reverse, Rabs_Ropp ;
 apply HB ; exists i ; reflexivity.
 rewrite <- Rabs_Ropp, <- Ropp_mult_distr_l_reverse ; apply HB ;
 exists i ; reflexivity.
Qed.

Lemma Cv_radius_weak_minus : forall (An Bn : nat -> R) (r1 r2 : R),
  Cv_radius_weak An r1 -> Cv_radius_weak Bn r2 ->
  Cv_radius_weak (An - Bn)%Rseq (Rmin (Rabs r1) (Rabs r2)).
Proof.
intros An Bn r1 r2 RhoA RhoB.
 assert (Rho'B := proj1 (Cv_radius_weak_opp Bn _) RhoB).
 unfold Rminus ; apply Cv_radius_weak_plus ; assumption.
Qed.

Lemma Cv_radius_weak_alt : forall An r,
  Cv_radius_weak An r <-> Cv_radius_weak (Rseq_alt An) r.
Proof.
intros An r ; split ; intro rAn.
 eapply Cv_radius_weak_abs, Cv_radius_weak_ext.
  apply Rseq_abs_alt.
  rewrite <- Cv_radius_weak_abs ; assumption.
 rewrite Cv_radius_weak_abs, Cv_radius_weak_ext with (Bn := Rseq_abs (Rseq_alt An)).
  rewrite <- Cv_radius_weak_abs ; assumption.
  symmetry ; apply Rseq_abs_alt.
Qed.

(** This lemma will, together with the one about An_deriv, give us Cv_radius_weak_prod. *)

Lemma Cv_radius_weak_prod_prelim : forall An Bn r1 r2,
  Cv_radius_weak An r1 -> Cv_radius_weak Bn r2 ->
  Cv_radius_weak ((An # Bn) / Rseq_shift INR)%Rseq (Rmin (Rabs r1) (Rabs r2)).
Proof.
intros An Bn r1 r2 rAn rBn.
assert (rAn' : Cv_radius_weak An (Rmin (Rabs r1) (Rabs r2))).
 apply Cv_radius_weak_le_compat with r1.
 rewrite Rabs_pos_eq ; [apply Rmin_l | apply Rmin_pos ; apply Rabs_pos].
 assumption.
assert (rBn' : Cv_radius_weak Bn (Rmin (Rabs r1) (Rabs r2))).
 apply Cv_radius_weak_le_compat with r2.
 rewrite Rabs_pos_eq ; [apply Rmin_r | apply Rmin_pos ; apply Rabs_pos].
 assumption.
clear rAn rBn ; destruct rAn' as [B1 HB1] ; destruct rBn' as [B2 HB2] ;
 exists (B1 * B2).
assert (H1 : Rseq_bound (gt_abs_pser An (Rmin (Rabs r1) (Rabs r2))) B1).
 intro n ; apply HB1 ; exists n ; unfold gt_abs_pser, Rseq_abs ;
 rewrite Rabs_Rabsolu ; reflexivity.
assert (H2 : Rseq_bound (gt_abs_pser Bn (Rmin (Rabs r1) (Rabs r2))) B2).
 intro n ; apply HB2 ; exists n ; unfold gt_abs_pser, Rseq_abs ;
 rewrite Rabs_Rabsolu ; reflexivity.
clear HB1 HB2.
intros x [n Hn] ; subst.
 erewrite gt_abs_pser_ext ; [| eapply Rseq_div_simpl].
 rewrite gt_abs_pser_mult_compat_r.
 eapply Rle_trans ; [eapply Rmult_le_compat_r ; [unfold Rseq_abs ;
 apply Rabs_pos | eapply gt_abs_pser_prod_le_compat] |].
 eapply Rle_trans ; [| eapply Rseq_bound_prod ; try eassumption].
right ; unfold Rseq_div, Rdiv, Rseq_mult ; rewrite Rabs_mult.
 apply Rmult_eq_compat ; [| unfold Rseq_abs ; reflexivity].
symmetry ; apply Rabs_pos_eq.
unfold Rseq_prod ; apply Rseq_sum_pos_strong ; intros p p_bd.
 unfold Rseq_mult ; apply Rmult_le_pos ; apply gt_abs_pser_pos.
Qed.

(** Cv_radius_weak is compatible with zip *)

Lemma Cv_radius_weak_zip_l : forall An Bn (r : nonnegreal),
  Cv_radius_weak An r -> Cv_radius_weak Bn r -> Cv_radius_weak (Rseq_zip An Bn) (Rsqrt r).
Proof.
intros An Bn r [BAn HAn] [BBn HBn] ; exists (Rmax BAn (BBn * Rabs (Rsqrt r))) ;
 intros x [i Hi] ; subst.
 unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_zip, Rseq_mult.
  case (n_modulo_2 i) ; intros [p Hp] ; rewrite Hp.
   rewrite Rsqrt_pow_even ; transitivity BAn ;
   [apply HAn ; exists p ; reflexivity | apply RmaxLess1].
   rewrite <- tech_pow_Rmult, Rsqrt_pow_even ; transitivity (Rabs (Bn p * r ^ p) * Rabs (Rsqrt r)).
    right ; rewrite <- Rabs_mult ; apply Rabs_eq_compat ; ring.
    transitivity (BBn * Rabs (Rsqrt r)).
     apply Rmult_le_compat_r ; [apply Rabs_pos | apply HBn ; exists p ; reflexivity].
     apply RmaxLess2.
Qed.

Lemma Cv_radius_weak_zip_r1 : forall An Bn r,
  Cv_radius_weak (Rseq_zip An Bn) r -> Cv_radius_weak An (r ^ 2).
Proof.
intros An Bn r [B HB] ; exists B ; intros x [i Hi] ; subst.
 transitivity (gt_abs_pser (Rseq_zip An Bn) r (2 * i)).
 right ; unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult, Rseq_zip.
  case (n_modulo_2 (2 * i)) ; intros [p Hp].
   assert (Hip : i = p) by omega ; rewrite Hip, pow_mult ; reflexivity.
   apply False_ind ; omega.
 apply HB ; exists (2 * i)%nat ; reflexivity.
Qed.

Lemma Rabs_null_rev : forall r, Rabs r = 0 -> r = 0.
Proof.
intros r Hr ; destruct (Req_dec r 0) as [r_eq | r_neq].
 assumption.
 destruct (Rabs_no_R0 _ r_neq Hr).
Qed.

Lemma Rabs_neq_rev : forall r, Rabs r <> 0 -> r <> 0.
Proof.
intros r Hr Hf ; rewrite Hf, Rabs_R0 in Hr ; apply Hr ; reflexivity.
Qed.

Lemma Cv_radius_weak_zip_r2 : forall An Bn r,
  Cv_radius_weak (Rseq_zip An Bn) r -> Cv_radius_weak Bn (r ^ 2).
Proof.
intros An Bn r [B HB] ; destruct (Req_dec (Rabs r) 0) as [r_eq | r_neq].
 rewrite (Rabs_null_rev _ r_eq) ; simpl ; rewrite Rmult_0_l ; apply Cv_radius_weak_0.
 exists (B / Rabs r) ; intros x [i Hi] ; subst.
 transitivity (gt_abs_pser (Rseq_zip An Bn) r (S (2 * i)) / Rabs r).
 right ; unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult, Rseq_zip.
  case (n_modulo_2 (S (2 * i))) ; intros [p Hp].
   apply False_ind ; omega.
   assert (Hip : i = p) by omega ; rewrite Hip , <- pow_mult, <- tech_pow_Rmult.
   replace (Bn p * (r * r ^ (2 * p))) with (Bn p * r ^ (2 * p) * r) by ring.
   unfold Rdiv ; rewrite (Rabs_mult _ r), Rmult_assoc, Rinv_r, Rmult_1_r.
    reflexivity.
    assumption.
 apply Rmult_le_compat_r.
  left ; apply Rinv_0_lt_compat, Rabs_pos_lt, Rabs_neq_rev ; assumption.
  apply HB ; exists (S (2 * i))%nat ; reflexivity.
Qed.

(** The finite_cv_radius is exactly the upper bound. We choose our definitions
because it gives more information (the convexity of the radius for example). *)

Lemma finite_cv_radius_is_lub : forall (An : Rseq) (r : R),
  finite_cv_radius An r ->
  is_lub (Cv_radius_weak An) r.
Proof.
intros An r [rho rho_ub] ; split.

 intros r' Hr' ; destruct (Rle_lt_dec r' r) as [r'ler | rltr'].
  assumption.
  destruct (rho_ub _ rltr' Hr').

 intros r' Hr' ; destruct (Rle_lt_dec r r') as [rler' | r'ltr].
  assumption.
  assert (H : has_ub (gt_abs_pser An (middle r' r))).
   assert (r'_pos : 0 <= r').
    apply Hr' ; apply Cv_radius_weak_0.
   apply rho ; split ;
   [apply middle_le_le_pos ; [| left ; apply Rle_lt_trans with r']
   | apply middle_is_in_the_middle] ; assumption.
   assert (Hf := Hr' _ H).
   assert (Hf' : r' < middle r' r) by (apply middle_is_in_the_middle ;
    assumption).
   clear -Hf Hf' ; apply False_ind ; lra.
Qed.

(** The reciprocal implication needs the EM axiom because is_lub is not informative
enough. *)

Lemma lub_is_finite_cv_radius : (forall (P : Prop), P \/ ~P) ->
  forall (An : Rseq) (r : R),
  is_lub (Cv_radius_weak An) r ->
  finite_cv_radius An r.
Proof.
intros EM An r [rho_ub rho_l] ; split.

 intros r' [r'_pos r'_bd].
 destruct (EM (Cv_radius_weak An r')) as [P | nP].
  assumption.
  destruct (Rlt_irrefl r); apply Rle_lt_trans with r' ;
  [apply rho_l | assumption] ;
  intros b Hf ; fold (Cv_radius_weak An b) in Hf ;
  destruct (Rle_lt_dec b r') as [b_le_r' | r'_lt_b] ;
  [assumption | destruct nP] ; apply Cv_radius_weak_le_compat with b.
   rewrite Rabs_pos_eq ; [rewrite Rabs_pos_eq |] ; [left | left ;
   apply Rle_lt_trans with r' |] ; assumption.
   assumption.

 intros r' r'_lb Hf ; apply (Rlt_irrefl r) ; apply Rlt_le_trans with r' ;
  [| apply rho_ub] ; assumption.
Qed.

(** Compatibility of the finite_cv_radius concept with various operations. *)

Lemma finite_cv_radius_scal_compat : forall (An : Rseq) (lam r : R), lam <> 0 ->
  (finite_cv_radius An r <-> finite_cv_radius (lam * An)%Rseq r).
Proof.
intros An lam r lam_neq ; split ; intros [H_inf H_sup].
 split ; intros r' ; rewrite <- Cv_radius_weak_scal ;
  [apply H_inf | | apply H_sup |] ; assumption.
 split ; intros r' ; rewrite (Cv_radius_weak_scal _ lam) ;
  [apply H_inf | | apply H_sup |] ; assumption.
Qed.

Lemma finite_cv_radius_abs_compat : forall (An : Rseq) (r : R),
  finite_cv_radius An r <-> finite_cv_radius (| An |) r.
Proof.
intros An r ; split ; intros [H_inf H_sup].
 split ; intros r' ; rewrite <- Cv_radius_weak_abs ;
  [apply H_inf | apply H_sup].
 split ; intros r' ; rewrite Cv_radius_weak_abs ;
  [apply H_inf | apply H_sup] ; assumption.
Qed.

Lemma finite_cv_radius_alt_compat : forall (An : Rseq) (r : R),
  finite_cv_radius An r <-> finite_cv_radius (Rseq_alt An) r.
Proof.
intros An r ; split ; intros [r_ub r_lub] ; split.
 intros ; rewrite <- Cv_radius_weak_alt ; apply r_ub ; assumption.
 intros ; rewrite <- Cv_radius_weak_alt ; apply r_lub ; assumption.
 intros ; apply Cv_radius_weak_alt, r_ub ; assumption.
 intros ; rewrite Cv_radius_weak_alt ; apply r_lub ; assumption.
Qed.

Lemma finite_cv_radius_pos : forall (An : Rseq) (r : R),
  finite_cv_radius An r -> 0 <= r.
Proof.
intros An r [_ Hf] ; destruct(Rle_lt_dec 0 r) as [H1 | H1] ;
 [| exfalso ; destruct (Hf 0) ; try apply Cv_radius_weak_0] ; assumption.
Qed.

Lemma finite_cv_radius_weakening : forall (An : Rseq) (r : R),
  finite_cv_radius An r ->
  forall x, Rabs x < r -> Cv_radius_weak An x.
Proof.
intros An r [H_sup _] x Hx ;
 apply Cv_radius_weak_Rabs ; apply H_sup ; split ;
 [apply Rabs_pos | assumption].
Qed.

Lemma finite_cv_radius_zip_compat_l : forall (An Bn : Rseq) (r : nonnegreal),
  finite_cv_radius An r ->
  (forall x, Rabs x < r -> Cv_radius_weak Bn x) ->
  finite_cv_radius (Rseq_zip An Bn) (Rsqrt r).
Proof.
intros An Bn r HAn HBn ; split.
 intros r' [r'_lb r'_ub] ; rewrite <- (Rsqrt_sqr r' (nnr_sqr r')).
  assert (r'2_encad : 0 <= nnr_sqr r' < r).
   split ; [apply cond_nonneg |].
    simpl ; fold (r' ^ 2) ; rewrite <- Rsqr_Rsqrt ; apply pow_lt_compat ; auto.
  apply Cv_radius_weak_zip_l.
   apply HAn ; assumption.
   apply HBn ; rewrite Rabs_right ; try apply Rle_ge ; apply r'2_encad.
   assumption.
   reflexivity.
  intros r' r'_lb Hf ; apply (proj2 HAn (r' ^ 2)), Cv_radius_weak_zip_r1 with Bn.
   rewrite <- Rsqr_Rsqrt ; apply pow_lt_compat.
    apply Rsqrt_positivity.
    assumption.
    auto.
   assumption.
Qed.

Lemma finite_cv_radius_zip_compat_r : forall (An Bn : Rseq) (r : nonnegreal),
  (forall x, Rabs x < r -> Cv_radius_weak An x) ->
  finite_cv_radius Bn r ->
  finite_cv_radius (Rseq_zip An Bn) (Rsqrt r).
Proof.
intros An Bn r HAn HBn ; split.
 intros r' [r'_lb r'_ub] ; rewrite <- (Rsqrt_sqr r' (nnr_sqr r')).
  assert (r'2_encad : 0 <= nnr_sqr r' < r).
   split ; [apply cond_nonneg |].
    simpl ; fold (r' ^ 2) ; rewrite <- Rsqr_Rsqrt ; apply pow_lt_compat ; auto.
  apply Cv_radius_weak_zip_l.
   apply HAn ; rewrite Rabs_right ; try apply Rle_ge ; apply r'2_encad.
   apply HBn ; assumption.
   assumption.
   reflexivity.
  intros r' r'_lb Hf ; apply (proj2 HBn (r' ^ 2)), Cv_radius_weak_zip_r2 with An.
   rewrite <- Rsqr_Rsqrt ; apply pow_lt_compat.
    apply Rsqrt_positivity.
    assumption.
    auto.
   assumption.
Qed.

(** Compatibility of the infinite_cv_radius concept with various operations. *)

Lemma infinite_cv_radius_zero : infinite_cv_radius 0.
Proof.
intro r ; exists 0 ; intros x [n Hn] ; subst ;
 unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult, Rseq_constant ;
 rewrite Rmult_0_l, Rabs_R0 ; reflexivity.
Qed.

Lemma infinite_cv_radius_shift_compat : forall An,
  infinite_cv_radius (Rseq_shift An) <-> infinite_cv_radius An.
Proof.
intro An ; split ; intros rAn r ;
 [ rewrite Cv_radius_weak_shift_compat
 | rewrite <- Cv_radius_weak_shift_compat ] ;
 trivial.
Qed.

Lemma infinite_cv_radius_subseq_compat : forall An Bn,
  subsequence Bn An -> infinite_cv_radius An -> infinite_cv_radius Bn.
Proof.
intros An Bn HAB HAn r ; pose (r' := Rmax (Rabs r) 1) ;
 assert (r'_pos : 0 <= r') by (apply Rmax_pos_l, Rabs_pos).
 apply Cv_radius_weak_le_compat with r'.
  rewrite (Rabs_right r') ; [apply Rmax_l | apply Rle_ge ; assumption].
  eapply Cv_radius_weak_subseq_compat.
  rewrite (Rabs_right r') ; [apply Rmax_r | apply Rle_ge ; assumption].
  eassumption.
 apply HAn.
Qed.

Lemma infinite_cv_radius_expand_compat : forall An l,
  infinite_cv_radius An -> infinite_cv_radius (An_expand An l).
Proof.
intros ; intro r ; rewrite <- Cv_radius_weak_expand_compat ; trivial.
Qed.

Lemma infinite_cv_radius_scal_compat : forall (An : Rseq) (lam : R), lam <> 0 ->
  (infinite_cv_radius An <-> infinite_cv_radius (lam * An)%Rseq).
Proof.
intros An lam lam_neq ; split ; intros rho r ;
 [rewrite <- Cv_radius_weak_scal | rewrite (Cv_radius_weak_scal _ lam)] ;
 auto.
Qed.

Lemma infinite_cv_radius_abs_compat : forall (An : Rseq),
  infinite_cv_radius An <-> infinite_cv_radius (| An |).
Proof.
intros An ; split ; intros rho r ;
 [rewrite <- Cv_radius_weak_abs | rewrite Cv_radius_weak_abs] ;
 apply rho.
Qed.

Lemma infinite_cv_radius_alt_compat : forall An,
  infinite_cv_radius An <-> infinite_cv_radius (Rseq_alt An).
Proof.
intro An ; split ; intros rAn r ;
 [rewrite <- Cv_radius_weak_alt | rewrite Cv_radius_weak_alt] ;
 apply rAn.
Qed.

Lemma infinite_cv_radius_opp_compat : forall (An : Rseq),
  infinite_cv_radius An <-> infinite_cv_radius (- An).
Proof.
intros An ; split ; intros rho r ;
 [rewrite <- Cv_radius_weak_opp | rewrite Cv_radius_weak_opp] ;
 apply rho.
Qed.

Section icvr_properties.

Variables (An Bn : Rseq).
Hypotheses (rAn : infinite_cv_radius An) (rBn : infinite_cv_radius Bn).

Lemma infinite_cv_radius_plus_compat : infinite_cv_radius (An + Bn).
Proof.
intro r ; rewrite <- Cv_radius_weak_Rabs, <- Rmin_diag ;
 apply Cv_radius_weak_plus ; [apply rAn | apply rBn].
Qed.

Lemma infinite_cv_radius_minus_compat : infinite_cv_radius (An - Bn).
Proof.
intro r ; rewrite <- Cv_radius_weak_Rabs, <- Rmin_diag ;
 apply Cv_radius_weak_minus ; [apply rAn | apply rBn].
Qed.

Lemma infinite_cv_radius_zip_compat_l : infinite_cv_radius (Rseq_zip An Bn).
Proof.
intro r ; apply Cv_radius_weak_Rabs ; rewrite <- Rsqrt_sqr with (y := nnr_sqr (Rabs r)).
 apply Cv_radius_weak_zip_l ; [apply rAn | apply rBn].
 apply Rabs_pos.
 reflexivity.
Qed.

End icvr_properties.

Lemma infinite_cv_radius_zip_compat_r1 : forall An Bn,
 infinite_cv_radius (Rseq_zip An Bn) -> infinite_cv_radius An.
Proof.
intros An Bn rAnBn r ; apply Cv_radius_weak_Rabs ;
 replace (Rabs r) with (nonneg (nnr_abs r)) by reflexivity ;
 rewrite <- Rsqr_Rsqrt with (nnr_abs r).
 eapply Cv_radius_weak_zip_r1, rAnBn.
Qed.

Lemma infinite_cv_radius_zip_compat_r2 : forall An Bn,
 infinite_cv_radius (Rseq_zip An Bn) -> infinite_cv_radius Bn.
Proof.
intros An Bn rAnBn r ; apply Cv_radius_weak_Rabs ;
 replace (Rabs r) with (nonneg (nnr_abs r)) by reflexivity ;
 rewrite <- Rsqr_Rsqrt with (nnr_abs r).
 eapply Cv_radius_weak_zip_r2, rAnBn.
Qed.

(** Pser and Un_cv are linked. See "tech12" for the reciprocal lemma *)

Lemma Pser_Rpser_link : forall An x l, Pser An x l <-> Rpser An x l.
Proof.
intros An x l ; split ; intro Hyp ; apply Hyp.
Qed.

Lemma Rpser_scal_compat : forall (r : R) An x l,
  Rpser An x l -> Rpser (r * An)%Rseq x (r * l).
Proof.
intros r An x l Hl eps eps_pos ; destruct (Req_dec r 0) as [Heq | Hneq].
exists O ; intros ; unfold R_dist ; rewrite Rseq_pps_scal_compat_l ;
 unfold Rseq_mult, Rseq_constant ; rewrite <- Rmult_minus_distr_l, Rabs_mult,
 Heq, Rabs_R0, Rmult_0_l ; assumption.
 pose (eps' := eps / Rabs r).
assert (eps'_pos : 0 < eps') by (unfold eps', Rdiv ;
  apply Rlt_mult_inv_pos ; [| apply Rabs_pos_lt] ; assumption).
 destruct (Hl eps' eps'_pos) as [N HN] ; exists N ; intros ; unfold R_dist ;
  rewrite Rseq_pps_scal_compat_l ; unfold Rseq_mult, Rseq_constant ;
  rewrite <- Rmult_minus_distr_l, Rabs_mult ; apply Rlt_le_trans with (Rabs r * eps').
  apply Rmult_lt_compat_l ; [apply Rabs_pos_lt | apply HN] ; assumption.
  right ; unfold eps' ; field ; apply Rabs_no_R0 ; assumption.
Qed.

Lemma Rpser_opp_compat : forall An x l,
  Rpser An x l -> Rpser (- An)%Rseq x (-l).
Proof.
intros An x l Hl eps eps_pos ; destruct (Hl _ eps_pos) as [N HN] ;
 exists N ; intros n n_lb ; unfold R_dist, Rminus in * ;
 rewrite Rseq_pps_opp_compat ; unfold Rseq_opp ; rewrite <- Ropp_plus_distr,
  Rabs_Ropp ; apply HN ; assumption.
Qed.

Lemma Rpser_add_compat : forall An Bn x la lb,
  Rpser An x la -> Rpser Bn x lb -> Rpser (An + Bn)%Rseq x (la + lb).
Proof.
intros An Bn x la lb Hla Hlb eps eps_pos.
 pose (eps' := middle 0 eps) ; assert (eps'_pos : 0 < eps')
 by (apply middle_is_in_the_middle ; assumption).
 destruct (Hla _ eps'_pos) as [Na HNa] ;
 destruct (Hlb _ eps'_pos) as [Nb HNb] ;
 exists (max Na Nb) ; intros n n_lb.
 rewrite Rseq_pps_plus_compat ; eapply Rle_lt_trans.
 eapply R_dist_plus.
 apply Rlt_le_trans with (eps' + eps').
  eapply Rlt_trans.
   eapply Rplus_lt_compat_l ; eapply HNb ;
    apply le_trans with (max Na Nb) ; [apply le_max_r | assumption].
   apply Rplus_lt_compat_r ; apply HNa ;
    apply le_trans with (max Na Nb) ; [apply le_max_l | assumption].
  right ; unfold eps', middle ; field.
Qed.

Lemma Rpser_minus_compat : forall An Bn x la lb,
  Rpser An x la -> Rpser Bn x lb -> Rpser (An - Bn)%Rseq x (la - lb).
Proof.
intros ; unfold Rseq_minus, Rminus ; apply Rpser_add_compat ;
 [| apply Rpser_opp_compat] ; assumption.
Qed.

Lemma Rpser_zip_compat : forall An Bn x la lb,
  Rpser An (x ^ 2) la -> Rpser Bn (x ^ 2) lb ->
  Rpser (Rseq_zip An Bn) x (la + x * lb).
Proof.
intros An Bn x la lb Hla Hlb ; unfold Rpser ; apply Rseq_cv_even_odd_compat.
 apply Rseq_cv_shift_compat ; rewrite Rseq_cv_eq_compat ;
  [| intro n ; apply Rseq_pps_zip_compat_even].
  apply Rseq_cv_plus_compat, Rseq_cv_mult_compat ; [| apply Rseq_constant_cv | apply Hlb].
  apply Rseq_cv_shift_compat_reciprocal, Hla.
 rewrite Rseq_cv_eq_compat ; [| intro n ; apply Rseq_pps_zip_compat_odd].
 apply Rseq_cv_plus_compat, Rseq_cv_mult_compat ; (assumption || apply Rseq_constant_cv).
Qed.

Lemma Rpser_alt_compat : forall An x la,
  Rpser An (- x) la -> Rpser (Rseq_alt An) x la.
Proof.
intros An x la Hla ; eapply Rseq_cv_eq_compat.
 apply Rseq_pps_alt_compat.
 assumption.
Qed.

Lemma Rpser_expand_compat : forall An l x la,
  Rpser An (l * x) la -> Rpser (An_expand An l) x la.
Proof.
intros ; eapply Rseq_cv_eq_compat.
 eapply Rseq_sum_ext ; intro ; apply gt_pser_expand_compat.
 assumption.
Qed.

Lemma Rpser_unique : forall An (x l1 l2 : R),
  Rpser An x l1 -> Rpser An x l2 -> l1 = l2.
Proof.
intros ; eapply Rseq_cv_unique ; eassumption.
Qed.

Lemma Rpser_unique_extentionality : forall An Bn (x l1 l2 : R),
  An == Bn -> Rpser An x l1 -> Rpser Bn x l2 -> l1 = l2.
Proof.
intros An Bn x l1 l2 Heq Hl1 Hl2 ; eapply Rseq_cv_unique ;
 [rewrite Rseq_cv_eq_compat |] ; [| eapply Rseq_pps_ext ; symmetry |] ;
 eassumption.
Qed.


Require Export Iron.Language.SimpleData.Exp.

(* Type Judgement assigns a type to an expression. *)
Inductive TYPE : defs -> tyenv -> exp -> ty -> Prop :=
 (* Variables *)
 | TYVar
   :  forall ds te i t
   ,  get i te = Some t
   -> TYPE ds te (XVar i) t

 (* Lambda Abstraction *)
 | TYLam
   :  forall ds te x t1 t2
   ,  TYPE ds (te :> t1) x            t2
   -> TYPE ds te         (XLam t1 x) (TFun t1 t2)

 (* Applications *)
 | TYApp
   :  forall ds te x1 x2 t1 t2
   ,  TYPE ds te x1           (TFun t1 t2)
   -> TYPE ds te x2           t1
   -> TYPE ds te (XApp x1 x2) t2

 (* Data Constructors *)
 | TYCon
   :  forall ds te xs dc dcs tsArgs tc
   ,  getDataDef dc ds = Some (DefData     dc tsArgs (TCon tc))
   -> getTypeDef tc ds = Some (DefDataType tc dcs)
   -> In dc dcs
   -> Forall2 (TYPE ds te) xs tsArgs
   -> TYPE ds te (XCon dc xs) (TCon tc)

 (* Case Expressions *)
 | TYCase
   :  forall ds te xObj tcPat tResult alts dcs

      (* check types of expression and alternatives *)
   ,  TYPE ds te xObj (TCon tcPat)
   -> Forall (fun alt => TYPEA ds te alt (TCon tcPat) tResult) alts

      (* there must be at least one alternative *)
   -> length alts > 0

      (* all data cons must have a corresponding alternative *)
   -> getTypeDef tcPat ds = Some (DefDataType tcPat dcs)
   -> Forall (fun dc => In dc (map dcOfAlt alts)) dcs

   -> TYPE ds te (XCase xObj alts) tResult

with TYPEA : defs -> tyenv -> alt -> ty -> ty -> Prop :=
 (* Case Alternatives *)
 | TYAlt
   :  forall ds te x1 t1 dc tsArgs tResult
   ,  getDataDef dc ds = Some (DefData dc tsArgs tResult)
   -> TYPE  ds (te >< tsArgs) x1 t1
   -> TYPEA ds te (AAlt dc tsArgs x1) tResult t1.

Hint Constructors TYPE.
Hint Constructors TYPEA.

(* Invert all hypothesis that are compound typing statements. *)
Ltac inverts_type :=
 repeat
  (match goal with
   | [ H: TYPE  _ _ (XVar  _)    _    |- _ ] => inverts H
   | [ H: TYPE  _ _ (XLam  _ _)  _    |- _ ] => inverts H
   | [ H: TYPE  _ _ (XApp  _ _)  _    |- _ ] => inverts H
   | [ H: TYPE  _ _ (XCon  _ _)  _    |- _ ] => inverts H
   | [ H: TYPE  _ _ (XCase _ _)  _    |- _ ] => inverts H
   | [ H: TYPEA _ _ (AAlt _ _ _) _ _  |- _ ] => inverts H
   end).

(********************************************************************)
(* Forms of values.
   If we know the type of a value,
   then we know the form of that value. *)
Lemma value_lam
 :  forall x ds te t1 t2
 ,  value x
 -> TYPE ds te x (TFun t1 t2)
 -> (exists t x', x = XLam t x').
Proof.
 intros. destruct x; burn.
Qed.
Hint Resolve value_lam.

(********************************************************************)
(* A well typed expression is well formed *)
Theorem type_wfX
 :  forall ds te x t
 ,  TYPE ds te x t
 -> wfX te x.
Proof.
 intros. gen ds te t.
 induction x using exp_mutind with
  (PA := fun a => forall ds te t1 t2
      ,  TYPEA ds te a t1 t2
      -> wfA te a)
  ; intros; inverts_type; eauto.

 Case "XCon".
  apply WfX_XCon. repeat nforall. intros.
  have HT: (exists t, TYPE ds te x t).
  spec H H0 ds te.
  destruct HT as [t].
  burn.

 Case "XCase".
  eapply WfX_XCase; repeat nforall; burn.
Qed.
Hint Resolve type_wfX.

(* Weakening Type Env in Type Judgement.
   We can insert a new type into the type environment, provided we
   lift existing references to types higher in the stack across
   the new one. *)
Lemma type_tyenv_insert
 :  forall ds te ix x t1 t2
 ,  TYPE ds te x t1
 -> TYPE ds (insert ix t2 te) (liftX 1 ix x) t1.
Proof.
 intros. gen ix ds te t1.
 induction x using exp_mutind with
  (PA := fun a => forall ix ds te t3 t4
      ,  TYPEA ds te a t3 t4
      -> TYPEA ds (insert ix t2 te) (liftA 1 ix a) t3 t4)
  ; intros; inverts_type; burn; simpl.

 Case "XVar".
  lift_cases; burn.

 Case "XLam".
  apply TYLam.
  rewrite insert_rewind. auto.

 Case "XCon".
  eapply TYCon; burn.
   apply (Forall2_map_left (TYPE ds (insert ix t2 te))).
   apply (Forall2_impl_in  (TYPE ds te)); eauto.
   nforall. eauto.

 Case "XCase".
  eapply TYCase; eauto.
   apply Forall_map.
   apply (Forall_impl_in (fun a => TYPEA ds te a (TCon tcPat) t1)); eauto.
   repeat nforall. burn.

  rewrite map_length; auto.

  norm.
   intros. rename x0 into d.
   rewrite map_map. unfold Basics.compose.
   eapply map_exists_in.
   have (In d (map dcOfAlt aa)).
   assert (exists a, dcOfAlt a = d /\ In a aa).
    eapply map_in_exists. auto.
   shift a. rip.
   eapply dcOfAlt_liftA.

 Case "XAlt".
  eapply TYAlt; eauto.
  rewrite insert_app. auto.
Qed.

(* We can push a new type onto the environment stack provided
   we lift references to existing types across the new one. *)
Lemma type_tyenv_weaken1
 :  forall ds te x t1 t2
 ,  TYPE ds te x t1
 -> TYPE ds (te :> t2) (liftX 1 0 x) t1.
Proof.
 intros.
 rrwrite (te :> t2 = insert 0 t2 te).
 burn using type_tyenv_insert.
Qed.

(* We can several new types onto the environment stack provided
   we lift referenes to existing types across the new one. *)
Lemma type_tyenv_weaken_append
 :  forall ds te te' x t1
 ,  TYPE ds te x t1
 -> TYPE ds (te >< te') (liftX (length te') 0 x) t1.
Proof.
 intros.
 induction te'; simpl.
 rewrite liftX_zero; auto.
 rewrite <- nat_plus_one.
 rrwrite (length te' + 1 = 1 + length te').
 rewrite <- liftX_plus.
 eapply type_tyenv_weaken1. auto.
Qed.