Definition Admit {A} : A. admit. Admitted.

Ltac rewr_assumption := idtac; match goal with
                          | [R: _ = _ |- _ ] => first [rewrite R| rewrite <- R]
                        end.

Module Type Preorder.

Parameter State : Type.
Parameter VM : State -> State -> Prop.

End Preorder.

Module Calculation (Ord : Preorder).
Import Ord.

Notation "x ==> y" := (VM x y) (at level 80, no associativity).

Reserved Notation "x =>> y" (at level 80, no associativity).
Inductive trc : State -> State -> Prop :=
| trc_refl c : c =>> c
| trc_step_trans c1 c2 c3 : c1 ==> c2 -> c2 =>> c3 -> c1 =>> c3
 where "x =>> y" := (trc x y).

Lemma trc_step c1 c2 : c1 ==> c2 -> c1 =>> c2.
Proof.
  intros.
  eapply trc_step_trans. eassumption. apply trc_refl.
Qed.

Lemma trc_trans c1 c2 c3 : c1 =>> c2 -> c2 =>> c3 -> c1 =>> c3.
Proof.
  intros T S.
  induction T. assumption. eapply trc_step_trans. eassumption. apply IHT.  assumption.
Qed.

Corollary trc_step_trans' c1 c2 c3 : c1 =>> c2 -> c2 ==> c3 -> c1 =>> c3.
Proof.
  intros. eapply trc_trans. eassumption. apply trc_step. assumption.
Qed.

Corollary trc_eq_trans c1 c2 c3 : c1 =>> c2 -> c2 = c3 -> c1 =>> c3.
Proof.
  intros. eapply trc_trans. eassumption. subst. apply trc_refl.
Qed.

