Require Export SL.SELLF.Syntax.
Require Export SL.SELLF.Signature.
Require Import LL.Misc.UtilsForall.

Ltac simplSignature :=
  repeat
    multimatch goal with
  (* Basic simplifcation *)
  | [  |- context[fst (_,_)] ] => simpl
  | [ H: context[fst (_,_)]  |- _ ] => simpl in H

  | [  |- context[_ []] ] => simpl
  | [ H: context[_ []]  |- _ ] => simpl in H

  | [ H1: u (fst ?F) = _, H2: context[_(?F :: _)] |- _ ] =>
     destruct F;simpl in H1;simpl in H2; try rewrite H1 in H2
  | [ H: u (fst ?F) = _ |- context[_ (?F :: _)] ] =>
     destruct F;simpl;simpl in H; try rewrite H
 | [ H1: ?s ?a = _, H2: context[if ?s ?a then _ else _] |- _ ] => rewrite H1 in H2
 | [ H: ?s ?a = _|- context[if ?s ?a then _ else _] ] => rewrite H

(* About second *)
 | [ H: context[second(_++_)] |- _ ] => rewrite secondApp in H
 | [ |- context[second(_++_)] ] => rewrite secondApp

 | [  |- context[_ (_::_)] ] => simpl
  | [ H: context[_ (_::_)] |- _ ] => simpl in H

  end.

  Ltac solveSignature :=
  match goal with
   | [H: _ ?a ?b (?F::?K) |- ?a (fst ?F) = ?b] => inversion H;subst;auto
   | [H: _ ?a ?b ((?s, _)::?K) |- ?a ?s = ?b] => inversion H;subst;auto

   | [H: _ ?i (?F::?K) |- lt ?i (fst ?F) ] => inversion H;subst;intuition
   | [H: _ ?i ((?s, _)::?K) |- lt ?i ?s ] => inversion H;subst;intuition
  end.

 Ltac solveLocation :=simplSignature; try solve [solveSignature]; autounfold in *;solveForall.

Section SubExpSets.

  Context `{SI : SigSELL}.
  Context `{OLS : OLSig}.

 Definition SetU (K : list TypedFormula):=
        Forall (fun k => u (fst k) = true) K.

   Definition SetL (K : list TypedFormula):=
        Forall (fun k => u (fst k) = false) K.

 Definition LtX i (K : list TypedFormula) := Forall (fun k => lt i (fst k)) K.

 Fixpoint getLtX  (a: subexp) (L: list TypedFormula) :=
  match L with
  | [] => []
  | (x,F) :: l0 => if lt_dec a x then (x,F) :: (getLtX a l0) else getLtX a l0
  end.

 Fixpoint getU  (L: list TypedFormula) :=
  match L with
  | [] => []
  | (x,F) :: l0 => if u x then (x,F) :: (getU l0) else getU l0
  end.

  Fixpoint getL  (L: list TypedFormula) :=
  match L with
  | [] => []
  | (x,F) :: l0 => if u x then (getL l0) else (x,F) :: getL l0
  end.

(*    Lemma filter_In : forall x l, In x (first (getU l)) <-> In x (first l) /\ sub x = true.
Proof.
      intros *.
      induction l; intros.
      - simpl; tauto.
      - destruct a. destruct (subDec s).
         all: simpl; rewrite e;simpl.
         all: intuition congruence.
    Qed. *)

Section Properties.
  Hint Unfold LtX getLtX SetU SetL:core.

  Lemma USetU (SE: USigSELL) K: SetU K.
  Proof with solveLocation.
  induction K...
  Qed.

  Lemma SetUFirst a F: u a = true -> SetU [(a, F)].
  Proof with solveLocation.
  auto.
  Qed.

  Lemma SetLFirst a F: u a = false -> SetL [(a, F)].
  Proof with solveLocation.
  auto.
  Qed.

  Lemma LtXRefl a F: LtX a [(a, F)].
  Proof with solveLocation.
  simpl...
  reflexivity.
  Qed.

  Lemma LtXTrans i a K : LtX i K -> lt a i -> LtX a K.
  Proof with solveLocation.
  induction K;simpl;intros...
  inversion H;subst.
  transitivity i;auto.
  inversion H;subst.
  apply IHK...
  Qed.

Lemma SETXLTEmpty i K:
       SetL K -> LtX i K -> u i = true -> K=[].
  Proof with solveLocation.
  destruct K;intros...
  destruct t as [p F].
  inversion H0;subst.
  assert(u p = true).
  { eapply uClosure.
     exact H1. simpl in H4... }
     inversion H...
  sauto.
  Qed.

    Lemma SETXClosure i K  :
       u i = true -> LtX i K -> SetU K.
  Proof with solveLocation.
  intros.
  induction K;intros...
  inversion H0;subst.
  eapply uClosure.
  exact H. exact H3.
  apply IHK...
  Qed.

 Lemma SETUIn a K: SetU K -> In a K -> u (fst a) = true.
  Proof with sauto.
  intros.
  eapply @ForallIn with (F:=a) in H...
  Qed.

 Lemma SETLIn a K: SetL K -> In a K -> u (fst a) = false.
  Proof with sauto.
  intros.
  eapply @ForallIn with (F:=a) in H...
  Qed.

  Lemma SETXempty K : SetU K -> SetL K -> K=[].
   Proof with sauto.
  destruct K;intros...
  destruct t as [p F].
  inversion H...
  inversion H0...
  Qed.

   Lemma SETUNotIn a F K : u a = true -> SetL K -> In (a, F) K -> False.
  Proof with sauto.
  induction K;intros...
  destruct a0.
  inversion H1...
  inversion H0...
  apply IHK...
  inversion H0...
  Qed.

   Lemma SETLNotIn a F K : u a = false -> SetU K -> In (a, F) K -> False.
  Proof with sauto.
  induction K;intros...
  destruct a0.
  inversion H1...
  inversion H0...
  apply IHK...
  inversion H0...
  Qed.

  Lemma SETUDec K :  {SetU K} + {~ SetU K}.
  Proof with sauto.
  apply Forall_dec; intros.
  destruct (uDec (fst x))...
  Qed.

  Lemma SETLDec K :  {SetL K} + {~ SetL K}.
  Proof with sauto.
  apply Forall_dec; intros.
  destruct (uDec (fst x))...
  right. intro...
  Qed.

   Global Instance perm_SetU :
      Proper (@Permutation TypedFormula ==>  Basics.impl)
             (SetU ).
    Proof.
      unfold Proper; unfold respectful; unfold Basics.impl .
      intros.
      unfold SetU.
      rewrite <- H;auto.
    Qed.

 Global Instance perm_SetL :
      Proper (@Permutation TypedFormula ==>  Basics.impl)
             (SetL ).
    Proof.
      unfold Proper; unfold respectful; unfold Basics.impl .
      intros.
      unfold SetL.
      rewrite <- H;auto.
    Qed.

Global Instance perm_LtX a :
      Proper (@Permutation TypedFormula  ==>  Basics.impl)
             (LtX a).
    Proof.
      unfold Proper; unfold respectful; unfold Basics.impl .
      intros.
      unfold LtX.
      rewrite <- H;auto.
    Qed.

Lemma SetU_then_empty K : SetU K -> getL K =[].
   Proof with sauto.
  induction K;intros...
  destruct a as [p F].
  inversion H...
  simpl. rewrite H2...
  Qed.

   Lemma SetL_then_empty K : SetL  K -> getU K =[].
   Proof with sauto.
  induction K;intros...
  destruct a as [p F].
  inversion H...
  simpl. rewrite H2...
  Qed.

 Global Instance trans_SetK :
       Proper (lt ==> @Permutation TypedFormula ==> Basics.flip Basics.impl)
             (LtX ).
    Proof.
      unfold Proper; unfold respectful; unfold Basics.flip; unfold Basics.impl .
      intros;subst.
      rewrite H0.
      eapply (LtXTrans _ _ _ H1);auto.
    Qed.

  Theorem cxtDestruct K: Permutation K (getU K++getL K).
 Proof with subst;auto.
 induction K;auto.
 destruct a as [a F].
 destruct (uDec a); simpl; rewrite e.
 constructor;auto.
 apply Permutation_cons_app;auto.
 Qed.

  Theorem cxtDestructSecond K: Permutation (second K) (second (getU K++getL K)).
 Proof with subst;auto.
 induction K;auto.
 destruct a as [a F].
 destruct (uDec a); simpl; rewrite e.
 constructor;auto.
 rewrite secondApp.
 simpl.
 apply Permutation_cons_app;auto.
 rewrite <- secondApp;auto.
 Qed.

 Theorem cxtDestruct' K: exists K1 K2, Permutation K (getU K++getL K1 ++ getL K2) /\ Permutation (getL K) (getL K1 ++ getL K2).
 Proof with sauto.
 induction K...
 exists [], [].
 simpl;auto.
 destruct a as [a F].
 destruct (uDec a); simpl;
 rewrite e;simpl.
 exists x, x0.
 constructor;auto.
 exists ((a,F)::x), x0.
  simpl; rewrite e;simpl.
  constructor;auto.
 apply Permutation_cons_app;auto.
 Qed.

  Theorem cxtDestructLtX i K: SetU K -> exists K', Permutation K (getLtX i K++getU K').
 Proof with sauto.
 induction K;intros...
 * exists nil...
 * destruct a as [a F].
    simpl in *.
    destruct (lt_dec i a)...
    inversion H...
    apply IHK in H3...
    exists x...
    rewrite <- app_comm_cons.
    rewrite <- H3...
    inversion H...
    apply IHK in H3...
    exists ((a,F)::x)...
    rewrite Permutation_app_comm.
    simpl...
    rewrite <- app_comm_cons.
    rewrite Permutation_app_comm.
    rewrite <- H3...
    Qed.

 Lemma getLtXPerm a K1 K2 : Permutation K1 K2 -> Permutation (getLtX a K1) (getLtX a K2).
Proof with subst;auto.
 revert dependent K2.
 revert dependent K1.
 induction 1;intros.
 * simpl...
 * destruct x as [x F];simpl.
   destruct (lt_dec a x)...
 * destruct x as [x F];
   destruct y as [y G];simpl.
   destruct (lt_dec a x);
   destruct (lt_dec a y)...
   apply perm_swap.
 * eapply (Permutation_trans IHPermutation1 IHPermutation2). Qed.

 Lemma getUPerm K1 K2 : Permutation K1 K2 -> Permutation (getU K1) (getU K2).
Proof with subst;auto.
 revert dependent K2.
 revert dependent K1.
 induction 1;intros.
 * simpl...
 * destruct x as [x F];
   destruct (uDec x);
   simpl;rewrite e...
 * destruct x as [x F];
   destruct y as [y G];
   destruct (uDec x);
   destruct (uDec y);
   simpl;rewrite e;rewrite e0...
   apply perm_swap.
 * eapply (Permutation_trans IHPermutation1 IHPermutation2). Qed.

  Lemma getLPerm K1 K2 : Permutation K1 K2 -> Permutation (getL K1) (getL K2).
Proof with subst;auto.
 revert dependent K2.
 revert dependent K1.
 induction 1;intros.
 * simpl...
 * destruct x as [x F];
   destruct (uDec x);
   simpl;rewrite e...
 * destruct x as [x F];
   destruct y as [y G];
   destruct (uDec x);
   destruct (uDec y);
   simpl;rewrite e;rewrite e0...
   apply perm_swap.
 * eapply (Permutation_trans IHPermutation1 IHPermutation2). Qed.

  Global Instance getLtX_morph a:
      Proper ((@Permutation TypedFormula) ==> (@Permutation TypedFormula))
             (getLtX a ).
    Proof.
    unfold Proper; unfold respectful.
    intros.
    apply getLtXPerm;auto.
    Qed.

  Global Instance getU_morph :
      Proper ((@Permutation TypedFormula) ==> (@Permutation TypedFormula))
             (getU ).
    Proof.
    unfold Proper; unfold respectful.
    intros.
    apply getUPerm;auto.
    Qed.

    Global Instance getL_morph :
      Proper ((@Permutation TypedFormula) ==> (@Permutation TypedFormula))
             (getL ).
    Proof.
    unfold Proper; unfold respectful.
    intros.
    apply getLPerm;auto.
    Qed.

      Lemma getLtX_fixpoint a K : getLtX a (getLtX a K) =  getLtX a K.
  Proof.
  induction K;auto.
  destruct a0;simpl;auto.
  destruct (lt_dec a s).
  simpl...
  destruct (lt_dec a s).
  rewrite IHK; auto.
  contradiction.
  rewrite IHK; auto.
 Qed.

  Lemma getU_fixpoint K : getU(getU K) =  getU K.
  Proof.
  induction K;auto.
  destruct a;simpl;auto.
  destruct (uDec s);rewrite e;auto;
  simpl; rewrite e.
  rewrite IHK; auto.
 Qed.

    Lemma getL_fixpoint K : getL(getL K) =  getL K.
  Proof.
  induction K;auto.
  destruct a;simpl;auto.
  destruct (uDec s);rewrite e;auto;
  simpl; rewrite e.
  rewrite IHK; auto.
 Qed.

  Lemma getUgetL K : getU(getL K) =  [].
  Proof.
  induction K;auto.
  destruct a;simpl;auto.
  destruct (uDec s);rewrite e;auto;
  simpl; rewrite e.
  rewrite IHK; auto.
 Qed.

  Lemma getLgetU K : getL(getU K) =  [].
  Proof.
   induction K;auto.
  destruct a;simpl;auto.
  destruct (uDec s);rewrite e;auto;
  simpl; rewrite e.
  rewrite IHK; auto.
  Qed.

  Lemma getUApp K1 K2 : getU (K1 ++ K2) =  getU K1 ++ getU K2.
  Proof.
    induction K1;auto.
  destruct a;simpl;auto.
  destruct (uDec s);rewrite e;auto;
  simpl.
  rewrite IHK1; auto.
   Qed.

   Lemma getLtXApp a K1 K2 : getLtX a (K1 ++ K2) =  getLtX a  K1 ++ getLtX a  K2.
  Proof.
    induction K1;auto.
  destruct a0;simpl;auto.
  destruct (lt_dec a s).
  simpl.
  rewrite IHK1;auto.
  rewrite IHK1;auto.
   Qed.

 Lemma getUApp' K1 K2 : Permutation (getU (K1 ++ K2)) (getU K1 ++ getU K2).
  Proof.
  rewrite getUApp;auto.
  Qed.

 Lemma uIngetU i F K :  u i = true -> In (i, F) K -> In (i, F) (getU K).
 Proof with sauto.
  intros.
  rewrite cxtDestruct in H0.
  apply in_app_or in H0.
  destruct H0;auto.
  induction K...
  destruct a.
  destruct(uDec s); simpl in *.
  rewrite e in *...  firstorder.
  rewrite e in *...
  inversion H0...
 Qed.

  Lemma getLApp K1 K2 : getL (K1 ++ K2) =  getL K1 ++ getL K2.
  Proof.
  induction K1;auto.
  destruct a;simpl;auto.
  destruct (uDec s);rewrite e;auto.
  simpl.
  rewrite IHK1. auto.
 Qed.

 Lemma getLApp' K1 K2 : Permutation (getL (K1 ++ K2)) (getL K1 ++ getL K2).
  Proof.
  rewrite getLApp;auto.
  Qed.

Lemma lIngetL i F K :  u i = false -> In (i, F) K -> In (i, F) (getL K).
 Proof with sauto.
  intros.
  rewrite cxtDestruct in H0.
  apply in_app_or in H0.
  destruct H0;auto.
  induction K...
  destruct a.
  destruct(uDec s); simpl in *;
  rewrite e in *...
  simpl in H0...
  firstorder.
 Qed.

