(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                          ElementComb_Behaviour.v                         *)
(****************************************************************************)

Require Export Conversions.
Require Export Bool.
Require Import Lib_Dec.
Require Import PortsCompl.
Require Export Manip_BoolLists.

(** List of all the 4 (input or output) ports **)

Definition All_Ports :=
  List4 (exist (fun p : nat => p < 4) 0 lt_O_4)
    (exist (fun p : nat => p < 4) 1 lt_1_4)
    (exist (fun p : nat => p < 4) 2 lt_2_4)
    (exist (fun p : nat => p < 4) 3 lt_3_4).

(** Behavioural description of the Ackgen unit **)

Definition Ackgen_Behaviour (ackIn disabled : bool)
  (grant : d_list bool 2) :=
  match ackIn && negb disabled with
  | true => Convert_list2 grant
  | false => List4 false false false false
  end.

(** Behavioural description of the Ack unit **)

Definition ack_behaviour (inp : T_Inportno 4) (a d : bool)
  (g : d_list bool 2) :=
  match eq_or_not_bis (Convert_list2_nat g) (no_in inp) with
  | left _ => a && negb d
  | right _ => false
  end.

Definition Ack_behaviour (ackIn disabled : d_list bool 4)
  (grant : d_list (d_list bool 2) 4) (inp : T_Inportno 4) :=
  Exists1_atleast (fun b : bool => b = true)
    (d_map3 (ack_behaviour inp) ackIn disabled grant).

Definition Ack_Behaviour (ackIn disabled : d_list bool 4)
  (grant : d_list (d_list bool 2) 4) :=
  d_map (Ack_behaviour ackIn disabled grant) All_Ports.

(****************************************************************************)

(** Pause_DataSwitch Unit **)

Lemma le_S_bool_nat : forall b : bool, S (bool_nat b) <= 4.
simple induction b; auto.
Qed.

Lemma le_SSS_bool_nat : forall b : bool, S (S (S (bool_nat b))) <= 4.
simple induction b; auto.
Qed.

Definition Dmux4t2ffc_Behaviour' (d : d_list bool 4)
  (outputDisable y : bool) :=
  match outputDisable with
  | true => List2 false false
  | false =>
      List2
        (Nth (i:=S (bool_nat y)) d (lt_O_Sn (bool_nat y)) (le_S_bool_nat y))
        (Nth (i:=S (S (S (bool_nat y)))) d (lt_O_Sn (S (S (bool_nat y))))
           (le_SSS_bool_nat y))
  end.

(** A simplier way for writing Dmux4t2ffc_Behaviour **)

Definition Dmux4t2ffc_Behaviour (d : d_list bool 4)
  (outputDisable y : bool) :=
  match outputDisable with
  | true => List2 false false
  | false =>
      match y with
      | true => List2 (Scd_of_l4 d) (Fth_of_l4 d)
      | false => List2 (Fst_of_l4 d) (Thd_of_l4 d)
      end
  end.

(****************************************************************************)

(** Arbitration Unit **)

(** Behavioural description of the Arbiter_XY unit **)
(** Arbiter_XY computes the two bits of the grant signal **)
(** x and y stand for x_grant and y_grant **)

Definition Arbiter_X_behaviour (ltReq : d_list bool 4)
  (RouteE x y : bool) :=
  match RouteE with
  | true =>
      match x with
      | true =>
          negb y && Fth_of_l4 ltReq
          || negb (Fst_of_l4 ltReq) && negb (Scd_of_l4 ltReq)
      | false =>
          (y || negb (Scd_of_l4 ltReq)) &&
          (Fth_of_l4 ltReq || Thd_of_l4 ltReq)
      end
  | false => x
  end.

Definition Arbiter_Y_behaviour (ltReq : d_list bool 4)
  (RouteE x y : bool) :=
  match RouteE with
  | true =>
      match y with
      | true =>
          (x && Scd_of_l4 ltReq || negb (Thd_of_l4 ltReq)) &&
          (negb x && Fth_of_l4 ltReq || negb (Fst_of_l4 ltReq))
      | false =>
          (x || negb (Thd_of_l4 ltReq)) && Fth_of_l4 ltReq
          || (negb x || negb (Fst_of_l4 ltReq)) && Scd_of_l4 ltReq
      end
  | false => y
  end.

(** Behavioural description of the Outdis unit **)

Definition Outdis_behaviour (ltReq RouteE fs old : bool) :=
  match old with
  | true => negb (RouteE && ltReq)
  | false => fs
  end.


(* Project files imports *)
Require Import MyLists.
Require Import Sequent_Calculus.
Require Import Basic_Properties.

(* Other imports *)
From Coq Require Import Arith.Arith.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
Import ListNotations.
Import Wf_nat.