Ltac smart_destruct x := first[is_var x;destruct x| let x' := fresh in remember x as x'; destruct x' ].

Ltac dist t := idtac; subst; simpl; try solve [t;try rewr_assumption;auto|apply trc_step;t;eauto
                                        |apply trc_refl;t;eauto] ; match goal with
                        | [ H : ex _ |- _ ] => destruct H; dist t
                        | [ H : or _ _ |- _ ] => destruct H; dist t
                        | [ |- context [let _ := ?x in _] ] => smart_destruct x;dist t
                        | [ |- context [match ?x with _ => _ end]] => smart_destruct x; dist t
                      end.

Ltac dist_refl := dist reflexivity.

Ltac check_exp' x y t := let h := fresh "check" in assert (h: x = y) by t; try rewrite <- h; clear h.
Ltac check_exp x y := let h := fresh "check" in assert (h: x = y) by reflexivity; clear h.

Ltac check_rel R Rel := first [check_exp R Rel|
                             fail 2 "wrong goal; expected relation" R "but found" Rel].

Tactic Notation "[]" := apply trc_refl.

Ltac step rel lem t1 e2 :=
  match goal with
    | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel;
        first [let h := fresh "rewriting" in
               assert(h : rel e2 rhs) by (dist t1) ; apply (fun x => lem _ _ _ x h); clear h | fail 2]
    | _ => fail 1 "goal is not a VM"
    end.

Tactic Notation  (at level 2)    "<<=" "{"tactic(t) "}" constr(e) :=
  step trc trc_trans t e.

Tactic Notation  (at level 2)    "=" "{"tactic(t) "}" constr(e) :=
  step (@eq State) trc_eq_trans t e.

Tactic Notation  (at level 2)    "<==" "{"tactic(t) "}" constr(e) :=
  step VM trc_step_trans' t e.

Ltac step_try rel e2 :=
  match goal with
    | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel;
                            first [let h := fresh "step_try" in assert(h : rel e2 rhs)|fail 2]
    | _ => fail 1 "goal is not a VM"
  end.

Tactic Notation  (at level 2)    "<<=" "{?}" constr(e) := step_try trc e.
Tactic Notation  (at level 2)    "<==" "{?}" constr(e) := step_try VM e.
Tactic Notation  (at level 2)    "=" "{?}" constr(e) := step_try (@eq State) e.

Tactic Notation  (at level 2)    "<==" "{"tactic(t1) "}?"  :=
  match goal with
    | [|- ?Rel ?lhs ?rhs] => check_rel trc Rel;
        first [eapply trc_trans; [idtac|solve[t1]] | fail 2]
      | _ => fail 1 "goal is not a VM"
    end.

Tactic Notation  (at level 2)  "begin" constr(rhs) :=  match goal with
    | [|- ?Rel ?lhs ?rhs'] => check_rel trc Rel; check_exp' rhs rhs' dist_refl
      | _ => fail 1 "rhs does not match"
    end.

Definition determ {A} (R : A -> A -> Prop) : Prop := forall C C1 C2, R C C1 -> R C C2 -> C1 = C2.

Definition trc' C C' :=  C =>> C' /\ ~ exists C'', C' ==> C''.

Notation "x =>>! y" := (trc' x y) (at level 80, no associativity).

Lemma determ_factor C1 C2 C3 : determ VM -> C1 ==> C2 -> C1 =>>! C3 -> C2 =>> C3.
Proof.
  unfold determ. intros. destruct H1.
  destruct H1. exfalso. apply H2. eexists. eassumption.

  assert (c2 = C2). eapply H. apply H1. apply H0. subst. assumption.
Qed.

Lemma determ_trc : determ VM -> determ trc'.
Proof.
  intros. unfold determ. intros. destruct H0.
  induction H0.

  destruct H1. destruct H0. reflexivity. exfalso. apply H2. eexists. eassumption.

  apply IHtrc. apply H2. split. eapply determ_factor; eassumption. destruct H1. assumption.
Qed.

End Calculation.


(** * Reasoning about nontermination *)

Require Import Coq.Logic.Classical_Pred_Set.
Require Export Combinators.
Open Scope code_scope.

Lemma sub_top_le (Var : Set) (x : Code Var) (f : Var -> Code Empty_set) :
  x @ f [= x @ sub_top.
Proof.
  induction x; simpl; intros; auto.
  freeze code_le in compute.
  auto.
Qed.

Lemma conv_nle_bot (Var : Set) (x : Code Var) : code_conv x <-> ~ x [= BOT.
Proof.
  split.
  - unfold code_le; intros H Hneg.
    apply (@not_conv_bot Var).
    rewrite <- beta_i; rewrite <- (@var_monad_unit_right Var _).
    apply Hneg; code_simpl; auto.
  - rewrite code_le_weaken.
    intro H.
    apply not_all_ex_not in H; destruct H as [ys H].
    apply not_all_ex_not in H; destruct H as [f H].
    apply not_all_ex_not in H; destruct H as [H Hb]; clear Hb.
    apply conv_apply in H.
    rewrite <- conv_close; unfold close.
    simpl in x.
    revert H; apply conv_proper_le.
    apply sub_top_le.
Qed.

Lemma not_conv_eq_bot (Var : Set) (x : Code Var) : ~ code_conv x <-> x == BOT.
Proof.
  split.
  - intro Hd; split; auto.
    code_le_weaken; intros c f Hc.
    rewrite sub_top_le in Hc.
    apply conv_apply in Hc.
    fold (@close Var) in Hc.
    rewrite conv_close in Hc.
    contradiction.
  - intros [H H']; clear H'.
    intro Hc.
    rewrite <- beta_i in Hc; rewrite <- (@var_monad_unit_right Var _) in Hc.
    apply H in Hc.
    code_simpl in Hc.
    apply not_conv_bot in Hc; auto.
Qed.

Lemma not_conv_div_bot (Var : Set) : ~ code_conv (div * BOT : Code Var).
Proof.
  (* TODO enumerate pi-reachable terms, then show TOP is not reachable *)
Admitted.

Lemma div_bot (Var : Set) : div * BOT == (BOT : Code Var).
Proof.
  apply not_conv_eq_bot; apply not_conv_div_bot.
Qed.
Hint Rewrite div_bot : code_simpl.

Lemma code_eq_ap_bot (Var : Set) (x : Code Var) : BOT * x == BOT.
Proof.
  apply not_conv_eq_bot.
  apply not_conv_heads_bot.
  heads.
Qed.
Hint Rewrite code_eq_ap_bot : code_simpl.

Section Omega.
  Context {Var : Set}.
  Let x := make_var Var 0.
  Definition Omega := Eval compute in close_var ((\x, x * x) * (\x, x * x)).
  Goal Omega = S * I * I * (S * I * I).
  Proof.
    reflexivity.
  Qed.
End Omega.

Lemma code_le_omega_bot (Var : Set) : (@Omega Var) [= BOT.
Proof.
  unfold Omega, code_le; intros Var' c f Ha.
  induction Ha.
  simpl in H.
  (* TODO enumerate pi-reachable terms, then show TOP is not reachable *)
Admitted.

Lemma code_eq_omega_bot (Var : Set) : (@Omega Var) == BOT.
Proof.
  split ; (apply code_le_omega_bot || auto).
Qed.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Import Category.Theory.Kan.Extension.
Require Import Category.Structure.Cone.
Require Import Category.Structure.Limit.
Require Import Category.Functor.Diagonal.
Require Import Category.Instance.Fun.

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

Theorem Kan_Limit `(F : J ⟶ C) `{Lim : @Limit _ _ F} `{@RightKan _ _ (Erase J) C} :
  Lim ≅ Ran (Erase J) F ().
Proof.
  given (cone : Cone F).
    pose (from ((@adj _ _ _ _ ran_adjoint
                      (Ran (Erase J) F) F)) nat_id) as adj_from;
    simpl in adj_from.

    unshelve (refine {| vertex_obj := Ran (Erase J) F tt |}).
      apply adj_from.
    abstract (intros; rewrite (naturality[adj_from]); simpl; cat).

  given (nat : Const Lim ○ Erase J ⟹ F). {
    transform; simpl; intros.
    + apply vertex_map.
    + abstract (cat; apply ump_cones).
    + abstract (cat; symmetry; apply ump_cones).
  }

  pose (to (@adj _ _ _ _ ran_adjoint (Const Lim) F) nat)
    as adj_to; simpl in adj_to.

  assert (to_from : adj_to () ∘ unique_morphism (ump_limits cone) ≈ id). {
    simpl.
    spose (iso_to_from
             ((@adj _ _ _ _ ran_adjoint
                    (Ran (Erase J) F) F)) nat_id tt) as X.
    rewrite fmap_id in X.
    rewrites.
    unfold adj_to; simpl.

    given (from_ran : Ran (Erase J) F ⟹ Const Lim). {
      transform; simpl; intros.
      + destruct x.
        apply (unique_morphism (ump_limits cone)).
      + abstract cat.
      + abstract cat.
    }

    spose (@to_adj_nat_l _ _ _ _ ran_adjoint
                         (Ran (Erase J) F) (Const Lim)
                         F nat from_ran tt) as X0.
    rewrites.

    assert (∀ f g, f ≈ g
              -> to (@adj _ _ _ _ ran_adjoint (Ran (Erase J) F) F) f
               ≈ to (@adj _ _ _ _ ran_adjoint (Ran (Erase J) F) F) g).
      intros; rewrites; reflexivity.
    simpl in X; apply X; clear X.

    intros; simpl.
    apply (unique_property (ump_limits cone)).
  }

  isomorphism; simpl.
  - apply adj_to.
  - apply (unique_morphism (ump_limits cone)).
  - apply to_from.
  - simpl in *.
    (* Since half of the isomorphism has already been proven in [to_from], it
       is sufficient to show that either [(adj nat) ()] is monic, or
       [unique_morphism (ump_limits cone)] is epic. I've chosen the latter due
       to Emily Riehl's statement in "Category Theory in Context" (p. 76):
       "... Proposition 3.1.7 implies that the only automorphism of [a limit
       object] l that commutes with the specified limit cone λ is the
       identity." *)
    assert (∀ (f g : Lim ~{ C }~> Lim),
              (∀ x, vertex_map[Lim] ∘ f ≈ @vertex_map _ _ _ Lim x) ->
              (∀ x, vertex_map[Lim] ∘ g ≈ @vertex_map _ _ _ Lim x) ->
              f ∘ unique_morphism (ump_limits cone) ≈
              g ∘ unique_morphism (ump_limits cone) -> f ≈ g) as HA.
      intros; clear adj_to to_from nat.
      rewrite <- (uniqueness (ump_limits Lim) _ X).
      rewrite <- (uniqueness (ump_limits Lim) _ X0).
      reflexivity.

    (* Apply the consequence that [unique_morphism (ump_limits cone)] is epic
      on morphisms commuting with the limit cone, leaving us with the burden
      of showing that the two sides of our equivalence do in fact commute for
      [Lim F]. The right side is trivial (id), while the left side relies on
      the naturality of the Kan adjunction. *)
    apply HA; simpl; intros; cat; swap 1 2.
      rewrite <- comp_assoc.
      rewrite to_from; cat.

    rewrite comp_assoc.
    srewrite (unique_property (ump_limits cone)).
    srewrite_r (iso_from_to
                  ((@adj _ _ _ _ ran_adjoint (Const Lim) F)) nat x).
    unfold adj_to.
    srewrite_r (@from_adj_nat_l _ _ _ _ ran_adjoint
                  (Const Lim) (Ran (Erase J) F) F nat_id
                  (to (@adj _ _ _ _ ran_adjoint (Const Lim) F) nat) x).
    sapply (@from_adj_respects
              _ _ _ _ (@ran_adjoint _ _ _ _ H) (Const Lim) F).
    simpl; intros; cat.
Qed.


(** printing ⊢k #⊢k# *)
(** printing ⊢s #⊢s# *)
(** printing ⊢! #⊢# *)
(** printing k⊣ #⊣# *)
(** printing |- #⊢# *)
(** printing ↗! #↗# *)
(** printing ↘! #↘# *)
(** printing ⦂ #:# *)
(** printing <⦂ #<:# *)
(** printing [<=] #⊆# *)
(** printing `union` #∪# *)
(** printing \u #∪# *)
(** printing `notin` #∉# *)
(** printing `in` #∈# *)
(** printing ⊆<⦂ #⊆<:# *)

Set Implicit Arguments.
Require Import Definitions.
Require Import OperationProperties.
Require Import Misc.
Require Import Program.
Require Import Arith.Wf_nat.

(** * Structural Properties of Full D#<:#

    This file contains several structural properties, which are quite standard to prove.
    These structural properties include:
    - weakening,
    - transitivity,
    - narrowing, and
    - substitution.
 *)

Section StructuralProperties.

  Lemma weaken_subty_gen G S U: forall G1 G2,
      G1 ++ G2 ⊢F S <⦂ U -> G1 ++ G ++ G2 ⊢F S <⦂ U.
  Proof.
    - intros. generalize dependent G.
      dependent induction H; intros; trivial.
      + apply binds_weaken with (F := G) in H.
        econstructor; eauto.
      + constructor; eroutine.
      + eapply st_all; eroutine.
        reassoc 4 with 2. apply H1; routine.
  Qed.

  Definition weaken_subty G S U: forall G',
      G ⊢F S <⦂ U -> G' ++ G ⊢F S <⦂ U.
  Proof.
    intros. reassoc 2 with 0.
    apply weaken_subty_gen; simpl; trivial.
  Qed.

  Section Reflexivity.

    Hint Extern 1 (_ <= _) => autorewrite with measures; simpl; lia.

    Program Fixpoint subty_refl T {measure (typ_struct_measure T)} : forall G,
      G ⊢F T <⦂ T := _.
    Next Obligation.
      destruct T; routine.
      pose proof (typ_struct_measure_ge_1 T1).
      pose proof (typ_struct_measure_ge_1 T2).
      econstructor; routine.
    Qed.

  End Reflexivity.

  (** transitivity in F#<:# is a bit easier to setup as the All case is the only complicated case.
   *)
  Section Transitivity.

    Inductive narrow T : nat -> env -> env -> Prop :=
    | n_first : forall G x S, G ⊢F S <⦂ T -> narrow T 0 (x ~ S ++ G) (x ~ T ++ G)
    | n_cons : forall G1 G2 n x T', narrow T n G1 G2 -> narrow T (S n) (x ~ T' ++ G1) (x ~ T' ++ G2).
    Local Hint Constructors narrow.

    Definition trans_on T : Prop :=
      forall G S U, G ⊢F S <⦂ T -> G ⊢F T <⦂ U -> G ⊢F S <⦂ U.

    Definition narrow_on T : Prop :=
      forall G S U, G ⊢F S <⦂ U -> forall n G', narrow T n G' G -> G' ⊢F S <⦂ U.
    Arguments trans_on T/.
    Arguments narrow_on T/.

    Hint Extern 1 (_ < _) => autorewrite with measures; simpl; lia.

    Lemma trans_hyp : forall T,
        (forall T', typ_struct_measure T' < typ_struct_measure T -> trans_on T' /\ narrow_on T') ->
        trans_on T.
    Proof.
      simpl. intros. induction H0; dependent induction H1; try solve [eroutine].
      - clear IHsubty0 IHsubty1 IHsubty2 IHsubty3.
        constructor.
        + apply (H T1); routine.
        + apply (H T2); routine.
      - clear IHsubty IHsubty0 H3 H5.
        econstructor.
        + apply (H T1); routine.
        + cofinite.
          rec_pose (H2 x) Hsub1; auto.
          rec_pose (H4 x) Hsub2; auto.
          apply (H (open x T2)); auto.
          rec_pose (H T1) Hrec; auto.
          destruct_conjs. eapply H5; auto.
    Qed.

    Inductive binds_n : var -> typ -> nat -> env -> Prop :=
    | bn_found : forall x T G, binds_n x T 0 ((x, T) :: G)
    | bn_cons :  forall x T n G y U, binds_n x T n G -> binds_n x T (S n) ((y, U) :: G).
    Local Hint Constructors binds_n.

    Lemma binds_n_to_binds : forall x T n G,
        binds_n x T n G -> binds x T G.
    Proof. induction on binds_n; routine. Qed.

    Lemma binds_to_binds_n : forall x T G,
        binds x T G -> exists n, binds_n x T n G.
    Proof.
      induction G; eroutine.
      specialize (IHG H). tidy_up.
      exists (S IHG). constructor. trivial.
    Qed.

    Lemma binds_equiv_binds_n : forall x T G,
        binds x T G <-> exists n, binds_n x T n G.
    Proof.
      split.
      - apply binds_to_binds_n.
      - routine. eauto using binds_n_to_binds.
    Qed.

    Lemma narrow_binds_n : forall T n G G',
        narrow T n G' G ->
        forall y T' m,
          binds_n y T' m G ->
          (m = n /\ T = T' /\ exists T'', binds_n y T'' m G' /\ (G' ⊢F T'' <⦂ T)) \/
          (m <> n /\ binds_n y T' m G').
    Proof.
      induction on narrow; routine.
      - invert H1; routine.
        left. repeat (split || eexists); eroutine.
        apply weaken_subty with (G' := x ~ S).
        trivial.
      - invert H0; routine.
        specialize (IHnarrow _ _ _ H6); routine.
        left. repeat (split || eexists); eroutine.
        apply weaken_subty with (G' := x ~ T').
        trivial.
    Qed.

    Lemma narrow_hyp : forall T,
        (forall T', typ_struct_measure T' = typ_struct_measure T -> trans_on T') ->
        narrow_on T.
    Proof.
      simpl. induction 2; eroutine.
      - specialize (IHsubty _ _ H2).
        rewrite binds_equiv_binds_n in H0.
        tidy_up.
        pose proof (narrow_binds_n H2 H3).
        tidy_up.
        + apply binds_n_to_binds in H7. econstructor; eauto.
        + apply binds_n_to_binds in H5. econstructor; eauto.
      - econstructor. eauto.
        cofinite.
        specialize (H1 x ltac:(auto)).
        rec_pose (H2 x ltac:(auto)) Hrec; eauto.
        econstructor. eauto.
    Qed.

    Program Fixpoint trans_and_narrow T {measure (typ_struct_measure T)} :
      trans_on T /\ narrow_on T := _.
    Next Obligation.
      split.
      - apply trans_hyp. auto.
      - apply narrow_hyp.
        intros. apply trans_hyp.
        intros. apply trans_and_narrow.
        auto.
    Qed.

    Theorem subty_trans : forall G S T U,
        G ⊢F S <⦂ T -> G ⊢F T <⦂ U -> G ⊢F S <⦂ U.
    Proof.
      intros. apply (trans_and_narrow T); auto.
    Qed.

  End Transitivity.

  Hint Resolve subst_open_comm_typ.

  Definition subst_env (z u: var) (G : env) : env := map (substi z u) G.

  Global Instance SubstiEnv : CanSubst env := { substi := subst_env }.

  Lemma free_all : forall x y T (G : env),
      y `notin` fv G ->
      binds x T G ->
      y `notin` fv T.
  Proof. induction on env; routine. Qed.

  Local Ltac fold_env :=
    lazymatch goal with
      |- context[?v ~ substi ?x ?y ?T ++ substi ?x ?y ?G] =>
      change (v ~ substi x y T ++ substi x y G)
    with (substi x y (v ~ T ++ G))
    end.

  Ltac apply_ind H := solve [eapply H; routine].

  Ltac fold_subst_fvar :=
    repeat match goal with
           | |- context[if ?x == ?y then ?z else ?x] =>
             change (if x == y then z else x) with (subst_fvar y z x)
           end.

  Ltac solve_by_weaken H :=
    cofinite; fold_substi;
    open_substi_transform;
    reassoc 3 with 2; fold_env;
    eapply H; routine;
    simpl_env;
    try apply weaken_subty; eauto.

  Lemma subty_subst_gen : forall x X S U G1 G2 y,
      G2 ++ x ~ X ++ G1 ⊢F S <⦂ U ->
      uniq (G2 ++ x ~ X ++ G1) ->
      x `notin` fv G1 ->
      forall Y,
        binds y Y (substi x y G2 ++ G1) ->
        substi x y G2 ++ G1 ⊢F Y <⦂ substi x y X ->
        substi x y G2 ++ G1 ⊢F substi x y S <⦂ substi x y U.
  Proof.
    intros. gen y Y. dependent induction H; intros; trivial.
    - simpl. auto.
    - simpl. destruct_eq.
      + econstructor; eauto.
        destruct_binds_hyp_uniq H; simpl dom in *; try solve_notin.
        eapply subty_trans. eassumption.
        apply_ind IHsubty.
      + destruct_binds_hyp_uniq H; simpl dom in *; try solve_notin.
        * econstructor.
          -- apply binds_app_2.
             apply binds_map_2.
             eassumption.
          -- apply_ind IHsubty.
        * econstructor; eauto.
          rewrite <- (@subst_fresh_typ x y T).
          -- apply_ind IHsubty.
          -- eapply free_all; eassumption.
    - simpl.
      apply st_fun; [apply_ind IHsubty1 | apply_ind IHsubty2].
    - simpl. eapply st_all.
      + apply_ind IHsubty.
      + solve_by_weaken H1.
  Qed.

  Lemma subty_subst : forall x X S U G y,
      x ~ X ++ G ⊢F S <⦂ U ->
      uniq (x ~ X ++ G) ->
      x `notin` fv G ->
      forall Y,
        binds y Y G ->
        G ⊢F Y <⦂ substi x y X ->
      G ⊢F substi x y S <⦂ substi x y U.
  Proof.
    intros. change G with (substi x y nil ++ G).
    eapply subty_subst_gen; routine.
  Qed.

  Ltac prelude :=
    intros;
    try erewrite subst_intro_typ.

  Ltac fin :=
    try eapply subty_subst;
    routine;
    try (simpl; fold_substi; fold_open_rec;
         eexrewrite subst_fresh_typ);
    routine.

  Lemma renaming_subty : forall G z T S U (x : var),
      uniq G ->
      z `notin` fv G `union` fv T `union` fv U `union` fv S ->
      z ~ T ++ G ⊢F open z S <⦂ open z U ->
      forall X,
        binds x X G ->
        G ⊢F X <⦂ T ->
        G ⊢F open x S <⦂ open x U.
  Proof using.
    prelude.
    erewrite subst_intro_typ with (t := U).
    all:fin.
  Qed.

  Hint Resolve subty_refl.

  Lemma open_subst_subty : forall x S G U1 U2 y,
      uniq G ->
      x `notin` fv G `union` fv S `union` fv U1 `union` fv U2 ->
      y `notin` fv G `union` fv S `union` fv U1 `union` fv U2 `union` singleton x ->
      x ~ S ++ G ⊢F open x U1 <⦂ open x U2 ->
      y ~ S ++ G ⊢F open y U1 <⦂ open y U2.
  Proof.
    intros.
    apply renaming_subty with (z := x) (T := S) (X := S); routine.
    simpl_env.
    apply weaken_subty_gen. trivial.
  Qed.

End StructuralProperties.

Hint Resolve subty_trans subty_refl.


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

(** ** Invertibility Lemmas
These theorems prove, roughly, that the application of positive rules
can be exchanged.
 *)

(* Add LoadPath "../../".    *)
Require Export TriSystem.
(*Require Export MSet.  *)
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.
Require Import StructuralRulesTriSystem.

Set Implicit Arguments.

(** Automatization for multiset reasoning  *)
Ltac simpl_union_context :=
  match goal with
  | [ H : [?b] ++ ?M =mul= [?a] ++ ?L |- _ ] =>
    apply DestructMSet in H; destruct H as [Hten1 | Hten2 ];
    [ destruct Hten1 as [HeqE HeqM] | destruct Hten2 as [L1 Hten2]; destruct Hten2]
  | [ H : [?b] ++ ?M =mul= ?a :: ?L |- _ ] =>
    apply DestructMSet in H; destruct H as [Hten1 | Hten2 ];
    [ destruct Hten1 as [HeqE HeqM] | destruct Hten2 as [L1 Hten2]; destruct Hten2]
  | [ H : ?M ++ ?N =mul= [?a] ++ ?x |- _ ] =>
    assert ((exists L1, M =mul= [a] ++ L1) \/ (exists L2, N =mul= [a] ++ L2)) as Hten by refine (solsls _ _ H);
    destruct Hten as [Hten1 | Hten2];
    [ destruct Hten1 as [L1 HL1]; assert (x =mul= N ++ L1) by refine (solsls2 _ H HL1) |
      destruct Hten2 as [L2 HL2]; rewrite union_comm_app in H;
      assert (x =mul= M ++ L2) by refine (solsls2 _ H HL2); rewrite union_comm_app in H
    ]

  end.

Ltac contradiction_multiset :=
  repeat
    match goal with
    | [ H : [?l] ++ ?L =mul= [] |- _ ] =>
      apply DestructMulFalse in H; contradiction
    | [ H : ?L ++ [?l] =mul= [] |- _ ] =>
      rewrite union_comm_app in H
    | [ H : [] =mul= [?l] ++ ?L |- _ ] =>
      symmetry in H
    | [ H : [] =mul= ?L ++ [?l] |- _ ] =>
      symmetry in H
    end.

(** Invertibility of the Copy Rule *)
Module InvCopy.

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

  Definition RDown (n:nat) := forall B  F  M  H,
      lexpPos M -> AsynchronousF F = false ->
      n |-F- B ++ [F]; M ++ [F]  ; DW H
                                   -> exists m, m|-F- B ++ [F] ; M  ; DW H.

  Lemma RDown0 : RDown 0.
  Proof.
    unfold RDown.
    intros.
    inversion H1;subst.
    destruct M. simpl in *.
    inversion H2. subst.
    eexists.
    eapply tri_init2;eauto.
    inversion H2. subst.
    apply EmptyMS in H7.
    contradiction.
  Qed.

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

  Lemma RUp0 : RUp 0.
    unfold RUp.
    intros.

    destruct L.
    + inversion H0;subst.
      eexists.
      simpl.
      eapply tri_dec2 with (F:= ⊤);auto.
      eapply tri_rel;auto.
      eapply tri_top.
    + inversion H0. subst.

      eexists.
      eapply tri_top.
  Qed.

  Theorem InvCopyAux1: forall  n , (forall m : nat, m <= n -> RInd m) -> RUp (S n).
    intros n IH.
    unfold RUp.  intros B L1 F M1 HM1pos HD1.
    destruct L1.
    + (* L1 is Empty *)
      simpl in *.
      assert (HF: NotPosOrPosAtom F \/ PosOrPosAtom F) by (apply DecPosOrPosAtom).
      destruct HF as [HF | HF].
      inversion HF;subst.
      ++  (* Neg Atom *)
        inversion HD1;subst.
        (* Decide 1 *)
        inversion H5;subst.
        rewrite union_comm_app in H0.
        simpl_union_context;subst.
        inversion H.

        (*  rewrite union_comm in H0.
        Agora, temos duas notações, comutatividade só pra ++. *)
        rewrite meq_cons_append in H0.
        rewrite H0 in H1.

        assert (Hn : S n0 <= S n0) by auto.
        generalize (IH (S n0) Hn);intros.
        destruct H3.

        unfold RDown in H6.
        simpl in H6.
        rewrite Nat.sub_0_r in H6.

        apply H6 in H1; auto.
        destruct H1.
        eexists.
        rewrite H2.
        eapply tri_dec1 with (F:=F);eauto.
        apply LPos1  with (M:= [F] ++ L1) in HM1pos;auto.
        eapply LPos3 in HM1pos. eassumption. eauto.

        (* Decide 2 *)
        rewrite union_comm_app in H0.
        simpl_union_context;subst.
        simpl in H. intuition.
        assert (Hn : S n0 <= S n0) by auto.
        generalize (IH (S n0) Hn);intros.
        destruct H3.

        unfold RDown in H6.
        simpl in H6.
        rewrite Nat.sub_0_r in H6.

        apply H6 with (H:=F) in H1;auto.
        destruct H1.
        eexists.

        eapply tri_dec2 with (F:=F);auto.
        rewrite H2. eauto.
        eassumption.
      ++ (* Top *)
        eexists. eapply tri_dec2 with (F:= ⊤);auto. eapply tri_rel;auto. apply tri_top.
      ++ (* bot *)
        inversion HD1;subst.
        eexists. eapply tri_dec2 with (F:= ⊥);auto. eapply tri_rel;auto. apply tri_bot. eassumption.
        simpl in H4. intuition.
      ++ (* Par *)
        inversion HD1;subst.
        eexists. eapply tri_dec2 with (F:= F0 $ G);auto. eapply tri_rel;auto. apply tri_par. eassumption.
        simpl in H4. intuition.
      ++ (* With *)
        inversion HD1;subst.
        eexists. eapply tri_dec2 with (F:= F0 & G);auto. eapply tri_rel;auto. apply tri_with; eassumption.
        simpl in H4. intuition.
      ++ (* quest *)
        inversion HD1;subst.
        eexists. eapply tri_dec2 with (F:= ? F0);auto. eapply tri_rel;auto. apply tri_quest. eassumption.
        simpl in H4. intuition.
      ++
        (* Store *)
        inversion HD1;subst.
        inversion HF.
        inversion HF.
        inversion HF.
        inversion HF.
        inversion H5;subst.
        rewrite union_comm_app in H0.
        simpl_union_context ; subst.

        (* Decide 1 *)
        eexists.
        rewrite HeqM.
        eapply tri_dec2 with (F:=F0);eauto.

        (* Decide 2 *)
        rewrite meq_cons_append in H0.
        rewrite H0 in H1.

        generalize(IH (S n0) (le_n (S n0)));intros.
        destruct H3.
        simpl in H6.
        rewrite Nat.sub_0_r in H6.
        apply H6 in H1;auto.
        destruct H1.
        eexists.
        rewrite H2.
        eapply tri_dec1 with (F:=F0);eauto.
        apply LPos1  with (M:= [F0] ++ L1) in HM1pos;auto.
        eapply LPos3 in HM1pos. eassumption. eauto.

        rewrite H0 in H1.
        generalize(IH (S n0) (le_n (S n0)));intros.
        destruct H2.
        simpl in H3.
        rewrite Nat.sub_0_r in H3.
        rewrite <- H0 in H1.
        apply H3 in H1;auto.
        destruct H1.
        eexists.
        rewrite H0.
        eapply tri_dec2 with (F:=F0);auto.
        rewrite <- H0.
        eassumption.

    +  (* L is not empty *)
      inversion HD1;subst.
      ++
        generalize(IH n (le_n n));intros.
        eapply H in H3;auto.
        destruct H3.
        eexists.
        eapply tri_bot.
        eassumption.
      ++ generalize(IH n (le_n n));intros.
         assert (Heq: F0 :: G :: L1 ++ [F] = (F0 :: G :: L1) ++ [F]) by auto.
         rewrite Heq in H3.
         eapply H in H3;auto.
         destruct H3.
         eexists.
         eapply tri_par.
         eassumption.
      ++
        assert (Hn0: n0 <= Init.Nat.max n0 m) by auto.
        generalize(IH n0 Hn0);intros.
        assert (Hm: m <= Init.Nat.max n0 m) by auto.
        generalize(IH m Hm);intros.

        rewrite app_comm_cons in H4.
        rewrite app_comm_cons in H5.
        eapply H in H4;auto.
        eapply H0 in H5;auto.
        destruct H4.
        destruct H5.
        eexists. eapply tri_with;eauto.
      ++ generalize(IH n (le_n n));intros.
         assert (Heq : (B ++ [F]) ++ [F0] =mul= (B ++ [F0]) ++ [F]) by solve_permutation.
         rewrite Heq in H3.
         eapply H in H3;auto.
         destruct H3.
         eexists.
         eapply tri_quest.
         rewrite Heq.
         eassumption.
      ++ generalize(IH n (le_n n));intros.
         eapply H  in H5;auto.
         destruct H5.
         eexists.
         eapply tri_store;auto.
         eassumption.
         apply LPos1 with (L:= [l] ++ M1);eauto.
         firstorder.
  Qed.

  Theorem InvCopyAux2: forall  n , (forall m : nat, m <= n -> RInd m) -> RDown (n).
    intros n IH.
    unfold RDown.  intros B F M H  HM1pos HPosF  HD1.
    elim (DecPosOrPosAtom H);intro HHpos.
    + (* H is not positive or atom *)
      inversion HHpos;subst.
      ++ (* Neg Atom *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        inversion IHd;subst.
        assert(Hnm: n <= S n0 ) by omega.
        generalize(IH n Hnm);intros.

        destruct H.
        unfold RUp in H.

        assert( exists m0 : nat, m0 |-F- B ++ [F]; M ++ [v ⁻] ; UP ([] ++ [])).
        apply H  ;auto.
        apply LPos1 with (L:= [v ⁻] ++ M);eauto. firstorder.

        destruct H2.
        eexists.
        eapply tri_rel;auto. eapply tri_store;auto.
        simpl in H2.
        eassumption.
        apply LPos1 with (L:= [F] ++ M);eauto. firstorder.
      ++ (* top *)
        eexists.
        eapply tri_rel;auto. eapply tri_top;auto.
      ++ (* bot *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n <= S n0 ) by omega.
        generalize(IH n Hnm);intros.

        destruct H.

        assert( exists m0 : nat, m0 |-F- B ++ [F]; M ; UP ([] ++ [])).
        apply H;auto.

        destruct H2. simpl in H2.
        eexists.
        eapply tri_rel;auto. eapply tri_bot;auto. eassumption.
        simpl in H5.
        intuition.

        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* Par *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n <= S n0 ) by omega.
        generalize(IH n Hnm);intros.

        destruct H.

        assert( exists m0 : nat, m0 |-F- B ++ [F] ; M ; UP ([F0 ; G] ++ [])).
        apply H;auto.

        destruct H2. simpl in H2.
        eexists.
        eapply tri_rel;auto. eapply tri_par;auto. eassumption.
        simpl in H5.
        intuition.
        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* with *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        (* assert(Hnm0: (Init.Nat.max n  m)  <= S n0 ) by omega.*)
        apply le_S_n in IHn.

        assert(Hnm1:  n <=  S n0 ). apply Nat.le_trans with (m:=Init.Nat.max n m);auto.
        assert(Hnm2:  m <=  S n0 ). apply Nat.le_trans with (m:=Init.Nat.max n m);auto.

        generalize(IH n Hnm1);intros.
        generalize(IH m Hnm2);intros.

        destruct H.
        destruct H1.

        assert( exists m0 : nat, m0 |-F- B ++ [F]; M; UP ([F0] ++ []))
          by ( apply H;auto).

        assert( exists m0 : nat, m0 |-F- B ++ [F]; M; UP ([G] ++ []))
          by (apply H1;auto).

        destruct H4. simpl in H4.
        destruct H6. simpl in H6.
        eexists.
        eapply tri_rel;auto. eapply tri_with;auto; eassumption.
        inversion H5. intuition.

        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* Quest *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n <= S n0 ) by omega.
        generalize(IH n Hnm);intros.

        destruct H.
        assert (Mequiv :  (B ++ [F]) ++ [F0] =mul=  (B ++ [F0]) ++ [F]) by solve_permutation.

        assert( exists m0 : nat, m0 |-F- (B ++ [F0]) ++ [F]; M; UP ([] ++ [])).
        apply H;auto. simpl. rewrite <- Mequiv. assumption.

        destruct H2.
        eexists.
        eapply tri_rel;auto.  eapply tri_quest;auto.
        rewrite Mequiv. eassumption.

        simpl in H5.
        intuition.
        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

    + (* H is positive *)
      inversion HHpos;subst.
      ++ (* Positive Atom *)
        inversion HD1;subst.
        apply eq_then_meq in H2.
        symmetry in H2.
        rewrite union_comm_app in H2.
        apply resolvers2 in H2.
        destruct H2.

        subst.
        eexists.
        eapply tri_init2;eauto.

        apply eq_then_meq in H.
        contradiction_multiset.

        simpl in H0.
        intuition.

      ++ (* 0 *)
        inversion HD1;subst.
        simpl in H0.
        intuition.

      ++ (* one *)
        inversion HD1;subst.
        apply eq_then_meq in H2.
        contradiction_multiset.

        simpl in H0.
        intuition.
      ++ (* Tensor *)
        inversion HD1;subst.
        assert (Ht : M++[F] =mul= [F] ++ M) by eauto.
        rewrite Ht in H1. clear Ht.
        symmetry in H1.
        assert ((exists L1, M0 =mul= [F] ++ L1) \/ (exists L2, N =mul= [F] ++ L2)) as Hten.
        eapply solsls. eapply H1.
        destruct Hten as [Hten1 | Hten2].

        +++ (* destruct HFnm as [M0' HFnm]. *)
          destruct Hten1 as [L1 HL1];
            assert (M =mul= N ++ L1) by ( eapply solsls2;eauto).
          rewrite union_comm_app in HL1.
          eapply TriExchange with (M' := L1 ++ [F]) in H6;auto .
          assert (Hn1 : S m <= S (Init.Nat.max n0 m)) by (auto using le_n_S).

          generalize(IH (S m) Hn1);intros.

          destruct H0.
          assert(exists m0 : nat, m0 |-F- B ++ [F] ; L1 ; DW G).
          apply H2 ;eauto.
          eapply LPos2 in HM1pos;eauto.
          simpl.
          rewrite Nat.sub_0_r.
          rewrite union_comm_app.
          rewrite app_nil_r in H6.
          apply H6.

          destruct H3.
          eexists.
          eapply tri_tensor with (N:= N) (M:= L1);auto.
          rewrite H.
          solve_meq.
          eauto.
          eauto.
        +++
          destruct Hten2 as [L2 HL2].
          rewrite union_comm_app in H1.
          assert (M =mul= M0 ++ L2) by (eapply solsls2; eauto).

          rewrite union_comm_app in HL2.

          eapply TriExchange with (M' := L2 ++ [F]) in H5;auto .
          assert(Hn1: (S n0)  <= S(Init.Nat.max n0 m) ) by (auto using le_n_S).
          generalize(IH (S n0) Hn1);intros.
          destruct H0.
          assert(exists m0 : nat, m0 |-F- B ++ [F] ; L2; DW F0).
          apply H2;eauto.
          eapply LPos2 in HM1pos;eauto.

          simpl.
          rewrite Nat.sub_0_r.
          rewrite union_comm_app.
          rewrite app_nil_r in H5.

          assumption.

          destruct H3.
          eexists.
          eapply tri_tensor with (M:= M0) (N:= L2 );auto.
          eassumption.
          eassumption.

        +++ simpl in H0.
            intuition.

      ++ (* Oplus *)
        inversion HD1;subst.
        generalize(IH (S n0) ( le_n (S n0)));intros.
        destruct H.
        assert(exists m0 : nat, m0 |-F- B ++ [F]; M ; DW F0).
        apply H0;auto.
        simpl.
        rewrite Nat.sub_0_r.
        assumption.

        destruct H1.
        eexists.
        eapply tri_plus1;eauto.

        (* Symmetric for G0 *)
        generalize(IH (S n0) ( le_n (S n0)));intros.
        destruct H.
        assert(exists m0 : nat, m0 |-F- B ++ [F]; M; DW G).
        apply H0;auto.
        simpl.
        rewrite Nat.sub_0_r.
        assumption.

        destruct H1.
        eexists.
        eapply tri_plus2;eauto.
        simpl in H0.
        intuition.

      ++ (* bang *)
        inversion HD1;subst.
        apply eq_then_meq in H.
        contradiction_multiset.

        simpl in H0.
        intuition.
  Qed.

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

      apply InvCopyAux2. assumption.
  Qed.

End InvCopy.
Export InvCopy.

Theorem InvCopy : forall B L F  M n,   n |-F- B ++ [F]  ;M ; UP (F :: L) -> lexpPos M  -> exists m, m|-F- B ++ [F] ; M  ; UP L .
  intros.
  apply EquivUpArrow with (L' := L ++ [F]) in H .
  destruct H.
  assert(HRn:  forall n, RUp n) by (apply InvCopy').

  generalize (HRn (x));intros.
  apply H1  ;auto.
  change (F::L) with ([F] ++ L).
  solve_permutation.
Qed.

Set Implicit Arguments.
Hint Resolve  app_nil_r.

(** Invertibility of the OPlus Rule *)
Module InvPlus.

  Lemma OPlusComm : forall B M F G X n, n |-F- B ; M ++ [F ⊕ G] ; X -> n |-F- B ; M ++ [G ⊕ F] ; X.
    intros.
    generalize dependent B.
    generalize dependent M.
    generalize dependent X.
    generalize dependent n.
    induction n using strongind;intros.
    + inversion H;subst.
      ++ (* H0 inconsistent *)
        apply eq_then_meq in H0.
        symmetry in H0.
        rewrite union_comm_app in H0.
        apply resolvers2 in H0. intuition. inversion H1.
      ++ (* H0 inconsistent *)
        apply eq_then_meq in H0.
        contradiction_multiset.
      ++ (* H0 inconsistent *)
        apply eq_then_meq in H0.
        contradiction_multiset.
      ++ (* Top *)
        eapply tri_top.
    + inversion H0;subst.
      ++ (* Tensor *)
        assert(H2': M0 ++ N =mul= [F ⊕ G] ++ M) by ( rewrite <- H2;solve_permutation).
        clear H2.

        assert ((exists L1, M0 =mul= [F ⊕ G] ++ L1) \/ (exists L2, N =mul= [F ⊕ G] ++ L2)) as Hten.
        eapply solsls;eauto.
        destruct Hten as [Hten1 | Hten2].
        +++
          destruct Hten1 as [L1 HL1]. assert (M =mul= N ++ L1) by (
                                                                   eapply solsls2;eauto).
          rewrite union_comm_app in H1.

          eapply TriExchange with (M' := L1 ++ [F ⊕ G] ) in H4; auto.
          apply H in H4; auto using Max.le_max_r.
          eapply tri_tensor with (M:=L1 ++ [G ⊕ F]) (N:=N);auto.
          rewrite H1. solve_permutation.
          solve_permutation.
        +++
          destruct Hten2 as [L2 HL2].
          rewrite union_comm_app in H2'.
          assert (M =mul= M0 ++ L2).
          eapply solsls2 with (M:=N);eauto.

          eapply TriExchange with (M' := L2 ++ [F ⊕ G]  ) in H3;auto.
          apply H in H3; auto using Max.le_max_l.
          eapply tri_tensor with (N:=L2 ++ [ G ⊕F]) (M:=M0);auto. rewrite H1.
          solve_permutation.
          eauto.
      ++ (* Oplus *) apply tri_plus1;auto.
      ++ (* Oplus *) apply tri_plus2;auto.
      ++ (* bang *)
        apply eq_then_meq in H2.
        contradiction_multiset.
      ++ (* Release *) apply tri_rel;auto.
      ++ (* bot *) apply tri_bot;auto.
      ++ (* par *) apply tri_par;auto.
      ++ (* with *) apply tri_with;auto.
      ++ (* quest *) apply tri_quest;auto.
      ++ (* store *)
        eapply TriExchange with (M' :=  (M ++ [F0]) ++ [F ⊕ G]) in H3;auto.
        apply H in H3;auto.
        apply tri_store;auto.
        eapply TriExchange with (M' :=  (M ++ [G ⊕ F]) ++ [F0]) in H3;auto.
        apply H3.
        solve_permutation.
        solve_permutation.

      ++ (* decide *)
        (* M ++ [F ⊕ G] =mul= [F0] ++ L' *)
        rewrite union_comm_app in H3.
        simpl_union_context.
        +++ subst.
            rewrite HeqM.
            eapply tri_dec1 with (F:= G ⊕ F);auto.

            inversion H4;subst.

            eapply tri_plus2. rewrite app_nil_r. assumption.
            eapply tri_plus1. rewrite app_nil_r. assumption.
            inversion H3.
        +++ rewrite meq_cons_append in H1.
            rewrite H1 in H4.
            apply H in H4;auto.
            rewrite H3.
            eapply tri_dec1 with (F:=F0);eauto.

      ++ (* decide B *)
        eapply tri_dec2;eauto.
  Qed.

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

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

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

  Lemma RUp0 : RUp 0.
    unfold RUp.
    intros.

    destruct L.
    + inversion H0;subst.
      eexists.
      simpl.
      eapply tri_dec1 with (F:= ⊤ ⊕ G);auto;
        eapply tri_plus1 ;auto;(
          eapply tri_rel;auto;
          eapply tri_top).
    + inversion H0. subst.
      simpl.
      eexists.
      eapply tri_top.
  Qed.

  Lemma RDown0 : RDown 0.
    unfold RDown.
    intros.
    inversion H2;subst.
    + destruct M. simpl in *. inversion H3. subst.
      inversion H1.
      inversion H3.
      apply EmptyMS in H5.
      contradiction.
    + apply EmptyMS in H3;contradiction.
    + apply EmptyMS in H3;contradiction.
  Qed.

  Theorem InvPlusAux1: forall  n , (forall m : nat, m <= n -> RInd m) -> RUp (S n).
    intros n IH.
    unfold RUp.  intros B L1 F G M1 HM1pos HD1.
    destruct L1.
    + (* L1 is Empty *)
      simpl in *.
      assert (HF: NotPosOrPosAtom F \/ PosOrPosAtom F) by (apply DecPosOrPosAtom).
      destruct HF as [HF | HF].
      ++ (* F is not a positive formula *)
        eexists.
        eapply tri_dec1 with (F:=  F ⊕ G);auto.
        eapply tri_plus1.
        eapply tri_rel;auto.
        apply NotPosOrPosAtomRelease. assumption.
        rewrite app_nil_r.
        apply HD1.
      ++ (* F IS PosOrPosAtom *)
        apply StoreInversion in HD1;auto.
        simpl in HD1. rewrite Nat.sub_0_r in HD1.
        (* it must be a dec rule *)
        inversion HD1;subst.
        +++ (*DEC 1 *)
          rewrite union_comm_app in H0.
          simpl_union_context;subst.

          eexists.
          eapply tri_dec1 with (F:=F0 ⊕ G);auto.
          eapply tri_plus1.
          rewrite HeqM.
          rewrite app_nil_r.
          eassumption.

          rewrite H0 in H1.
          rewrite meq_cons_append in H1.
          assert(Hn : S n0 <= S n0) by auto.
          generalize(IH (S n0) Hn);intros.
          destruct H3.
          simpl in H4. rewrite Nat.sub_0_r in H4.
          eapply H4 in H1;eauto.
          destruct H1.
          eexists.
          rewrite H2.
          eapply tri_dec1 with (F:=F0);auto.
          eapply H1.
          apply LPos1 in H2;auto.
          inversion H2.
          auto.

        +++  (* DEC 2 *)
          assert(Hn : S n0 <= S n0) by auto.
          generalize(IH (S n0) Hn);intros.
          destruct H2.
          simpl in H3. rewrite Nat.sub_0_r in H3.
          unfold RDown in H3.
          apply H3 with (G:=G) in H1;auto.
          destruct H1. rewrite H0 in H1.
          eexists.
          rewrite H0.
          eapply tri_dec2 with (F:=F0);eauto.

    +   (* L is not empty *)
      inversion HD1;subst.
      ++
        generalize(IH n (le_n n));intros.
        destruct H.
        unfold RUp in H.
        apply H with (G:=G)in H3;auto.
        destruct H3.
        eexists.
        eapply tri_bot.
        eassumption.
      ++ generalize(IH n (le_n n));intros.
         destruct H.
         assert (F0 :: G0 :: L1 ++ [F] = (F0 :: G0 :: L1) ++ [F]) by auto.
         rewrite H1 in H3.
         unfold RUp in H.
         eapply H in H3;auto.
         destruct H3.
         eexists.
         eapply tri_par.
         eassumption.
      ++
        assert (Hn0: n0 <= Init.Nat.max n0 m) by auto.
        generalize(IH n0 Hn0);intros.
        assert (Hm: m <= Init.Nat.max n0 m) by auto.
        generalize(IH m Hm);intros.
        destruct H.
        destruct H0.
        rewrite app_comm_cons in H4.
        rewrite app_comm_cons in H5.
        unfold RUp in H. unfold RUp in H0.
        eapply H with (G:=G) in H4;auto.
        eapply H0 with (G:=G) in H5;auto.
        destruct H4.
        destruct H5.
        eexists. eapply tri_with;eauto.
      ++ generalize(IH n (le_n n));intros.
         destruct H.
         eapply H in H3;auto.
         destruct H3.
         eexists.
         eapply tri_quest.
         eassumption.
      ++ generalize(IH n (le_n n));intros.
         destruct H.
         unfold RUp in H.
         eapply H with (G:=G) in H5;auto.
         destruct H5.
         eexists.
         eapply tri_store;auto.
         assert((M1 ++ [l]) ++ [F ⊕ G] =mul=  (M1 ++ [F ⊕ G]) ++ [l]) by solve_permutation.
         rewrite <- H2. eauto.
         apply LPos1 with (L:= [l] ++ M1);eauto.
         constructor;auto.
  Qed.

  Theorem InvPlusAux2: forall  n , (forall m : nat, m <= n -> RInd m) -> RDown (n).
    intros n IH.
    unfold RDown.  intros B F G M H  HM1pos HPosF  HD1.
    elim (DecPosOrPosAtom H);intro HHpos.
    + (* H is not positive or atom *)
      inversion HHpos;subst.
      ++ (* Neg Atom *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        inversion IHd;subst.
        assert(Hnm: n <= S n0 ) by omega.
        generalize(IH n Hnm);intros.

        destruct H.
        unfold RUp in H.
        assert( exists m0 : nat, m0 |-F- B; ((M ++ [v ⁻]) ) ++ [F ⊕ G]; UP ([] ++ [])).
        apply H  ;auto.

        apply LPos1 with (L:= [v ⁻] ++ M);auto. solve_permutation. firstorder.
        destruct H2.
        eexists.
        eapply tri_rel;auto. eapply tri_store;auto.
        simpl in H2.
        eapply TriExchange.  apply H2. auto. solve_permutation.
        eapply LPos1;auto.
        rewrite union_comm_app. firstorder. apply PosOrPosAtomAsync;auto.
      ++ (* top *)
        eexists.
        eapply tri_rel;auto. eapply tri_top;auto.
      ++ (* bot *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n <= S n0 ) by omega.
        generalize(IH n Hnm);intros.

        destruct H.

        assert( exists m0 : nat, m0 |-F- B; M ++ [F ⊕ G]; UP ([] ++ [])).
        apply H;auto.

        destruct H2. simpl in H2.
        eexists.
        eapply tri_rel;auto. eapply tri_bot;auto. eassumption.
        simpl in H5.
        intuition.

        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* Par *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n <= S n0 ) by omega.
        generalize(IH n Hnm);intros.

        destruct H.

        assert( exists m0 : nat, m0 |-F- B; M ++ [F ⊕ G]; UP ([F0 ; G0] ++ [])).
        apply H;auto.

        destruct H2. simpl in H2.
        eexists.
        eapply tri_rel;auto. eapply tri_par;auto. eassumption.
        simpl in H5.
        intuition.
        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* with *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        (* assert(Hnm0: (Init.Nat.max n  m)  <= S n0 ) by omega.*)
        apply le_S_n in IHn.

        assert(Hnm1:  n <=  S n0 ). apply Nat.le_trans with (m:=Init.Nat.max n m);auto.
        assert(Hnm2:  m <=  S n0 ). apply Nat.le_trans with (m:=Init.Nat.max n m);auto.

        generalize(IH n Hnm1);intros.
        generalize(IH m Hnm2);intros.

        destruct H.
        destruct H1.

        assert( exists m0 : nat, m0 |-F- B; M ++ [F ⊕ G]; UP ([F0] ++ []))
          by ( apply H;auto).

        assert( exists m0 : nat, m0 |-F- B; M ++ [F ⊕ G]; UP ([G0] ++ []))
          by (apply H1;auto).

        destruct H4. simpl in H4.
        destruct H6. simpl in H6.
        eexists.
        eapply tri_rel;auto. eapply tri_with;auto; eassumption.
        inversion H5. intuition.

        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* Quest *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n <= S n0 ) by omega.
        generalize(IH n Hnm);intros.

        destruct H.

        assert( exists m0 : nat, m0 |-F- B ++ [F0]; M ++ [F ⊕ G]; UP ([] ++ [])).
        apply H;auto.
        destruct H2.
        eexists.
        eapply tri_rel;auto. eapply tri_quest;auto. eassumption.

        simpl in H5.
        intuition.
        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

    + (* H is positive *)
      inversion HHpos;subst.
      ++ (* Positive Atom *)
        inversion HD1;subst.
        apply eq_then_meq in H2.
        symmetry in H2.
        rewrite union_comm_app in H2.
        apply resolvers2 in H2.
        destruct H2. subst.
        inversion HPosF.
        apply EmptyMS in H.
        contradiction.

        simpl in H0.
        intuition.

      ++ (* 0 *)
        inversion HD1;subst.
        simpl in H0.
        intuition.

      ++ (* one *)
        inversion HD1;subst.
        apply eq_then_meq in H2.
        contradiction_multiset.

        simpl in H0.
        intuition.
      ++ (* Tensor *)
        inversion HD1;subst.
        assert (Ht : M++[F] =mul= [F] ++ M) by solve_permutation.
        rewrite Ht in H1. clear Ht.
        symmetry in H1.
        assert ((exists L1, M0 =mul= [F] ++ L1) \/ (exists L2, N =mul= [F] ++ L2)) as Hten.
        eapply solsls;eauto.
        destruct Hten as [Hten1 | Hten2].

        +++ (* destruct HFnm as [M0' HFnm]. *)
          destruct Hten1 as [L1 HL1];
            assert (M =mul= N ++ L1) by ( eapply solsls2;eauto).

          rewrite union_comm_app in HL1.
          eapply TriExchange with (M' := L1 ++ [F]) in H6;auto .
          assert (Hn1 : S m <= S (Init.Nat.max n0 m)) by (auto using le_n_S).

          generalize(IH (S m) Hn1);intros.

          destruct H0.
          assert(exists m0 : nat, m0 |-F- B; L1 ++ [F ⊕ G]; DW G0).
          apply H2 ;eauto.
          eapply LPos2 in HM1pos;eauto.
          simpl.
          rewrite Nat.sub_0_r.
          assumption.
          destruct H3.
          eexists.
          eapply tri_tensor with (N:= N) (M:= L1 ++ [F ⊕ G]);auto.
          rewrite union_comm_app in H.
          rewrite H.
          solve_permutation.

          eauto.
          eauto.
        +++
          destruct Hten2 as [L2 HL2].
          rewrite union_comm_app in H1.
          assert (M =mul= M0 ++ L2) by (eapply solsls2; eauto).
          rewrite union_comm_app in HL2.

          eapply TriExchange with (M' := L2 ++ [F]) in H5;auto .
          assert(Hn1: (S n0)  <= S(Init.Nat.max n0 m) ) by (auto using le_n_S).
          generalize(IH (S n0) Hn1);intros.
          destruct H0.
          assert(exists m0 : nat, m0 |-F- B; L2 ++ [F ⊕ G]; DW F0).
          apply H2;eauto.
          eapply LPos3 in H;auto.

          simpl.
          rewrite Nat.sub_0_r.
          assumption.

          destruct H3.
          eexists.
          eapply tri_tensor with (M:= M0) (N:= L2 ++ [F ⊕ G]);auto.
          rewrite H. auto.
          solve_permutation.
          eauto.
          eauto.

        +++ simpl in H0.
            intuition.

      ++ (* Oplus *)
        inversion HD1;subst.
        generalize(IH (S n0) ( le_n (S n0)));intros.
        destruct H.
        assert(exists m0 : nat, m0 |-F- B; M ++ [F ⊕ G]; DW F0).
        apply H0;auto.
        simpl.
        rewrite Nat.sub_0_r.
        assumption.

        destruct H1.
        eexists.
        eapply tri_plus1;eauto.

        (* Symmetric for G0 *)
        generalize(IH (S n0) ( le_n (S n0)));intros.
        destruct H.
        assert(exists m0 : nat, m0 |-F- B; M ++ [F ⊕ G]; DW G0).
        apply H0;auto.
        simpl.
        rewrite Nat.sub_0_r.
        assumption.

        destruct H1.
        eexists.
        eapply tri_plus2;eauto.
        simpl in H0.
        intuition.

      ++ (* bang *)
        inversion HD1;subst.
        apply eq_then_meq in H.
        contradiction_multiset.

        simpl in H0.
        intuition.
  Qed.

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

      apply InvPlusAux2. assumption.
  Qed.

End InvPlus.
Export InvPlus.

Theorem InvOplus1 : forall B L F G M n, n |-F- B;M ; UP (L ++ [F]) -> lexpPos M -> exists m, m|-F- B ; M ++ [F ⊕ G] ; UP L .
  intros.
  assert(HRn:  forall n, RUp n) by (apply InvPlus').
  generalize (HRn (n));intros.
  unfold RUp in H1.
  apply H1  ;auto.
Qed.

Theorem InvOplus2 : forall B L F G M n, n |-F- B;M ; UP (L ++ [G]) -> lexpPos M -> exists m, m|-F- B ; M ++ [F ⊕ G] ; UP L .
  intros.
  assert(HRn:  forall n, RUp n) by (apply InvPlus').
  generalize (HRn (n));intros.
  unfold RUp in H1.
  assert (exists m : nat, m |-F- B; M ++ [G ⊕ F]; UP L).
  apply H1  ;auto.
  destruct H2.
  apply OPlusComm in H2.
  eexists.
  eauto.
Qed.

(** Invertibility of the Tensor Rule *)
Module InvTensor.
  Lemma TensorComm : forall B M F G X n, n |-F- B ; M ++ [F ** G] ; X -> n |-F- B ; M ++ [G ** F] ; X.
    intros.
    generalize dependent B.
    generalize dependent M.
    generalize dependent X.
    generalize dependent n.
    induction n using strongind;intros.
    + inversion H;subst.
      ++ (* H0 inconsistent *)
        apply eq_then_meq in H0.
        symmetry in H0.
        rewrite union_comm_app in H0.
        apply resolvers2 in H0; intuition. inversion H1.
      ++ (* H0 inconsistent *)
        apply eq_then_meq in H0.
        contradiction_multiset.
      ++ (* H0 inconsistent *)
        apply eq_then_meq in H0.
        contradiction_multiset.
      ++ (* Top *)
        eapply tri_top.
    + inversion H0;subst.
      ++ (* Tensor *)
        (* rewrite union_comm_app in H2 *)

        assert(H2': M0 ++ N =mul= [F ** G] ++ M) by ( rewrite <- H2;solve_permutation).
        clear H2.

        assert ((exists L1, M0 =mul= [F ** G] ++ L1) \/ (exists L2, N =mul= [F ** G] ++ L2)) as Hten.
        eapply solsls;eauto.

        destruct Hten as [Hten1 | Hten2].

        +++
          destruct Hten1 as [L1 HL1]. assert (M =mul= N ++ L1) by (
                                                                   eapply solsls2;eauto).
          rewrite union_comm_app in H1.
          eapply TriExchange with (M' := L1 ++ [F ** G] ) in H4; auto.
          apply H in H4; auto using Max.le_max_r.
          eapply tri_tensor with (M:=L1 ++ [G ** F]) (N:=N);auto.
          rewrite H1. solve_permutation.
          rewrite HL1. auto.
          solve_permutation.
        +++
          destruct Hten2 as [L2 HL2].
          rewrite union_comm_app in H2'.
          assert (M =mul= M0 ++ L2).
          eapply solsls2 with (M:=N);eauto.
          eapply TriExchange with (M' := L2 ++ [F ** G]  ) in H3;auto.
          rewrite union_comm_app in H1.
          apply H in H3; auto using Max.le_max_l.
          eapply tri_tensor with (N:=L2 ++ [ G **F]) (M:=M0);auto.
          rewrite H1.
          solve_permutation.
          solve_permutation.
      ++ (* Oplus *) apply tri_plus1;auto.
      ++ (* Oplus *) apply tri_plus2;auto.
      ++ (* bang *)
        apply eq_then_meq in H2.
        contradiction_multiset.
      ++ (* Release *) apply tri_rel;auto.
      ++ (* bot *) apply tri_bot;auto.
      ++ (* par *) apply tri_par;auto.
      ++ (* with *) apply tri_with;auto.
      ++ (* quest *) apply tri_quest;auto.
      ++ (* store *)
        eapply TriExchange with (M' :=  (M ++ [F0]) ++ [F ** G]) in H3;auto.
        apply H in H3;auto.
        apply tri_store;auto.
        eapply TriExchange with (M' :=  (M ++ [G ** F]) ++ [F0]) in H3;auto.
        apply H3.
        solve_permutation.
        solve_permutation.
      ++ (* decide *)
        (* M ++ [F ** G] =mul= [F0] ++ L' *)
        rewrite union_comm_app in H3.
        simpl_union_context.
        +++ subst.
            inversion H4;subst.
            eapply tri_dec1 with (F:= G ** F);auto.
            rewrite HeqM.
            rewrite union_comm_app in H5.
            assert(Init.Nat.max n0 m = Init.Nat.max m n0) by (apply Max.max_comm).
            rewrite H1.
            eapply tri_tensor with (m:=n0)(n:=m) (N:=M0) (M:=N);auto.
            rewrite H5. auto. solve_permutation.
            inversion H3.
        +++ rewrite meq_cons_append in H1.
            rewrite H1 in H4.
            apply H in H4;auto.
            rewrite H3.
            eapply tri_dec1 with (F:=F0);eauto.
      ++ (* decide B *)
        eapply tri_dec2;eauto.
  Qed.

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

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

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

  Lemma RUp0 : RUp 0.
    unfold RUp.
    intros.
    assert(n = 0%nat) by omega.
    assert(m = 0%nat) by omega.
    subst.
    destruct L ; destruct L'.
    + inversion H2. inversion H3. subst.
      eexists.
      simpl.
      eapply tri_dec1 with (F:= ⊤ ** ⊤);eauto.
      eapply tri_tensor with (M:=M) (N:= M');auto;(
        eapply tri_rel;auto;
        eapply tri_top).
    + inversion H3. subst.
      simpl.
      eexists.
      eapply tri_top.
    + inversion H2. subst.
      simpl.
      eexists.
      eapply tri_top.
    + inversion H2. subst.
      simpl.
      eexists.
      eapply tri_top.
  Qed.

  Lemma RDown0 : RDown 0.
    unfold RDown.
    intros.
    assert(n = 0%nat) by omega.
    assert(m = 0%nat) by omega.
    subst.
    inversion H4. subst.
    inversion H5; subst.
    +
      destruct M. simpl in *. inversion H6.
      subst.
      inversion H3.
      simpl in H6.
      inversion H6;subst.
      apply EmptyMS in H8.
      contradiction.

    + apply EmptyMS in H6;contradiction.
    + apply EmptyMS in H6;contradiction.
  Qed.

  Theorem InvTensorAuxNilNilPosNeg:
    forall  n n1 n2 B M1 M2 F G ,
      (forall m : nat, m <= n -> RInd m) ->
      n1 |-F- B ; M1; UP [F] ->
                      n2 |-F- B ; M2; UP [G] ->
                                      PosOrPosAtom F -> NotPosOrPosAtom G ->
                                      S n = n1 + n2 ->
                                      lexpPos M1 -> lexpPos M2 ->
                                      exists m : nat, m |-F- B; (M1 ++ M2) ++ [F ** G]; UP [].
    intros n n1 n2 B M1 M2 F G IH HD1 HD2 HF HG Hnm  HM1pos HM2pos.
    apply PosOrPosAtomAsync in HF as HF'.
    inversion HD1;subst;simpl in *; try(inversion HF').

    (* It must be a decition rule *)
    inversion H5;subst;auto.
    + (* DEC 1 *)
      rewrite union_comm_app in H1.
      apply DestructMSet in H1 as Heq.
      destruct Heq as [[Heq Heq'] | Heq];subst.
      ++(* case F0 = F *)
        eexists.
        eapply tri_dec1 with (F:= F0 ** G) ;auto.
        eapply tri_tensor with (N:=M1)(M:=M2);auto. solve_permutation.
        rewrite Heq'.  eassumption.
        eapply tri_rel;auto.
        apply NotPosOrPosAtomRelease;auto.
        eassumption.

      ++ destruct Heq as [M2'].
         destruct H3.

         assert (Hn: S (n1 + n2) <= n ) by omega.
         generalize (IH (S (n1+ n2)) Hn) as IH';intros.
         destruct IH' as [HRU HRD].
         simpl in HRD.
         rewrite Nat.sub_0_r in HRD.
         assert(exists m : nat, m |-F- B; (M2' ++ M2 ) ++ [F ** G]; DW F0) .
         rewrite <- app_assoc.

         apply HRD with (m:=n2) (n:=n1);clear HRD; auto.
         rewrite meq_cons_app in H6.
         apply LPos3 in H6;auto.
         assert(M2' ++ [F] =mul= L'). rewrite H3. solve_permutation.
         eapply TriExchange;eauto.
         inversion H7.
         assert(HeqMul: (M1 ++ M2) ++ [F ** G]  =mul= [F0] ++ (M2' ++ M2 ++ [F ** G])) by
             (rewrite H6; simpl; solve_permutation).
         eexists.
         eapply tri_dec1 with (F:=F0);eauto.
         rewrite app_assoc. eassumption.
    + (* Decision on B *)
      assert (Hn: S (n1 + n2) <= n ) by omega.
      generalize (IH (S (n1+ n2)) Hn) as IH';intros.
      destruct IH' as [HRU HRD].
      simpl in HRD.
      rewrite Nat.sub_0_r in HRD.
      assert(exists m : nat, m |-F- B; (M1 ++ M2 ) ++ [F ** G]; DW F0) .
      rewrite <- app_assoc.
      apply HRD with (m:=n2) (n:=n1);clear HRD; auto.

      inversion H3.
      eexists. eapply tri_dec2 with (F:=F0)  ;eauto.
  Qed.

  Theorem InvTensorAuxNilNilPosPos:
    forall  n n1 n2 B M1 M2 F G ,
      (forall m : nat, m <= n -> RInd m) ->
      n1 |-F- B ; M1; UP [F] ->
                      n2 |-F- B ; M2; UP [G] ->
                                      PosOrPosAtom F -> PosOrPosAtom G ->
                                      S n = n1 + n2 ->
                                      lexpPos M1 -> lexpPos M2 ->
                                      exists m : nat, m |-F- B; (M1 ++ M2) ++ [F ** G]; UP [].
    intros n n1 n2 B M1 M2 F G IH HD1 HD2 HF HG Hnm  HM1pos HM2pos.
    apply PosOrPosAtomAsync in HF as HF'.
    apply PosOrPosAtomAsync in HG as HG'.
    inversion HD1;subst;simpl in *; try(inversion HF').
    inversion HD2;subst;simpl in *; try(inversion HG').
    (* clear HD1. clear HD2. *)

    (* It must be a decition rule *)
    inversion H5;inversion H8;subst;auto.
    + (* DEC 1 / DEC 1*)
      rewrite union_comm_app in H2. rewrite union_comm_app in H12.
      apply DestructMSet in H2 as Heq1.
      apply DestructMSet in H12 as Heq2.
      destruct Heq1 as [[Heq1 Heq1'] | Heq1]; destruct Heq2 as [[Heq2 Heq2'] | Heq2]; subst.
      ++(* case F0 = F F1 = G*)
        eexists.
        eapply tri_dec1 with (F:= F0 ** F1) ;auto.
        rewrite app_nil_r.
        eapply tri_tensor with (N:=M1)(M:=M2) ;eauto.
        rewrite Heq1'. eauto.
        rewrite Heq2'.
        eauto.
      ++ (* case F0 = F, G<> F1 *)
        destruct Heq2 as [M2']. destruct H6.
        assert (Hn: S (S (S(n2 + n3))) <= n ) by omega.
        generalize (IH (S (S (S (n2+ n3)))) Hn) as IH';intros.
        destruct IH' as [HRU HRD].
        simpl in HRD.
        (* rewrite Nat.sub_0_r in HRD. *)

        assert(exists m : nat, m |-F- B; M2' ++ M1  ++ [G ** F0]; DW F1) .

        apply HRD with (m:=S (S n2)) (n:=  n3) ;clear HRD; auto.
        omega.
        rewrite meq_cons_app in H9.
        apply LPos3 in H9;auto.
        rewrite meq_cons_append in H6. rewrite H6  in H13. auto.

        destruct H10.
        assert(HeqMul: (M1 ++ M2) ++ [F0 ** G]  =mul= [F1] ++ (M1 ++ M2'  ++ [F0 ** G]))
          by (rewrite H9; solve_permutation).
        eexists. eapply tri_dec1 with (F:=F1);eauto.
        rewrite app_assoc.
        apply TensorComm ;auto.
        eapply TriExchange;eauto.
      ++ (* case F0 <> F , F1 = G *)
        destruct Heq1 as [M1']. destruct H6.
        assert (Hn: S (S (S(n2 + n3))) <= n ) by omega.
        generalize (IH (S (S (S (n2+ n3)))) Hn) as IH';intros.
        destruct IH' as [HRU HRD].
        simpl in HRD.
        (* rewrite Nat.sub_0_r in HRD. *)

        assert(exists m : nat, m |-F- B; M1' ++ M2  ++ [F ** F1]; DW F0) .
        apply HRD with (m:=S (S n3)) (n:=  n2);clear HRD; auto.
        omega.
        rewrite meq_cons_app in H9.
        apply LPos3 in H9;auto.
        rewrite meq_cons_append in H6. rewrite <- H6. eauto.
        destruct H10.
        assert(HeqMul: (M1 ++ M2) ++ [F ** F1]  =mul= [F0] ++ (M1' ++ M2  ++ [F ** F1])) by(
                                                                                rewrite H9; solve_permutation).
        eexists. eapply tri_dec1 with (F:=F0);eauto.

      ++ (* case both are different *)
        destruct Heq1 as [M1']. destruct H6.
        destruct Heq2 as [M2']. destruct H10.

        assert (Hn: S (S (S(n2 + n3))) <= n ) by omega.
        generalize (IH (S (S (S (n2+ n3)))) Hn) as IH';intros.
        destruct IH' as [HRU HRD].
        simpl in HRD.
        (* rewrite Nat.sub_0_r in HRD. *)

        assert(exists m : nat, m |-F- B; M1' ++ M2  ++ [F ** G]; DW F0) .
        apply HRD with (m:=S (S n3)) (n:=  n2);clear HRD; auto.
        omega.
        rewrite meq_cons_app in H9.
        apply LPos3 in H9 ;auto.
        rewrite meq_cons_append in H6. rewrite <- H6. eauto.
        destruct H15.
        assert(HeqMul: (M1 ++ M2) ++ [F ** G]  =mul= [F0] ++ (M1' ++ M2  ++ [F ** G])) by(
                                                                                rewrite H9; solve_permutation).
        eexists. eapply tri_dec1 with (F:=F0);eauto.
    + (* DEC 2 / DEC 1*)
      assert (Hn: S (S (S(n2 + n3))) <= n ) by omega.
      generalize (IH (S (S (S (n2+ n3)))) Hn) as IH';intros.
      destruct IH' as [HRU HRD].
      simpl in HRD.

      assert(exists m : nat, m |-F- B; M2 ++ M1  ++ [G ** F]; DW F1) .
      apply HRD with (m:=S (S n2)) (n:=  n3);clear HRD; auto.
      omega.
      destruct H6.
      eexists.
      apply TensorComm;auto.
      eapply tri_dec2 with (F:=F1);eauto.
      eapply TriExchange;eauto.
    + (* DEC 1 / DEC 2*)
      assert (Hn: S (S (S(n2 + n3))) <= n ) by omega.
      generalize (IH (S (S (S (n2+ n3)))) Hn) as IH';intros.
      destruct IH' as [HRU HRD].
      simpl in HRD.

      assert(exists m : nat, m |-F- B; M1 ++ M2  ++ [F ** G]; DW F0) .
      apply HRD with (m:=S (S n3)) (n:=  n2);clear HRD; auto.
      omega.
      destruct H6.
      eexists.
      rewrite <- app_assoc.
      eapply tri_dec2 with (F:=F0);eauto.

    + (* DEC 2 / DEC 2*)
      assert (Hn: S (S (S(n2 + n3))) <= n ) by omega.
      generalize (IH (S (S (S (n2+ n3)))) Hn) as IH';intros.
      destruct IH' as [HRU HRD].
      simpl in HRD.

      assert(exists m : nat, m |-F- B; M1 ++ M2  ++ [F ** G]; DW F0) .
      apply HRD with (m:=S (S n3)) (n:=  n2);clear HRD; auto.
      omega.
      destruct H6.
      eexists.
      rewrite <- app_assoc.
      eapply tri_dec2 with (F:=F0);eauto.
  Qed.

  Lemma InvTensorAux1' : forall n n1 n2 B M1 M2 L1 l L2 F G,
      n1 |-F- B; M1; UP (L1 ++ [F]) ->
                     n2 |-F- B; M2; UP ((l :: L2) ++ [G])->
                                    (forall m : nat, m <= n -> RInd m) ->
                                    S n = n1 + n2 ->
                                    lexpPos M1 ->
                                    lexpPos M2 ->
                                    exists m : nat, m |-F- B; (M1 ++ M2) ++ [F ** G]; UP (L1 ++ l :: L2).

    intros n n1 n2 B M1 M2 L1 l L2 F G HD1 HD2 IH Hnm HM1pos HM2pos.
    simpl in *.
    inversion HD2;subst.
    ++ (* top *)
      apply EquivAuxTop.
    ++ (* bottom *)
      assert (Hn: (n0 + n1) <= n ) by omega.
      generalize (IH (n0 + n1) Hn) as IH';intros.
      destruct IH' as [HRU HRD].
      clear HRD.
      unfold RUp in HRU .
      assert(Hih : exists m : nat, m |-F- B; M1 ++ M2  ++ [F ** G]; UP (L1 ++ L2)) .
      apply HRU with (n:=n1) (m:=n0);auto.
      omega.
      destruct Hih.
      rewrite <- app_assoc.
      eapply EquivAuxBot ;eassumption.
    ++ (* par *)
      assert (Hn: (n0 + n1) <= n ) by omega.
      generalize (IH (n0 + n1) Hn) as IH';intros.
      destruct IH' as [HRU HRD].
      clear HRD.
      unfold RUp in HRU .
      assert(Hih : exists m : nat, m |-F- B; M1 ++ M2  ++ [F ** G]; UP (L1 ++ (F0 :: G0 :: L2))) .
      apply HRU with (n:=n1) (m:=n0);auto.
      omega.
      destruct Hih.
      rewrite <- app_assoc.
      eapply EquivAuxPar with(F:=F0) (G:=G0); eassumption.
    ++ (* with *)
      assert (Hn: (n0 + n1) <= n ) by (
                                       rewrite <- Nat.add_succ_comm in Hnm; inversion Hnm;
                                       rewrite plus_comm;
                                       apply plus_le_compat_l ;apply  Max.le_max_l).

      assert (Hn': (m + n1) <= n ) by (
                                       rewrite <- Nat.add_succ_comm in Hnm; inversion Hnm;
                                       rewrite plus_comm;
                                       apply plus_le_compat_l ;apply  Max.le_max_r).

      generalize (IH (n0 + n1) Hn) as IH';intros.
      generalize (IH (m + n1) Hn') as IH'';intros.

      destruct IH' as [HRU HRD];clear HRD.
      destruct IH'' as [HRU' HRD'];clear HRD'.
      unfold RUp in HRU .
      unfold RUp in HRU'.

      assert(Hih : exists m : nat, m |-F- B; M1 ++ M2  ++ [F ** G]; UP (L1 ++ (F0  :: L2))) .
      apply HRU with (n:=n1) (m:=n0);auto.
      omega.

      assert(Hih' : exists m : nat, m |-F- B; M1 ++ M2  ++ [F ** G]; UP (L1 ++ (G0  :: L2))) .
      apply HRU' with (n:=n1) (m0:=m);auto.
      omega.
      clear HRU. clear HRU'.

      destruct Hih.
      destruct Hih'.
      rewrite <- app_assoc.
      eapply EquivAuxWith;eassumption.

    ++ (* quest *)
      assert (Hn: (n0 + n1) <= n ) by omega.
      generalize (IH (n0 + n1) Hn) as IH';intros.
      destruct IH' as [HRU HRD].
      clear HRD.
      unfold RUp in HRU .
      assert(Hih : exists m : nat, m |-F- B ++ [F0] ; M1 ++ M2  ++ [F ** G]; UP (L1 ++  L2)) .
      apply HRU with (n:=n1) (m:=n0);auto.
      omega.
      eapply TriWeakening;eauto.

      destruct Hih.
      rewrite <- app_assoc.
      eapply EquivAuxQuest; eassumption.
    ++ (* Store *)
      assert (Hn: (n0 + n1) <= n ) by omega.
      generalize (IH (n0 + n1) Hn) as IH';intros.
      destruct IH' as [HRU HRD].
      clear HRD.
      unfold RUp in HRU .
      assert(Hih : exists m : nat, m |-F- B  ; M1 ++ (M2 ++ [l])  ++ [F ** G]; UP (L1 ++  L2)) .
      apply HRU with (n:=n1) (m:=n0);auto.
      omega.
      assert (lexpPos( [l] ++ M2)).
      apply lexpPosUnion;auto. firstorder.
      apply LPos1 with (L:= [l] ++ M2);auto. solve_permutation.

      destruct Hih.
      eapply EquivAuxSync with (F:=l);eauto.
      eapply TriExchange with (M':= ((M1 ++ M2) ++ [F ** G]) ++ [l])in H;auto.
      eassumption.
      solve_permutation.

  Qed.

  Theorem InvTensorAux1: forall  n , (forall m : nat, m <= n -> RInd m) -> RUp (S n).
    intros n IH.
    unfold RUp.  intros B L1 L2 F G M1 M2 n1 n2 Hnm HM1pos HM2pos HD1 HD2.
    destruct L1; destruct L2.
    + (* L1 and L2 are Empty *)
      simpl in *.
      assert (HF: NotPosOrPosAtom F \/ PosOrPosAtom F) by (apply DecPosOrPosAtom).
      assert (HG: NotPosOrPosAtom G \/ PosOrPosAtom G) by (apply DecPosOrPosAtom).

      destruct HG as [HG | HG] ; destruct HF as [HF | HF].
      ++
        (* F and G are NotPosOrPosAtom *)
        eexists.
        eapply tri_dec1 with (F := F ** G) ;eauto.
        eapply tri_tensor with (F:=F) (M:=M2) (N:=M1);auto. solve_permutation.
        eapply tri_rel; auto using NotPosOrPosAtomRelease;eassumption.
        eapply tri_rel; auto using NotPosOrPosAtomRelease;eassumption.
      ++ (* F is positive and G is Not *)
        rewrite app_assoc.
        eapply InvTensorAuxNilNilPosNeg;eauto.
      ++ (* G is positive and F is Not *)
        assert(exists m : nat, m |-F- B; (M2 ++ M1) ++ [G ** F]; UP []).
        eapply InvTensorAuxNilNilPosNeg with(F:=G) (G:=F) (n1:=n2) (n2:=n1) (M1:=M2)(M2:=M1);eauto. omega.
        destruct H.
        eexists.
        rewrite app_assoc.
        apply TensorComm.
        eapply TriExchange with (M:= (M2 ++ M1) ++ [G ** F]);eauto.

      ++ (* Both are positive *)
        rewrite app_assoc.
        eapply InvTensorAuxNilNilPosPos;eauto.

    + (* L2 is not empty *)
      rewrite  app_assoc.
      eapply InvTensorAux1';eauto.

    + (* L2 empty and L1 is not empty *)
      assert ((l :: L1) ++ [] = [] ++ (l :: L1) ) by  auto using app_nil_r.
      rewrite H.
      assert(exists m : nat,m |-F- B; (M2 ++ M1) ++ [G ** F]; UP ([] ++ l :: L1)).
      eapply InvTensorAux1' with (F:=G) (G:=F);eauto.
      omega.
      destruct H0.
      apply TensorComm in H0.
      eexists.
      eapply TriExchange;eauto.

    + (* L1 and L2 are not empty *)
      rewrite app_assoc.
      eapply InvTensorAux1';eauto.
  Qed.

  Theorem InvTensorAux2: forall  n , (forall m : nat, m <= n -> RInd m) -> RDown (n).

    intros n IH.
    unfold RDown.  intros B F G M M' n1 n2 H Hnm HM1pos HM2pos HPosF  HD1 HD2.
    elim (DecPosOrPosAtom H);intro HHpos.
    + (* H is not positive or atom *)
      inversion HHpos;subst.
      ++ (* Neg Atom *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        inversion IHd;subst.
        assert(Hnm: n0 + n2 <= S n + n2 ) by omega.
        generalize(IH (n0 + n2) Hnm);intros.

        destruct H.
        unfold RUp in H.
        assert( exists m0 : nat, m0 |-F- B; (M ++ [v ⁻]) ++ M' ++ [F ** G]; UP ([] ++ [])).
        apply H with (m:=n2) (n:= n0);auto.
        apply LPos1 with (L:= [v ⁻] ++ M);eauto. constructor;auto.
        destruct H2.
        eexists.
        eapply tri_rel;auto. eapply tri_store;auto.
        simpl in H2.
        eapply TriExchange.  apply H2. auto. solve_permutation.
        eapply LPos1;auto. firstorder.

        apply LPos1 with  (L:=[F] ++ M);auto.
        simpl. intuition. solve_permutation.
        constructor;auto.
        apply PosOrPosAtomAsync;auto.
      ++ (* top *)
        eexists.
        eapply tri_rel;auto. eapply tri_top;auto.
      ++ (* bot *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n0 + n2 <= S n + n2 ) by omega.
        generalize(IH (n0 + n2) Hnm);intros.

        destruct H.

        assert( exists m0 : nat, m0 |-F- B; M ++ M' ++ [F ** G]; UP ([] ++ [])).
        apply H with (m:=n2) (n:= n0);auto.

        destruct H2. simpl in H2.
        eexists.
        eapply tri_rel;auto. eapply tri_bot;auto. eassumption.
        simpl in H5.
        intuition.

        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* Par *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n0 + n2 <= S n + n2 ) by omega.
        generalize(IH (n0 + n2) Hnm);intros.

        destruct H.

        assert( exists m0 : nat, m0 |-F- B; M ++ M' ++ [F ** G]; UP ([F0 ; G0] ++ [])).
        apply H with (m:=n2) (n:= n0);auto.

        destruct H2. simpl in H2.
        eexists.
        eapply tri_rel;auto. eapply tri_par;auto. eassumption.
        simpl in H5.
        intuition.
        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* with *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm0: (Init.Nat.max n0  m) + n2 <= S n + n2 ) by omega.
        assert(Hnm1:  n0 + n2 <= S n + n2 ) by (
                                                apply plus_le_reg_r in Hnm0;
                                                apply plus_le_compat_r;
                                                assert (n0 <= Init.Nat.max n0 m) by apply Max.le_max_l;
                                                omega).

        assert(Hnm2:  m + n2 <= S n + n2 ) by (
                                               apply plus_le_reg_r in Hnm0;
                                               apply plus_le_compat_r;
                                               assert (m <= Init.Nat.max n0 m) by apply Max.le_max_r;
                                               omega).

        generalize(IH (n0 + n2) Hnm1);intros.
        generalize(IH (m + n2) Hnm2);intros.

        destruct H.
        destruct H1.

        assert( exists m0 : nat, m0 |-F- B; M ++ M' ++ [F ** G]; UP ([F0] ++ []))
          by ( apply H with (n:=n0) (m:=n2);auto).

        assert( exists m0 : nat, m0 |-F- B; M ++ M' ++ [F ** G]; UP ([G0] ++ []))
          by (apply H1  with (n:=m) (m0:=n2);auto).

        destruct H4. simpl in H4.
        destruct H6. simpl in H6.
        eexists.
        eapply tri_rel;auto. eapply tri_with;auto; eassumption.
        simpl in H5.
        intuition.
        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

      ++ (* Quest *)
        inversion HD1;subst.
        apply UpExtension in H4.
        destruct H4 as [n'  [IHn IHd]].
        simpl in IHd.
        inversion IHd;subst.

        assert(Hnm: n0 + n2 <= S n + n2 ) by omega.
        generalize(IH (n0 + n2) Hnm);intros.

        destruct H.

        assert( exists m0 : nat, m0 |-F- B ++ [F0]; M ++ M' ++ [F ** G]; UP ([] ++ [])).
        apply H with (m:=n2) (n:= n0);auto.
        eapply TriWeakening;eauto.

        destruct H2. simpl in H2.
        eexists.
        eapply tri_rel;auto. eapply tri_quest;auto. eassumption.
        simpl in H5.
        intuition.
        apply LPos1 with (L:= [F] ++ M);eauto.
        constructor;auto using PosOrPosAtomAsync.

    + (* H is positive *)
      inversion HHpos;subst.
      ++ (* Positive Atom *)
        inversion HD1;subst.
        (*  Bem, não é multiset mas vamos tentar *)
        apply eq_then_meq in H2.
        symmetry in H2.
        rewrite union_comm_app in H2.
        apply resolvers2 in H2.
        destruct H2.
        subst.
        inversion HPosF.

        apply EmptyMS in H. contradiction.

        simpl in H0.
        intuition.

      ++ (* 0 *)
        inversion HD1;subst.
        simpl in H0.
        intuition.

      ++ (* one *)
        inversion HD1;subst.
        apply eq_then_meq in H2.
        contradiction_multiset.

        simpl in H0.
        intuition.
      ++ (* Tensor *)
        inversion HD1;subst.

        assert(H2': M0 ++ N =mul= [F] ++ M)by ( rewrite <- H1;solve_permutation).
        clear H1.

        assert ((exists L1, M0 =mul= [F] ++ L1) \/ (exists L2, N =mul= [F] ++ L2)) as Hten.
        eapply solsls;eauto.
        destruct Hten as [Hten1 | Hten2].
        +++
          destruct Hten1 as [L1 HL1]. assert (M =mul= N ++ L1) by (
                                                                   eapply solsls2;eauto).
          rewrite union_comm_app in HL1.
          eapply TriExchange with (M' := L1 ++ [F]) in H6;auto .
          assert(Hn1: (S m) + n2 <= S(Init.Nat.max n m) + n2) by(
                                                                  apply le_n_S;apply plus_le_compat;auto).
          generalize(IH (S m + n2) Hn1);intros.
          destruct H0.
          assert(exists m0 : nat, m0 |-F- B; L1 ++ M' ++ [F ** G]; DW G0).
          apply H1 with   (n :=m) (m0:=n2) ;eauto. omega.
          eapply LPos2 in HM1pos;eauto.

          destruct H2.
          (*rewrite H in H1. *)

          assert(exists m0 : nat, m0 |-F- B; L1 ++ N ++ M' ++ [F ** G] ;  DW (F0 ** G0)).
          eexists.
          eapply tri_tensor with (N:= N) (M:= L1 ++ M' ++ [F ** G]);eauto.
          destruct H3.
          eapply TriExchange with (M' := (M ++ M') ++ [F ** G])in H3;auto.
          eexists.
          rewrite app_assoc.
          eassumption.
          rewrite H.
          solve_permutation.

        +++
          destruct Hten2 as [L2 HL2].
          rewrite union_comm_app in H2'.
          assert (M =mul= M0 ++ L2).
          eapply solsls2 with (M:=N);eauto.

          rewrite union_comm_app in HL2.
          eapply TriExchange with (M' := L2 ++ [F]) in H5;auto .
          assert(Hn1: (S n) + n2 <= S(Init.Nat.max n m) + n2) by(
                                                                  apply le_n_S;apply plus_le_compat;auto).
          generalize(IH (S n + n2) Hn1);intros.
          destruct H0.
          assert(exists m0 : nat, m0 |-F- B; L2 ++ M' ++ [F ** G]; DW F0).
          apply H1 with   (n0 :=n) (m:=n2) ;eauto. omega.
          eapply LPos2 in HM1pos;eauto.

          destruct H2.
          (* rewrite HL2 in H1. *)

          assert(exists m0 : nat, m0 |-F- B; M0 ++ L2 ++ M' ++ [F ** G] ;  DW (F0 ** G0)).
          eexists.
          eapply tri_tensor with (M:= M0) (N:= L2 ++ M' ++ [F ** G]);eauto.

          destruct H3.
          eapply TriExchange with (M' := (M ++ M') ++ [F ** G])in H3;auto.
          eexists.
          rewrite app_assoc.
          eassumption.
          rewrite H.
          solve_permutation.
        +++ simpl in H0.
            intuition.

      ++ (* Oplus *)
        inversion HD1;subst.
        generalize(IH (S n + n2) ( le_n (S n + n2)));intros.
        destruct H.
        assert(exists m0 : nat, m0 |-F- B; M ++ M' ++ [F ** G]; DW F0).
        apply H0 with (n0 :=n) (m:=n2);auto.
        omega.
        destruct H1.
        eexists.
        eapply tri_plus1;eauto.

        (* Symmetric for G0 *)
        generalize(IH (S n + n2) ( le_n (S n + n2)));intros.
        destruct H.
        assert(exists m0 : nat, m0 |-F- B; M ++ M' ++ [F ** G]; DW G0).
        apply H0 with (n0 :=n) (m:=n2);auto.
        omega.
        destruct H1.
        eexists.
        eapply tri_plus2;eauto.
        simpl in H0.
        intuition.
      ++ (* bang *)
        inversion HD1;subst.
        apply eq_then_meq in H.
        contradiction_multiset.

        simpl in H0.
        intuition.
  Qed.

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

      apply InvTensorAux2. assumption.
  Qed.

End InvTensor.
Export InvTensor.

Theorem InvTensor : forall B L L' F G M M' n m, lexpPos M -> lexpPos M' -> n |-F- B;M ; UP ( L ++ [F]) -> m |-F- B;M' ; UP (L' ++ [G]) -> exists m, m|-F- B ; M ++ M' ++ [F ** G] ; UP (L ++ L').
  intros.
  assert(HRn:  forall n, RUp n) by (apply InvTensor').
  generalize (HRn (n+m));intros.
  unfold RUp in H3.
  apply H3  with (n0:=n) (m0:=m) ;auto.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)

(** * Accessible subuniverses and modalities *)

Require Import HoTT.Basics HoTT.Types.
Require Import Extensions NullHomotopy.
Require Import Modality.

Local Open Scope nat_scope.
Local Open Scope path_scope.

(** ** Accessible reflective subuniverses *)

(** An accessible reflective subuniverse is one that is the localization at a small family of maps.  Accessibility is necessary for some constructions, and in practice it's a reasonable hypothesis that includes most examples (though a few examples, such as double negation, may only be accessible if we assume propositional resizing).

We now give the basic definitions related to accessibility, using [ooExtendableAlong] as our notion of equivalence as we did with reflective subuniverses.  The actual construction of a reflective subuniverse by localization will be in [Localization]. *)

Record LocalGenerators@{a} :=
  { lgen_indices : Type@{a} ;
    lgen_domain : lgen_indices -> Type@{a} ;
    lgen_codomain : lgen_indices -> Type@{a} ;
    lgenerator : forall i, lgen_domain i -> lgen_codomain i
  }.

Coercion lgenerator : LocalGenerators >-> Funclass.

(** We put this definition in a module so that no one outside of this file will use it accidentally.  It will be redefined in [Localization] to refer to the localization reflective subuniverse, which is judgmentally the same but will also pick up typeclass inference for [In]. *)
Module Import IsLocal_Internal.
  Definition IsLocal f X :=
    (forall (i : lgen_indices f), ooExtendableAlong (f i) (fun _ => X)).
End IsLocal_Internal.

Class IsAccRSU@{a i} (O : Subuniverse@{i}) :=
{
  acc_lgen : LocalGenerators@{a} ;
  inO_iff_islocal : forall (X : Type@{i}),
      (** We call [iff] explicitly to control the number of universe parameters. *)
      iff@{i i i} (In O X) (IsLocal acc_lgen X) ;
}.

Arguments acc_lgen O {_}.
Arguments inO_iff_islocal O {_} X.

  Global Instance O_inverts_generators {O : ReflectiveSubuniverse} `{IsAccRSU O}
             (i : lgen_indices (acc_lgen O))
  : O_inverts O (acc_lgen O i).
  Proof.
    pose (ext_dom := fst (inO_iff_islocal O (O (lgen_domain (acc_lgen O) i))) _).
    pose (ext_cod := fst (inO_iff_islocal O (O (lgen_codomain (acc_lgen O) i))) _).
    simple refine (isequiv_adjointify _ _ _ _).
    - apply O_rec.
      exact ((fst (ext_dom i 1%nat) (to O _)).1).
    - apply O_indpaths; intros x; simpl.
      rewrite O_rec_beta.
      refine ((fst (snd (ext_cod i 2)
                        (fun x => O_functor O (acc_lgen O i)
                                            ((fst (ext_dom i 1%nat) (to O _)).1 x))
                        _) _).1 x); intros a.
      rewrite ((fst (ext_dom i 1%nat) (to O _)).2 a).
      apply to_O_natural.
    - apply O_indpaths; intros x; simpl.
      rewrite (to_O_natural O (acc_lgen O i) x).
      rewrite O_rec_beta.
      apply ((fst (ext_dom i 1%nat) (to O _)).2 x).
  Qed.

(** The construction of the localization reflective subuniverse for any family of maps will be in [Localization]. *)

(** ** Accessible modalities *)

(** A modality is accessible just when its underlying reflective subuniverse is accessible.  However, for modalities we have a simpler characterization in terms of families of generating connected objects rather than families of generating inverted maps.  We call an object [S]-null if it is local with respect to the maps [S i -> Unit]. *)

Record NullGenerators :=
  { ngen_indices : Type@{a} ;
    ngen_type : ngen_indices -> Type@{a}
  }.

Coercion ngen_type : NullGenerators >-> Funclass.

Definition null_to_local_generators : NullGenerators@{a1} -> LocalGenerators@{a2}
  := fun S => Build_LocalGenerators (ngen_indices S) (ngen_type S) (fun _ => Unit) (fun _ _ => tt).

(** As with [IsLocal], the real version of this notation will be defined in [Nullification]. *)
Module Import IsNull_Internal.
  Definition IsNull (S : NullGenerators@{a}) (X : Type@{i})
    := IsLocal@{i i a} (null_to_local_generators@{a a} S) X.
End IsNull_Internal.

(** A central fact: if a type [X] is null for all the fibers of a map [f], then it is [f]-local.  (NB: the converse is *not* generally true.)  TODO: Should this go in [Extensions]? *)
Definition extendable_isnull_fibers (n : nat)
           {A B} (f : A -> B) (C : B -> Type)
: (forall b, ooExtendableAlong (const_tt (hfiber f b))
                               (fun _ => C b))
  -> ExtendableAlong n f C.
Proof.
  revert C.
  simple_induction n n IHn; intros C null; [exact tt | split].
  - intros g.
    exists (fun b => (fst (null b 1%nat) (fun x => x.2 # g x.1)).1 tt).
    intros a.
    rewrite (path_unit tt (const_tt _ a)).
    exact ((fst (null (f a) 1%nat) _).2 (a ; 1)).
  - intros h k.
    apply IHn; intros b.
    apply ooextendable_homotopy, null.
Defined.

Definition ooextendable_isnull_fibers {A B} (f : A -> B) (C : B -> Type)
: (forall b, ooExtendableAlong (const_tt (hfiber f b))
                               (fun _ => C b))
  -> ooExtendableAlong f C
:= fun null n => extendable_isnull_fibers n f C null.

(** We define a modality to be accessible if it consists of the null types for some family of generators as above. *)

Class IsAccModality@{a i} (O : Subuniverse@{i}) :=
{
  acc_ngen : NullGenerators@{a} ;
  inO_iff_isnull : forall (X : Type@{i}),
      iff@{i i i} (In O X) (IsNull acc_ngen X) ;
}.

Arguments acc_ngen O {_}.
Arguments inO_iff_isnull O {_} X.

Section AccessibleModalities.
  Context (O : Modality) {acco : IsAccModality O}.

  (** Unsurprisingly, the generators are connected. *)
  Global Instance isconnected_acc_ngen i : IsConnected O (acc_ngen O i).
  Proof.
    apply isconnected_from_elim_to_O.
    pose (H := fst (fst (inO_iff_isnull O (O (acc_ngen O i))) _ i 1%nat)
                   (to O ((acc_ngen O) i))).
    exists (H.1 tt).
    exact (fun x => (H.2 x)^).
  Defined.

  (** If all the generators are inhabited, some things become a bit simpler. *)
  Section InhabitedGenerators.

    Context (inhab : forall i, acc_ngen O i).

    (** For testing modal-ness of types, it suffices for all maps out of a generator to be constant.  Probably one could do without [Funext].  *)
    Definition inO_const_fromgen `{Funext} A
               (c : forall i (f : acc_ngen O i -> A), NullHomotopy f)
    : In O A.
    Proof.
      apply (snd (inO_iff_isnull O A)); intros i.
      apply ((equiv_ooextendable_isequiv _ _)^-1%equiv).
      snrapply isequiv_adjointify.
      - intros f []; exact (c i f).1.
      - intros f; apply path_arrow; intros x.
        simpl; unfold composeD.
        symmetry; exact ((c i f).2 x).
      - intros g; apply path_arrow; intros [].
        pose ((c i (g oD (null_to_local_generators (acc_ngen O)) i)).2).
        simpl in p; unfold composeD in p.
        symmetry; apply p, inhab.
    Defined.

    (** In particular, all hprops are modal. *)
    Definition inO_hprop_inhab_gen `{Funext} (A : Type) `{IsHProp A}
    : In O A.
    Proof.
      apply inO_const_fromgen; intros i f.
      exists (f (inhab i)).
      intros; apply path_ishprop.
    Defined.

  End InhabitedGenerators.

End AccessibleModalities.

(** We will now show that a modality is accessible in this sense if and only if its underlying reflective subuniverse is accessible in the sense previously defined.  We (almost?) never need to actually use this, though; in practice accessible modalities usually seem to be given to us with the appropriate sort of generators. *)

(** One direction of this implication is trivial. *)
Global Instance acc_rsu_modality (O : Modality) `{IsAccModality O}
  : IsAccRSU O
  := Build_IsAccRSU O (null_to_local_generators (acc_ngen O)) (fun X => inO_iff_isnull O X).

(** For the less trivial converse, the idea is as follows.  By [ooextendable_isnull_fibers], we can detect locality with respect to a map by nullity with respect to its fibers.  Therefore, our first thought might be to just consider all the fibers of all the maps that we are localizing at.  However, this doesn't quite work because [ooextendable_isnull_fibers] is not an if-and-only-if, so not every modal type would necessarily be null for that type family.

     We do know, however, that if [f] is an [O]-connected map, then any [O]-modal type is null for its fibers (since they are [O]-connected types).  There is no *a priori* why all the maps we localize at should end up being connected for the modality; they will always be inverted, but not every inverted map is connected (unless the modality is lex).  But if [f : A -> B] is [O]-inverted, then the [O]-connected map [to O A] is (up to equivalence) the composite of [f] with the [O]-connected map [to O B].  Thus, if [X] is null for the fibers of [to O A] and [to O B], it will be [f]-local and hence [O]-modal, while all [O]-modal types will be null for these fibers since they are connected. *)

(** We don't make this an [Instance] since it is rarely used, and would cause loops when combined with the previous one. *)
Definition acc_modality_rsu (O : Modality) `{IsAccRSU O}
  : IsAccModality O.
Proof.
  unshelve econstructor.
  { refine (Build_NullGenerators
              (  { i : lgen_indices@{a} (acc_lgen O)
                   & O (lgen_domain@{a} (acc_lgen O) i) }
               + { i : lgen_indices@{a} (acc_lgen O)
                   & O (lgen_codomain@{a} (acc_lgen O) i) })
              _).
    intros [ [i x] | [i x] ]; exact (hfiber (to O _) x). }
  { assert (cm := @conn_map_to_O O).
    split.
    - intros X_inO [ [i x] | [i x] ];
        exact (ooextendable_const_isconnected_inO O _ _).
    - intros Xnull.
      apply (snd (inO_iff_islocal O X)); intros i.
      refine (cancelL_ooextendable (fun _ => X) (acc_lgen O i)
                                   (to O (lgen_codomain (acc_lgen O) i)) _ _).
      + apply ooextendable_isnull_fibers; intros x.
        exact (Xnull (inr (i;x))).
      + refine (ooextendable_homotopic _
                                       (O_functor O (acc_lgen O i)
                                                  o to O (lgen_domain (acc_lgen O) i)) _ _).
        1:apply to_O_natural.
        apply ooextendable_compose.
        * apply ooextendable_equiv, O_inverts_generators.
        * apply ooextendable_isnull_fibers; intros x.
          exact (Xnull (inl (i;x))). }
Defined.

(** The construction of the nullification modality for any family of types will be in [Nullification]. *)