Lemma lIngetU i F K :  u i = true -> In (i, F) K -> In (i, F) (getU K).
 Proof with sauto.
  intros.
  rewrite cxtDestruct in H0.
  apply in_app_or in H0.
  destruct H0;auto.
  induction K...
  destruct a.
  destruct(uDec s); simpl in *;
  rewrite e in *...
  simpl in H0...
  firstorder.
  inversion H0...
 Qed.

  Theorem getUtoSetU K: SetU (getU K).
 Proof with subst;auto.
 induction K...
 apply Forall_nil.
 destruct a as [a F].
 simpl.
 destruct (uDec a); simpl;
 rewrite e...
 Qed.

   Theorem getLtoSetU K: SetU (getL K) -> getL K =[].
 Proof with sauto.
 induction K;intros.
 * auto.
 * destruct a as [a F].
   destruct (uDec a); simpl in *;
  rewrite e in *...
  inversion H...
 Qed.

 Lemma getUPerm_SetU K X : Permutation (getU K) X -> SetU X.
  Proof.
  intros.
  symmetry in H.
  rewrite  H.
  apply getUtoSetU.
 Qed.

  Theorem getLtoSetL K: SetL (getL K).
 Proof with subst;auto.
 induction K...
 apply Forall_nil.

 destruct a as [a F].
 simpl.
 destruct (uDec a); simpl;
 rewrite e...
 Qed.

  Lemma getLPerm_SetL K X : Permutation (getL K) X -> SetL X.
  Proof.
  intros.
  symmetry in H.
  rewrite H.
  apply getLtoSetL.
 Qed.

  Theorem setUtoGetU K: SetU K -> getU K = K.
 Proof with subst;auto.
 induction K; intros...
 destruct a as [a F].
 inversion H...
 apply IHK in H3.
 simpl in *. rewrite H2...
 rewrite H3...
 Qed.

  Theorem getUtoSetU' K:  getU K = K -> SetU K.
 Proof with sauto.
 induction K; intros...
 destruct a as [a F].
 simpl in H.
 destruct (uDec a)...
 apply Forall_cons...
 apply IHK...
 inversion H...
  rewrite H1...
  assert(SetU (getU K)) by apply getUtoSetU.
  rewrite H in H0.
  inversion H0...
 Qed.

  Theorem setLtoGetL K: SetL K -> getL K = K.
 Proof with subst;auto.

 induction K; intros...
 destruct a as [a F].
 inversion H...
 apply IHK in H3.
 simpl in *. rewrite H2...
 rewrite H3...
 Qed.

   Lemma getUPermU K1 K2 : Permutation (getU K1) K2 -> Permutation (getU K1) (getU K2).