Theorem cut_oplus :
  forall (A B : formula),
    (forall (n m : nat) (C : formula)
            (Gamma Delta1 Delta2 : list formula),
        (n; Gamma |- A) ->
        (m; Delta1 ++ [A] ++ Delta2 |- C) ->
        exists z : nat,
          (z; Gamma ++ Delta1 ++ Delta2 |- C))
    ->
    (forall (n m : nat) (C : formula)
            (Gamma Delta1 Delta2 : list formula),
        (n; Gamma |- B) ->
        (m; Delta1 ++ [B] ++ Delta2 |- C) ->
        exists z : nat,
          (z; Gamma ++ Delta1 ++ Delta2 |- C))
    ->
    forall (n m : nat)
           (C: formula)
           (Gamma Delta1 Delta2 : list formula),
      (n; Gamma |- (A # B))
      ->
      (m; Delta1 ++ [A # B] ++ Delta2 |- C)
      -> exists z, z; (Gamma ++ Delta1 ++ Delta2) |- C.
Proof.
  intros A B IHA1 IHA2 n m.
  (* We start induction on depth of proof *)
  (* This is necessary for Commuting Conversions *)
  remember (n + m) as l.
  generalize dependent m.
  generalize dependent n.
  induction (lt_wf l) as [l _ IHl].

  intros n m sum C Gamma Delta1 Delta2 LH.
  remember (A # B) as cutF.

  (* By cases on LH *)
  destruct LH.

  (* LH = OneL *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1 n m eq2
                    C Gamma Delta1 Delta2 LH RH).
    clear eq1. clear eq2. clear RH. clear LH.

    destruct IHl as [z Hyp].
    exists (S z).
    simpl in *.
    constructor; auto.

  (* LH = OneR *)
  * discriminate.

  (* LH = Axiom *)
  * intros RH.
    subst. clear IHA1. clear IHA2.
    assert (RH' : m; [] ++ Delta1 ++ [A # B]
                       ++ Delta2 |- C)
      by auto.
    apply exchange_with_env_l in RH'.
    exists (m + length Delta1).
    assumption.

  (* LH = TensorL *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1 n m eq2
                    C (A0::B0::env)
                    Delta1 Delta2 LH RH).
    clear eq1. clear eq2. clear RH. clear LH.

    destruct IHl as [z Hyp].
    exists (S z).
    simpl in *.
    constructor; auto.

  (* LH = TensorR *)
  * discriminate.

  (* LH is LolliL *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1
                    n m  eq2
                    C
                    (B0 :: env2)
                    Delta1 Delta2 LH2 RH
               ).
    clear eq1. clear eq2. clear RH. clear LH2.
    destruct IHl as [z IHl].

    assert (z; B0:: env2 ++ Delta1
                 ++ Delta2 |- C) by auto.
    apply (level_depth
             n env1 A0
             z (B0::env2 ++ Delta1 ++ Delta2) C
             LH1) in H.
    clear LH1. destruct H as [k [H1 H2]].

    apply (LolliL k env1 A0
                   (env2 ++ Delta1 ++ Delta2) B0 C
                   H1) in H2.

    exists (S k).
    assert (eq: S k;
            ([A0 -o B0] ++ env1 ++ env2)
              ++ Delta1 ++ Delta2  |- C)
      by (repeat rewrite <- app_assoc in *; auto).
    auto.

  (* LH is LolliR *)
  * discriminate.

  (* LH is WithL1 *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1
                    n m  eq2
                    C
                    (A0 :: Gamma)
                    Delta1 Delta2 LH RH
               ).
    clear eq1. clear eq2. clear RH. clear LH.
    destruct IHl as [z IHl].

    assert (eq: z; A0:: Gamma ++ Delta1
                 ++ Delta2 |- C) by auto.

    apply (WithL1 z (Gamma ++ Delta1 ++ Delta2)
                   A0 B0 C)
      in eq.

    exists (S z).
    assert (H: S z;
            ([A0 & B0] ++ Gamma)
              ++ Delta1 ++ Delta2 |- C) by auto.
    auto.

  (* LH is WithL2 *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1
                    n m  eq2
                    C
                    (B0 :: Gamma)
                    Delta1 Delta2 LH RH
               ).
    clear eq1. clear eq2. clear RH. clear LH.
    destruct IHl as [z IHl].

    assert (eq: z; B0:: Gamma ++ Delta1
                 ++ Delta2 |- C) by auto.

    apply (WithL2 z (Gamma ++ Delta1 ++ Delta2)
                   A0 B0 C)
      in eq.

    exists (S z). auto.

  (* LH is WithR *)
  * discriminate.

  (* LH is OplusL *)
  * intros RH.
    subst. clear IHA1. clear IHA2.

    assert (eq1: n + m < S n + m) by omega.
    assert (eq2: n + m = n + m) by omega.
    assert (RH': m; Delta1 ++ [A # B] ++ Delta2 |- C)
           by auto.
    apply (IHl (n + m) eq1
                    n m  eq2
                    C
                    (A0 :: Gamma)
                    Delta1 Delta2 LH1) in RH.
    apply (IHl (n + m) eq1
                    n m  eq2
                    C
                    (B0 :: Gamma)
                    Delta1 Delta2 LH2) in RH'.
    clear eq1. clear eq2. clear LH1. clear LH2.
    destruct RH as [z RH].
    destruct RH' as [z' RH'].

    assert (H1: z; A0 :: Gamma
                     ++ Delta1 ++ Delta2 |- C)
      by auto.
    assert (H2: z'; B0 :: Gamma
                     ++ Delta1 ++ Delta2 |- C)
      by auto.

    apply (level_depth
             z (A0 :: Gamma ++ Delta1 ++ Delta2) C
             z' (B0 :: Gamma ++ Delta1 ++ Delta2) C
             H1) in H2.
    destruct H2 as [k [H H']].

    apply (OplusL k (Gamma ++ Delta1 ++ Delta2)
                  A0 B0 C H) in H'.

    exists (S k).
    auto.

  (* LH is OplusR1 *)
  * inversion HeqcutF.
    subst. clear HeqcutF.
    intros RH.
    remember (Delta1 ++ [A # B] ++ Delta2) as CF.
    inversion HeqCF as [backup].

    {
      destruct RH.

      (* RH = OneL *)
      - clear IHA1. clear IHA2.
        apply element_in_app_head in HeqCF.
        destruct HeqCF as [[t1 [t2 t3]] | [l t]].
        * discriminate.
        * subst.
          assert (eq:
                    (One :: l) ++ [A # B] ++ Delta2 =
                    Delta1 ++ [A # B] ++ Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear backup.

          apply (OplusR1 n Gamma A B) in LH.
          assert (eq1 : S n + n0 < S n + S n0)
            by omega.
          assert (eq2 : S n + n0 = S n + n0)
            by omega.
          specialize (IHl ((S n) + n0)
                          eq1 (S n) n0 eq2 A0
                          Gamma l
                          Delta2 LH RH
                     ).
          destruct IHl as [z IHl].
          clear eq1. clear eq2. clear LH. clear RH.

          apply (OneL z (Gamma ++ l ++ Delta2) A0)
            in IHl.

          assert (eq: S z;
                  ([One] ++ Gamma)
                    ++ l ++ Delta2 |- A0)
            by auto.

          apply exchange_subset in eq.
          destruct eq as [m [ _ H]].

          assert (eq: m;
                  Gamma ++ ([One] ++ l)
                        ++ Delta2 |- A0)
            by (repeat rewrite <- app_assoc in *;
                auto).

          exists m; auto.

      (* RH is OneR *)
      - simpl in *.
        apply app_cons_not_nil in HeqCF.
        destruct HeqCF.

      (* RH is Atom *)
      - apply app_singleton in HeqCF.
        destruct HeqCF as [t1 [t2 t3]].
        subst.

        exists (S n).
        rewrite app_nil_r.
        constructor; auto.

      (* RH is TensorL *)
      - inversion HeqCF.
        apply element_in_app_head in HeqCF.

        destruct HeqCF as [Left | Right].

        * destruct Left as [t1 [t2 t3]].
          discriminate.

        * destruct Right as [l H].
          subst.
          assert (eq: (A0 ** B0 :: l)
                        ++ [A # B] ++ Delta2 =
                      Delta1 ++ [A # B] ++ Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          apply (OplusR1 n Gamma A B) in LH.
          specialize (IHl (S n + n0) eq1 (S n) n0 eq2
                          C Gamma
                          (A0::B0::l)
                          Delta2 LH RH).
          clear eq1. clear eq2. clear RH. clear LH.

          destruct IHl as [z H].

          rewrite app_assoc in H.
          apply exchange_subset in H.
          destruct H as [m [ _ H]].

          assert( eq: m;
                  [A0] ++ [B0]
                       ++ l ++ Gamma ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto).
          simpl in eq.

          apply (TensorL m (l ++ Gamma
                              ++ Delta2) A0 B0 C)
            in eq.

          assert (eq': S m;
                  ((A0 ** B0 :: l) ++ Gamma)
                    ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto).

          apply exchange_subset in eq'.
          destruct eq' as [k [ _ Final]].
          rewrite <- app_assoc in Final.

          exists k; auto.

      (* RH is TensorR *)
      - (* cleaning *)
        clear IHA1. clear IHA2.

        (* some pre-processing *)
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1 (S n) n0 eq2).
        clear eq1. clear eq2.

        (* We go by cases, since *)
        (* A & B could be in RH1 or RH2 *)
        apply element_in_app in HeqCF.
        {
          destruct HeqCF as [inEnv1 | inEnv2].

          (* on the left *)
          - destruct inEnv1 as [t1 [t2 [l t3]]].
            subst. clear t1. clear t2.

            (* one more infere&substitute *)
            assert (eq: (Delta1 ++ [A # B]) ++ (l ++ env2) =
                        (Delta1 ++ [A # B]) ++ Delta2).
            { repeat rewrite <- app_assoc in *. auto. }
            apply app_inv_head in eq. subst. clear backup.

            apply (OplusR1 n Gamma A B) in LH.
            specialize (IHl A0 Gamma Delta1 l LH RH1).
            clear LH. clear RH1.
            destruct IHl as [z LH].

            apply (level_depth z (Gamma ++ Delta1 ++ l) A0
                               n0 env2 B0 LH) in RH2.
            clear LH.
            destruct RH2 as [k [LH RH]].

            exists (S k).
            rewrite app_assoc.
            rewrite app_assoc.
            constructor;
              [rewrite <- app_assoc; auto | auto].

          (* on the right *)
          - destruct inEnv2 as [t1 [t2 [l t3]]].
            subst. clear t1. clear t2.

            (* one more infere&substitute *)
            assert (eq: (env1 ++ l) ++ ([A # B] ++ Delta2) =
                        Delta1 ++ (A # B :: Delta2))
              by (repeat rewrite <- app_assoc in *; auto).
            apply app_inv_tail in eq. subst.
            clear backup.

            apply (OplusR1 n Gamma A B) in LH.
            specialize (IHl B0 Gamma l Delta2 LH RH2).
            clear LH. clear RH2.
            destruct IHl as [z LH].

            apply (level_depth z (Gamma ++ l ++ Delta2) B0
                               n0 env1 A0 LH) in RH1.
            clear LH.
            destruct RH1 as [k [RH LH]].

            pose proof (TensorR k env1 A0
                                (Gamma ++ l ++ Delta2) B0
                                LH RH).
            assert (eq: S k; (env1 ++ Gamma) ++ l ++ Delta2
                           |- (A0 ** B0))
              by (rewrite <- app_assoc; auto ).
            apply exchange_subset in eq.
            destruct eq as [m [temp final]]. clear temp.
            exists m.
            repeat rewrite <- app_assoc in *; auto.
        }

        (* RH is LolliL *)
      - inversion HeqCF.
        subst.
        (* we need to proceed by cases *)
        assert (eq: (A0 -o B0 :: env1) ++ env2 =
                    Delta1 ++ [A # B] ++ Delta2) by auto.
        apply element_in_app in eq.
        {
          destruct eq as [inLeft | inRight].

          (* on the left *)
          - destruct inLeft as [t1 [t2 [l t3]]].
            clear t1. clear t2.

            (* we have two more cases: reduce or commute *)
            assert (eq: [A0 -o B0] ++ env1 =
                        Delta1 ++ [A # B] ++ l) by auto.
            apply element_in_app in eq.

            {
              destruct eq as [reduction | commute].

              (* reduction case *)
              - destruct reduction as [_ [_ [l' t]]].
              apply app_singleton in t.
              destruct t as [t1 [t2 t4]].
              discriminate.

              (* commute case *)
              - destruct commute as [t1 [t2 [l' t4]]].
                clear t1. clear t2. clear IHA1. clear IHA2.

                (* some substitutions *)
                subst.
                assert (eq: (A0 -o B0 :: l')
                              ++ ([A # B] ++ l) =
                            Delta1 ++ ([A # B] ++ l))
                  by auto.
                apply app_inv_tail in eq.
                subst. clear t3.
                assert (eq: ([A0 -o B0]
                               ++ l'
                               ++ [A # B])
                              ++ l ++ env2 =
                            ([A0 -o B0] ++ l' ++ [A # B])
                              ++ Delta2).
                { repeat rewrite <- app_assoc in *. auto. }
                apply app_inv_head in eq.
                subst. clear HeqCF. clear H0.

                assert (eq1: S n + n0 < S n + S n0)
                  by omega.
                apply (OplusR1 n Gamma A B) in LH.
                assert (eq2: S n + n0 = S n + n0) by omega.
                specialize (IHl (S n + n0) eq1
                                (S n) n0 eq2
                                A0 Gamma l' l LH RH1).
                clear eq1. clear eq2. clear LH. clear RH1.
                destruct IHl as [z Last].

                apply (level_depth z (Gamma ++ l' ++ l) A0
                                   n0 (B0::env2) C Last)
                  in RH2.

                destruct RH2 as [k [First Second]].
                pose proof (LolliL k (Gamma ++ l' ++ l)
                                   A0
                                   env2 B0 C First Second).

                assert(eq: S k; [] ++ [A0 -o B0] ++ Gamma
                                   ++ l' ++ l ++ env2 |- C).
                { simpl in *.
                  repeat rewrite <- app_assoc in *.
                  auto. }

                apply exchange_with_env_r in eq.

                exists (S k + length Gamma); auto.
            }

          (* on the right *)
          - destruct inRight as [t1 [t2 [l t3]]].
            clear t1. clear t2. clear IHA1. clear IHA2.

            (* first some subst, to simplify *)
            subst.
            assert (eq: (A0 -o B0 :: env1 ++ l)
                          ++ (A # B :: Delta2)
                        =
                        Delta1 ++ (A # B :: Delta2)).
            { simpl in *.
              repeat rewrite <- app_assoc in *. auto. }
            apply app_inv_tail in eq.
            subst. clear HeqCF.

            assert (eq1: S n + n0 < S n + S n0) by omega.
            assert (eq2: S n + n0 = S n + n0) by omega.
            apply (OplusR1 n Gamma A B) in LH.
            specialize (IHl (S n + n0) eq1
                            (S n) n0 eq2
                            C Gamma (B0::l) Delta2 LH RH2).
            clear eq1. clear eq2. clear LH. clear RH2.
            destruct IHl as [z Last].

            assert (eq1: z; [] ++ Gamma ++ [B0]
                               ++ l ++ Delta2 |- C)
              by auto.

            apply exchange_with_env_l in eq1.
            simpl in eq1.
            apply (level_depth
                     (z + length Gamma)
                     (B0 :: Gamma ++ l ++ Delta2) C
                     n0 env1 A0 eq1) in RH1.
            clear eq1. clear Last.

            destruct RH1 as [k [RH LH]].

            pose proof (LolliL k env1 A0
                               (Gamma ++ l ++ Delta2) B0 C
                               LH RH).

            assert (eq1: S k; (([A0 -o B0] ++ env1)
                                 ++ Gamma) ++ l ++ Delta2
                              |- C).
            { repeat rewrite <- app_assoc in *.
              simpl. auto. }

            apply exchange_subset in eq1.
            destruct eq1 as [m [temp Final]].

            exists m.

            assert (eq1:  m; Gamma
                               ++ ([A0 -o B0] ++ env1 ++ l)
                               ++ Delta2 |- C).
            { repeat rewrite <- app_assoc in *. auto. }

            simpl in *; auto.
        }

      (* RH is LolliR *)
      - subst. clear IHA1. clear IHA2.

        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (OplusR1 n Gamma A B) in LH.
        apply (IHl (S n + n0) eq1
                   (S n) n0 eq2
                   B0
                   Gamma
                   (A0::Delta1) Delta2 LH) in RH.
        destruct RH as [z RH]. clear LH.
        clear eq1. clear eq2.

        rewrite app_assoc in RH.
        apply exchange_subset in RH.
        destruct RH as [m [ _  H]].
        rewrite <- app_assoc in H.
        simpl in *.
        apply (LolliR m (Delta1 ++ Gamma ++ Delta2) A0 B0)
          in H.
        rewrite app_assoc in H.
        apply exchange_subset in H.
        destruct H as [m0 [_ H]].
        rewrite <- app_assoc in H.
        exists m0; auto.

      (* RH is WithL1 -- MAY REDUCE *)
      - apply element_in_app_head in HeqCF.
        destruct HeqCF as [Left | Right].

        + destruct Left as [t1 [t2 t3]].
          inversion t2.

        + destruct Right as [l t].
          subst.

          assert (eq: (A0 & B0 :: l)
                        ++ [A # B] ++ Delta2 =
                      Delta1 ++ A # B :: Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear backup.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          apply (OplusR1 n Gamma A B) in LH.
          apply (IHl (S n + n0) eq1
                     (S n) n0 eq2
                     C
                     Gamma
                     (A0::l) Delta2 LH) in RH.
          destruct RH as [z H].
          clear LH. clear eq1. clear eq2.

          rewrite app_assoc in H.
          apply exchange_subset in H.
          destruct H as [m [ _ H]].
          rewrite <- app_assoc in H.
          simpl in *.
          apply (WithL1 m (l ++ Gamma ++ Delta2)
                        A0 B0 C) in H.

          assert(H': S m; (A0 & B0 :: l)
                            ++ Gamma
                            ++ Delta2 |- C)
            by auto.
          rewrite app_assoc in H'.
          apply exchange_subset in H'.
          destruct H' as [m0 [_ H']].
          rewrite <- app_assoc in H'.
          exists m0; auto.

      (* RH is WithL2 -- MAY REDUCE *)
      - apply element_in_app_head in HeqCF.
        destruct HeqCF as [Left | Right].

        + destruct Left as [t1 [t2 t3]].
          inversion t2.

        (* Commute *)
        + destruct Right as [l t].
          subst.

          assert (eq: (A0 & B0 :: l)
                        ++ [A # B] ++ Delta2 =
                      Delta1 ++ A # B :: Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear backup.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          apply (OplusR1 n Gamma A B) in LH.
          apply (IHl (S n + n0) eq1
                     (S n) n0 eq2
                     C
                     Gamma
                     (B0::l) Delta2 LH) in RH.
          destruct RH as [z H].
          clear LH. clear eq1. clear eq2.

          rewrite app_assoc in H.
          apply exchange_subset in H.
          destruct H as [m [ _ H]].
          rewrite <- app_assoc in H.
          simpl in *.
          apply (WithL2 m (l ++ Gamma ++ Delta2)
                        A0 B0 C) in H.

          assert(H': S m; (A0 & B0 :: l)
                            ++ Gamma
                            ++ Delta2 |- C)
            by auto.
          rewrite app_assoc in H'.
          apply exchange_subset in H'.
          destruct H' as [m0 [_ H']].
          rewrite <- app_assoc in H'.
          exists m0; auto.

      (* RH is WithR *)
      - subst.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1 (S n) n0 eq2).
        clear IHA1. clear IHA2.
        clear eq1. clear eq2.

        apply (OplusR1 n Gamma A B) in LH.
        apply (IHl A0 Gamma Delta1 Delta2 LH) in RH1.
        apply (IHl B0 Gamma Delta1 Delta2 LH) in RH2.
        clear LH. clear IHl.

        destruct RH1 as [z1 RH1].
        destruct RH2 as [z2 RH2].

        apply (level_depth
                 z1 (Gamma ++ Delta1 ++ Delta2) A0
                 z2 (Gamma ++ Delta1 ++ Delta2) B0
                 RH1) in RH2.
        clear RH1.
        destruct RH2 as [k [H1 H2]].

        apply (WithR k (Gamma ++ Delta1 ++ Delta2)
                     A0 B0 H1) in H2.
        exists (S k); auto.

      (* RH is OplusL *)
      - subst.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1
                        (S n) n0 eq2 C Gamma).
        clear eq1. clear eq2.

        apply element_in_app_head in HeqCF.
        {
          destruct HeqCF as [L | R].

          (* Reduce *)
          - destruct L as [t1 [t2 t3]].
            inversion t2.
            subst. clear backup. clear t2.
            clear IHl.

            assert(RH1': n0;
                   [] ++ [A] ++ Delta2 |- C)
              by auto.
            apply (IHA1 n n0 C Gamma
                        [] Delta2 LH) in RH1'.
            destruct RH1' as [z1 H1].
            exists z1; auto.

          (* Commute *)
          - destruct R as [l t].
            subst.
            assert (eq: (A0 # B0 :: l)
                          ++ [A # B] ++ Delta2 =
                        Delta1
                          ++ A # B :: Delta2) by auto.
            apply app_inv_tail in eq.
            subst. clear backup.

            apply (OplusR1 n Gamma A B) in LH.
            apply (IHl (A0::l) Delta2 LH) in RH1.
            apply (IHl (B0::l) Delta2 LH) in RH2.
            clear LH.
            destruct RH1 as [z1 RH1].
            destruct RH2 as [z2 RH2].
            rewrite app_assoc in *.
            apply exchange_subset in RH1.
            apply exchange_subset in RH2.
            destruct RH1 as [m1 [_ RH1]].
            destruct RH2 as [m2 [_ RH2]].
            rewrite <- app_assoc in *.

            apply (level_depth
                     m1 (A0:: l ++ Gamma ++ Delta2) C
                     m2 (B0:: l ++ Gamma ++ Delta2) C
                     RH1) in RH2.
            clear RH1.
            destruct RH2 as [k [H1 H2]].

            apply (OplusL k (l ++ Gamma ++ Delta2)
                          A0 B0 C H1) in H2.

            assert (eq: S k; ((A0 # B0 :: l)
                                ++ Gamma)
                               ++ Delta2 |- C)
              by (repeat rewrite <- app_assoc in *; auto).

            apply exchange_subset in eq.
            destruct eq as [m [_ H]].
            rewrite <- app_assoc in *.

            exists m; auto.
        }

      (* RH is OplusR1 *)
      - subst.
        clear IHA1. clear IHA2.

        apply (OplusR1 n Gamma A B) in LH.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (IHl (S n + n0) eq1
                   (S n) n0 eq2
                   A0
                   Gamma
                   Delta1 Delta2 LH) in RH.
        destruct RH as [z RH]. clear LH.
        clear eq1. clear eq2.

        exists (S z); constructor; auto.

      (* RH is OplusR2 *)
      - subst.
        clear IHA1. clear IHA2.

        apply (OplusR1 n Gamma A B) in LH.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (IHl (S n + n0) eq1
                   (S n) n0 eq2
                   B0
                   Gamma
                   Delta1 Delta2 LH) in RH.
        destruct RH as [z RH]. clear LH.
        clear eq1. clear eq2.

        exists (S z).
        apply OplusR2; auto.

      (* RH is Perm *)
      - clear IHA1. clear IHA2.

        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1
                        (S n) n0 eq2 C Gamma).
        clear eq1. clear eq2.

        apply elements_in_app in HeqCF.

        { destruct HeqCF as [First | Remaining].

          (* First *)
          - destruct First as [_ [l t]].
            subst.
            assert (eq: (Delta1 ++ [A # B])
                          ++ l ++ B0 :: A0 :: Delta =
                        (Delta1 ++ [A # B]) ++ Delta2)
              by (repeat rewrite <- app_assoc in *; auto).

            apply app_inv_head in eq.
            subst. clear backup.

            repeat rewrite <- app_assoc in RH.

            apply (OplusR1 n Gamma A B) in LH.
            apply (IHl Delta1
                       (l ++ [A0] ++ [B0] ++ Delta)
                       LH)
              in RH.
            destruct RH as [z H].
            rewrite app_assoc in H.
            rewrite app_assoc in H.

            apply (Perm z ((Gamma ++ Delta1) ++ l)
                        Delta A0 B0 C) in H.
            repeat rewrite <- app_assoc in *.

            exists (S z); auto.

          - destruct Remaining as [Second | Remaining].

            (* Second *)
            + destruct Second as [t1 [t2 t3]].
              subst. clear backup.
              rewrite app_assoc in RH.
              apply (OplusR1 n Gamma A B) in LH.
              apply (IHl (Delta1 ++ [A0])
                         Delta LH) in RH.
              destruct RH as [z H].
              rewrite <- app_assoc in *.
              exists z; auto.

            + destruct Remaining as [Third | Fourth].

              * destruct Third as [t1 [t2 t3]].
                subst. clear backup.
                apply (OplusR1 n Gamma A B) in LH.
                apply (IHl Gamma0 ([B0] ++ Delta2)
                           LH) in RH.
                destruct RH as [z H].
                rewrite <- app_assoc.
                exists z; auto.

              * destruct Fourth as [_ [l t]].
                subst.
                assert (eq: (Gamma0
                              ++ B0 :: A0 :: l)
                              ++ A # B::Delta2 =
                                     Delta1
                                       ++ A # B :: Delta2)
                  by (repeat rewrite <- app_assoc in *;
                      auto).
                apply app_inv_tail in eq.
                subst. clear backup.

                rewrite app_assoc in RH.
                rewrite app_assoc in RH.
                rewrite app_assoc in RH.
                apply (OplusR1 n Gamma A B) in LH.
                apply (IHl
                         (((Gamma0 ++ [A0]) ++ [B0]) ++ l)
                         Delta2
                         LH) in RH.
                destruct RH as [z H].
                repeat rewrite <- app_assoc in *.
                rewrite app_assoc in *.
                apply (Perm z
                            (Gamma ++ Gamma0)
                            (l ++ Delta2)
                            A0 B0 C) in H.
                exists (S z); auto.
        }
    }

  (* LH is OplusR2 *)
  * inversion HeqcutF.
    subst. clear HeqcutF.
    intros RH.
    remember (Delta1 ++ [A # B] ++ Delta2) as CF.
    inversion HeqCF as [backup].

    {
      destruct RH.

      (* RH = OneL *)
      - clear IHA1. clear IHA2.
        apply element_in_app_head in HeqCF.
        destruct HeqCF as [[t1 [t2 t3]] | [l t]].
        * discriminate.
        * subst.
          assert (eq:
                    (One :: l) ++ [A # B] ++ Delta2 =
                    Delta1 ++ [A # B] ++ Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear backup.

          apply (OplusR2 n Gamma A B) in LH.
          assert (eq1 : S n + n0 < S n + S n0)
            by omega.
          assert (eq2 : S n + n0 = S n + n0)
            by omega.
          specialize (IHl ((S n) + n0)
                          eq1 (S n) n0 eq2 A0
                          Gamma l
                          Delta2 LH RH
                     ).
          destruct IHl as [z IHl].
          clear eq1. clear eq2. clear LH. clear RH.

          apply (OneL z (Gamma ++ l ++ Delta2) A0)
            in IHl.

          assert (eq: S z;
                  ([One] ++ Gamma)
                    ++ l ++ Delta2 |- A0)
            by auto.

          apply exchange_subset in eq.
          destruct eq as [m [ _ H]].

          assert (eq: m;
                  Gamma ++ ([One] ++ l)
                        ++ Delta2 |- A0)
            by (repeat rewrite <- app_assoc in *;
                auto).

          exists m; auto.

      (* RH is OneR *)
      - simpl in *.
        apply app_cons_not_nil in HeqCF.
        destruct HeqCF.

      (* RH is Atom *)
      - apply app_singleton in HeqCF.
        destruct HeqCF as [t1 [t2 t3]].
        subst.

        exists (S n).
        rewrite app_nil_r.
        apply (OplusR2 n Gamma A B); auto.

      (* RH is TensorL *)
      - inversion HeqCF.
        apply element_in_app_head in HeqCF.

        destruct HeqCF as [Left | Right].

        * destruct Left as [t1 [t2 t3]].
          discriminate.

        * destruct Right as [l H].
          subst.
          assert (eq: (A0 ** B0 :: l)
                        ++ [A # B] ++ Delta2 =
                      Delta1 ++ [A # B] ++ Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          apply (OplusR2 n Gamma A B) in LH.
          specialize (IHl (S n + n0) eq1 (S n) n0 eq2
                          C Gamma
                          (A0::B0::l)
                          Delta2 LH RH).
          clear eq1. clear eq2. clear RH. clear LH.

          destruct IHl as [z H].

          rewrite app_assoc in H.
          apply exchange_subset in H.
          destruct H as [m [ _ H]].

          assert( eq: m;
                  [A0] ++ [B0]
                       ++ l ++ Gamma ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto).
          simpl in eq.

          apply (TensorL m (l ++ Gamma
                              ++ Delta2) A0 B0 C)
            in eq.

          assert (eq': S m;
                  ((A0 ** B0 :: l) ++ Gamma)
                    ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto).

          apply exchange_subset in eq'.
          destruct eq' as [k [ _ Final]].
          rewrite <- app_assoc in Final.

          exists k; auto.

      (* RH is TensorR *)
      - (* cleaning *)
        clear IHA1. clear IHA2.

        (* some pre-processing *)
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1 (S n) n0 eq2).
        clear eq1. clear eq2.

        (* We go by cases, since *)
        (* A & B could be in RH1 or RH2 *)
        apply element_in_app in HeqCF.
        {
          destruct HeqCF as [inEnv1 | inEnv2].

          (* on the left *)
          - destruct inEnv1 as [t1 [t2 [l t3]]].
            subst. clear t1. clear t2.

            (* one more infere&substitute *)
            assert (eq: (Delta1 ++ [A # B]) ++ (l ++ env2) =
                        (Delta1 ++ [A # B]) ++ Delta2).
            { repeat rewrite <- app_assoc in *. auto. }
            apply app_inv_head in eq. subst. clear backup.

            apply (OplusR2 n Gamma A B) in LH.
            specialize (IHl A0 Gamma Delta1 l LH RH1).
            clear LH. clear RH1.
            destruct IHl as [z LH].

            apply (level_depth z (Gamma ++ Delta1 ++ l) A0
                               n0 env2 B0 LH) in RH2.
            clear LH.
            destruct RH2 as [k [LH RH]].

            exists (S k).
            rewrite app_assoc.
            rewrite app_assoc.
            constructor;
              [rewrite <- app_assoc; auto | auto].

          (* on the right *)
          - destruct inEnv2 as [t1 [t2 [l t3]]].
            subst. clear t1. clear t2.

            (* one more infere&substitute *)
            assert (eq: (env1 ++ l) ++ ([A # B] ++ Delta2) =
                        Delta1 ++ (A # B :: Delta2))
              by (repeat rewrite <- app_assoc in *; auto).
            apply app_inv_tail in eq. subst.
            clear backup.

            apply (OplusR2 n Gamma A B) in LH.
            specialize (IHl B0 Gamma l Delta2 LH RH2).
            clear LH. clear RH2.
            destruct IHl as [z LH].

            apply (level_depth z (Gamma ++ l ++ Delta2) B0
                               n0 env1 A0 LH) in RH1.
            clear LH.
            destruct RH1 as [k [RH LH]].

            pose proof (TensorR k env1 A0
                                (Gamma ++ l ++ Delta2) B0
                                LH RH).
            assert (eq: S k; (env1 ++ Gamma) ++ l ++ Delta2
                           |- (A0 ** B0))
              by (rewrite <- app_assoc; auto ).
            apply exchange_subset in eq.
            destruct eq as [m [temp final]]. clear temp.
            exists m.
            repeat rewrite <- app_assoc in *; auto.
        }

        (* RH is LolliL *)
      - inversion HeqCF.
        subst.
        (* we need to proceed by cases *)
        assert (eq: (A0 -o B0 :: env1) ++ env2 =
                    Delta1 ++ [A # B] ++ Delta2) by auto.
        apply element_in_app in eq.
        {
          destruct eq as [inLeft | inRight].

          (* on the left *)
          - destruct inLeft as [t1 [t2 [l t3]]].
            clear t1. clear t2.

            (* we have two more cases: reduce or commute *)
            assert (eq: [A0 -o B0] ++ env1 =
                        Delta1 ++ [A # B] ++ l) by auto.
            apply element_in_app in eq.

            {
              destruct eq as [reduction | commute].

              (* reduction case *)
              - destruct reduction as [_ [_ [l' t]]].
              apply app_singleton in t.
              destruct t as [t1 [t2 t4]].
              discriminate.

              (* commute case *)
              - destruct commute as [t1 [t2 [l' t4]]].
                clear t1. clear t2. clear IHA1. clear IHA2.

                (* some substitutions *)
                subst.
                assert (eq: (A0 -o B0 :: l')
                              ++ ([A # B] ++ l) =
                            Delta1 ++ ([A # B] ++ l))
                  by auto.
                apply app_inv_tail in eq.
                subst. clear t3.
                assert (eq: ([A0 -o B0]
                               ++ l'
                               ++ [A # B])
                              ++ l ++ env2 =
                            ([A0 -o B0] ++ l' ++ [A # B])
                              ++ Delta2).
                { repeat rewrite <- app_assoc in *. auto. }
                apply app_inv_head in eq.
                subst. clear HeqCF. clear H0.

                assert (eq1: S n + n0 < S n + S n0)
                  by omega.
                apply (OplusR2 n Gamma A B) in LH.
                assert (eq2: S n + n0 = S n + n0) by omega.
                specialize (IHl (S n + n0) eq1
                                (S n) n0 eq2
                                A0 Gamma l' l LH RH1).
                clear eq1. clear eq2. clear LH. clear RH1.
                destruct IHl as [z Last].

                apply (level_depth z (Gamma ++ l' ++ l) A0
                                   n0 (B0::env2) C Last)
                  in RH2.

                destruct RH2 as [k [First Second]].
                pose proof (LolliL k (Gamma ++ l' ++ l)
                                   A0
                                   env2 B0 C First Second).

                assert(eq: S k; [] ++ [A0 -o B0] ++ Gamma
                                   ++ l' ++ l ++ env2 |- C).
                { simpl in *.
                  repeat rewrite <- app_assoc in *.
                  auto. }

                apply exchange_with_env_r in eq.

                exists (S k + length Gamma); auto.
            }

          (* on the right *)
          - destruct inRight as [t1 [t2 [l t3]]].
            clear t1. clear t2. clear IHA1. clear IHA2.

            (* first some subst, to simplify *)
            subst.
            assert (eq: (A0 -o B0 :: env1 ++ l)
                          ++ (A # B :: Delta2)
                        =
                        Delta1 ++ (A # B :: Delta2)).
            { simpl in *.
              repeat rewrite <- app_assoc in *. auto. }
            apply app_inv_tail in eq.
            subst. clear HeqCF.

            assert (eq1: S n + n0 < S n + S n0) by omega.
            assert (eq2: S n + n0 = S n + n0) by omega.
            apply (OplusR2 n Gamma A B) in LH.
            specialize (IHl (S n + n0) eq1
                            (S n) n0 eq2
                            C Gamma (B0::l) Delta2 LH RH2).
            clear eq1. clear eq2. clear LH. clear RH2.
            destruct IHl as [z Last].

            assert (eq1: z; [] ++ Gamma ++ [B0]
                               ++ l ++ Delta2 |- C)
              by auto.

            apply exchange_with_env_l in eq1.
            simpl in eq1.
            apply (level_depth
                     (z + length Gamma)
                     (B0 :: Gamma ++ l ++ Delta2) C
                     n0 env1 A0 eq1) in RH1.
            clear eq1. clear Last.

            destruct RH1 as [k [RH LH]].

            pose proof (LolliL k env1 A0
                               (Gamma ++ l ++ Delta2) B0 C
                               LH RH).

            assert (eq1: S k; (([A0 -o B0] ++ env1)
                                 ++ Gamma) ++ l ++ Delta2
                              |- C).
            { repeat rewrite <- app_assoc in *.
              simpl. auto. }

            apply exchange_subset in eq1.
            destruct eq1 as [m [temp Final]].

            exists m.

            assert (eq1:  m; Gamma
                               ++ ([A0 -o B0] ++ env1 ++ l)
                               ++ Delta2 |- C).
            { repeat rewrite <- app_assoc in *. auto. }

            simpl in *; auto.
        }

      (* RH is LolliR *)
      - subst. clear IHA1. clear IHA2.

        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (OplusR2 n Gamma A B) in LH.
        apply (IHl (S n + n0) eq1
                   (S n) n0 eq2
                   B0
                   Gamma
                   (A0::Delta1) Delta2 LH) in RH.
        destruct RH as [z RH]. clear LH.
        clear eq1. clear eq2.

        rewrite app_assoc in RH.
        apply exchange_subset in RH.
        destruct RH as [m [ _  H]].
        rewrite <- app_assoc in H.
        simpl in *.
        apply (LolliR m (Delta1 ++ Gamma ++ Delta2) A0 B0)
          in H.
        rewrite app_assoc in H.
        apply exchange_subset in H.
        destruct H as [m0 [_ H]].
        rewrite <- app_assoc in H.
        exists m0; auto.

      (* RH is WithL1 -- MAY REDUCE *)
      - apply element_in_app_head in HeqCF.
        destruct HeqCF as [Left | Right].

        + destruct Left as [t1 [t2 t3]].
          inversion t2.

        + destruct Right as [l t].
          subst.

          assert (eq: (A0 & B0 :: l)
                        ++ [A # B] ++ Delta2 =
                      Delta1 ++ A # B :: Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear backup.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          apply (OplusR2 n Gamma A B) in LH.
          apply (IHl (S n + n0) eq1
                     (S n) n0 eq2
                     C
                     Gamma
                     (A0::l) Delta2 LH) in RH.
          destruct RH as [z H].
          clear LH. clear eq1. clear eq2.

          rewrite app_assoc in H.
          apply exchange_subset in H.
          destruct H as [m [ _ H]].
          rewrite <- app_assoc in H.
          simpl in *.
          apply (WithL1 m (l ++ Gamma ++ Delta2)
                        A0 B0 C) in H.

          assert(H': S m; (A0 & B0 :: l)
                            ++ Gamma
                            ++ Delta2 |- C)
            by auto.
          rewrite app_assoc in H'.
          apply exchange_subset in H'.
          destruct H' as [m0 [_ H']].
          rewrite <- app_assoc in H'.
          exists m0; auto.

      (* RH is WithL2 -- MAY REDUCE *)
      - apply element_in_app_head in HeqCF.
        destruct HeqCF as [Left | Right].

        + destruct Left as [t1 [t2 t3]].
          inversion t2.

        (* Commute *)
        + destruct Right as [l t].
          subst.

          assert (eq: (A0 & B0 :: l)
                        ++ [A # B] ++ Delta2 =
                      Delta1 ++ A # B :: Delta2)
            by auto.
          apply app_inv_tail in eq.
          subst. clear backup.

          assert (eq1: S n + n0 < S n + S n0) by omega.
          assert (eq2: S n + n0 = S n + n0) by omega.
          apply (OplusR2 n Gamma A B) in LH.
          apply (IHl (S n + n0) eq1
                     (S n) n0 eq2
                     C
                     Gamma
                     (B0::l) Delta2 LH) in RH.
          destruct RH as [z H].
          clear LH. clear eq1. clear eq2.

          rewrite app_assoc in H.
          apply exchange_subset in H.
          destruct H as [m [ _ H]].
          rewrite <- app_assoc in H.
          simpl in *.
          apply (WithL2 m (l ++ Gamma ++ Delta2)
                        A0 B0 C) in H.

          assert(H': S m; (A0 & B0 :: l)
                            ++ Gamma
                            ++ Delta2 |- C)
            by auto.
          rewrite app_assoc in H'.
          apply exchange_subset in H'.
          destruct H' as [m0 [_ H']].
          rewrite <- app_assoc in H'.
          exists m0; auto.

      (* RH is WithR *)
      - subst.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1 (S n) n0 eq2).
        clear IHA1. clear IHA2.
        clear eq1. clear eq2.

        apply (OplusR2 n Gamma A B) in LH.
        apply (IHl A0 Gamma Delta1 Delta2 LH) in RH1.
        apply (IHl B0 Gamma Delta1 Delta2 LH) in RH2.
        clear LH. clear IHl.

        destruct RH1 as [z1 RH1].
        destruct RH2 as [z2 RH2].

        apply (level_depth
                 z1 (Gamma ++ Delta1 ++ Delta2) A0
                 z2 (Gamma ++ Delta1 ++ Delta2) B0
                 RH1) in RH2.
        clear RH1.
        destruct RH2 as [k [H1 H2]].

        apply (WithR k (Gamma ++ Delta1 ++ Delta2)
                     A0 B0 H1) in H2.
        exists (S k); auto.

      (* RH is OplusL *)
      - subst.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1
                        (S n) n0 eq2 C Gamma).
        clear eq1. clear eq2.

        apply element_in_app_head in HeqCF.
        {
          destruct HeqCF as [L | R].

          (* Reduce *)
          - destruct L as [t1 [t2 t3]].
            inversion t2.
            subst. clear backup. clear t2.
            clear IHl.

            assert(RH2': n0;
                   [] ++ [B] ++ Delta2 |- C)
              by auto.
            apply (IHA2 n n0 C Gamma
                        [] Delta2 LH) in RH2'.
            destruct RH2' as [z1 H1].
            exists z1; auto.

          (* Commute *)
          - destruct R as [l t].
            subst.
            assert (eq: (A0 # B0 :: l)
                          ++ [A # B] ++ Delta2 =
                        Delta1
                          ++ A # B :: Delta2) by auto.
            apply app_inv_tail in eq.
            subst. clear backup.

            apply (OplusR2 n Gamma A B) in LH.
            apply (IHl (A0::l) Delta2 LH) in RH1.
            apply (IHl (B0::l) Delta2 LH) in RH2.
            clear LH.
            destruct RH1 as [z1 RH1].
            destruct RH2 as [z2 RH2].
            rewrite app_assoc in *.
            apply exchange_subset in RH1.
            apply exchange_subset in RH2.
            destruct RH1 as [m1 [_ RH1]].
            destruct RH2 as [m2 [_ RH2]].
            rewrite <- app_assoc in *.

            apply (level_depth
                     m1 (A0:: l ++ Gamma ++ Delta2) C
                     m2 (B0:: l ++ Gamma ++ Delta2) C
                     RH1) in RH2.
            clear RH1.
            destruct RH2 as [k [H1 H2]].

            apply (OplusL k (l ++ Gamma ++ Delta2)
                          A0 B0 C H1) in H2.

            assert (eq: S k; ((A0 # B0 :: l)
                                ++ Gamma)
                               ++ Delta2 |- C)
              by (repeat rewrite <- app_assoc in *; auto).

            apply exchange_subset in eq.
            destruct eq as [m [_ H]].
            rewrite <- app_assoc in *.

            exists m; auto.
        }

      (* RH is OplusR1 *)
      - subst.
        clear IHA1. clear IHA2.

        apply (OplusR2 n Gamma A B) in LH.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (IHl (S n + n0) eq1
                   (S n) n0 eq2
                   A0
                   Gamma
                   Delta1 Delta2 LH) in RH.
        destruct RH as [z RH]. clear LH.
        clear eq1. clear eq2.

        exists (S z); constructor; auto.

      (* RH is OplusR2 *)
      - subst.
        clear IHA1. clear IHA2.

        apply (OplusR2 n Gamma A B) in LH.
        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        apply (IHl (S n + n0) eq1
                   (S n) n0 eq2
                   B0
                   Gamma
                   Delta1 Delta2 LH) in RH.
        destruct RH as [z RH]. clear LH.
        clear eq1. clear eq2.

        exists (S z).
        apply OplusR2; auto.

      (* RH is Perm *)
      - clear IHA1. clear IHA2.

        assert (eq1: S n + n0 < S n + S n0) by omega.
        assert (eq2: S n + n0 = S n + n0) by omega.
        specialize (IHl (S n + n0) eq1
                        (S n) n0 eq2 C Gamma).
        clear eq1. clear eq2.

        apply elements_in_app in HeqCF.

        { destruct HeqCF as [First | Remaining].

          (* First *)
          - destruct First as [_ [l t]].
            subst.
            assert (eq: (Delta1 ++ [A # B])
                          ++ l ++ B0 :: A0 :: Delta =
                        (Delta1 ++ [A # B]) ++ Delta2)
              by (repeat rewrite <- app_assoc in *; auto).

            apply app_inv_head in eq.
            subst. clear backup.

            repeat rewrite <- app_assoc in RH.

            apply (OplusR2 n Gamma A B) in LH.
            apply (IHl Delta1
                       (l ++ [A0] ++ [B0] ++ Delta)
                       LH)
              in RH.
            destruct RH as [z H].
            rewrite app_assoc in H.
            rewrite app_assoc in H.

            apply (Perm z ((Gamma ++ Delta1) ++ l)
                        Delta A0 B0 C) in H.
            repeat rewrite <- app_assoc in *.

            exists (S z); auto.

          - destruct Remaining as [Second | Remaining].

            (* Second *)
            + destruct Second as [t1 [t2 t3]].
              subst. clear backup.
              rewrite app_assoc in RH.
              apply (OplusR2 n Gamma A B) in LH.
              apply (IHl (Delta1 ++ [A0])
                         Delta LH) in RH.
              destruct RH as [z H].
              rewrite <- app_assoc in *.
              exists z; auto.

            + destruct Remaining as [Third | Fourth].

              * destruct Third as [t1 [t2 t3]].
                subst. clear backup.
                apply (OplusR2 n Gamma A B) in LH.
                apply (IHl Gamma0 ([B0] ++ Delta2)
                           LH) in RH.
                destruct RH as [z H].
                rewrite <- app_assoc.
                exists z; auto.

              * destruct Fourth as [_ [l t]].
                subst.
                assert (eq: (Gamma0
                              ++ B0 :: A0 :: l)
                              ++ A # B::Delta2 =
                                     Delta1
                                       ++ A # B :: Delta2)
                  by (repeat rewrite <- app_assoc in *;
                      auto).
                apply app_inv_tail in eq.
                subst. clear backup.

                rewrite app_assoc in RH.
                rewrite app_assoc in RH.
                rewrite app_assoc in RH.
                apply (OplusR2 n Gamma A B) in LH.
                apply (IHl
                         (((Gamma0 ++ [A0]) ++ [B0]) ++ l)
                         Delta2
                         LH) in RH.
                destruct RH as [z H].
                repeat rewrite <- app_assoc in *.
                rewrite app_assoc in *.
                apply (Perm z
                            (Gamma ++ Gamma0)
                            (l ++ Delta2)
                            A0 B0 C) in H.
                exists (S z); auto.
        }
    }

  (* LH is Perm *)
  * intros.
    clear IHA1. clear IHA2.
    assert (eq1: n + m < l) by omega.
    assert (eq2: n + m = n + m) by omega.
    specialize (IHl (n + m) eq1 n m eq2
                    C (Gamma ++ [A0] ++ [B0] ++ Delta)
                    Delta1 Delta2
                    LH
                    H
               ).
    destruct IHl as [z Hyp].
    exists (S z).
    repeat rewrite <- app_assoc in *.
    constructor; auto.
Qed.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import ssreflect Program Lia BinPos Arith.Compare_dec Bool.
From MetaCoq.Template Require Import utils LibHypsNaming.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICSize PCUICInduction.
From Coq Require Import List.
From Equations Require Import Equations.
From Equations.Prop Require Import Subterm.
Import PCUICEnvTyping.

Definition def_depth_gen (depth : term -> nat) (x : def term)
  := max (depth (dtype x)) (depth (dbody x)).

Definition list_depth_gen {A} (depth : A -> nat) :=
  fix list_depth (l : list A) : nat :=
    match l with
    | [] => 0
    | a :: v => (max (depth a) (list_depth v))
    end.

Definition mfixpoint_depth_gen (depth : term -> nat) (l : mfixpoint term) :=
  list_depth_gen (def_depth_gen depth) l.

Definition decl_depth_gen (depth : term -> nat) (x : context_decl) :=
  max (depth (decl_type x)) (option_default depth (decl_body x) 0).

Definition context_depth_gen (depth : term -> nat) (l : context) :=
  list_depth_gen (decl_depth_gen depth) l.

Definition branch_depth_gen (depth : term -> nat) p (br : branch term) :=
  let pard := list_depth_gen depth p.(pparams) in
  let bctxd := context_depth_gen depth br.(bcontext) in
  max (pard + bctxd) (depth br.(bbody)).

Definition predicate_depth_gen (depth : term -> nat) (p : PCUICAst.predicate term) :=
  let pard := list_depth_gen depth p.(pparams) in
  let pctxd := context_depth_gen depth p.(pcontext) in
    max (pard + pctxd) (depth p.(preturn)).

Fixpoint depth t : nat :=
  match t with
  | tRel i => 1
  | tEvar ev args => S (list_depth_gen depth args)
  | tLambda na T M => S (max (depth T) (depth M))
  | tApp u v => S (max (depth u) (depth v))
  | tProd na A B => S (max (depth A) (depth B))
  | tLetIn na b t b' => S (max (depth b) (max (depth t) (depth b')))
  | tCase ind p c brs => S (max (predicate_depth_gen depth p)
    (max (depth c) (list_depth_gen (branch_depth_gen depth p) brs)))
  | tProj p c => S (depth c)
  | tFix mfix idx => S (mfixpoint_depth_gen depth mfix)
  | tCoFix mfix idx => S (mfixpoint_depth_gen depth mfix)
  | _ => 1
  end.

Notation context_depth := (context_depth_gen depth).
Notation list_depth := (list_depth_gen depth).
Notation mfixpoint_depth := (mfixpoint_depth_gen depth).

Lemma depth_mkApps f l : max (depth f) (list_depth l) <= depth (mkApps f l).
Proof.
  induction l in f |- *; simpl; try lia.
  specialize (IHl (tApp f a)).
  cbn -[max] in IHl.
  etransitivity; tea.
  lia.
Qed.

Lemma mfixpoint_depth_In {mfix d} :
  In d mfix ->
  depth (dbody d) <= mfixpoint_depth mfix /\
  depth (dtype d) <= mfixpoint_depth mfix.
Proof.
  induction mfix in d |- *; simpl; auto.
  move=> [->|H]. unfold def_depth_gen. split; try lia.
  destruct (IHmfix d H). split; lia.
Qed.

Lemma mfixpoint_depth_nth_error {mfix i d} :
  nth_error mfix i = Some d ->
  depth (dbody d) <= mfixpoint_depth mfix.
Proof.
  induction mfix in i, d |- *; destruct i; simpl; try congruence.
  move=> [] ->. unfold def_depth_gen. lia.
  move/IHmfix. lia.
Qed.

Lemma nth_error_depth {A} (f : A -> nat) {l : list A} {n x} :
  nth_error l n = Some x ->
  f x <= list_depth_gen f l.
Proof.
  induction l in n |- *; destruct n; simpl => //; auto.
  - intros [= <-]. lia.
  - intros hnth. specialize (IHl _ hnth). lia.
Qed.

Lemma map_depth_hom {A} {depth : A -> nat} {l : list A} {f : A -> A} :
  (forall x : A, depth (f x) = depth x) ->
  list_depth_gen depth (map f l) = list_depth_gen depth l.
Proof.
  intros Hf.
  revert l.
  fix aux 1. destruct l. simpl; auto. simpl.
  f_equal. apply Hf. apply aux.
Defined.

Lemma depth_lift n k t : depth (lift n k t) = depth t.
Proof.
  revert n k t.
  fix aux 3.
  destruct t; simpl; try rewrite map_depth_hom; try lia.
  all:try now rewrite !aux.
  all:try intros; auto.
  - destruct x. simpl. unfold branch_depth_gen; cbn.
    f_equal. apply aux.
  - f_equal. f_equal.
    rewrite /predicate_depth_gen /=. f_equal.
    f_equal. exact (map_depth_hom (aux n k)).
    apply aux.
    f_equal. apply aux.
    revert brs.
    fix aux' 1. destruct brs; simpl; trivial.
    f_equal. 2:apply aux'.
    rewrite /branch_depth_gen /=.
    f_equal. f_equal. apply (map_depth_hom (aux n k)).
  - unfold mfixpoint_depth_gen.
    f_equal.
    apply map_depth_hom. intros.
    simpl. destruct x. simpl. unfold def_depth_gen. simpl.
    f_equal; apply aux.
  - unfold mfixpoint_depth_gen.
    f_equal.
    apply map_depth_hom. intros.
    simpl. destruct x. simpl. unfold def_depth_gen. simpl.
    f_equal; apply aux.
Qed.

Lemma All_depth {s l} k :
  All (fun x => forall k, depth (subst s k x) <= depth x + list_depth s) l ->
  list_depth (map (subst s k) l) <= list_depth l + list_depth s.
Proof.
  intros a. revert k. induction a; simpl; auto; intros; try lia.
  specialize (p k); specialize (IHa k). lia.
Qed.

Lemma depth_subst s k t : depth (subst s k t) <= depth t + list_depth s.
Proof.
  induction t in k |- * using term_forall_list_ind; simpl; auto; try lia.
  - destruct Nat.leb. destruct nth_error eqn:hnth.
    eapply (nth_error_depth depth) in hnth.
    rewrite depth_lift. lia. simpl. lia.
    simpl. lia.
  - eapply (All_depth k) in X. lia.
  - specialize (IHt1 k); specialize (IHt2 (S k)); lia.
  - specialize (IHt1 k); specialize (IHt2 (S k)); lia.
  - specialize (IHt1 k); specialize (IHt2 k); specialize (IHt3 (S k)); lia.
  - specialize (IHt1 k); specialize (IHt2 k); lia.
  - destruct X as [? [? ?]].
    rewrite /predicate_depth_gen /=.
    eapply (All_depth k) in a.
    assert ((list_depth (map (subst s k) (pparams p)) +
        context_depth (pcontext p)) <=
      (list_depth (pparams p) + context_depth (pcontext p) + list_depth s)) by lia.
    specialize (IHt k).
    assert (list_depth_gen (branch_depth_gen depth (map_predicate_k id (subst s) k p)) (map_branches_k (subst s) id k l) <=
        (list_depth_gen (branch_depth_gen depth p) l) + list_depth s).
    { clear -a X0 k. induction X0; simpl; auto; try lia.
      destruct p0. specialize (l0 (#|bcontext x| + k)).
      rewrite {1 3}/branch_depth_gen /= /id. rewrite /id in IHX0. lia. }
    specialize (l0 (#|pcontext p| + k)).
    assert ((list_depth (map (subst s k) (pparams p)) + context_depth (pcontext p)) <=
      (list_depth (pparams p) + context_depth (pcontext p) + list_depth s)) by lia.
    lia.
  - specialize (IHt k). lia.
  - rewrite /mfixpoint_depth_gen. generalize #|m|.
    induction X in k |- *; simpl; auto; try lia.
    destruct p. intros n'.
    rewrite {1 3}/def_depth_gen /=.
    specialize (l0 k).
    specialize (l1 (n' + k)). simpl in l1.
    specialize (IHX k n'). lia.
  - rewrite /mfixpoint_depth_gen. generalize #|m|.
    induction X in k |- *; simpl; auto; try lia.
    destruct p. intros n'.
    rewrite {1 3}/def_depth_gen /=.
    specialize (l0 k).
    specialize (l1 (n' + k)). simpl in l1.
    specialize (IHX k n'). lia.
Qed.

Lemma depth_subst_instance u t : depth (subst_instance u t) = depth t.
Proof.
  revert t.
  fix aux 1.
  destruct t; simpl; try rewrite map_depth_hom; try lia; tas.
  all:try rewrite !aux //.
  - destruct x. simpl. unfold branch_depth_gen; cbn.
    f_equal. apply aux.
  - f_equal. f_equal.
    rewrite /predicate_depth_gen /=. f_equal.
    f_equal. exact (map_depth_hom aux).
    apply aux.
    f_equal. rewrite /branch_depth_gen /=.
    revert brs.
    fix aux' 1. destruct brs; simpl; auto.
    f_equal; auto. f_equal. f_equal. exact (map_depth_hom aux).
  - unfold mfixpoint_depth_gen.
    f_equal.
    apply map_depth_hom. intros.
    simpl. destruct x. simpl. unfold def_depth_gen. simpl.
    f_equal; apply aux.
  - unfold mfixpoint_depth_gen.
    f_equal.
    apply map_depth_hom. intros.
    simpl. destruct x. simpl. unfold def_depth_gen. simpl.
    f_equal; apply aux.
Qed.

Lemma depth_subst_decl s k d :
  decl_depth_gen depth (subst_decl s k d) <= decl_depth_gen depth d + list_depth s.
Proof.
  destruct d as [na [b|] ty]; rewrite /decl_depth_gen /=.
  pose proof (depth_subst s k ty).
  pose proof (depth_subst s k b). lia.
  pose proof (depth_subst s k ty). lia.
Qed.

Lemma depth_subst_context s k ctx :
  context_depth (subst_context s k ctx) <= context_depth ctx + list_depth s.
Proof.
  induction ctx; simpl; try lia.
  rewrite subst_context_snoc /=.
  pose proof (depth_subst_decl s (#|ctx| + k) a). lia.
Qed.

Lemma depth_subst_instance_context u (ctx : context) : context_depth (subst_instance u ctx) = context_depth ctx.
Proof.
  induction ctx; simpl; auto.
  rewrite IHctx. f_equal.
  rewrite /decl_depth_gen /=.
  destruct decl_body; rewrite /= !depth_subst_instance //.
Qed.

(*Lemma list_depth_mapi_context_hom (depth : context_decl -> nat) (l : context) (f : nat -> term -> term) :
  (forall k x, depth (map_decl (f k) x) = depth x) ->
  list_depth_gen depth (mapi_context f l) = list_depth_gen depth l.
Proof.
  intros.
  revert l.
  fix auxl' 1.
  destruct l; simpl. reflexivity.
  f_equal. f_equal. apply H. apply auxl'.
Defined.*)

Definition onctx_rel (P : context -> term -> Type) (Γ Δ : context) :=
  All_local_env (PCUICInduction.on_local_decl (fun Δ => P (Γ ,,,  Δ))) Δ.

Definition CasePredProp (P : context -> term -> Type) Γ (p : predicate term) :=
  All (P Γ) p.(pparams) × onctx_rel P Γ (inst_case_context p.(pparams) p.(puinst) p.(pcontext)) ×
  P (Γ ,,, inst_case_context p.(pparams) p.(puinst) p.(pcontext)) p.(preturn).

Definition CaseBrsProp p P Γ (brs : list (branch term)) :=
  All (fun x : branch term => onctx_rel P Γ (inst_case_context p.(pparams) p.(puinst) x.(bcontext))
     * P (Γ ,,, inst_case_context p.(pparams) p.(puinst) x.(bcontext)) (bbody x)) brs.

Lemma list_depth_app {A} (depth : A -> nat) (l l' : list A) :
  list_depth_gen depth (l ++ l') = max (list_depth_gen depth l) (list_depth_gen depth l').
Proof.
  induction l; simpl; auto.
  rewrite IHl. lia.
Qed.

Lemma In_list_depth {A : Type} (f : A -> nat) :
  forall x xs, In x xs -> f x < S (list_depth_gen f xs).
Proof.
  intros. induction xs.
  destruct H.
  * destruct H. simpl; subst. lia.
    specialize (IHxs H). simpl. lia.
Qed.

Lemma list_depth_rev {A} (depth : A -> nat) (l : list A) :
  list_depth_gen depth (rev l) = list_depth_gen depth l.
Proof.
  induction l using rev_ind; simpl; auto; try lia.
  rewrite rev_app_distr /= list_depth_app /=. lia.
Qed.

Lemma list_depth_mapi_rec_le {A B} (l : list A) (f : nat -> A -> B) k
  (depthA : A -> nat) (depthB : B -> nat) :
  (forall i x, depthB (f i x) <= depthA x) ->
  list_depth_gen depthB (mapi_rec f l k) <= list_depth_gen depthA l.
Proof.
  intro H. induction l in k |- *. reflexivity.
  simpl. specialize (H k a). specialize (IHl (S k)). lia.
Qed.

Lemma context_depth_inst_case_context pars puinst pctx :
  context_depth (inst_case_context pars puinst pctx) <=
  context_depth pctx + list_depth pars.
Proof.
  rewrite /inst_case_context.
  rewrite -list_depth_rev.
  etransitivity; [eapply depth_subst_context|].
  now rewrite depth_subst_instance_context.
Qed.

Lemma term_forall_ctx_list_ind :
  forall (P : context -> term -> Type),
    (forall Γ (n : nat), P Γ (tRel n)) ->
    (forall Γ (i : ident), P Γ (tVar i)) ->
    (forall Γ (n : nat) (l : list term), All (P Γ) l -> P Γ (tEvar n l)) ->
    (forall Γ s, P Γ (tSort s)) ->
    (forall Γ (n : aname) (t : term), P Γ t -> forall t0 : term, P (vass n t :: Γ) t0 -> P Γ (tProd n t t0)) ->
    (forall Γ (n : aname) (t : term), P Γ t -> forall t0 : term, P (vass n t :: Γ) t0 -> P Γ (tLambda n t t0)) ->
    (forall Γ (n : aname) (t : term),
        P Γ t -> forall t0 : term, P Γ t0 -> forall t1 : term, P (vdef n t t0 :: Γ) t1 -> P Γ (tLetIn n t t0 t1)) ->
    (forall Γ (t u : term),
      (forall t', depth t' < depth (tApp t u) -> P Γ t') ->
      P Γ t -> P Γ u -> P Γ (tApp t u)) ->
    (forall Γ s (u : list Level.t), P Γ (tConst s u)) ->
    (forall Γ (i : inductive) (u : list Level.t), P Γ (tInd i u)) ->
    (forall Γ (i : inductive) (n : nat) (u : list Level.t), P Γ (tConstruct i n u)) ->
    (forall Γ (ci : case_info) (p : predicate term) (t : term) (brs : list (branch term)),
        CasePredProp P Γ p ->
        P Γ t ->
        CaseBrsProp p P Γ brs ->
        P Γ (tCase ci p t brs)) ->
    (forall Γ (s : projection) (t : term), P Γ t -> P Γ (tProj s t)) ->
    (forall Γ (m : mfixpoint term) (n : nat),
        All_local_env (PCUICInduction.on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context m) ->
        tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tFix m n)) ->
    (forall Γ (m : mfixpoint term) (n : nat),
        All_local_env (PCUICInduction.on_local_decl (fun Γ' t => P (Γ ,,, Γ') t)) (fix_context m) ->
        tFixProp (P Γ) (P (Γ ,,, fix_context m)) m -> P Γ (tCoFix m n)) ->
    (forall Γ p, P Γ (tPrim p)) ->
    forall Γ (t : term), P Γ t.
Proof.
  intros ????????????????? Γ t.
  revert Γ t. set(foo:=CoreTactics.the_end_of_the_section). intros.
  Subterm.rec_wf_rel aux t (MR lt depth); unfold MR in *; simpl. clear H1.
  assert (auxl : forall Γ {A} (l : list A) (f : A -> term),
    list_depth_gen (fun x => depth (f x)) l < depth pr0 ->
    All (fun x => P Γ (f x)) l).
  { induction l; try solve [constructor].
    move=> f /= Hdepth.
    constructor.
    * eapply aux => //. red. lia.
    * apply IHl => //. lia. }
  assert (forall mfix, context_depth (fix_context mfix) <= mfixpoint_depth_gen depth mfix).
  { induction mfix. simpl. auto. simpl. unfold fix_context.
    unfold context_depth.
    rewrite /context_depth list_depth_rev /=. cbn.
    rewrite depth_lift. unfold context_depth in IHmfix.
    epose (list_depth_mapi_rec_le mfix
                                 (fun (i : nat) (d : def term) => vass (dname d) ((lift0 i) (dtype d))) 1
                                 (def_depth_gen depth) (decl_depth_gen depth)).
    forward l. intros. destruct x; cbn; rewrite depth_lift. lia.
    rewrite /mfixpoint_depth_gen {1}/def_depth_gen. lia. }
  assert (auxΓ : forall Γ Δ,
             context_depth Δ < depth pr0 ->
             onctx_rel P Γ Δ).
  { move=> Γ Δ.
    induction Δ; cbn.
    - constructor.
    - case: a => [na [b|] ty] /=;
      rewrite {1}/decl_depth_gen /context_depth_gen /= => Hlt; constructor; auto.
      + eapply IHΔ => //. unfold context_depth. lia.
      + simpl. apply aux => //. red.  lia.
      + simpl. split.
        * apply aux => //. red. lia.
        * apply aux=> //; red; lia.
      + apply IHΔ => //; unfold context_depth; lia.
      + apply aux => //. red. lia. }
  assert (forall m, list_depth_gen (fun x : def term => depth (dtype x)) m < S (mfixpoint_depth_gen depth m)).
  { clear. unfold mfixpoint_depth_gen, def_depth_gen. induction m. simpl. auto. simpl. lia. }
  assert (forall m, list_depth_gen (fun x : def term => depth (dbody x)) m < S (mfixpoint_depth_gen depth m)).
  { clear. unfold mfixpoint_depth_gen, def_depth_gen. induction m. simpl. auto. simpl. lia. }

  move aux at top. move auxl at top. move auxΓ at top.

  destruct pr0; eauto;
    (move: pr2=> /= /and3P [pr20 pr21 pr22] || move: pr2 => /= /andP [pr20 pr21] || idtac);
    try match reverse goal with
          |- context [tFix _ _] => idtac
        | H : _ |- _ => solve [apply H; (eapply aux || eapply auxl); auto; red; simpl; try lia]
        end.

  - eapply X10; eauto.
    * red. split.
      + eapply auxl; auto. simpl. unfold predicate_depth_gen, branch_depth_gen.
        now change (fun x => depth x) with depth; lia.
      + split.
        ++ apply auxΓ. simpl. unfold predicate_depth_gen.
          pose proof (context_depth_inst_case_context p.(pparams) p.(puinst) p.(pcontext)). lia.
        ++ eapply aux; auto. simpl. unfold predicate_depth_gen. lia.
    * eapply aux => //. simpl; lia.
    * red. simpl in aux.
      have auxbr := fun Γ t (H : depth t <= list_depth_gen (branch_depth_gen depth p) brs) =>
        aux Γ t ltac:(lia).
      move: auxbr.
      clear -auxΓ.
      induction brs. simpl. constructor.
      constructor. simpl in auxbr.
      + split. eapply auxΓ. simpl.
        unfold branch_depth_gen at 1. rewrite /predicate_depth_gen /=.
        pose proof (context_depth_inst_case_context p.(pparams) p.(puinst) a.(bcontext)).
        lia.
        eapply auxbr. unfold branch_depth_gen. lia.
      + eapply IHbrs. intros. apply auxΓ. simpl in *. lia.
        intros. apply auxbr. simpl. lia.
  - eapply X12; try (apply aux; red; simpl; lia).
    apply auxΓ => //. simpl. specialize (H mfix). lia.
    red. apply All_pair. split; apply auxl; simpl; auto.

  - eapply X13; try (apply aux; red; simpl; lia).
    apply auxΓ => //. simpl. specialize (H mfix). lia.
    red. apply All_pair. split; apply auxl; simpl; auto.
Defined.

Definition CasePredProp_depth (P : term -> Type) (p : predicate term) :=
  All P p.(pparams) × onctx P (inst_case_context p.(pparams) p.(puinst) p.(pcontext)) ×
  P p.(preturn).

Definition CaseBrsProp_depth p (P : term -> Type) (brs : list (branch term)) :=
  All (fun x : branch term => onctx P (inst_case_context p.(pparams) p.(puinst) x.(bcontext))
     * P (bbody x)) brs.

Lemma term_ind_depth_app :
  forall (P : term -> Type),
    (forall (n : nat), P (tRel n)) ->
    (forall (i : ident), P (tVar i)) ->
    (forall (n : nat) (l : list term), All (P) l -> P (tEvar n l)) ->
    (forall s, P (tSort s)) ->
    (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> P (tProd n t t0)) ->
    (forall (n : aname) (t : term), P t -> forall t0 : term, P t0 -> P (tLambda n t t0)) ->
    (forall (n : aname) (t : term),
        P t -> forall t0 : term, P t0 -> forall t1 : term, P t1 -> P (tLetIn n t t0 t1)) ->
    (forall (t u : term),
      (forall t', depth t' < depth (tApp t u) -> P t') ->
      P t -> P u -> P (tApp t u)) ->
    (forall s (u : list Level.t), P (tConst s u)) ->
    (forall (i : inductive) (u : list Level.t), P (tInd i u)) ->
    (forall (i : inductive) (n : nat) (u : list Level.t), P (tConstruct i n u)) ->
    (forall (ci : case_info) (p : predicate term) (t : term) (brs : list (branch term)),
        CasePredProp_depth P p ->
        P t ->
        CaseBrsProp_depth p P brs ->
        P (tCase ci p t brs)) ->
    (forall (s : projection) (t : term), P t -> P (tProj s t)) ->
    (forall (m : mfixpoint term) (n : nat),
        onctx P (fix_context m) ->
        tFixProp P P m -> P (tFix m n)) ->
    (forall (m : mfixpoint term) (n : nat),
        onctx P (fix_context m) ->
        tFixProp P P m -> P (tCoFix m n)) ->
    (forall p, P (tPrim p)) ->
    forall (t : term), P t.
Proof.
  intros ????????????????? t.
  revert t. set(foo:=CoreTactics.the_end_of_the_section). intros.
  Subterm.rec_wf_rel aux t (MR lt depth); unfold MR in *; simpl. clear H0.
  assert (auxl : forall {A} (l : list A) (f : A -> term),
    list_depth_gen (fun x => depth (f x)) l < depth pr1 ->
    All (fun x => P (f x)) l).
  { induction l; try solve [constructor].
    move=> f /= Hdepth.
    constructor.
    * eapply aux => //. red. lia.
    * apply IHl => //. lia. }
  assert (forall mfix, context_depth (fix_context mfix) <= mfixpoint_depth_gen depth mfix).
  { induction mfix. simpl. auto. simpl. unfold fix_context.
    unfold context_depth.
    rewrite /context_depth list_depth_rev /=. cbn.
    rewrite depth_lift. unfold context_depth in IHmfix.
    epose (list_depth_mapi_rec_le mfix
                                 (fun (i : nat) (d : def term) => vass (dname d) ((lift0 i) (dtype d))) 1
                                 (def_depth_gen depth) (decl_depth_gen depth)).
    forward l. intros. destruct x; cbn; rewrite depth_lift. lia.
    rewrite /mfixpoint_depth_gen {1}/def_depth_gen. lia. }
  assert (auxΓ : forall Δ,
             context_depth Δ < depth pr1 ->
             onctx P Δ).
  { move=> Γ h.
    induction Γ; cbn.
    - constructor.
    - case: a h => [na [b|] ty] /=;
      rewrite {1}/decl_depth_gen /context_depth_gen /= => Hlt; constructor; auto.
      + simpl. split.
        * apply aux => //. red. cbn. lia.
        * apply aux=> //; red; lia.
      + apply IHΓ => //; unfold context_depth; lia.
      + red; cbn. split. apply aux => //. red. lia. exact tt.
      + apply IHΓ => //. unfold context_depth; lia. }
  assert (forall m, list_depth_gen (fun x : def term => depth (dtype x)) m < S (mfixpoint_depth_gen depth m)).
  { clear. unfold mfixpoint_depth_gen, def_depth_gen. induction m. simpl. auto. simpl. lia. }
  assert (forall m, list_depth_gen (fun x : def term => depth (dbody x)) m < S (mfixpoint_depth_gen depth m)).
  { clear. unfold mfixpoint_depth_gen, def_depth_gen. induction m. simpl. auto. simpl. lia. }

  move aux at top. move auxl at top. move auxΓ at top.

  destruct pr1; eauto;
    (move: pr2=> /= /and3P [pr20 pr21 pr22] || move: pr2 => /= /andP [pr20 pr21] || idtac);
    try match reverse goal with
          |- context [tFix _ _] => idtac
        | H : _ |- _ => solve [apply H; (eapply aux || eapply auxl); auto; red; simpl; try lia]
        end.

  - eapply X10; eauto.
    * red. split.
      + eapply auxl; auto. simpl. unfold predicate_depth_gen, branch_depth_gen.
        now change (fun x => depth x) with depth; lia.
      + split.
        ++ apply auxΓ. simpl. unfold predicate_depth_gen.
          pose proof (context_depth_inst_case_context p.(pparams) p.(puinst) p.(pcontext)). lia.
        ++ eapply aux; auto. simpl. unfold predicate_depth_gen. lia.
    * eapply aux => //. simpl; lia.
    * red. simpl in aux.
      have auxbr := fun t (H : depth t <= list_depth_gen (branch_depth_gen depth p) brs) =>
        aux t ltac:(lia).
      move: auxbr.
      clear -auxΓ.
      induction brs. simpl. constructor.
      constructor. simpl in auxbr.
      + split. eapply auxΓ. simpl.
        unfold branch_depth_gen at 1. rewrite /predicate_depth_gen /=.
        pose proof (context_depth_inst_case_context p.(pparams) p.(puinst) a.(bcontext)).
        lia.
        eapply auxbr. unfold branch_depth_gen. lia.
      + eapply IHbrs. intros. apply auxΓ. simpl in *. lia.
        intros. apply auxbr. simpl. lia.
  - eapply X12; try (apply aux; red; simpl; lia).
    apply auxΓ => //. simpl. specialize (H mfix). lia.
    red. apply All_pair. split; apply auxl; simpl; auto.

  - eapply X13; try (apply aux; red; simpl; lia).
    apply auxΓ => //. simpl. specialize (H mfix). lia.
    red. apply All_pair. split; apply auxl; simpl; auto.
Defined.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2016 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

Require Import Wf_nat Arith.Lt Bvector Relations Wellfounded.
From Equations Require Import Init Classes Below Signature EqDec NoConfusion.

Generalizable Variables A R S B.

Scheme Acc_dep := Induction for Acc Sort Prop.

(** The fixpoint combinator associated to a well-founded relation,
   just reusing the [Wf.Fix] combinator. *)

Definition FixWf `{WF:WellFounded A R} (P : A -> Type)
  (step : forall x : A, (forall y : A, R y x -> P y) -> P x) : forall x : A, P x :=
  Fix wellfounded P step.

Lemma Acc_pi (A : Type) (R : relation A) i (x y : Acc R i) : x = y.
Proof.
  revert y.
  induction x using Acc_dep.
  intros. destruct y.
  f_equal.
  extensionality y. extensionality H'. apply H.
Qed.

Lemma FixWf_unfold `{WF : WellFounded A R} (P : A -> Type)
  (step : forall x : A, (forall y : A, R y x -> P y) -> P x) (x : A) :
  FixWf P step x = step x (fun y _ => FixWf P step y).
Proof.
  intros. unfold FixWf, Fix. destruct wellfounded.
  simpl. f_equal. extensionality y. extensionality h.
  f_equal. apply Acc_pi.
Qed.

Hint Rewrite @FixWf_unfold : Recursors.

Lemma FixWf_unfold_step :
  forall (A : Type) (R : Relation_Definitions.relation A) (WF : WellFounded R) (P : A -> Type)
    (step : forall x : A, (forall y : A, R y x -> P y) -> P x) (x : A)
    (step' : forall y : A, R y x -> P y),
    step' = (fun (y : A) (_ : R y x) => FixWf P step y) ->
    FixWf P step x = step x step'.
Proof. intros. rewrite FixWf_unfold, H. reflexivity. Qed.

Hint Rewrite @FixWf_unfold_step : Recursors.

Ltac unfold_FixWf :=
  match goal with
    |- context [ @FixWf ?A ?R ?WF ?P ?f ?x ] =>
    let step := fresh in
    set(step := fun y (_ : R y x) => @FixWf A R WF P f y) in *;
    rewrite (@FixWf_unfold_step A R WF P f x step); [hidebody step|reflexivity]
  end.

Ltac unfold_recursor := unfold_FixWf.

(** Inline so that we get back a term using general recursion. *)

Extraction Inline FixWf Fix Fix_F.

(** This hint database contains the constructors of every derived
   subterm relation. It is used to automatically find proofs that
   a term is a subterm of another.
   *)

Create HintDb subterm_relation discriminated.
Create HintDb Recursors discriminated.
Create HintDb rec_decision discriminated.

(** We can automatically use the well-foundedness of a relation to get
   the well-foundedness of its transitive closure.
   Note that this definition is transparent as well as [wf_clos_trans],
   to allow computations with functions defined by well-founded recursion.
   *)

Lemma WellFounded_trans_clos `(WF : WellFounded A R) : WellFounded (clos_trans A R).
Proof. apply wf_clos_trans. apply WF. Defined.

Hint Extern 4 (WellFounded (clos_trans _ _)) =>
  apply @WellFounded_trans_clos : typeclass_instances.

Instance wf_MR {A R} `(WellFounded A R) {B} (f : B -> A) : WellFounded (MR R f).
Proof. red. apply measure_wf. apply H. Defined.

Hint Extern 0 (MR _ _ _ _) => red : Below.

Instance lt_wf : WellFounded lt := lt_wf.
Hint Resolve lt_n_Sn : Below.

(** We also add hints for transitive closure, not using [t_trans] but forcing to
   build the proof by successive applications of the inner relation. *)

Hint Resolve t_step : subterm_relation.

Lemma clos_trans_stepr A (R : relation A) (x y z : A) :
  R y z -> clos_trans A R x y -> clos_trans A R x z.
Proof. intros Hyz Hxy. exact (t_trans _ _ x y z Hxy (t_step _ _ _ _ Hyz)). Defined.

Hint Resolve clos_trans_stepr : subterm_relation.

(** The default tactic to build proofs of well foundedness of subterm relations. *)

Ltac simp_sigmas := repeat destruct_one_sigma ; simpl in *.

Ltac eapply_hyp :=
  match goal with
    [ H : _ |- _ ] => eapply H
  end.

Create HintDb solve_subterm discriminated.

Hint Extern 4 (_ = _) => reflexivity : solve_subterm.
Hint Extern 10 => eapply_hyp : solve_subterm.

Ltac solve_subterm := intros;
  apply Transitive_Closure.wf_clos_trans;
  red; intros; simp_sigmas; on_last_hyp ltac:(fun H => depind H); constructor;
  intros; simp_sigmas; on_last_hyp ltac:(fun HR => depind HR);
  simplify_dep_elim; try typeclasses eauto with solve_subterm.

(** A tactic to launch a well-founded recursion. *)

Ltac rec_wf_fix recname kont :=
  let hyps := fresh in intros hyps;
  intro; on_last_hyp ltac:(fun x => rename x into recname;
                           unfold MR at 1 in recname) ;
  destruct_right_sigma hyps; try curry recname; simpl in recname;
  kont recname.

(* Ltac rec_wf_fix x recname fixterm := *)
(*   apply fixterm ; clear_local ;  *)
(*   intros until 1 ; simp_sigmas ;  *)
(*     on_last_hyp ltac:(fun x => rename x into recname) ; *)
(*   simplify_dep_elim ; intros ; unblock_goal ; intros ; *)
(*   move recname at bottom ; try curry recname ; simpl in recname. *)

(** Generalize an object [x], packing it in a sigma type if necessary. *)

Ltac sigma_pack t :=
  let packhyps := fresh "hypspack" in
  let xpack := fresh "pack" in
  uncurry_hyps packhyps;
    (progress (set(xpack := t) in |- ;
               cbv beta iota zeta in xpack; revert xpack;
               pattern sigma packhyps;
               clearbody packhyps;
               revert packhyps;
               clear_nonsection)).

(** We specialize the tactic for [x] of type [A], first packing
   [x] with its indices into a sigma type and finding the declared
   relation on this type. *)

Ltac rec_wf recname t kont :=
  sigma_pack t;
    match goal with
      [ |- forall (s : ?T) (s0 := @?b s), @?P s ] =>
      let fn := constr:(fun s : T => b s) in
      let c := constr:(wellfounded (R:=MR _ fn)) in
      let wf := constr:(FixWf (WF:=c)) in
      intros s _; revert s; refine (wf P _); simpl ;
      rec_wf_fix recname kont
    end.

Ltac rec_wf_eqns recname x :=
  rec_wf recname x
         ltac:(fun rechyp => add_pattern (hide_pattern rechyp)).

Ltac rec_wf_rel_aux recname t rel kont :=
  sigma_pack t;
    match goal with
      [ |- forall (s : ?T) (s0 := @?b s), @?P s ] =>
      let fn := constr:(fun s : T => b s) in
      let c := constr:(wellfounded (R:=MR rel fn)) in
      let wf := constr:(FixWf (WF:=c)) in
      intros s _; revert s; refine (wf P _); simpl ;
      rec_wf_fix recname kont
    end.

Ltac rec_wf_eqns_rel recname x rel :=
  rec_wf_rel_aux recname x rel ltac:(fun rechyp => add_pattern (hide_pattern rechyp)).

Ltac rec_wf_rel recname x rel :=
  rec_wf_rel_aux recname x rel ltac:(fun rechyp => idtac).

(** The [pi] tactic solves an equality between applications of the same function,
   possibly using proof irrelevance to discharge equality of proofs. *)

Ltac pi := repeat progress (f_equal || reflexivity) ; apply proof_irrelevance.

(** Define non-dependent lexicographic products *)

Require Import Wellfounded Relation_Definitions.
Require Import Relation_Operators Lexicographic_Product Wf_nat.
Arguments lexprod [A] [B] _ _.

Section Lexicographic_Product.

  Variable A : Type.
  Variable B : Type.
  Variable leA : A -> A -> Prop.
  Variable leB : B -> B -> Prop.

  Inductive lexprod : A * B -> A * B -> Prop :=
    | left_lex :
      forall (x x':A) (y:B) (y':B),
        leA x x' -> lexprod (x, y) (x', y')
    | right_lex :
      forall (x:A) (y y':B),
        leB y y' -> lexprod (x, y) (x, y').

  Lemma acc_A_B_lexprod :
    forall x:A, Acc leA x -> (well_founded leB) ->
                forall y:B, Acc leB y -> Acc lexprod (x, y).
  Proof.
    induction 1 as [x _ IHAcc]; intros H2 y.
    induction 1 as [x0 H IHAcc0]; intros.
    apply Acc_intro.
    destruct y as [x2 y1]; intro H6.
    simple inversion H6; intro.
    injection H1. injection H3. intros. subst. clear H1 H3.
    apply IHAcc; auto with sets.
    noconf H3; noconf H1.
  Qed.

  Theorem wf_lexprod :
    well_founded leA ->
    well_founded leB -> well_founded lexprod.
  Proof.
    intros wfA wfB; unfold well_founded.
    destruct a.
    apply acc_A_B_lexprod; auto with sets; intros.
  Defined.

End Lexicographic_Product.

Instance wellfounded_lexprod A B R S `(wfR : WellFounded A R, wfS : WellFounded B S) :
  WellFounded (lexprod A B R S) := wf_lexprod A B R S wfR wfS.

Hint Constructors lexprod : Below.