Proof with sauto.
 intros.
 rewrite H.
 apply getUPerm_SetU in H.
 rewrite cxtDestruct...
 rewrite (SetU_then_empty _ H)...
 rewrite setUtoGetU...
 rewrite setUtoGetU...
 Qed.

 Theorem Unb_Lin_Disj' K: exists K1 K2, SetU K1 /\ SetL K2 /\ Permutation K (K1++K2).
 Proof with sauto .
 induction K;auto.
 do 2 eexists [];simpl...
 destruct IHK.
 destruct H.
 decompose [and] H ;clear H.
 destruct a as [a F].
 destruct (uDec a).
 eexists ((a,F)::x).
 eexists x0.
 split...
 rewrite H3...

 eexists x.
 eexists ((a,F)::x0).
 split...
 rewrite H3...
  Qed.

 Lemma getUS F t D L: getU D = (t, F)::L -> u t = true.
 Proof with sauto.
 induction D;intros...
 destruct a.
 destruct (uDec s).
 inversion H...
 inversion H1...
 inversion H...
 Qed.

 Lemma ltConv a b K: lt a b -> exists K', Permutation (getLtX a K) (getLtX b K ++ K').
  Proof with sauto.
  revert dependent a.
  revert dependent b.
  revert dependent K.

  induction K;intros...
  exists nil...
  destruct a.
  simpl...
  destruct (lt_dec b s)...
  destruct (lt_dec a0 s)...
  -
  apply IHK in H...
  exists x.
  rewrite H...
  - assert(lt a0 s).
     transitivity b;auto.
     contradiction.
 -
   destruct (lt_dec a0 s)...
   apply IHK in H...

   exists ((s, o) ::x).
  rewrite  H...
  Qed.

 Lemma ltConv' a b K: lt a b -> LtX b (getL K) -> exists K', Permutation (getLtX a K) (getLtX b K ++ getU K').
  Proof with sauto.
  revert dependent a.
  revert dependent b.
  revert dependent K.

  induction K;intros...
  exists nil...
  destruct a.
  destruct (uDec s).
  * simpl in *...
  destruct (lt_dec b s)...
  destruct (lt_dec a0 s)...
  -
  apply IHK in H...
  exists x.
  rewrite H...
  - assert(lt a0 s).
     transitivity b;auto.
     contradiction.
 -
   destruct (lt_dec a0 s)...
   apply IHK in H...
   simpl in H0.
   exists ((s, o) ::x).
  rewrite  H...
  simpl...
  *
  simpl in *...
  destruct (lt_dec b s)...
  destruct (lt_dec a0 s)...
  -
  apply IHK in H...
  exists x.
  rewrite H...
  inversion H0...
  - assert(lt a0 s).
     transitivity b;auto.
     contradiction.
 -
   destruct (lt_dec a0 s)...
   inversion H0...
   inversion H0...
 Qed.

  Lemma linearEmpty K : getL K = [] -> getL K = [] /\ Permutation (getU K) K /\ SetU K.
  Proof with sauto.
  intros. split;auto.
  revert dependent K.
  induction K;intros...
  2:{
   destruct a as [p F].
  destruct (uDec p).
  simpl in H. rewrite e in H.
  apply Forall_cons...
  apply IHK...
  simpl in H. rewrite e in H.
  apply Forall_cons... }

  destruct a as [p F].
  destruct (uDec p).
  - simpl. rewrite e.
    simpl in H.
    rewrite e in H.
    apply IHK in H...
  - simpl. rewrite e.
    simpl in H.
    rewrite e in H.
    inversion H...
Qed.

   Lemma bangUnb i K : u i = true -> LtX i (getL K) -> K = getU K.
   Proof with sauto.
  induction K;intros...
  destruct a as [p F].
  simpl in H0.
  destruct (uDec p)...
  simpl...
  rewrite IHK...
  rewrite getU_fixpoint...
  inversion H0...
  assert(u p = true).
  eauto.
  sauto.
Qed.

Lemma unboundedEmpty K : getU K = [] -> getU K = [] /\ Permutation (getL K) K /\ SetL K.
  Proof with sauto.
  intros. split;auto.
  revert dependent K.
  induction K;intros...
   2:{
   destruct a as [p F].
  destruct (uDec p).
  simpl in H. rewrite e in H.
  apply Forall_cons...
  simpl in H. rewrite e in H.
  apply Forall_cons...
  apply IHK...
  }

  destruct a as [p F].
  destruct (uDec p).
  - simpl. rewrite e.
    simpl in H.
    rewrite e in H.
    inversion H...
  - simpl. rewrite e.
    simpl in H.
    rewrite e in H.
     apply IHK in H...
 Qed.

  Lemma SetK4Destruct  K : SetU K -> SetU (getU K) /\ SetU (getL K).
  Proof with sauto.
  intros.
  rewrite cxtDestruct in H;split;
  apply Forall_app in H...
  Qed.

  Lemma SetK4DestructL  K : SetL K -> SetL (getU K) /\ SetL (getL K).
  Proof with sauto.
  intros.
  rewrite cxtDestruct in H;split;
  apply Forall_app in H...
  Qed.

 Lemma InContext1 F CD C D:
  Permutation (getU CD) (getU C) ->
  Permutation (getU CD) (getU D) ->
  Permutation (getL CD) (getL C ++ getL D) ->
  In F C ->  In F CD.
  Proof with sauto.
  intros.
  rewrite cxtDestruct.
  rewrite H.
  rewrite H1.
  rewrite app_assoc.
  rewrite <- cxtDestruct.
  apply in_or_app;auto.
  Qed.

 Lemma InSecond1 F CD C D:
  Permutation (getU CD) (getU C) ->
  Permutation (getU CD) (getU D) ->
  Permutation (getL CD) (getL C ++ getL D) ->
  In F (second C) ->  In F (second CD).
  Proof with sauto.
  intros.
  unfold second.
  rewrite cxtDestruct.
  rewrite H.
  rewrite H1.
  rewrite app_assoc.
  rewrite <- cxtDestruct.
  rewrite map_app.
  apply in_or_app;auto.
  Qed.

 Lemma InContext2 F CD C D:
  Permutation (getU CD) (getU C) ->
  Permutation (getU CD) (getU D) ->
  Permutation (getL CD) (getL C ++ getL D) ->
  In F D ->  In F CD.
  Proof with sauto.
  intros.
  rewrite cxtDestruct.
  rewrite H0.
  rewrite H1.
  rewrite Permutation_midle_app.
  rewrite <- cxtDestruct.
  apply in_or_app;auto.
  Qed.

  Lemma InSecond2 F CD C D:
  Permutation (getU CD) (getU C) ->
  Permutation (getU CD) (getU D) ->
  Permutation (getL CD) (getL C ++ getL D) ->
  In F (second D) ->  In F (second CD).
  Proof with sauto.
  intros.
  unfold second.
  rewrite cxtDestruct.
  rewrite H0.
  rewrite H1.
  rewrite Permutation_midle_app.
  rewrite <- cxtDestruct.
  rewrite map_app.
  apply in_or_app;auto.
  Qed.

   Lemma simplUnb CD C D:
  Permutation (getU CD) (getU D) ->
  Permutation (getL CD) (getL C ++ getL D) ->
  SetU C -> Permutation CD D.
  Proof.
  intros.
  rewrite (SetU_then_empty _ H1) in H0.
  rewrite (cxtDestruct CD).
  rewrite H0.
  rewrite H.
  simpl.
  rewrite <- cxtDestruct;auto.
  Qed.

  Lemma simplUnb' CD C D:
  Permutation (getU CD) (getU C) ->
  Permutation (getL CD) (getL C ++ getL D) ->
  SetU D -> Permutation CD C.
  Proof.
  intros.
  rewrite (SetU_then_empty _ H1) in H0.
  rewrite (cxtDestruct CD).
  rewrite H.
  rewrite H0;sauto.
  rewrite <- cxtDestruct;auto.
  Qed.

  Lemma isFormulaL_getU K :
      isFormulaL (second K) -> isFormulaL  (second (getU K)).
  Proof.
    induction K;intros;sauto.
    destruct a as [a F].
    destruct(uDec a);simpl;sauto.
    -
      simpl in *.
      inversion H;sauto.
      apply Forall_cons;sauto.
    -
      simpl in *.
      inversion H;sauto.
  Qed.

    Lemma isFormulaL_getL  B :
      isFormulaL  (second B) -> isFormulaL  (second (getL B)).
  Proof.
    induction B;intros;sauto.
    destruct a as [a F].
    destruct(uDec a);simpl;sauto.
    - simpl in *.
      inversion H;sauto.
   -  simpl in *.
      inversion H;sauto.
      apply Forall_cons;sauto.
  Qed.

  Lemma isFormulaLSplitUL  B :
      isFormulaL  (second (getU B)) ->  isFormulaL  (second (getL B)) -> isFormulaL  (second B).
  Proof.
    intros.
    rewrite cxtDestructSecond.
    rewrite secondApp.
    apply Forall_app;auto.
  Qed.

     Lemma isFormulaLSecond  B D X Y:
     Permutation (getL B) (getL D ++ X) ->
     Permutation (getU B) (getU D ++ Y) ->
     isFormulaL  (second B) -> isFormulaL  (second D).
  Proof.
    autounfold;unfold second;intros.
    rewrite cxtDestruct in H1.
    rewrite H in H1.
    rewrite H0 in H1.
    fold (second ((getU D ++ Y) ++ getL D ++ X)) in H1.
    repeat rewrite secondApp in H1.
    apply Forall_app in H1.
    destruct H1.
    apply Forall_app in H1.
    apply Forall_app in H2.
    sauto.
    rewrite cxtDestruct.
    fold (second (getU D ++ getL D)).
    repeat rewrite secondApp.
    apply Forall_app;auto.
    Qed.

  Lemma isFormulaSecond1  BD X Y B Z U:
  isFormulaL  (second (X++getU BD++Y)) ->
  Permutation (X++getU BD++Y) (Z++B++U) ->
  isFormulaL  (second B).
   Proof with sauto.
   intros.
   assert(isFormulaL  (second (Z ++ B ++ U))).
   symmetry in H0.
   autounfold.
   unfold second.
   rewrite H0...
   rewrite !secondApp in H1.
   apply Forall_app in H1...
   apply Forall_app in H3...
 Qed.

 Lemma isFormulaSecond2  BD X Y B Z U:
  isFormulaL  (second (X++getL BD++Y)) ->
  Permutation (X++getL BD++Y) (Z++B++U) ->
  isFormulaL  (second B).
   Proof with sauto.
   intros.
   assert(isFormulaL  (second (Z ++ B ++ U))).
   symmetry in H0.
   autounfold.
   unfold second.
   rewrite H0...
   rewrite !secondApp in H1.
   apply Forall_app in H1...
   apply Forall_app in H3...
 Qed.

  Lemma isFormulaSecondSplit1  BD X Y B D:
  isFormulaL  (second (BD++X++Y)) ->
  Permutation (getU BD++X) (getU B) ->
  Permutation (getL BD++Y) (getL B ++ getL D) -> isFormulaL  (second B).
   Proof with sauto.
  intros.
   rewrite !secondApp in H.
  assert(isFormulaL  (second BD)).
  apply Forall_app in H...
  assert(isFormulaL  (second X)).
  apply Forall_app in H...
  apply Forall_app in H4...
  assert(isFormulaL  (second Y)).
  apply Forall_app in H...
  apply Forall_app in H5...
  assert(Permutation ([] ++ getU BD ++ X) ([] ++getU B ++ [])).
  sauto.
  eapply isFormulaSecond1  in H5...
  assert(Permutation ([] ++ getL BD ++ Y) ([] ++getL B ++ getL D)).
  sauto.
  eapply isFormulaSecond2  in H6...
  apply isFormulaLSplitUL...

  rewrite !secondApp...
  apply Forall_app...
  apply isFormulaL_getL...
  rewrite !secondApp...
  apply Forall_app...
  apply isFormulaL_getU...
 Qed.

  Lemma isFormulaSecondSplit2  BD X Y B D:
  isFormulaL  (second (BD++X++Y)) ->
  Permutation (getU BD++X) (getU D) ->
  Permutation (getL BD++Y) (getL B ++ getL D) -> isFormulaL  (second D).
   Proof with sauto.
  intros.
  eapply isFormulaSecondSplit1 with (X:=X) (Y:=Y) (BD:=BD) (D:=B);auto.
  rewrite H1...
  Qed.

 End Properties.

  End SubExpSets.

 Global Hint Resolve USetU getUtoSetU: core.

(* Global Hint Resolve LtXRefl: core. *)

Global Hint Extern 1 (LtX ?a ?K) =>
  match goal with
  | H: LtX ?i ?K,  H1: lt ?a ?i |- _ =>  apply (LtXTrans _ _ _ H H1)
  end : core.

Ltac solveLT :=
try
 match goal with
   | [ |- lt ?x ?x ] => reflexivity
   | [H: lt ?x ?y, H2: lt ?y ?z |- lt ?x ?z ] => transitivity y;auto
   | [H: lt ?x ?y, H2: LtX ?y ?K |- LtX ?x ?K ] => rewrite H;auto
   | [H: Permutation ?K ?K', H2: LtX ?x ?K' |- LtX ?x ?K ] => rewrite H;auto
    | [H: Permutation ?K ?K', H2: LtX ?x ?K |- LtX ?x ?K' ] => rewrite <- H;auto

  end;auto.

(*   Lemma asasa (OLS : OLSig)  (SI : SigSELL) x y K: lt y x -> lt x K -> lt y K. *)

(* Forall_nil: Forall P []
Forall_inv: Forall P (a :: l) -> P a
ForallIn: Forall f L -> In F L -> f F
Forall_inv_tail: Forall P (a :: l) -> Forall P l
Forall_cons: P x -> Forall P l -> Forall P (x :: l)
Forall_forall: Forall P l <-> (forall x : A, In x l -> P x)

PermuteMap: Forall f L -> Permutation L L' -> Forall f L'

Forall_impl:
  (forall a : A, P a -> Q a) ->
  forall l : list A, Forall P l -> Forall Q l

Permutation_Forall:
  forall [A : Type] [P : A -> Prop],
  Proper (Permutation (A:=A) ==> Basics.impl) (Forall P)

Forall_elt: Forall P (l1 ++ a :: l2) -> P a

ForallInP: Forall f L -> Permutation L (F :: L') -> f F

Forall_cons_iff: Forall P (a :: l) <-> P a /\ Forall P l
Forall_and: Forall P l -> Forall Q l -> Forall (fun x : A => P x /\ Q x) l

Forall_dec:
  (forall x : A, {P x} + {~ P x}) ->
  forall l : list A, {Forall P l} + {~ Forall P l}

Forall_and_inv:
  Forall (fun x : A => P x /\ Q x) l ->
  Forall P l /\ Forall Q l

exists_Forall:
  (exists k : A, Forall (P k) l) ->
  Forall (fun x : B => exists k : A, P k x) l

Forall_map:
  Forall P (map f l) <-> Forall (fun x : A => P (f x)) l

Forall_app:
  Forall P (l1 ++ l2) <-> Forall P l1 /\ Forall P l2

Forall_flat_map:
Forall P (flat_map f ls) <->
 Forall (fun d : A => Forall P (f d)) ls

map_ext_Forall:
  forall [A B : Type] (f g : A -> B) [l : list A],
  Forall (fun x : A => f x = g x) l -> map f l = map g l

Forall_rect:
  forall [A : Type] [P : A -> Prop] (Q : list A -> Type),
  Q [] ->
  (forall (b : A) (l : list A), P b -> Q (b :: l)) ->
  forall l : list A, Forall P l -> Q l

getUtoSetU getLtoSetL
uIngetU lIngetL lIngetU *)

  Section Locations.
  Context `{SI : SigSELL}.
  Context `{OLS : OLSig}.

   Lemma asasa i K : u  i = true -> LtX i (getL K) -> K = getU K.
   Proof with sauto.
  induction K;intros...
  destruct a as [p F].
  simpl in H0.
  destruct (uDec p)...
  simpl...
  rewrite IHK...
  rewrite getU_fixpoint...
  inversion H0...
  assert(u p = true).
  eauto.
  sauto.
Qed.

  End Locations.

Global Hint Resolve getUtoSetU : ExBase.
Global Hint Unfold  SetU SetL getU getL: core.

(*
 Global Hint Unfold SetU SetL:core.
Global Hint Resolve  USetU: core.
Global Hint Resolve SetUKClosure   getUtoSetU getLtoSetL: core. *)

(* Global Hint Resolve linearInUnb: core.
 *)

Ltac solveSE :=
try
 match goal with
  | [H: SetU ((?s, _)::_) |- u ?s = true] => inversion H;subst;auto
    | [H: SetL ((?s, _)::_) |- u ?s = false] => inversion H;subst;auto

  | [H: SetU (?s::_) |- u (fst ?s) = true] => inversion H;subst;intuition
    | [H: SetL (?s::_) |- u (fst ?s) = false] => inversion H;subst;intuition

    | [H: SetU (_::?K) |- SetU ?K] => inversion H;subst;auto
   | [H: SetL (_::?K) |- SetL ?K] => inversion H;subst;auto
 end.

 Ltac simplEmpty :=
 repeat
  multimatch goal with

  | [H: SetU ?K, H1: SetL ?K |- _  ] =>  assert(K=[]) by apply (SETXempty _ _ H H1);clear H H1

  | [H: SetL ?K, H0: LtX ?i ?K, H1:  u ?i = true |- _  ] =>  assert(K=[]) by apply (SETXLTEmpty _ _ H H0 H1);clear H

  | [  |- context[getL(getU _)] ] => setoid_rewrite getLgetU
  | [ H: context[getL(getU _)] |- _  ] => setoid_rewrite getLgetU in H
  | [  |- context[getU(getL _)] ] => setoid_rewrite getUgetL
  | [ H: context[getU(getL _)] |- _  ] => setoid_rewrite getUgetL in H

  | [ H: SetU ?K |- context[getL ?K] ] => setoid_rewrite (SetU_then_empty _ H)
  | [ H1: SetU ?K, H2: context[getL ?K] |- _ ] => setoid_rewrite (SetU_then_empty _ H1) in H2

  | [ H: SetL ?K |- context[getU ?K] ] => setoid_rewrite (SetL_then_empty _ H)
  | [ H1: SetL ?K, H2: context[getU ?K] |- _ ] => setoid_rewrite (SetL_then_empty _ H1) in H2

 | [ H: SetU (getL ?K)  |- context[getL ?K] ] => setoid_rewrite (getLtoSetU _ H)
  | [H0: SetU (getL ?K), H: context[getL ?K] |- _  ] => setoid_rewrite (getLtoSetU _ H0) in H

 | [H: SetU (getL ?K) |- context[getL ?K]  ] => setoid_rewrite (getLtoSetU _ H)

  | [H: SetU (getL ?K), H1: context[getL ?K] |- _  ] => setoid_rewrite (getLtoSetU _ H) in H1
end.

Ltac simplFix :=
 repeat
  multimatch goal with

 | [  |- context[getU (getU _)] ] => setoid_rewrite getU_fixpoint
 | [H:  context[getU (getU _)]  |- _ ]  => setoid_rewrite getU_fixpoint in H

 | [  |- context[getL (getL _)] ] => setoid_rewrite getL_fixpoint
 | [H:  context[getL (getL _)]  |- _ ]  => setoid_rewrite getL_fixpoint in H

 | [H: SetU ?K  |- context[getU ?K] ] => setoid_rewrite (setUtoGetU _ H)
 | [H: SetU ?K, H1: context[getU ?K]  |- _ ]  => setoid_rewrite (setUtoGetU _ H) in H1

 | [H: SetL ?K  |- context[getL ?K] ] => setoid_rewrite (setLtoGetL _ H)
 | [H: SetL ?K, H1: context[getL ?K]  |- _ ]  => setoid_rewrite (setLtoGetL _ H) in H1

end.

Ltac simplCtx :=
 multimatch goal with

 | [  |- context[getU(_++_)] ] => setoid_rewrite getUApp
 | [  |- context[getL(_++_)] ] => setoid_rewrite getLApp
 | [ H: context[getU(_++_)] |- _ ] => setoid_rewrite getUApp in H
 | [ H: context[getL(_++_)] |- _ ] => setoid_rewrite getLApp in H
  | [  |- context[(second (getU ?K++getL ?K))] ] => setoid_rewrite <- cxtDestructSecond
 | [ H:context[(second (getU ?K++getL ?K))] |- _ ] => setoid_rewrite <- cxtDestructSecond in H
end.

(* Ltac solveSignature2 :=
 match goal with
  | [ H: SetU ?K |- SetU (getU ?K)] => apply SetK4Destruct in H;sauto
  | [ H: SetL ?K |- SetL (getL ?K)] => apply SetK4Destruct in H;sauto

| [ H: SetU ?K, H2: Permutation (getU ?K) (?K2 ++ _) |- SetU ?K2] =>
   let H' := fresh "H" in
          apply SetK4Destruct in H; destruct H as [H H'];rewrite H2 in H;solveSignature2
 | [ H: SETX ?s ?b ?K, H2: Permutation (getU ?K) (_ ++ ?K2) |- SETX ?s ?b ?K2] =>
   let H' := fresh "H" in
          apply SetK4Destruct in H; destruct H as [H H'];rewrite H2 in H;solveSignature2

  | [H: Permutation (getU ?CN) (_ ++ ?M) |- SetU ?N] =>  apply getUPerm_SetU in H;solveSignature2
  | [H: Permutation (getU ?CN) (?M ++ _) |- SetU ?M] =>  apply getUPerm_SetU in H;solveSignature2

 | [ H1: u ?i = false, H2: In (?i, ?F) ?B  |- In (?i, ?F) (getL ?B) ] => apply lIngetL;auto

end.
 *)

Tactic Notation "srewrite" constr(H) := autounfold;
 let Hs := type of H in
 match Hs with
| Permutation _ _ => try rewrite H

end.

Tactic Notation "srewrite_reverse" constr(H) := autounfold;
 let Hs := type of H in
 match Hs with
| Permutation _ _ => symmetry in H;try rewrite H

end.

Tactic Notation "srewrite" constr(H1) "in" constr(H2) :=
autounfold in H2;
 let Hs := type of H1 in
 match Hs with
| Permutation _ _ => try rewrite H1 in H2

end.

Tactic Notation "srewrite_reverse" constr(H1) "in" constr(H2) :=
autounfold in H2;
 let Hs := type of H1 in
 match Hs with
| Permutation _ _ => symmetry in H1; try rewrite H1 in H2

end.


Require Import Iron.Language.SystemF2Data.Type.
Require Import Iron.Language.SystemF2Data.Exp.Relation.TypeX.

(* Substitution of Exps in Exps *)
Fixpoint substXX (d:  nat) (u: exp) (xx: exp) : exp :=
 match xx with
    | XVar ix
    => match nat_compare ix d with
       (* Index matches the one we are substituting for. *)
       | Eq  => u

       (* Index was free in the original expression.
          As we've removed the outermost binder, also decrease this
          index by one. *)
       | Gt  => XVar (ix - 1)

       (* Index was bound in the original expression. *)
       | Lt  => XVar ix
       end

    |  XLAM x1
    => XLAM (substXX d (liftTX 0 u) x1)

    |  XAPP x1 t2
    => XAPP (substXX d u x1) t2

    (* Increase the depth as we move across a lambda.
       Also lift free references in the exp being substituted
       across the lambda as we enter it. *)
    |  XLam t1 x2
    => XLam t1 (substXX (S d) (liftXX 1 0 u) x2)

    |  XApp x1 x2
    => XApp (substXX d u x1) (substXX d u x2)

    |  XCon dc ts xs
    => XCon dc ts (map (substXX d u) xs)

    |  XCase x alts
    => XCase (substXX d u x) (map (substXA d u) alts)

    |  XPrim p xs
    => XPrim p (map (substXX d u) xs)

    |  XLit l
    => xx
    end

with substXA (d: nat) (u: exp) (aa: alt)
 := match aa with
    |  AAlt (DataCon tag arity) x
    => AAlt (DataCon tag arity)
         (substXX (d + arity)
                  (liftXX arity 0 u) x)
    end.

(* The data constructor of an alternative is unchanged
   by exp substitution. *)
Lemma dcOfAlt_substXA
 : forall d u a
 , dcOfAlt (substXA d u a) = dcOfAlt a.
Proof.
 intros. destruct a. destruct d0. auto.
Qed.
Hint Rewrite dcOfAlt_substXA : global.

(* Substitution of exps in exps preserves typing *)
Theorem subst_exp_exp_ix
 :  forall ix ds ke te x1 t1 x2 t2
 ,  get  ix te = Some t2
 -> TYPE ds ke te           x1 t1
 -> TYPE ds ke (delete ix te) x2 t2
 -> TYPE ds ke (delete ix te) (substXX ix x2 x1) t1.
Proof.
 intros. gen ix ds ke te t1 x2 t2.
 induction x1 using exp_mutind with
  (PA := fun a1 => forall ix ds ke te x2 t11 t12 t2
      ,  get ix te = Some t2
      -> TYPEA ds ke te           a1 t11 t12
      -> TYPE  ds ke (delete ix te) x2 t2
      -> TYPEA ds ke (delete ix te) (substXA ix x2 a1) t11 t12);
  intros; simpl; inverts_type; eauto.

 - Case "XVar".
   fbreak_nat_compare.
   SCase "n = ix".
    rewrite H in H3. inverts H3. auto.

  + SCase "n < ix".
    apply TYVar; auto.

  + SCase "n > ix".
    apply TYVar; auto.
    rewrite <- H3.
    destruct n.
    * burn.
    * simpl. rrwrite (n - 0 = n) by omega.
      apply get_delete_below; burn.

 - Case "XLAM".
   simpl.
   eapply (IHx1 ix) in H3.
   + apply TYLAM.
     unfold liftTE. rewrite map_delete. eauto.
   + eapply get_map. eauto.
   + unfold liftTE. rewrite <- map_delete.
     rrwrite ( map (liftTT 1 0) (delete ix te)
             = liftTE 0 (delete ix te)).
     apply type_kienv_weaken1. auto.

 - Case "XLam".
   simpl.
   apply TYLam; auto.
    rewrite delete_rewind.
    eauto using type_tyenv_weaken1.

 - Case "XCon".
   eapply TYCon; eauto.
    apply (Forall2_map_left (TYPE ds ke (delete ix te))).
    apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
    snorm. eauto.

 - Case "XCase".
   eapply TYCase; eauto.
   (* Alts have correct type *)
   + clear IHx1.
     eapply Forall_map.
     norm. eauto.

   (* Required datacon is in alts list *)
   + norm.
     rename x into d. lists.
     apply in_map_iff.
     have (exists a, dcOfAlt a = d /\ In a aa).
      shift a. rip.
     rewrite dcOfAlt_substXA; auto.

 - Case "XPrim".
   eapply TYPrim; eauto.
    apply (Forall2_map_left (TYPE ds ke (delete ix te))).
    apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
    snorm. eauto.

 - Case "AAlt".
   defok ds (DefData dc tsFields tc).
   eapply TYAlt; eauto.
   rewrite delete_app.
   lists.
   assert ( length tsFields
          = length (map (substTTs 0 tsParam) tsFields)) as HL
    by (lists; auto).
   rewrite HL.
   eapply IHx1 with (t2 := t2); eauto.
   rewrite <- delete_app.
   eauto using type_tyenv_weaken_append.
Qed.

Theorem subst_exp_exp
 :  forall ds ke te x1 t1 x2 t2
 ,  TYPE ds ke (te :> t2) x1 t1
 -> TYPE ds ke te x2 t2
 -> TYPE ds ke te (substXX 0 x2 x1) t1.
Proof.
 intros.
 rrwrite (te = delete 0 (te :> t2)).
 eapply subst_exp_exp_ix; burn.
Qed.


(** * Natural Deduction and Sequent Calculus for LM

In this file we encode the logical rules of natural deduction for
minimal logic. Then, using the cut-elimination theorem of LL we prove
the relative completeness of these systems

 *)
Require Import FLL.Misc.Permutations.
Require Import FLL.SL.CutElimination.
Require Export FLL.OL.CutCoherence.LM.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

(** The syntax of the system is already specified in LM. We then proceed directly to encode the inference rules of ND. *)

(** The following clauses define the introduction and elimination rules for the 3 connectives of LM. *)
Definition IMP_ELIMINATION F G:= ((perp (up G)) ** (! atom (up F)) ** (! atom (up (t_bin IMP F G))) ).
Definition IMP_INTRO F G := ( ( perp ( up  ( t_bin IMP F G))) ** ( ? (atom (down F)) $ (atom (up G )) )).
Definition CONJ_ELIMINATION F G :=  ( (perp (up F)) op  (perp (up G)) ) ** (! atom (up (t_bin AND F G))) .
Definition CONJ_INTRO F G := (perp (up (t_bin AND F G))) ** (  (atom (up F)) & (atom (up G))) .
Definition ALL_ELIMINATION FX := E{ fun t => (perp ( up (FX t))) ** (! atom (up( t_quant ALL FX)))}.
Definition ALL_INTRO FX  := (perp (up ( t_quant ALL FX))) ** F{ fun t => atom (up (FX t))}.

Notation "F *** G" := (t_bin AND F G) (at level 10) .
Notation "F ---> G" := (t_bin IMP F G) (at level 10) .
Notation "'FALL' FX " := (t_quant ALL FX) (at level 10).

(** The theory [NM] is composed of the introduction and elimination rules above *)
Inductive NM : oo -> Prop :=
| IMP_I : forall F G, isOLFormula F -> isOLFormula G ->
                      NM (IMP_INTRO F G)
| IMP_E : forall F G, isOLFormula F -> isOLFormula G ->
                      NM (IMP_ELIMINATION F G)
| CONJ_I : forall F G, isOLFormula F -> isOLFormula G ->
                       NM (CONJ_INTRO F G)
| CONJ_E : forall F G, isOLFormula F -> isOLFormula G ->
                       NM (CONJ_ELIMINATION F G)
| ALL_I : forall FX, uniform FX -> (forall t, proper t -> isOLFormula (FX t)) ->
                     NM (ALL_INTRO FX)
| ALL_E : forall FX , uniform FX -> (forall t, proper t -> isOLFormula (FX t)) ->
                      NM (ALL_ELIMINATION FX ).

(** An inductive definition for the ND system. This will be used to prove that
the LL encoding is sound and complete *)

Inductive NMSeq : list uexp -> uexp -> Prop :=
| NMinit : forall L F,  NMSeq (F:: L) F
| NMImpElim: forall L A B , isOLFormula A -> NMSeq L A -> NMSeq L (A ---> B) -> NMSeq L B
| NMImpIntro: forall L A B, NMSeq (A :: L) B  -> NMSeq L (A ---> B)
| NMAndElim1 : forall L A B, isOLFormula B -> NMSeq L (A *** B) -> NMSeq L A
| NMAndElim2 : forall L A B, isOLFormula A -> NMSeq L (A *** B) -> NMSeq L B
| NMAndIntro : forall L A B, NMSeq L A -> NMSeq L B -> NMSeq L (A *** B)
| NMAllElim :forall L FX t, isOLFormula (FALL FX) -> uniform FX -> proper t -> NMSeq L (FALL FX) -> NMSeq L (FX t)
| NMAllIntro : forall L FX, uniform FX -> (forall t, proper t -> NMSeq  L (FX t)) -> NMSeq L (FALL FX)
| (* Explicit exchange *)
NMEx : forall L L' G, Permutation L L' -> NMSeq L G -> NMSeq L' G
| (* Contraction *)
NMContr : forall L F G, (NMSeq (F :: F:: L)) G -> (NMSeq (F :: L)) G
.

(** A Theory including [RCUTPOS], [RCUT], [POS] and [RINIT] *)
Inductive StrRulesPOS : oo -> Prop :=
| stp_cutP : forall F, isOLFormula F -> StrRulesPOS (RCUTPOS F)
| stp_cut : forall F, isOLFormula F -> StrRulesPOS (RCUT F)
| stp_pos : forall F, isOLFormula F -> StrRulesPOS (POS F)
| stp_init : forall F, isOLFormula F -> StrRulesPOS (RINIT F)
.

Theorem StrRulesPOSFormulas : forall F,  StrRulesPOS F -> isFormula F.
  intros.
  inversion H;subst;auto;
  constructor;auto.
Qed.

(** Sequent and natural deduction systems with the structural rules *)
Inductive NMSTR : oo -> Prop :=
| nm_rl : forall F, NM F -> NMSTR F
| nm_str: forall F, StrRulesPOS F -> NMSTR F.

Inductive SEQSTR : oo -> Prop :=
| sq_rl : forall F, buildTheory F -> SEQSTR F
| sq_str: forall F, StrRulesPOS F -> SEQSTR F.

Hint Constructors StrRulesPOS NM LMSeq NMSTR SEQSTR  : core.
Hint Constructors NMSTR SEQSTR : core.
Hint Unfold IMP_ELIMINATION IMP_INTRO   POS RCUT RINIT CONJ_ELIMINATION CONJ_INTRO  : core .
Hint Unfold ALL_ELIMINATION ALL_INTRO    : core.
Hint Constructors StrRulesPos : core .
Hint Constructors isFormula : core.

Ltac SolveIsFormulas' := SolveIsFormulas ; solveUniform.

Theorem NMStrRulesFormulas : forall F,  NMSTR F -> isFormula F.
  intros.
  inversion H;subst;auto.
  inversion H0;subst;SolveIsFormulas'.
  inversion H0;subst;SolveIsFormulas'.
Qed.

Theorem SeqStrRulesFormulas : forall F,  SEQSTR F -> isFormula F.
  intros.
  inversion H;subst;auto.
  inversion H0;subst; destruct C;subst;SolveIsFormulas'.
  inversion H0;subst;SolveIsFormulas.
Qed.

Global Instance NML_morph :
  Proper ((@Permutation uexp) ==> eq ==> iff) (NMSeq).
Proof.
  unfold Proper; unfold respectful.
  intros.
  split;intros;subst.
  eapply NMEx;eauto.
  apply Permutation_sym in H.
  eapply NMEx;eauto.
Qed.

Ltac solveOLTheory :=
  try
    match goal with
    | [|- NMSTR _] =>
      first [ apply ooth_init ; auto ; SolveIS
            | do 2 constructor;auto ; SolveIS ]
    end.

(** ** Adequacy of the encoding *)

Theorem Soundeness: forall L F, NMSeq L F ->
                                isOLFormulaL L ->
                                isOLFormula F ->
                                seq NMSTR (LEncode L) (REncode [F]) (> []).
Proof with solveF;solveLL;solveOLTheory;SolveIS;solveOLTheory.
  intros.
  induction H.
  + (* init *)
    decide3 (RINIT F)...
    tensor (REncode [F]) (@nil oo)...
  + (* IMP Elimination *)
    decide3 (IMP_ELIMINATION  A B)...
    tensor [u| B |] (@nil oo).
    tensor [u| B |] (@nil oo).
  + (* IMP introduction *)
    inversion H1...
    decide3 (IMP_INTRO  A B)...
    tensor  [u| A ---> B |] (@nil oo).
    assert(Permutation (LEncode L ++ [d| A |]) (LEncode (A :: L))).
    rewrite Permutation_app_comm...
    rewrite H2;apply IHNMSeq...
  + (* AND Elimination 1*)
    decide3 (CONJ_ELIMINATION  A B)...
    unfold CONJ_ELIMINATION.
    tensor  [u| A  |] (@nil oo).
  + (* AND Elimination 2 *)
    decide3 (CONJ_ELIMINATION  A B)...
    unfold CONJ_ELIMINATION.
    tensor  [u| B  |] (@nil oo).
  + (* AND Intro *)
    inversion H1...
    decide3 (CONJ_INTRO  A B)...
    tensor [u| A *** B |] (@nil oo).
  + (* ALL Elim *)
    decide3 (ALL_ELIMINATION  FX)...
    intros.
    inversion H...
    existential t...
    tensor  [u| FX t |] (@nil oo).
  + (* ALL Intro *)
    decide3 (ALL_INTRO FX)...
    intros.
    inversion H1...
    tensor [u| FALL FX |] (@nil oo).
    specialize (H3 x properX)...
    apply H3...
  +  (* Exchange *)
    eapply Permutation_map in  H as H'.
    unfold LEncode; rewrite <- H'...
    apply IHNMSeq...
    rewrite H...
  + (* Contraction *)
    eapply contractionSet with (L0:=LEncode [F]);[firstorder|]...
    apply IHNMSeq...
Qed.

(** Due to the presence of the rule [RCUT], the theory [NMSTR] is
adequate at the level of proofs. Note that [RCUT] can produce sequents
only with left atoms. The following theorem shows that those sequents
cannot prove anything. *)

Theorem OnlyLeft : forall n L, ~  seqN NMSTR n (LEncode L) [] (> []).
Proof with solveF.
  induction n using strongind;intros;intro Hneg;
    inversion Hneg...
  inversion H2.
  apply InIsPositiveL in H2...
  inversion H1...
  + (* rule *)
    inversion H0...
    ++ FLLInversionAll.
       simpl in H8.
       apply Permutation_nil in H8;inversion H8.
       apply NoUinL in H9;contradiction.
    ++ FLLInversionAll.
       simpl in H9.
       rewrite app_nil_r in H8.
       apply Permutation_nil in H8...
       apply Permutation_nil in H9...
       apply NoUinL in H7;contradiction.
    ++ FLLInversionAll.
       apply Permutation_nil in H8...
       inversion H8...
       apply NoUinL in H9;contradiction.
    ++ FLLInversionAll.
       apply Permutation_nil in H8... inversion H8.
       apply NoUinL in H7;contradiction.
       apply Permutation_nil in H8... inversion H8.
       apply NoUinL in H7;contradiction.
    ++ FLLInversionAll.
       apply Permutation_nil in H8... inversion H8.
       apply NoUinL in H9;contradiction.
    ++ FLLInversionAll.
       apply Permutation_nil in H9... inversion H9.
       apply NoUinL in H10;contradiction.
  +  (* Structural *)
    inversion H0...
    ++ (* CUTPOS *)
      unfold RCUTPOS in H3.
      FLLInversionAll.
      rewrite app_nil_r in H7.
      apply Permutation_nil in H7...
      assert (n0 <= S (S (S n0)) ) by lia.
      specialize (H n0 H3 ((L ++ [F0 ]))).
      apply H.
      unfold LEncode in *.
      rewrite map_app...
    ++ (* CUT *)
      unfold RCUT in H3.
      FLLInversionAll.
      apply Permutation_nil in H7...
      apply app_eq_nil in H7...
      apply AbsoroptionAtom in H16.
      assert (n0 <= S (S (S n0)) ) by lia.
      specialize (H n0 H3 (F0 :: L)).
      apply H...
    ++ (* POS *)
      unfold POS in H3.
      FLLInversionAll.
      apply Permutation_nil in H7... inversion H7.
      assert (n0 <= S (S (S n0)) ) by lia.
      specialize (H n0 H6 (L ++ [F0])).
      apply H...
      unfold LEncode in *.
      rewrite map_app...
      LLExact H13.
      rewrite H7...
    ++ (* INit *)
      FLLInversionAll.
      apply Permutation_nil in H7... inversion H7.
      apply NoUinL in H8;contradiction.
      apply Permutation_nil in H7... inversion H7.
      apply NoUinL in H9;contradiction.
Qed.

(** Completeness theorem *)
Theorem Completeness: forall n L F ,
    isOLFormulaL L ->
    isOLFormula F ->
    seqN NMSTR n (LEncode L)  (REncode [F]) (> []) ->
    NMSeq L F .
Proof with solveF;solveLL;SolveIS;CleanContext.
  induction n using strongind;intros.
  inversion H1.
  inversion H2;subst.
  simpl in H5.
  apply RemoveUnique in H5...
  apply InIsPositiveL in H5;contradiction.
  inversion H4...
  + (* from the theory *)
    inversion H3;clear H2...
    ++ (* IMP Intro *)
      FLLInversionAll.
      inversion H9...
      apply NMImpIntro.
      eapply (H n0)...
      LLExact H16.
      apply NoUinL in H10;contradiction.
    ++ (* IMP Elimination *)
      FLLInversionAll.
      rewrite app_nil_r in H9...
      rewrite app_nil_r in H10...
      apply NMImpElim with (A:= F1)...
      eapply (H n)...
      eapply (H (S n))...
      apply NoUinL in H8;contradiction.
    ++ (* Conj Intro *)
      FLLInversionAll.
      inversion H9...
      apply NMAndIntro;eapply (H n)...
      apply NoUinL in H10;contradiction.
    ++ (* Conj Elim *)
      FLLInversionAll.
      rewrite app_nil_r in H9...
      apply NMAndElim1 with (B:=G)...
      apply (H n0)...
      rewrite app_nil_r in H9...
      apply NMAndElim2 with (A:=F1)...
      apply (H n0)...
    ++ (* All Intro *)
      FLLInversionAll.
      inversion H9...
      apply NMAllIntro...
      intros.
      specialize (H16 _ H6).
      invTri H16.
      apply (H n)...
      apply NoUinL in H10;contradiction.
    ++ (* All Elim *)
      FLLInversionAll.
      inversion H10...
      apply NMAllElim ...
      apply (H n)...
  + (* Structural rule *)
    inversion H3;clear H2...
    ++ (* CUTPOS *)
      unfold RCUTPOS in H6.
      FLLInversionAll.
      rewrite app_nil_r in H8.
      apply Permutation_unq in H8...
      apply NMImpElim with (A:=F1)...
      apply (H n0)...
      apply NMImpIntro.
      apply (H n0)...
      LLExact H12.
    ++ (* CUT LIN *)
      unfold RCUT in H6.
      FLLInversionAll.
      apply Permutation_unq in H8...
      symmetry in H8.
      apply AppUnq in H8.
      destruct H8...
      apply AbsoroptionAtom in H17.
      assert( seqN NMSTR n0 (LEncode ( F1 ::  L)) [] (> [])).
      LLExact H17.
      apply OnlyLeft in H2...
      rewrite Permutation_app_comm in H17;simpl in H17.
      apply AbsoroptionAtom in H17.
      apply NMImpElim with (A:=F1)...
      apply (H n0)...
      apply NMImpIntro.
      apply (H n0)...
    ++ (* POS *)
      unfold POS in H6.
      FLLInversionAll.
      inversion H8...
      rewrite Permutation_app_comm in H14;simpl in H14.
      apply contractionN in H14...
      apply (H n0)...
    ++ FLLInversionAll;
         inversion H8...
       apply in_map_iff in H7...
       inversion H7...
       apply InPermutation in H9...
       rewrite H7.
       apply NMinit.
Qed.

Theorem Adequacy:  forall L F ,
    isOLFormulaL L ->
    isOLFormula F ->
    seq NMSTR  (LEncode L)  (REncode [F]) (> []) <->
    NMSeq L F .
Proof with solveF.
  split;intros.
  apply seqtoSeqN in H1;CleanContext.
  eapply Completeness;eauto.
  apply Soundeness in H1...
Qed.

(** ** Rules' equivalences *)

(** Now we prove the dualities between Left (resp. right) introduction
rules in sequent calculus and Elimination (resp. Introduction) rules
in Natural Deduction *)
Hint Unfold POS : core .

Theorem ImplLeftElimination1 :
  forall F G, isOLFormula F -> isOLFormula G ->
              (seq StrRulesPOS [] [] (> [ (makeRuleBin IMP Left F G)  ^ ; (IMP_ELIMINATION F G)])).
Proof with SolveIsFormulas;solveF.
  intros F G isF isG; autounfold;simpl;solveLL.
  ExchangeFront' 3.
  decide3 (POS ( t_bin IMP F G))...
  tensor [d| t_bin IMP F G | ] [(u^| G | ** (! u| F |)) ** (! u| t_bin IMP F G |);  ! d^| G |] .
  simpl.
  decide3 (RCUT G).
  tensor  [(u^| G | ** (! u| F |)) ** (! u| t_bin IMP F G |) ] [! d^| G |].
  decide1 ((u^| G | ** (! u| F |)) ** (! u| t_bin IMP F G |)).
  tensor [u| G |] (@nil oo).
  tensor [u| G |] (@nil oo).
  decide2 (u^| F |).
  decide3 (RINIT ( t_bin IMP F G)).
  tensor [u| t_bin IMP F G |] (@nil oo)...

  decide3 (POS G).
  tensor [d| G |] [! d^| G |]. simpl.
  decide1 (! d^| G|).
  solveLL...
  decide1 (d^| G|)...
Qed.

Theorem ImplLeftElimination2 :
  forall F G, isOLFormula F -> isOLFormula G ->
              (seq StrRulesPOS [] [] (> [ (IMP_ELIMINATION F G) ^ ; (makeRuleBin IMP Left F G)])).
Proof with SolveIsFormulas.
  intros F G isF isG; autounfold;simpl;solveLL.
  decide3 (RCUTPOS (t_bin IMP F G))...
  tensor   [u| G |; d^| t_bin IMP F G | ** ((! u| F |) ** (? d| G |))] (@nil oo);simpl.
  decide1 (d^| t_bin IMP F G | ** ((! u| F |) ** (? d| G |))).
  tensor (@nil oo) [u| G |].
  right...
  tensor (@nil oo) [u| G |].
  decide2 (u^|F|).
  simpl.
  decide3( RINIT (G))...
  tensor  [u| G |] (@nil oo).
  right ...
  decide2 (u^| t_bin IMP F G |).
Qed.

Theorem ImplRightIntroduction1 :
  forall F G, isOLFormula F -> isOLFormula G ->
              (seq StrRulesPOS [] [] (> [ (makeRuleBin IMP Right F G) ^ ; (IMP_INTRO F G)])).
Proof with SolveIsFormulas.
  intros F G isF isG; autounfold;simpl;solveLL.
  decide1 (u^| t_bin IMP F G | ** ((? d| F |) $ u| G |)).
  tensor [u| t_bin IMP F G |] [(! d^| F |) ** u^| G |].
  decide1 ((! d^| F |) ** u^| G |).
  tensor (@nil oo) [u| G |].
  decide1 (d^| F |).
Qed.

Theorem ImplRightIntroduction2 :
  forall F G, isOLFormula F -> isOLFormula G ->
              (seq StrRulesPOS [] [] (> [ (IMP_INTRO F G) ^ ; (makeRuleBin IMP Right F G)])).
Proof with SolveIsFormulas.
  intros F G isF isG; autounfold;simpl;solveLL.
  decide1 (  u^| t_bin IMP F G | ** ((? d| F |) $ u| G |)).
  tensor [u| t_bin IMP F G |] [(! d^| F |) ** u^| G |].
  decide1 ((! d^| F |) ** u^| G |).
  tensor (@nil oo)  [u| G |].
  decide1 (d^| F |).
Qed.

Theorem ConjLeftElimination1 :
  forall F G, isOLFormula F -> isOLFormula G ->
              (seq StrRulesPOS [] [] (> [ (makeRuleBin AND Left F G) ^ ; (CONJ_ELIMINATION F G)])).
Proof with SolveIsFormulas.
  intros F G isF isG; autounfold;simpl;solveLL.
  + decide3 (RCUT F).
    tensor  [d| t_bin AND F G |; (u^| F | op u^| G |) ** (! u| t_bin AND F G |)] [! d^| F |].
    decide3 (POS (t_bin AND F G)).
    tensor [d| t_bin AND F G |][ (u^| F | op u^| G |) ** (! u| t_bin AND F G |); u| F |] ...
    decide1 ((u^| F | op u^| G |) ** (! u| t_bin AND F G |)).
    tensor [ u| F |]  (@nil oo).
    decide3 (RINIT (t_bin AND F G)).
    tensor [u| t_bin AND F G |] (@nil oo)...
    decide3 (POS F).
    tensor [ d| F |][! d^| F |]...
    decide1 (! d^| F |)...
    solveLL.
    decide1 ( d^| F |);solveLL...
  + decide3 (POS (t_bin AND F G)).
    tensor  [d| t_bin AND F G |][ ! d^| G |; (u^| F | op u^| G |) ** (! u| t_bin AND F G |)]...
    decide3 (RCUT G).
    tensor [(u^| F | op u^| G |) ** (! u| t_bin AND F G |)] [! d^| G |].
    decide1 ((u^| F | op u^| G |) ** (! u| t_bin AND F G |)).
    tensor [u| G |] (@nil oo).
    decide3 (RINIT (t_bin AND F G)).
    tensor [u| t_bin AND F G |] (@nil oo)...
    decide3 (POS G).
    tensor [d| G |] [! d^| G |]...
    decide1 (! d^| G |)...
    solveLL.
    decide1 ( d^| G |)...
Qed.

Theorem ConjLeftElimination2 :
  forall F G, isOLFormula F -> isOLFormula G ->
              (seq StrRulesPOS [] [] (> [ (CONJ_ELIMINATION F G) ^ ; (makeRuleBin AND Left F G)])).
Proof with SolveIsFormulas.
  intros F G isF isG; autounfold;simpl;solveLL.
  + decide3 (RCUTPOS ( t_bin AND F G)).
    tensor  [u| F |; d^| t_bin AND F G | ** ((? d| F |) op (? d| G |))] (@nil oo)...
    decide1 (d^| t_bin AND F G | ** ((? d| F |) op (? d| G |))).
    tensor (@nil oo) [u| F |]...
    oplus1...
    decide3 (RINIT F).
    tensor ([u| F |]) (@nil oo)...
    decide2 (u^| t_bin AND F G |).
  +  decide3 (RCUTPOS ( t_bin AND F G)).
     tensor [u| G |; d^| t_bin AND F G | ** ((? d| F |) op (? d| G |))] (@nil oo)...
     decide1 (d^| t_bin AND F G | ** ((? d| F |) op (? d| G |))).
     tensor (@nil oo) [u| G |]...
     oplus2...
     decide3 (RINIT G).
    tensor ([u| G |]) (@nil oo)...
    decide2 (u^| t_bin AND F G |).
Qed.

Theorem ConjRightIntroduction1 :
  forall F G, isOLFormula F -> isOLFormula G ->
              (seq StrRulesPOS [] [] (> [ (makeRuleBin AND Right F G) ^ ; (CONJ_INTRO F G)])).
Proof with SolveIsFormulas.
  intros F G isF isG; autounfold;simpl;solveLL.
  decide1 (perp (up (t_bin AND F G)) ** (atom (up F) & atom (up G))).
  tensor [atom (up (t_bin AND F G)) ] [perp (up F) op perp (up G)].
  decide1 (perp (up F) op perp (up G)).
  decide1 (perp (up F) op perp (up G)).
Qed.

Theorem ConjRightIntroduction2 :
  forall F G, isOLFormula F -> isOLFormula G ->
              (seq StrRulesPOS [] [] (> [ (CONJ_INTRO F G) ^ ; (makeRuleBin AND Right F G)])).
Proof with SolveIsFormulas.
  intros F G isF isG; autounfold;simpl;solveLL.
  decide1 ( u^| t_bin AND F G | ** (u| F | & u| G |)).
  tensor [u| t_bin AND F G |][ u^| F | op u^| G |].
  decide1 (u^| F | op u^| G |).
  decide1 (u^| F | op u^| G |).
Qed.

Theorem AllLeftElimination1 : forall FX, uniform FX ->  (forall x, proper x -> isOLFormula( FX x)) ->
                                         (seq StrRulesPOS [] [] (> [ (makeRuleQ ALL Left FX) ^ ; (ALL_ELIMINATION FX)])).
Proof with SolveIsFormulas'.
  intros FX  isFX isFXt; autounfold;simpl;solveLL.
  decide3 (POS ( t_quant ALL FX)).
  tensor [d| t_quant ALL FX |][ ! d^| FX x |; E{ fun t  => u^| FX t | ** (! u| t_quant ALL FX |)}]...
  decide3 (RCUT (FX x)).
  tensor [ E{ fun t  => u^| FX t | ** (! u| t_quant ALL FX |)}] [! d^| FX x |]...
  decide1 (E{ fun t => u^| FX t | ** (! u| t_quant ALL FX |)}).
  existential x...
  tensor  [u| FX x |] (@nil oo).
  decide3 (RINIT (t_quant ALL FX)).
  tensor  [u| t_quant ALL FX |] (@nil oo)...
  decide3 (POS (FX x)).
  tensor [ d| FX x |] [! d^| FX x |]...
  decide1 (! d^| FX x |)...
  solveLL.
  decide1 (d^| FX x |)...
Qed.

Theorem AllLeftElimination2 : forall FX, uniform FX ->  (forall x, proper x -> isOLFormula( FX x)) ->
                                         (seq StrRulesPOS [] [] (> [ (ALL_ELIMINATION FX) ^ ; (makeRuleQ ALL Left FX)])).
Proof with SolveIsFormulas'.
  intros FX  isFX isFXt; autounfold;simpl.
  apply tri_fx'...
  intros.
  solveLL.
  decide3( RCUTPOS ( t_quant ALL FX)).
  tensor [u| FX x |; d^| t_quant ALL FX | ** E{ fun t => ? d| FX t |}] (@nil oo) ...
  decide1 (d^| t_quant ALL FX | ** E{ fun t => ? d| FX t |}).
  tensor (@nil oo)  [u| FX x |]...
  existential x...
  decide3 (RINIT (FX x))...
  tensor  [u| FX x |] (@nil oo)...
  decide2 (u^| t_quant ALL FX |).
Qed.

Theorem AllRightIntroduction1 : forall FX, uniform FX ->  (forall x, proper x -> isOLFormula( FX x)) ->
                                           (seq StrRulesPOS [] [] (> [(makeRuleQ ALL Right FX) ^ ; (ALL_INTRO FX)])).
Proof with SolveIsFormulas.
  intros FX  isFX isFXt; autounfold;simpl.
  solveLL.
  decide1 (perp (up (t_quant ALL FX)) ** F{ fun t=> atom (up (FX t))}).
  tensor  [atom (up (t_quant ALL FX))] [E{ fun x => perp (up (FX x))}].
  solveLL.
  decide1 (E{ fun x0 => perp (up (FX x0))}).
  existential x.
Qed.

Theorem AllRightIntroduction2 : forall FX, uniform FX ->  (forall x, proper x -> isOLFormula( FX x)) ->
                                           (seq StrRulesPOS [] [] (> [ (ALL_INTRO FX) ^ ; (makeRuleQ ALL Right FX)])).
Proof with SolveIsFormulas.
  intros FX  isFX isFXt; autounfold;simpl.
  solveLL.
  decide1 (perp (up (t_quant ALL FX)) ** F{ fun t => atom (up (FX t))}).
  tensor [atom (up (t_quant ALL FX))] [E{ fun x => perp (up (FX x))}].
  solveLL.
  decide1 (E{ fun x0 => perp (up (FX x0))}).
  existential x.
Qed.

Definition AND' : connectives := AND .
Definition IMP' : connectives := IMP .
Definition ALL' : quantifiers := ALL .

(** ** Relative completeness of ND and SEQ *)

(** If there is a proof using the rules of the sequent system then there is a proof in natural deduction *)
Theorem SEQtoNM: forall n B M X , isFormulaL B -> isFormulaL M -> isNotAsyncL M -> isArrow X ->
                                  (seqN SEQSTR n B M X ) ->
                                  (seq NMSTR B M X ).
Proof with solveF;SolveIsFormulas;SolveIS.
  induction n using strongind; intros B M arrow isB isM isNoatAsyncM isArr Hseq.
  inversion Hseq...

  inversion Hseq;solveF;simpl in isArr;
    try solve [inversion isArr ; solveF; apply H in H1;solveF;SolveIsFormulas
              ].

  inversion isArr... apply H in H2... apply H in H3... tensor M0 N.

  apply H in H2...

  inversion isArr... inversion H3... apply H in H1...

  inversion isArr... inversion H4... apply H in H1... apply H in H2...

  inversion isArr... inversion H3... apply H in H1...

  inversion isArr; apply H in H2;SolveIsFormulas.

  apply H in H3... decide1 F;eauto.
  decide2 F...
  apply H in H3...
  eapply Forall_forall with (l:=B);eauto.

  { (* decide 3 case *)
    inversion H1...
    {
      inversion H0...
      destruct C. (* no constants *)
      destruct C. (* no constants *)
      + (* Right rule *)
        destruct C...
        { (* AND *)
          inversion H4...
          apply H in H3...
          assert(Cut: seq NMSTR B ([] ++M) ( > [(CONJ_INTRO F0 G)])).
          apply GeneralCut' with (C:= (makeRuleBin AND' Right F0 G) ^) (dualC := (makeRuleBin AND' Right F0 G))...
          apply NMStrRulesFormulas.
          eapply WeakTheory with (theory:=  StrRulesPOS  ) .
          apply nm_str.
          generalize( ConjRightIntroduction1 H7 H9);intro HCut;simpl in HCut...
          apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
          unfold AND'...
          apply AbsorptionTheory with (F:= (CONJ_INTRO F0 G))...
        }
        { (* Implication *)
          inversion H4...
          apply H in H3...
          assert(Cut: seq NMSTR B ([] ++M) ( > [(IMP_INTRO F0 G)])).
          apply GeneralCut' with (C:= (makeRuleBin IMP' Right F0 G) ^) (dualC := (makeRuleBin IMP' Right F0 G))...
          apply NMStrRulesFormulas.
          eapply WeakTheory with (theory:=  StrRulesPOS  ) .
          apply nm_str.
          generalize( ImplRightIntroduction1 H7 H9);intro HCut;simpl in HCut...
          unfold IMP'...
          apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
          simpl in Cut.
          apply AbsorptionTheory with (F:= (IMP_INTRO F0 G))...
        }
      + (* Left rule *)
        destruct C...
        { (* AND *)
          inversion H4...
          apply H in H3...
          assert(Cut: seq NMSTR B ([] ++M) ( > [(CONJ_ELIMINATION F0 G)])).
          apply GeneralCut' with (C:= (makeRuleBin AND' Left F0 G) ^) (dualC := (makeRuleBin AND' Left F0 G))...
          apply NMStrRulesFormulas.
          eapply WeakTheory with (theory:=  StrRulesPOS  ) .
          apply nm_str.
          generalize( ConjLeftElimination1 H7 H9);intro HCut;simpl in HCut...
          unfold AND'.
          apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
          simpl in Cut.
          apply AbsorptionTheory with (F:= (CONJ_ELIMINATION F0 G))...
        }
        { (* IMP *)
          inversion H4...
          apply H in H3...
          assert(Cut: seq NMSTR B ([] ++M) ( > [(IMP_ELIMINATION F0 G)])).
          apply GeneralCut' with (C:= (makeRuleBin IMP' Left F0 G) ^) (dualC := (makeRuleBin IMP' Left F0 G))...
          apply NMStrRulesFormulas.
          eapply WeakTheory with (theory:=  StrRulesPOS).
          apply nm_str.
          generalize( ImplLeftElimination1 H7 H9);intro HCut;simpl in HCut...
          unfold IMP'.
          apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
          simpl in Cut.
          apply AbsorptionTheory with (F:= (IMP_ELIMINATION F0 G))...
        }
      + (* Quantifier Right *)
        destruct C...
        inversion H5;SolveIS...
        apply lbindEq in H7...
        assert (HIs: forall t, proper t -> isOLFormula (FX t)).
        intros...
        apply H in H3;solveF...
        assert(Cut: seq NMSTR B ([] ++M) ( > [(ALL_INTRO FX)])).
        apply GeneralCut' with (C:=  (makeRuleQ ALL' Right FX) ^) (dualC := (makeRuleQ ALL' Right FX));solveF;SolveIsFormulas'.
        apply NMStrRulesFormulas.
        eapply WeakTheory with (theory:=  StrRulesPOS).
        apply nm_str.
        generalize( AllRightIntroduction1 H4 HIs);intro HCut;simpl in HCut.
        unfold ALL'...
        apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
        apply AbsorptionTheory with (F:= (ALL_INTRO FX));solveF;SolveIsFormulas'.
        SolveIsFormulas'.
      + (* Quantifier Left *)
        destruct C...
        inversion H5;SolveIS...
        apply lbindEq in H7...
        assert (HIs: forall t, proper t -> isOLFormula (FX t)).
        intros...
        apply H in H3...
        assert(Cut: seq NMSTR B ([] ++M) ( > [(ALL_ELIMINATION FX)])).
        apply GeneralCut' with (C:= (makeRuleQ ALL' Left FX) ^) (dualC := (makeRuleQ ALL' Left FX));SolveIsFormulas'.
        apply NMStrRulesFormulas.
        eapply WeakTheory with (theory:=  StrRulesPOS).
        apply nm_str.
        generalize( AllLeftElimination1 H4 HIs);intro HCut;simpl in HCut.
        unfold ALL'...
        apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
        apply AbsorptionTheory with (F:= (ALL_ELIMINATION FX));SolveIsFormulas'.
        SolveIsFormulas'.
    }
    apply H in H3...
    decide3 F...
    apply StrRulesPOSFormulas...
  }

  inversion isArr... apply H in H3... existential t.

  inversion isArr... solveLL.
  apply H2 in properX. apply H in properX...
  inversion H4...
Qed.

(** If there is a proof using the rules of Natural Deduction  then there is a proof in the sequent calculus *)

Theorem NMtoSeq: forall n B M X , isFormulaL B -> isFormulaL M -> isNotAsyncL M -> isArrow X ->
                                  (seqN NMSTR n B M X ) ->
                                  (seq  SEQSTR B M X ).
Proof with solveF;SolveIsFormulas.
  induction n using strongind; intros B M arrow isB isM isNoatAsyncM isArr Hseq.
  inversion Hseq...

  inversion Hseq;solveF;simpl in isArr;
    try solve [inversion isArr ; solveF; apply H in H1;solveF;SolveIsFormulas
              ].

  inversion isArr... apply H in H2... apply H in H3... tensor M0 N.

  apply H in H2...

  inversion isArr... inversion H3... apply H in H1...

  inversion isArr... inversion H4... apply H in H1... apply H in H2...

  inversion isArr... inversion H3... apply H in H1...

  inversion isArr... apply H in H2...

  apply H in H3... decide1 F;eauto.

  decide2 F;eauto. apply H in H3...

  eapply Forall_forall with (l:=B);eauto.

  { (* decide 3 case *)
    inversion H1...
    {
      inversion H0...
      + (* implication right *)
        apply H in H3...
        assert(Cut: seq SEQSTR B ([] ++M) ( > [(makeRuleBin IMP Right F0 G)])).
        apply GeneralCut' with (C:= (IMP_INTRO F0 G) ^) (dualC := IMP_INTRO F0 G)...
        apply SeqStrRulesFormulas.
        eapply WeakTheory with (theory:=  StrRulesPOS).
        apply sq_str.
        generalize( ImplRightIntroduction2 H4 H5);intro HCut;simpl in HCut...
        apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
        simpl in Cut.
        apply AbsorptionTheory with (F:= (makeRuleBin IMP' Right F0 G)) ...
        unfold IMP'...
        do 2 constructor. eapply isFBin...
      + (* implication left*)
        apply H in H3...
        assert(Cut: seq SEQSTR B ([] ++M) ( > [(makeRuleBin IMP Left F0 G)])).
        apply GeneralCut' with (C:= (IMP_ELIMINATION F0 G) ^) (dualC := IMP_ELIMINATION F0 G)...
        apply SeqStrRulesFormulas.
        eapply WeakTheory with (theory:=  StrRulesPOS).
        apply sq_str.
        generalize( ImplLeftElimination2 H4 H5);intro HCut;simpl in HCut...
        apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
        apply AbsorptionTheory with (F:= (makeRuleBin IMP' Left F0 G))...
        unfold IMP'... do 2 constructor. eapply isFBin...
      + (* Conjunction right *)
        apply H in H3...
        assert(Cut: seq SEQSTR B ([] ++M) ( > [(makeRuleBin AND Right F0 G)])).
        apply GeneralCut' with (C:= (CONJ_INTRO F0 G) ^) (dualC := CONJ_INTRO F0 G)...
        apply SeqStrRulesFormulas.
        eapply WeakTheory with (theory:=  StrRulesPOS).
        apply sq_str.
        generalize( ConjRightIntroduction2 H4 H5);intro HCut;simpl in HCut...
        apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
        apply AbsorptionTheory with (F:= (makeRuleBin AND' Right F0 G))...
        unfold IMP'... do 2 constructor. eapply isFBin...
      + (* conjunction left *)
        apply H in H3...
        assert(Cut: seq SEQSTR B ([] ++M) ( > [(makeRuleBin AND Left F0 G)])).
        apply GeneralCut' with (C:= (CONJ_ELIMINATION F0 G) ^) (dualC := CONJ_ELIMINATION F0 G)...
        apply SeqStrRulesFormulas.
        eapply WeakTheory with (theory:=  StrRulesPOS).
        apply sq_str.
        generalize( ConjLeftElimination2 H4 H5);intro HCut;simpl in HCut...
        apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
        apply AbsorptionTheory with (F:= (makeRuleBin AND' Left F0 G))...
        unfold AND'... do 2 constructor. eapply isFBin...
      + (* all *)
        apply H in H3...
        assert(Cut: seq SEQSTR B ([] ++M) ( > [(makeRuleQ ALL Right FX)])).
        apply GeneralCut' with (C:= (ALL_INTRO FX) ^) (dualC := ALL_INTRO FX);SolveIsFormulas'.
        apply SeqStrRulesFormulas.
        eapply WeakTheory with (theory:=  StrRulesPOS).
        apply sq_str.
        generalize( AllRightIntroduction2 H4 H5);intro HCut;simpl in HCut.
        apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut...
        apply AbsorptionTheory with (F:= (makeRuleQ ALL' Right FX));SolveIsFormulas'.
        unfold ALL'...
        do 2 constructor...
        SolveIsFormulas'.
      + (* all *)
        apply H in H3...
        assert(Cut: seq SEQSTR B ([] ++M) ( > [(makeRuleQ ALL Left FX)])).
        apply GeneralCut' with (C:= (ALL_ELIMINATION FX) ^) (dualC := ALL_ELIMINATION FX);SolveIsFormulas'.
        apply SeqStrRulesFormulas.
        eapply WeakTheory with (theory:=  StrRulesPOS).
        apply sq_str.
        generalize( AllLeftElimination2 H4 H5);intro HCut;simpl in HCut.
        apply weakeningGen with (CC' := B) in HCut. rewrite app_nil_r in HCut;SolveIsFormulas'.
        apply AbsorptionTheory with (F:= (makeRuleQ ALL' Left FX));SolveIsFormulas'.
        unfold ALL'...
        do 2 constructor...
        SolveIsFormulas'.
    }
    apply H in H3...
    decide3 F...
    apply StrRulesPOSFormulas...
  }
  inversion isArr...
  apply H in H3...
  existential t.

  inversion isArr...
  solveLL.
  apply H2 in properX. apply H in properX...
  inversion H4...
Qed.

Hint Constructors NMSeq : core .
Hint Constructors OLTheory buildTheory : core.
Hint Constructors  isOLFormula : core.
Hint Unfold IsPositiveLAtomFormulaL : core.
Hint Constructors IsPositiveRAtomFormula : core .

(** Mutual relative completeness of natural deduction and sequent calculus.  *)
Theorem NDSeqAdequacy: forall F, isOLFormula F ->
                            (seq SEQSTR  [] [ atom (up F) ] (> [ ]))  <->
                            (seq NMSTR  [] [ atom (up F) ]  (> [ ])).
Proof with solveF;SolveIsFormulas.
  intros.
  split;intro.
  apply seqtoSeqN in H0;CleanContext.
  eapply SEQtoNM... eauto.
  apply seqtoSeqN in H0;CleanContext.
  eapply NMtoSeq... eauto.
Qed.


From Hammer Require Import Hammer.

Require Import Recdef.
Require Import Arith.Wf_nat.
Require Import Omega.
Require Export RegExp.Utility.
Require Export RegExp.Definitions.
Require Export RegExp.Boolean.
Require Export RegExp.Concat.

Unset Standard Proposition Elimination Names.

Lemma matches_Star_EmptyString : forall r, (Star r) ~== EmptyString.
Proof. hammer_hook "Star" "Star.matches_Star_EmptyString".
intros r.  simpl; auto.
Qed.

Lemma matches_Star_r : forall s r, r ~== s -> (Star r) ~== s.
Proof. hammer_hook "Star" "Star.matches_Star_r".
induction s; simpl.
intros r nu_r.  auto.
intros r Hra.  replace s with (s ++ "")%string.
eapply (matches_Cat s ""%string (r/a) (Star r)); try auto.
eapply string_right_id.
Qed.

Lemma matches_Star_right_s : forall s r,
(Star r) ~= s = (Eps || (r ++ Star r)) ~= s.
Proof. hammer_hook "Star" "Star.matches_Star_right_s".
induction s; simpl; intro r.
auto.
repeat erewrite matches_Or.  erewrite Empty_false.  simpl.
destruct (nu r).
erewrite Or_idem_s.  auto.
auto.
Qed.

Lemma matches_Star_right : forall r, Star r =R= Eps || (r ++ Star r).
Proof. hammer_hook "Star" "Star.matches_Star_right".
unfold re_eq.  intros r s.  eapply matches_Star_right_s.
Qed.

Lemma divide_Star_right : forall s r, (Star r) ~== s -> s <> ""%string ->
{s':string & {s'':string | s = (s' ++ s'')%string /\ s' <> ""%string /\
r ~== s' /\ (Star r) ~== s''}}.
Proof. hammer_hook "Star" "Star.divide_Star_right".
induction s; intros r Hstar Hs.
elim Hs.  auto.
simpl in Hstar.
specialize (divide_Cat s (r/a) (Star r) Hstar).  intro H0.
destruct H0 as [s0' [s0'' [H01 [H02 H03]]]].
rewrite <- derivation in H02.
exists (String a s0'). exists s0''.
split.
simpl.  rewrite <- H01.  auto.
split.
intro H.  discriminate H.
auto.
Qed.

Lemma Star_to_list : forall s r, (Star r) ~== s ->
{ss:list string | forallb (fun s => r ~= s) ss = true /\
concat_list_string ss = s /\
forallb (fun s => bneq_empty_string s) ss = true }.
Proof. hammer_hook "Star" "Star.Star_to_list".
refine (induction_ltof2 string str_length _ _).
intros s IHs r Hstar.
specialize(string_dec s ""%string).  intro Hs_dec.  destruct Hs_dec.

exists nil.  auto.

specialize(divide_Star_right s r Hstar n).  intro H1.
destruct H1 as [s' [s'' [H11 [H12 [H13 H14]]]]].
assert(Hltof: ltof string str_length s'' s).
unfold ltof.  rewrite H11.  rewrite str_length_append.
assert(Hlen_s: forall s, s <> ""%string -> str_length s <> 0).
induction s0.
intro H'. elim H'. auto.
simpl. intro H'. intro H''. discriminate H''.
specialize(Hlen_s s' H12).  omega.
specialize(IHs s'' Hltof r H14).
destruct IHs as [ss' [IH1 [IH2 IH3]]].
exists (s' :: ss').  split.
simpl. rewrite H13. rewrite IH1. auto.  split.
simpl. rewrite IH2. rewrite <- H11. auto.
simpl. rewrite IH3. unfold bneq_empty_string. destruct (string_dec s' ""%string).
simpl. elim H12. auto.
auto.
Defined.

Lemma Star_to_list_not_nil : forall s r, (Star r) ~== s -> s <> ""%string ->
{ss:list string | forallb (fun s => r ~= s) ss = true /\
concat_list_string ss = s /\ ss <> nil /\
forallb (fun s => bneq_empty_string s) ss = true }.
Proof. hammer_hook "Star" "Star.Star_to_list_not_nil".
intros s r Hstar Hs.
specialize(Star_to_list s r Hstar). intro H.
destruct H as [ss' [IH1 [IH2 IH3]]].
exists ss'.  split; try auto.
split; try auto.
split; try auto.
intro Hss'.  rewrite Hss' in IH2.  simpl in IH2.  elim Hs.  auto.
Defined.

Lemma list_to_Star : forall xs r,
forallb (fun s : string => r ~= s) xs = true ->
Star r ~== concat_list_string xs.
Proof. hammer_hook "Star" "Star.list_to_Star".
induction xs; intros r0 Hf; simpl.
auto.
simpl in Hf.
case_eq (r0 ~= a); case_eq (forallb (fun s : string => r0 ~= s) xs); intros H1 H2.

cut(Eps || (r0 ++ (Star r0)) ~== (a ++ concat_list_string xs)). intro H3.
erewrite matches_Star_right.  auto.
cut((r0 ++ (Star r0)) ~== (a ++ concat_list_string xs)). intro H4.
erewrite matches_Or.  rewrite H4.
destruct (Eps ~= (a ++ concat_list_string xs)); auto.
erewrite matches_Cat; auto.

rewrite H1 in Hf; rewrite H2 in Hf; simpl in Hf; discriminate Hf.

rewrite H1 in Hf; rewrite H2 in Hf; simpl in Hf; discriminate Hf.

rewrite H1 in Hf; rewrite H2 in Hf; simpl in Hf; discriminate Hf.
Qed.

Lemma divide_Star_left : forall s r, (Star r) ~== s -> s <> ""%string ->
{s':string & {s'':string | s = (s' ++ s'')%string /\ s'' <> ""%string /\
(Star r) ~== s' /\ r ~== s''}}.
Proof. hammer_hook "Star" "Star.divide_Star_left".
intros s r Hstar Hs.
specialize(Star_to_list_not_nil s r Hstar Hs). intro H0.
destruct H0 as [ss' [H01 [H02 [H03 H04]]]].
specialize (exists_last H03).  intro Hlast.
destruct Hlast as [ss0 [s0 Hlast']].
exists (concat_list_string ss0).  exists s0.  split.
erewrite <- concat_list_string_xs_x.  rewrite <- Hlast'.  auto.  split.

assert(H': In s0 ss').
rewrite Hlast'.  eapply In_list_append_right.  eapply in_eq.
specialize(forallb_forall (fun s => bneq_empty_string s) ss'). intros H''.
destruct H'' as [H'' _].  specialize(H'' H04).  specialize(H'' s0 H').
unfold bneq_empty_string in H''.
destruct (string_dec s0 ""%string). discriminate H''. auto.
split.

eapply list_to_Star.  rewrite Hlast' in H01.
apply(forallb_divide_left string (fun s => r ~= s) ss0 (s0::nil) H01).

specialize(In_snoc string s0 ss0).
intros HIn.  rewrite <- Hlast' in HIn.
specialize(forallb_forall (fun s => r ~= s) ss'). intro H.
destruct H as [H _].  eapply H.  auto.

auto.
Qed.

Lemma forallb_matches_morphism_s : forall ss r r', r =R= r' ->
forallb (fun s0 => r ~= s0) ss = forallb (fun s0 => r' ~= s0) ss.
Proof. hammer_hook "Star" "Star.forallb_matches_morphism_s".
induction ss.
intros r r' H.  simpl.  auto.
intros r r' H.  simpl.  rewrite <- (IHss r r' H).  unfold re_eq in H.
rewrite <- (H a).  auto.
Qed.

Lemma Star_morphism_s : forall s r r', r =R= r' -> (Star r) ~= s = (Star r') ~= s.
Proof. hammer_hook "Star" "Star.Star_morphism_s".
induction s.
intros r r' H.  simpl.  auto.
intros r r' H.  simpl.
case_eq ((r / a ++ Star r) ~= s); case_eq ((r' / a ++ Star r') ~= s);
intros H0 H1; try auto.

specialize(divide_Cat s (r/a) (Star r) H1).  intros H2.
destruct H2 as [s' [s'' [H01 [H02 H03]]]].
erewrite <- derivation in H02.
unfold re_eq in H.  erewrite H in H02.  erewrite derivation in H02.
specialize(Star_to_list s'' r H03).  intro H2.
destruct H2 as [ss [H21 [H22 H23]]].
rewrite (forallb_matches_morphism_s ss r r') in H21.
specialize(list_to_Star ss r' H21).  intro H3.  rewrite H22 in H3.
specialize(matches_Cat s' s'' (r'/a) (Star r') H02 H3).  intro H4.
rewrite <- H01 in H4.  rewrite H0 in H4.  inversion H4.  auto.

specialize(divide_Cat s (r'/a) (Star r') H0).  intros H2.
destruct H2 as [s' [s'' [H01 [H02 H03]]]].
erewrite <- derivation in H02.
unfold re_eq in H.  erewrite <- H in H02.  erewrite derivation in H02.
specialize(Star_to_list s'' r' H03).  intro H2.
destruct H2 as [ss [H21 [H22 H23]]].
rewrite (forallb_matches_morphism_s ss r' r) in H21.
specialize(list_to_Star ss r H21).  intro H3.  rewrite H22 in H3.
specialize(matches_Cat s' s'' (r/a) (Star r) H02 H3).  intro H4.
rewrite <- H01 in H4.  rewrite H1 in H4.  inversion H4.
setoid_symmetry.  auto.
Qed.

Add Parametric Morphism : Star with
signature re_eq ==> re_eq as Star_morphism.
Proof.
intros x y H.  unfold re_eq.  intros s.  eapply Star_morphism_s.  exact H.
Qed.

Lemma matches_Star_left_s : forall s r, (Star r) ~= s = (Eps || (Star r ++ r)) ~= s.
Proof. hammer_hook "Star" "Star.matches_Star_left_s".
intros s r.
case_eq (Star r ~= s); intro Hstar;
case_eq ((Eps || (Star r ++ r)) ~= s); intro H; try auto.

destruct (string_dec s ""%string).

rewrite e in H.  erewrite matches_Or in H.  simpl in H.  discriminate H.

specialize(divide_Star_left s r Hstar n).  intro H0.
destruct H0 as [s' [s'' [H01 [H02 [H03 H04]]]]].
specialize(matches_Cat s' s'' (Star r) r H03 H04).  intro H0.
rewrite <- H01 in H0.   rewrite matches_Or in H.  rewrite H0 in H.
destruct (Eps ~= s); simpl in H; discriminate H.

destruct (string_dec s ""%string).

rewrite e in Hstar.  simpl in Hstar.  discriminate Hstar.

rewrite matches_Or in H.  replace (Eps ~= s) with false in H.  simpl in H.

specialize(divide_Cat s (Star r) r H).  intro H'.
destruct H' as [s' [s'' [H01 [H02 H03]]]].

specialize(Star_to_list s' r H02).  intro H'.
destruct H' as [ss [H11 [H12 H13]]].

specialize(forallb_list_xs_x string (fun s => r ~= s) ss s'' H11 H03).
intros Hf.

specialize(concat_list_string_xs_x ss s'').  intros Hf'.
rewrite H12 in Hf'.  rewrite <- H01 in Hf'.

specialize(list_to_Star (ss ++ s''::nil) r Hf).  intros Hf''.
rewrite Hf' in Hf''.

rewrite Hf'' in Hstar.  discriminate Hstar.

induction s;  simpl.
elim n.  auto.
symmetry.  eapply Empty_false.
Qed.

Lemma matches_Star_left : forall r, Star r =R= Eps || (Star r ++ r).
Proof. hammer_hook "Star" "Star.matches_Star_left".
unfold re_eq.  intros r s.  eapply matches_Star_left_s.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*  Pierre Casteran
    LaBRI, Université Bordeaux 1, and Inria Futurs (Logical)
*)

Require Import Arith Omega.
Require Import ArithRing.

Require Import More_nat.
Require Import EPSILON0.

Unset Standard Proposition Elimination Names.

(* we still not use Standard Library's multisets : should we ? *)

Inductive nfs : T1 -> Prop :=
|nfs_nil :  nfs zero
|nfs_cons :  forall a n b,  nf a -> nfs b -> nfs (cons a n b).

Hint Constructors nfs nf : T1.

Lemma nf_nfs : forall a, nf a -> nfs a.
Proof.
 induction 1; simpl; auto with T1.
Qed.

(*  Number of occurrences of c in a *)

Fixpoint multiplicity (c:T1) (a:T1) {struct a}: nat :=
  match a with
  | zero => 0
  | (cons a' n' b') =>
      match T1_eq_dec c a' with
      | left _ => ( (S n') +(multiplicity c b'))%nat
      | right _ => multiplicity c b'
      end
  end.

Lemma multiplicity_rw1 : forall a  n b, multiplicity a (cons a n b) =
                                  (S n + multiplicity a b)%nat.
  simpl.
 intros; case (T1_eq_dec a a).
 auto.
 intro; absurd (a=a);auto.
Qed.

Lemma multiplicity_rw2 : forall a  a' n' b', a <> a' ->
                         multiplicity a (cons a' n' b') = multiplicity a b'.
Proof.
 simpl.
 intros; case (T1_eq_dec a a').
 intro; case H;auto.
 auto.
Qed.

Fixpoint app (o o':T1) {struct o} : T1 :=
  match o with zero => o'
             | cons a n b => cons a n (app b  o')
  end.

Infix "::" := app (at level 60, right associativity) : cantor_scope.

Lemma multiplicity_of_app : forall l l' a, multiplicity a (l ::  l') =
                                     (multiplicity a l + multiplicity a l')%nat.
Proof.
 induction l; simpl; auto with arith.
 intros.
 case (T1_eq_dec a l1).
 rewrite IHl2.
 clear IHl1 IHl2; intro; omega.
 auto.
Qed.

Definition equiv (l l':T1) :=
    forall o, multiplicity o l = multiplicity o l'.

(* equiv is an equivalence ! *)

Lemma equiv_refl : forall l:T1, equiv l l.
Proof.
 unfold equiv; trivial.
Qed.

Lemma equiv_sym : forall l l':T1, equiv l l' -> equiv l' l.
Proof.
  unfold equiv; auto.
Qed.

Lemma equiv_trans :
 forall l l' l'', equiv l l' ->
                         equiv l' l'' ->
                         equiv l l''.
Proof.
 intros l l' l'' H H0 z.
 eapply trans_eq; eauto.
Qed.

Lemma equiv_cons :
 forall a n l l', equiv l l' ->
                  equiv (cons a n l) (cons a n l').
Proof.
 intros a n l l' H a'.
 simpl ; case (T1_eq_dec a' a); auto.
Qed.

Lemma equiv_tail : forall a n  l l', equiv (cons a n l) (cons a n l') ->
                                     equiv l l'.
Proof.
 intros.
 unfold equiv;intros.
 generalize (H o).
 simpl.
 case (T1_eq_dec o a).
 intro;omega.
 auto.
Qed.

Lemma equiv_perm :
 forall a n b p l l',
   equiv l l' ->
   equiv (cons a n (cons b p l))(cons b p (cons a n l')).
Proof.
 intros a n b p l l' H c; simpl.
 case (T1_eq_dec c a); case (T1_eq_dec c b);
  simpl; case (H c); auto.
 intros;ring.
Qed.

Lemma app_equiv_comm : forall l l', equiv (l :: l') (l' :: l).
 unfold equiv;intros.
 do 2 rewrite multiplicity_of_app.
 auto with arith.
Qed.

Lemma app_equiv_assoc : forall l l' l'', equiv ((l ::l') :: l'')
                                           (l :: (l' :: l'')).
 unfold equiv;intros.
 repeat rewrite multiplicity_of_app.
  auto with arith.
Qed.

Lemma equiv_cong1 : forall l1 l2 l, equiv l1 l2 -> equiv (l1 :: l)
                                                         (l2 :: l).

 unfold equiv;intros;repeat rewrite multiplicity_of_app.
 auto with arith.
Qed.

 Lemma equiv_cong2 : forall l1 l2 l, equiv l1 l2 -> equiv (l :: l1)
                                                          (l :: l2).

 unfold equiv;intros;repeat rewrite multiplicity_of_app.
 auto with arith.
Qed.

Hint Resolve equiv_cons equiv_refl equiv_perm equiv_tail app_equiv_assoc : T1.

(* insertion of z into l at the right place
   (assuming l is sorted)
*)

Fixpoint sort_aux (a:T1)(n:nat) (l:T1) {struct l} : T1 :=
  match l with
  | zero => (cons a n zero)
 |  cons b p l' =>
     ( match trichotomy_inf a b with
      |  inleft (left _ ) =>  (cons b p (sort_aux a n l'))
      | inleft (right _) => (cons b (S  n +p)%nat  l')
      | inright _ => (cons a n (cons b p l'))
      end)
   end.

(* the sort_aux function seems to be a good tool for sorting ... *)

Lemma sort_aux_equiv : forall l a n,
                  equiv (cons a n l) (sort_aux a n l).
Proof.
 induction l ; auto with T1.
 intros x n0; simpl. case (trichotomy_inf x l1).

 destruct s.
 eapply equiv_trans.
 2:eapply equiv_cons.
 apply equiv_perm.
 apply equiv_refl.
 auto.
 subst l1.
 2:intro;apply equiv_refl.
 unfold equiv;simpl.
 intro o;case (T1_eq_dec o x).
 intro; omega.
 auto.
Qed.

(* ici *)

Lemma sort_aux_nf :
 forall (l x:T1) n,  nf x -> nf l -> nf (sort_aux x n l).
Proof.
 induction 2.

 simpl.
 auto with T1.

 simpl.
 case (trichotomy_inf x a).
 destruct s.
 constructor;auto.
 constructor; auto with T1.
 constructor; auto with T1 arith.
  constructor; auto with T1 arith.
 simpl.
case (trichotomy_inf x a).
destruct s.
simpl in IHnf2.
generalize IHnf2.
case (trichotomy_inf x a').
destruct s.
constructor 3.
 auto.
 auto.
auto.

subst x.
 constructor;auto.
 constructor;auto.
 constructor;auto.
constructor.
auto.
auto.
 constructor;auto.
Qed.

(* the sorting function *)
(* supprimer la prÃ©conditions nfs l *)

Fixpoint sort (alpha :T1) : T1 :=
 match alpha with zero => zero
            | cons a n b => sort_aux a n (sort b)
 end.

Lemma sort_equiv :
  forall alpha:T1, equiv alpha (sort alpha).
Proof.
 induction alpha;simpl.
 split;auto with T1.
 apply equiv_trans with (cons alpha1 n (sort alpha2)).
 apply equiv_cons.
 auto.
 apply sort_aux_equiv.
Qed.

Lemma sort_nf : forall alpha, nfs alpha -> nf (sort alpha).
Proof.
 induction alpha;simpl.
 constructor.
 intro; apply sort_aux_nf.
 inversion H;auto.
 apply IHalpha2.
 inversion H;auto.
Qed.

(* something to do with multisets ? *)

Definition ltM (a:T1)(l l':T1) :=
 (multiplicity a l < multiplicity a l')%nat /\
 forall b,  a < b -> multiplicity b l = multiplicity b l'.

Lemma ltM_equiv_ltM : forall a l l' l'', ltM a l l' ->
                                         equiv l' l'' -> ltM a l l''.
Proof.
 unfold ltM, equiv.
 intros.
 case H; intros; clear H.
 split.
 rewrite <- H0; auto.
 intros; rewrite <- H0;auto.
Qed.

Lemma ltM_equiv_ltMR :
  forall a l l' l'', ltM a l l' -> equiv l l'' -> ltM a l'' l'.
Proof.
 unfold ltM, equiv.
 intros.
 case H; intros; clear H.

 split.

 rewrite <- H0; auto.
 intros; rewrite <- H0;auto.
Qed.

(* never used *)
Lemma ltM_trans : forall a l l' , ltM a l l' -> forall l'', ltM a l' l'' ->
                                                            ltM a l l''.
 induction 1.
 destruct 1.
 split.
 eauto with arith.
 intros ; rewrite H0; auto.
 Qed.

(* never used *)

Lemma ltM_trans_1 : forall a b l l' l'', a < b -> ltM a l l' ->
                                          ltM b l' l'' ->
                                          ltM b l l''.
 destruct 2.
 destruct 1.
 split.
 replace (multiplicity b l) with (multiplicity b l').
 auto.
 symmetry;apply H1; auto.
 intros; transitivity (multiplicity b0 l');auto.
 apply H1.
 eapply lt_trans; eauto.
Qed.

Lemma ltM_trans_2 : forall a b l l' l'',  b <  a -> ltM a l l' ->
                                          ltM b l' l'' ->
                                          ltM a l l''.
 destruct 2.
 destruct 1.
 split.
 replace (multiplicity a l'') with (multiplicity a l').
 auto.
 apply H3.
 auto.
 intros;
 transitivity (multiplicity b0 l');auto.
 apply H3.
 eapply lt_trans; eauto.
Qed.

 (* should be interesting to consider a projection
    exists a, ltM a l l'
 *)

 Lemma lt_ltM : forall a n b l l',  b < a -> ltM a l l' ->
                                     ltM a (cons b n l) l'.
 induction 2; split.
 simpl.
 case (T1_eq_dec a b).
 intro; absurd (lt a a);auto with T1.
 subst b;auto.
 auto.
 intros; simpl.
 case (T1_eq_dec b0 b).
 intro; subst b0; case (lt_not_gt H);auto.
 auto.
 Qed.

(* proof too much long ! *)

Lemma nf_multiplicity_head : forall l c n , nf (cons c n l) ->
                                          multiplicity c (cons c n l) = S n.
Proof.
 induction l.
 simpl.
 intros; case (T1_eq_dec c c).
 auto with arith.
 intros; absurd (c=c); auto.
 intros;case (T1_eq_dec c c).
 2: intros;absurd (c=c);auto.
 case (T1_eq_dec c l1); simpl.
 assert (c <> l1).
 red; intro; subst l1.
 case (lt_irr (a:=c)).
 inversion_clear H;auto.
 intros; absurd (c=l1);auto.
 assert (nf (cons c n0 l2)).
 generalize H;induction l2.
 constructor.
 inversion H;auto.
 constructor.
 inversion H;auto.
 apply lt_trans with l1;auto.
 inversion H8;auto.
 inversion H0;auto.
 inversion H0.
 inversion H8;auto.
 intros; case (T1_eq_dec c c).
 case (T1_eq_dec c l1).
 intro;case n1;auto.
 replace (multiplicity c l2) with 0.
 auto with arith.
 generalize H0;elim l2.
 simpl;auto.
 intros.
 simpl.
 case (T1_eq_dec c t).
 intro.
 subst t; inversion H3.
 case (lt_irr H7).
 intro;apply H2.
 generalize H3;case t0.
 constructor;auto.
 inversion H3;auto.
 constructor;auto.
 inversion H4.
 apply lt_trans with t;auto.
 inversion H12;auto.
 inversion H4;auto.
 inversion H4.
 inversion H12;auto.
 intro H1;case H1;auto.
Qed.

(* Should make the previous proof simpler  *)

Lemma nf_multiplicity_tail : forall l a c n ,
                                 a < c -> nf (cons c n l) ->
                                 multiplicity a (cons c n l) = multiplicity a l.
Proof.
 inversion_clear 2.
 simpl;case (trichotomy_inf a c).
 destruct 1.
 case (T1_eq_dec a c).
 intro; subst a; absurd (lt c c);auto with T1.
 auto.
 case (T1_eq_dec a c).
 intro; subst a; absurd (lt c c);auto with T1.
 auto .

 case (T1_eq_dec a c).
   intro; subst a; absurd (lt c c);auto with T1.
 auto.
 simpl.
  case (T1_eq_dec a c).
 case (T1_eq_dec a a').
   intro; subst a; intros;absurd (lt c c);auto with T1.
 subst c;auto.
  intros; subst a; intros;absurd (lt c c);auto with T1.
  auto.
Qed.

Lemma  nf_multiplicity_big : forall l a c n , c < a -> nf (cons c n l) ->
                                                 multiplicity a (cons c n l) = 0.

Proof.
 induction l.
 inversion_clear 2.
 simpl; case (T1_eq_dec a c).
 intros; subst a; intros;absurd (lt c c);auto with T1.
 auto.
 simpl.
 intros.
 case (T1_eq_dec a c).
 intros; subst a; intros;absurd (lt c c);auto with T1.
 intro;
 case (T1_eq_dec a c).
 intro; subst a.
 case (lt_irr  H);auto.
intros; case (T1_eq_dec a l1).
intro; absurd (lt a l1).
rewrite <- e.
subst l1.
apply lt_irr.
subst l1.
inversion_clear H0;auto.
eapply lt_trans;eauto.
generalize (IHl2 a c n H).
simpl.
case (T1_eq_dec a c).
intro; absurd (a=c);auto.
intros.
apply H1.
inversion_clear H0.
auto.
inversion_clear H4.
constructor;auto.
constructor; auto.
eapply lt_trans ; eauto.
Qed.

Lemma ltM_inv : forall a b n l l',
  nf (cons b n l) ->  nf  (cons b n l') ->
  ltM a (cons b n l) (cons b n l') ->
                    ltM a l l'.
Proof.
 inversion_clear 3.
 case (trichotomy_inf a b).
 destruct 1.
 do 2 rewrite nf_multiplicity_tail in H2; auto.
 split;auto.
 intros.
 generalize (H3 _ H1).
 simpl.
 case (T1_eq_dec b0 b).
 auto.
 clear H3;intro;omega.
 auto.
 subst b; do 2 rewrite nf_multiplicity_head in H2;auto.
 absurd (n<n)%nat; auto with arith.
 intro.
 do 2 rewrite nf_multiplicity_big in H2;auto.
 inversion H2.
Qed.

Lemma ltM_inv2 : forall l l' a b n b' n',  nf (cons b n l) ->
                                       nf (cons b' n' l') ->
                                       ltM  a (cons b n l) (cons b' n' l') ->
                                         a <= b'.
intros.
case H1.
intros H2 H3.
case (trichotomy_inf a b').
destruct 1.
auto.
auto.
right;auto.
left;auto.
intro.
rewrite (nf_multiplicity_big  _ _ _ _ l0 H0) in H2;auto.
inversion H2.
Qed.

Lemma ltM_inv3: forall l l' a b n b' n',  a < b' ->
                                         nf (cons b n l) ->
                                         nf (cons b' n' l') ->
                                         ltM  a (cons b n l) (cons b' n' l') ->
                                          b = b' /\ n = n'.
intros.
case H2.
intros.
case (trichotomy_inf b b').
destruct 1.
generalize (H4 _ H).
rewrite nf_multiplicity_big;auto.
rewrite nf_multiplicity_head.
discriminate 1.
auto.
split.
auto.
subst b'.
generalize (H4 _ H).
rewrite nf_multiplicity_head ;auto.
rewrite nf_multiplicity_head ;auto.
intro.
assert (lt a b).
eapply lt_trans;eauto.
generalize (H4 _ H5).
rewrite nf_multiplicity_head ;auto.
rewrite nf_multiplicity_big ;auto.
intro;absurd (0<n)%nat.
discriminate H6.
discriminate H6.
Qed.

Lemma ltM_cons : forall a l l' b n, ltM a l l' -> ltM a (cons b n l)
                                                         (cons b n l').
Proof.
 intros.
 unfold ltM.
 case H; intros.
 split; simpl.
 case (T1_eq_dec a b).
 auto with arith.
 auto.
 intros; case (T1_eq_dec b0 b).
 intro; subst b0;auto.
 intro;apply H1.
auto.
Qed.

Lemma ltM_app : forall a l l' l'', ltM a l l' -> ltM a (l'' :: l)
                                                       (l'' :: l').
Proof.
 induction l'';simpl.
 auto.
 intros;apply ltM_cons.
 auto.
Qed.

Lemma ltM_appR : forall a l l' l'', ltM a l l' -> ltM a (app l l'')
                                                        (app l' l'').
Proof.
  intros.
  eapply ltM_equiv_ltM.
  2:apply app_equiv_comm.
  eapply ltM_equiv_ltMR.
  2:apply app_equiv_comm.
 apply ltM_app.
 auto.
Qed.

Lemma lt_ltM2 : forall c c', nf c -> nf c' ->
                             c < c' ->
                            {a:T1| ltM a c c'}.
Proof.
 induction c; destruct c'.
 intros; elimtype False.
 inversion H1.
 exists c'1;simpl.
 constructor.
 simpl.
 case (T1_eq_dec c'1 c'1).
 auto with arith.
 intros; absurd (c'1=c'1);auto.
 intros;rewrite nf_multiplicity_big.
 simpl;auto.
 auto.
 auto.
 intros;elimtype False.
inversion H1.
intros.
case (trichotomy_inf c1 c'1).
destruct 1.

exists c'1.
simpl.
inversion H1.
split.

rewrite nf_multiplicity_big.
rewrite nf_multiplicity_head.
auto with arith.
 auto.
 auto.
 auto.
intros; repeat rewrite nf_multiplicity_big.
auto.
auto.
auto.
eapply lt_trans;eauto.
 auto.
 split.
 repeat rewrite nf_multiplicity_head.
 auto with arith.
 auto.
 subst c'1.
 auto.
intros.

repeat rewrite nf_multiplicity_big;auto.
subst c'1;auto.
subst c'1; case (lt_irr l).
subst c'1.

case (lt_eq_lt_dec n n0).
destruct 1.
exists c1.
split.
repeat rewrite nf_multiplicity_head.
auto with arith.
auto.
auto.
intros; repeat rewrite nf_multiplicity_big;auto.
subst n0.
assert (lt c2 c'2).
eapply lt_inv_b;eauto.

case (IHc2 c'2).
eapply nf_inv2;eauto.

eapply nf_inv2;eauto.
auto.
intros;exists x.
apply ltM_cons.
auto.
intros.
elimtype False.
 generalize (lt_inv_nb H1).
destruct 1.
absurd (n<n)%nat;eauto with arith.
case H2;intros ;subst n.
absurd (n0<n0)%nat;auto with arith.
intros.
absurd (EPSILON0.le c1 c'1).
unfold EPSILON0.le.
red; destruct 1.
subst c'1;case (lt_irr l).
case (lt_not_gt l);auto.
inversion H1.
right;auto.
subst c1;left;auto.
left.
auto.
Qed.

(* to do : use natural_sigma and forget about being sorted *)

Lemma ltM_lt : forall a l l', nf l -> nf l' ->
                          ltM a l l' ->
                          l < l'.
Proof.
 induction l; destruct l'.
 intros; absurd (ltM a zero zero);auto.
 unfold ltM;simpl.
 red; case (1).
 destruct 2.
 inversion H2.
 simpl.
 auto with T1.
 inversion 3.
 inversion H2.
 intros.
 case (trichotomy_inf l1 l'1).
 destruct 1.
 constructor 2;auto.
 subst l'1.
 case (trichotomy_inf a l1).
 destruct 1.
 case H1;intros.
 rewrite  (nf_multiplicity_tail _ _ _ _ l H) in H2.
 rewrite  (nf_multiplicity_tail _ _ _ _ l H0) in H2.
 generalize (H3 _ l).
 rewrite nf_multiplicity_head .
 rewrite nf_multiplicity_head .
 injection 1.
 intro; subst n0.
 constructor 4.
 apply IHl2.
 inversion_clear H; eauto.
 constructor.
 inversion_clear H0; eauto.
 constructor.
 split.
 auto.
 intros b H11.
 generalize (H3 _ H11).
 simpl.
 case (T1_eq_dec b l1).
 intros; clear H3; omega.
 auto.
 auto.
 auto.
 subst l1.
 case H1;intros.
 do 2 rewrite nf_multiplicity_head in H2.
 constructor 3;auto.
 clear H3;omega.
 auto.
 auto.
 auto.
 case H1;intros.
 do 2 rewrite nf_multiplicity_big in H2.
 inversion_clear H2.
 auto.
 auto.
 auto.
 auto.
 auto.
 auto.
 auto.
 auto.
 intro.
 generalize (ltM_inv2 _ _ _ _ _ _ _ H H0 H1).
 destruct 1.
 subst l'1.
 case H1;intros.
 generalize (H3 _ l).
 rewrite (nf_multiplicity_head);auto.
 rewrite (nf_multiplicity_big);auto.
 intro.
 discriminate H4.
 generalize (ltM_inv3 _ _ _ _ _ _   _ H2 H H0  H1).
 destruct 1.
 subst l'1.
 case (lt_irr l).
Qed.

Lemma ltM_tail : forall a n l,  ltM a l (cons a n  l).
Proof.
 intros; unfold ltM.
 split.
 simpl.
 case (T1_eq_dec a a).
 intro; omega.
 intro; absurd (a=a);auto.
 intros; simpl.
 case (T1_eq_dec b a).
 intro; absurd (lt a b).
subst b;auto with T1.
 auto.
 auto.
Qed.

Lemma ltM_head : forall a n a' p l , a' < a ->
                                     ltM a (cons a' p l)
                                           (cons a n l).
Proof.
 intros; unfold ltM.
 split.
 simpl.
 case (T1_eq_dec a a').
 intro.
 absurd (lt a a);auto with T1.
 subst a;auto.
 case (T1_eq_dec a a).
 intros;omega.
 intros; absurd (a=a);auto.
 simpl.
 intros;case (T1_eq_dec b a'); case (T1_eq_dec b a).
 intro; subst b; absurd (lt a a);auto with T1.
 intros.
 subst b; case (lt_not_gt H0);auto.
 intro; subst b; absurd (lt a a);auto with T1.
 auto.
Qed.

Lemma nfs_to_nf : forall l a, nfs l -> (0 < multiplicity a l)%nat -> nf a.
Proof.
  induction l.
  simpl.
  inversion 2.
  simpl.
  intros; case (T1_eq_dec a l1).
  intro; subst a.
  inversion H;auto.
  generalize H0; case (T1_eq_dec a l1).
  intros; absurd (a=l1);auto.
  intros.
  apply IHl2.
  inversion H.
  auto.
  auto.
 Qed.

Lemma nf_to_nfs : forall l, nf l ->
                       nfs l.
Proof.
  induction l.
  constructor.
  constructor.
  inversion H;auto.
  inversion H;auto.
  constructor.
  subst l2.
  auto.
 Qed.

Lemma nf_unicity :forall l, nf l -> forall l',equiv l l' -> nf l' -> l=l'.
Proof.
 induction 1.
 induction 2.
 auto.
 unfold equiv in H.
 generalize (H a).
 simpl.
 case (T1_eq_dec a a).
 discriminate 2.
 intros; absurd (a=a);auto.
 unfold equiv in H.
 generalize (H a).
  simpl.
  case (T1_eq_dec a a).
  discriminate 2.
 intros; absurd (a=a);auto.
 destruct l'.
  unfold equiv .
 intro H0;generalize (H0 a).
 simpl.
 case (T1_eq_dec a a).
 discriminate 2.
  intros; absurd (a=a);auto.
 case l'2.
 unfold equiv; simpl.
 intros.
  generalize (H0 a).
 case (T1_eq_dec a a).
 case (T1_eq_dec a l'1).
 intros.
 subst l'1.
 assert (n=n0).
 clear H0;omega.
 subst n;auto.
 discriminate 3.
 intro; absurd (a=a);auto.
 unfold equiv.
 intros.
 generalize (H0 l'1).
 simpl.
 case (T1_eq_dec l'1 a).
 intro;subst l'1.
 case (T1_eq_dec a a).
 case (T1_eq_dec a t).
 intros;subst t.
 absurd (lt a a).
 apply lt_irr.
  inversion_clear H1;auto.
 intros.
 generalize (H0 t).
 simpl.
 case (T1_eq_dec t a).
 intro; absurd (t = a);auto.
case (T1_eq_dec t t).
 discriminate 3.

 intro; absurd (t=t);auto.
 intro;absurd (a=a);auto.
 case (T1_eq_dec l'1 l'1).
 discriminate 3.
 intro;absurd (l'1 = l'1);auto.
 destruct l'.
 unfold equiv.
 intros.
 generalize (H2 a);simpl.
 case (T1_eq_dec a a).
 discriminate 2.
 intro;absurd (a=a);auto.
 case l'2.
 unfold equiv;intros .
 generalize (H2 a).
 simpl.
 case (T1_eq_dec a a).
 case (T1_eq_dec a a').
 intros;subst a'.
 case (lt_irr H).
 case (T1_eq_dec a l'1).
 intro; subst l'1.

 generalize (H2 a').
 simpl.
 case (T1_eq_dec a' a).
 intro; absurd (a'=a);auto.
 subst a'.
 case (lt_irr H).
 case (T1_eq_dec a' a').
 discriminate 3.

 intro;absurd (a'=a');auto.

 discriminate 4.
 intro;absurd (a=a);auto.
 intros.
 case (trichotomy_inf  a l'1).
 destruct 1.
 unfold equiv in H2.
 generalize (H2 l'1).
 rewrite nf_multiplicity_big.
 rewrite nf_multiplicity_head.
 discriminate 1.
 auto.
 auto.
 constructor;auto.
 subst l'1.
 unfold equiv in H2.
 generalize (H2 a).
 rewrite nf_multiplicity_head.
 rewrite nf_multiplicity_head.
 injection 1;intro; subst n0.
  rewrite (IHnf2 (cons t n1 t0)).
 auto.
 apply equiv_tail with  a n.
 unfold equiv;auto.
 inversion H3;auto.
 auto.
 constructor;auto.
 intros.
 generalize (H2 a).
 rewrite nf_multiplicity_head.
 rewrite nf_multiplicity_big.
 discriminate 1.
 auto.
 auto.
 constructor;auto.
Qed.


(** * Functors *)
(** Since there are only notations in [Functor.Notations], we can just export those. *)
Require Export Functor.Notations.

(** ** Definition *)
Require Functor.Core.
(** ** Composition *)
Require Functor.Composition.Core.
(** ** Duals *)
Require Functor.Dual.
(** ** Identity *)
Require Functor.Identity.
(** ** Classification of path space *)
Require Functor.Paths.
(** ** Product functors *)
Require Functor.Prod.Core.
(** ** Coproduct functors *)
Require Functor.Sum.
(** ** Full, Faithful, Fully Faithful *)
Require Functor.Attributes.
(** ** Pointwise functors (functoriality of functor category construction) *)
Require Functor.Pointwise.Core.

Include Functor.Composition.Core.
Include Functor.Core.
Include Functor.Dual.
Include Functor.Identity.
Include Functor.Paths.
Include Functor.Prod.Core.
Include Functor.Sum.
Include Functor.Attributes.
Include Functor.Pointwise.Core.

(** We want to have the following as subdirectories/modules, not at top level.  Unfortunately, namespacing in Coq is kind-of broken (see, e.g., https://coq.inria.fr/bugs/show_bug.cgi?id=3676), so we don't get the ability to rename subfolders by [Including] into other modules. *)
Require Functor.Pointwise.

(** We don't want to make utf-8 notations the default, so we don't export them. *)