(* 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_tensor :
  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 *)
  * inversion HeqcutF.
    subst. clear HeqcutF.

    intros RH.
    remember (Delta1 ++ [A ** B] ++ Delta2) as RHEnv.

    (* We proceed by cases on RH *)
    { destruct RH.

      (* RH is OneL *)
      + subst.

        pose proof (TensorR n env1 A env2 B LH1 LH2).
        clear LH1. clear LH2.

        assert (eq: [One] ++ Gamma =
                    Delta1 ++ [A ** B] ++ Delta2)
          by auto.
        apply element_in_app in eq.
        destruct eq as [Left | Right].

        * destruct Left as [t1 [t2 [l t3]]].
          clear t1. clear t2.
          apply app_singleton in t3.
          destruct t3 as [t1 [t2 t3]].
          discriminate.

        * destruct Right as [t1 [t2 [l t3]]].
          clear t1. clear t2.
          subst.
          assert (eq: ([One] ++ l)
                        ++ [A ** B] ++ Delta2 =
                      Delta1 ++ [A ** B] ++ Delta2)
              by auto.
          apply app_inv_tail in eq.
          subst. clear HeqRHEnv.

          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 (env1 ++ env2) l Delta2
                          H RH).
            clear eq1. clear eq2. clear RH. clear H.

            destruct IHl as [z Hyp].
            pose proof (OneL
                          z
                          ((env1 ++ env2) ++ l ++ Delta2)
                          A0 Hyp).
            assert (H': S z;
                    [] ++ [One] ++ (env1 ++ env2)
                       ++ l ++ Delta2 |- A0) by auto.
            apply exchange_with_env_r in H'.

            exists (S z + length (env1 ++ env2)).

            repeat rewrite <- app_assoc in *; auto.

      (* RH is OneR *)
      + apply app_cons_not_nil in HeqRHEnv.
        destruct HeqRHEnv.

      (* RH is Axiom *)
      + apply app_singleton in HeqRHEnv.
        destruct HeqRHEnv as [t1 [t2 t3]].
        subst.
        rewrite app_nil_r.
        exists (S n).
        constructor; auto.

      (* RH is TensorL *)
      + destruct Delta1.
        (* Here we have two cases: *)
        (* i) TensorL on cut formula (Delta1 = []) *)
        (* ii) TensorL not on cut form. (Delta1!=[]) *)

        (* i) we need to reduce *)
        * inversion HeqRHEnv.
          subst. clear HeqRHEnv. clear IHl.

          (* we first cut A *)
          assert (RH': n0;
                  [] ++ [A] ++ (B::Delta2) |- C)
            by auto.
          apply (IHA1 n n0 C env1 []
                     (B::Delta2) LH1)
            in RH'.
          clear RH. clear LH1.
          destruct RH' as [z RH].

          (* second, we cut B *)
          assert (RH': z;
                  env1 ++ [B] ++ Delta2 |-C)
            by auto.
          apply (IHA2 n z C env2 env1 Delta2
                     LH2) in RH'.
          clear RH. clear LH2.
          destruct RH' as [z' RH].

          rewrite app_assoc in RH.
          apply exchange_subset in RH.
          destruct RH as [m [t1 RH]].

          exists m; auto.

        (* ii) we need to commute *)
        * assert (eq: [A0 ** B0] ++ env =
                      (f :: Delta1)
                        ++ [A ** B]
                        ++ Delta2)
            by auto.
          apply element_in_app in eq.

          {
            destruct eq as [Left | Right].

            - destruct Left as [t1 [t2 [l t3]]].
              clear t1. clear t2.
              apply app_singleton in t3.
              destruct t3; discriminate.

            - destruct Right as [t1 [t2 [l t3]]].
              clear t1. clear t2. clear IHA1. clear IHA2.
              subst.
              assert (eq:
                        (A0 ** B0 :: l)
                          ++ [A ** B] ++ Delta2 =
                        (f :: Delta1)
                          ++ [A ** B] ++ Delta2)
                by auto.
              apply app_inv_tail in eq.
              inversion eq.
              subst. clear eq. clear HeqRHEnv.

              assert (Hyp:
                        n0;
                      (A0 :: B0 :: Delta1)
                        ++ [A ** B]
                        ++ Delta2 |- C) by auto.
              pose proof (TensorR n env1 A
                                  env2 B LH1 LH2).
              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
                              (env1 ++ env2)
                              (A0::B0::Delta1)
                              Delta2 H RH
                         ).
              destruct IHl as [z IHl].

              rewrite app_assoc in IHl.

              apply exchange_subset in IHl.
              destruct IHl as [m [t1 Final]].

              simpl in Final.
              pose proof (TensorL
                            m
                            ((Delta1 ++ env1 ++ env2)
                               ++ Delta2) A0 B0 C Final).
              assert (eq:
                        S m;
                      [] ++ (([A0 ** B0]
                         ++ Delta1) ++ (env1 ++ env2))
                         ++ Delta2
                      |- C)
                by (repeat rewrite <- app_assoc in *;
                    auto).
              apply exchange_subset in eq.
              destruct eq as [k [temp1 temp2]].

              exists k.
              simpl in *.
              repeat rewrite <- app_assoc in *; auto.
          }

      (* RH is TensorR *)
      + subst. clear IHA1. clear IHA2.

        (* We reapply TensorR - Coq undoes it *)
        pose proof (TensorR n env1 A env2 B LH1 LH2).
        rename H into LH.
        clear LH1.
        clear LH2.

        (* We now reason by cases *)
        (* depending on where the cutformula is: *)
        (* it's either in RH1 or RH2 *)
        inversion HeqRHEnv.
        apply element_in_app in H0.
        destruct H0.

        (* Cut formula on left premise of RH *)
        * destruct H as [t1 [t2 [l t3]]].
          subst. clear t1. clear t2.
          assert (eq:
                    (Delta1 ++ [A ** B])
                      ++ l ++ env3 =
                    (Delta1 ++ [A ** B])
                      ++ Delta2)
            by (repeat rewrite <- app_assoc in *; auto).
          apply app_inv_head in eq.
          subst. clear HeqRHEnv.

          (* We start using the IH on l *)
          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
                          (env1 ++ env2)
                          Delta1 l LH RH1
                     ).
          clear eq1. clear eq2. clear RH1. clear LH.

          destruct IHl as [z Hyp].
          apply (level_depth
                   z ((env1 ++ env2) ++ Delta1 ++ l) A0
                   n0 env3 B0 Hyp) in RH2.
          destruct RH2 as [k [Hyp1 Hyp2]].

          exists (S k).

          apply (TensorR
                   k
                   ((env1 ++ env2) ++ Delta1 ++ l) A0
                   env3 B0 Hyp1) in  Hyp2.

          repeat rewrite <- app_assoc in *; auto.

        (* Cut formula on right premise of RH *)
        *
          (* We start using the IH on l *)
          specialize (IHl  ((S n) + n0)).

          assert (eq1: S n + n0 < S n + S n0)
            by omega.

          specialize (IHl eq1 (S n) n0).

          assert (eq2: S n + n0 = S n + n0)
            by omega.

          destruct H as [H' H ].
          destruct H as [Hextra H].
          destruct H as [l].
          inversion H as [env3Def].

          rewrite H in RH2.

          specialize
            (IHl eq2 B0 (env1 ++ env2)
                 l Delta2 LH RH2).

          destruct IHl.

          apply (level_depth
                   n0 env0 A0
                   x ((env1 ++ env2) ++ l ++ Delta2) B0
                   RH1) in H0.
          clear RH1. clear RH2. clear LH.
          clear Hextra. clear eq1. clear eq2. subst.
          clear env3Def.
          assert (eq: (env0 ++ l)
                        ++ [A ** B] ++ Delta2 =
                      Delta1 ++ [A ** B] ++ Delta2)
            by ( repeat rewrite <- app_assoc; auto ).
          apply app_inv_tail in eq.
          subst. clear HeqRHEnv. clear H'.
          destruct H0 as [k [RH1 RH2]].

          pose proof (TensorR
                        k env0 A0
                        ((env1 ++ env2)
                           ++ l ++ Delta2) B0
                        RH1 RH2).
          assert ( eq: S k;
                   (env0 ++ (env1 ++ env2))
                     ++ l ++ Delta2
                   |- (A0 ** B0))
            by ( repeat rewrite <- app_assoc in *;
                 auto ).
          apply exchange_subset in eq.
          destruct eq as [m [temp Final]].
          exists m.
          repeat rewrite <- app_assoc in *; auto.

      (* RH is LolliL *)
      +
        (* We reapply TensorR - Coq undoes it *)
        pose proof (TensorR n env1 A env2 B LH1 LH2).
        rename H into LH.
        clear LH1. clear LH2. clear IHA1. clear IHA2.
        subst.

        (* we need to generate cases *)
        assert ([A0 -o B0] ++ env0 ++ env3 =
                Delta1 ++ [A ** B] ++ Delta2)
          by auto.
        rewrite app_assoc in H.
        apply element_in_app in H.
        destruct H as [Left | Right].

        * destruct Left as [t1 [t2 [l Hyp]]].
          clear t1. clear t2.
          inversion Hyp as [subst1].
          apply element_in_app in Hyp.
          {
            destruct Hyp as [LeftLeft | LeftRight].

            + destruct LeftLeft as [t1 [t2 [l' t3]]].
              simpl in *.
              destruct t1;[discriminate | destruct H].

            + destruct LeftRight as [t1 [t2 [l0 t3]]].
              subst. clear t1. clear t2.
              assert(eq1:  (A0 -o B0 :: l0) ++ (A ** B:: l) =
                           Delta1 ++ A ** B :: l)
                by (repeat rewrite <- app_assoc; auto ).
              apply app_inv_tail in eq1.
              subst.
              assert(eq1: ([A0 -o B0] ++ l0 ++ [A ** B])
                            ++ l ++ env3 =
                          ([A0 -o B0] ++ l0 ++ [A ** B])
                            ++ Delta2)
                by (repeat rewrite <- app_assoc in *; auto ).
              apply app_inv_head in eq1.
              subst. clear subst1. clear HeqRHEnv.

              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
                              (env1 ++ env2)
                              l0 l LH RH1 ).
              clear eq1. clear eq2. clear RH1. clear LH.
              destruct IHl as [z IHl].

              apply (level_depth
                       z ((env1 ++ env2) ++ l0 ++ l) A0
                       n0 (B0::env3) C IHl) in RH2.
              clear IHl. destruct RH2 as [k [Hyp1 Hyp2]].

              pose proof (LolliL
                            k
                            ((env1 ++ env2) ++ l0 ++ l) A0
                            env3 B0 C Hyp1 Hyp2).
              assert (eq: S k;
                      ([A0 -o B0] ++ (env1 ++ env2))
                        ++ l0 ++ l ++ env3 |- C)
                by (repeat rewrite <- app_assoc in *; auto).
              apply exchange_subset in eq.
              destruct eq as [m [t1 Hyp]].

              exists m.

              repeat rewrite <- app_assoc in *; auto.

          }

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

          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
                          (env1 ++ env2)
                          (B0 :: l) Delta2 LH RH2).
          clear eq1. clear eq2. clear LH. clear RH2.
          destruct IHl as [z Hyp].

          assert (eq: z; [] ++ (env1 ++ env2) ++ [B0]
                            ++ l ++ Delta2 |- C)
            by auto.
          clear Hyp.
          apply exchange_with_env_l in eq.
          simpl in eq.
          apply (level_depth
                   n0 env0 A0
                   (z + length (env1 ++ env2))
                   (B0 :: (env1 ++ env2) ++ l ++ Delta2)
                   C RH1) in eq.
          clear RH1.
          destruct eq as [k [Hyp1 Hyp2]].
          apply (LolliL
                   k env0 A0
                   ((env1 ++ env2) ++ l ++ Delta2) B0 C Hyp1)
            in Hyp2.
          clear Hyp1.

          assert (Hyp: S k;
                  ((A0 -o B0 :: env0) ++ (env1 ++ env2))
                    ++ l ++ Delta2 |- C)
            by (repeat rewrite <- app_assoc in *; auto ).

          apply exchange_subset in Hyp.
          destruct Hyp as [m [_ Final]].

          repeat rewrite <- app_assoc in *.
          exists m; auto.

      (* RH is a LolliR *)
      + subst.

        (* We reapply TensorR - Coq undoes it *)
        pose proof (TensorR n env1 A env2 B LH1 LH2).
        rename H into LH.
        clear LH1. clear LH2.

        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
                        B0
                        (env1 ++ env2)
                        (A0 :: Delta1)
                        Delta2
                        LH
                        RH
                   ).
        clear eq1. clear eq2.

        destruct IHl as [z IHl].

        assert (eq1: z;
                [] ++
                   (env1 ++ env2) ++ [A0] ++ Delta1 ++ Delta2
                |- B0
               ) by auto.

        apply exchange_with_env_l in eq1.
        simpl in eq1.

        pose proof (LolliR
                      (z + length (env1 ++ env2))
                      ((env1 ++ env2) ++ Delta1 ++ Delta2)
                      A0
                      B0
                      eq1
                   ).

        exists (S (z + length (env1 ++ env2))).
        assumption.

      (* RH is a WithL1 *)
      + clear IHA1. clear IHA2.
        assert (eq: [A0 & B0] ++ Gamma =
                    Delta1 ++ [A ** B] ++ Delta2)
          by auto.
        apply element_in_app in eq.
        {
          destruct eq as [Left | Right].

          - destruct Left as [_ [ _ [l Hyp]]].
            apply app_singleton in Hyp.
            destruct Hyp as [t1 [t2 t3]].
            subst.
            simpl in *. inversion HeqRHEnv.

          - destruct Right as [ _ [ _ [l Hyp]]].
            subst.
            assert (eq: (A0 & B0 :: l) ++ [A ** B] ++ Delta2
                             =
                             Delta1 ++ [A ** B] ++ Delta2)
              by auto.
            apply app_inv_tail in eq.
            subst. clear HeqRHEnv.

            apply (TensorR n env1 A env2 B LH1) in LH2.
            clear LH1. rename LH2 into 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
                            C
                            (env1 ++ env2)
                            (A0 ::l) Delta2 LH RH).
            clear eq1. clear eq2. clear LH. clear RH.
            destruct IHl as [z Hyp].

            assert (eq: z; ((env1 ++ env2) ++ (A0 :: l))
                             ++ Delta2 |- C)
              by ( repeat rewrite <- app_assoc in *; auto ).

            apply exchange_subset in eq.
            destruct eq as [m [ _ Hyp']].

            repeat rewrite <- app_assoc in *.
            simpl in *.

            apply (WithL1 m (l ++ env1 ++ env2 ++ Delta2)
                          A0 B0 C) in Hyp'.

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

            apply exchange_subset in eq.
            destruct eq as [m' [ _ Hyp'']].

            exists m'.
            repeat rewrite <- app_assoc in *; auto.
        }

      (* RH is a WithL2 *)
      + clear IHA1. clear IHA2.
        assert (eq: [A0 & B0] ++ Gamma =
                    Delta1 ++ [A ** B] ++ Delta2)
          by auto.
        apply element_in_app in eq.
        {
          destruct eq as [Left | Right].

          - destruct Left as [_ [ _ [l Hyp]]].
            apply app_singleton in Hyp.
            destruct Hyp as [t1 [t2 t3]].
            subst.
            simpl in *. inversion HeqRHEnv.

          - destruct Right as [ _ [ _ [l Hyp]]].
            subst.
            assert (eq: (A0 & B0 :: l) ++ [A ** B] ++ Delta2
                             =
                             Delta1 ++ [A ** B] ++ Delta2)
              by auto.
            apply app_inv_tail in eq.
            subst. clear HeqRHEnv.

            apply (TensorR n env1 A env2 B LH1) in LH2.
            clear LH1. rename LH2 into 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
                            C
                            (env1 ++ env2)
                            (B0 ::l) Delta2 LH RH).
            clear eq1. clear eq2. clear LH. clear RH.
            destruct IHl as [z Hyp].

            assert (eq: z; ((env1 ++ env2) ++ (B0 :: l))
                             ++ Delta2 |- C)
              by ( repeat rewrite <- app_assoc in *; auto ).

            apply exchange_subset in eq.
            destruct eq as [m [ _ Hyp']].

            repeat rewrite <- app_assoc in *.
            simpl in *.

            apply (WithL2 m (l ++ env1 ++ env2 ++ Delta2)
                          A0 B0 C) in Hyp'.

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

            apply exchange_subset in eq.
            destruct eq as [m' [ _ Hyp'']].

            exists m'.
            repeat rewrite <- app_assoc in *; auto.
        }

      (* RH is a WithR *)
      + subst. clear IHA1. clear IHA2.

        (* We reapply TensorR - Coq undoes it *)
        pose proof (TensorR n env1 A env2 B LH1 LH2).
        rename H into LH.
        clear LH1. clear LH2.

        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 (env1 ++ env2) Delta1 Delta2
                   LH) in RH1.
        apply (IHl (S n + n0) eq1
                   (S n) n0 eq2
                   B0 (env1 ++ env2) Delta1 Delta2
                   LH) in RH2.

        destruct RH1 as [z1 RH1].
        destruct RH2 as [z2 RH2].
        clear eq1. clear eq2. clear LH.

        apply (level_depth
                 z1 ((env1 ++ env2) ++ Delta1 ++ Delta2) A0
                 z2 ((env1 ++ env2) ++ Delta1 ++ Delta2) B0
                 RH1) in RH2.
        clear RH1.
        destruct RH2 as [k [H1 H2]].
        exists (S k).
        constructor; auto.

      (* RH is a OplusL1 *)
      + clear IHA1. clear IHA2.
        assert (H: [A0 # B0] ++ Gamma =
                Delta1 ++ [A ** B] ++ Delta2) by auto.
        apply element_in_app in H.
        {
          destruct H as [Left | Right].

          - destruct Left as [_ [ _ [l val]]].
            apply app_singleton in val.
            destruct val as [t1 [t2 t3]].
            subst.
            inversion HeqRHEnv.

          - destruct Right as [ _ [ _ [l val]]].
            subst.

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

            (* We reapply TensorR - Coq undoes it *)
            pose proof (TensorR n env1 A env2 B LH1 LH2).
            rename H into LH.
            clear LH1. clear LH2.

            assert (eq1: S n + n0 < S n + S n0) by omega.
            assert (eq2: S n + n0 = S n + n0) by omega.
            assert (RH1':
                      n0; (A0 :: l) ++ [A ** B]
                             ++ Delta2 |- C) by auto.
            assert (RH2':
                      n0; (B0 :: l) ++ [A ** B]
                             ++ Delta2 |- C) by auto.
            apply (IHl (S n + n0) eq1
                       (S n) n0 eq2
                       C (env1 ++ env2) (A0::l) Delta2
                       LH) in RH1'.
            apply (IHl (S n + n0) eq1
                       (S n) n0 eq2
                       C (env1 ++ env2) (B0::l) Delta2
                       LH) in RH2'.
            destruct RH1' as [z H1].
            destruct RH2' as [z' H2].

            assert (H1':
                      z; ((env1 ++ env2) ++ (A0 :: l))
                           ++ Delta2 |- C)
              by (repeat rewrite <- app_assoc in *;
                  auto).
            apply exchange_subset in H1'.
            destruct H1' as [m1 [_ H1']].
            assert (H2':
                      z'; ((env1 ++ env2) ++ (B0 :: l))
                            ++ Delta2 |- C)
              by (repeat rewrite <- app_assoc in *;
                  auto).
            apply exchange_subset in H2'.
            destruct H2' as [m2 [_ H2']].

            apply (level_depth
                     m1 (((A0 :: l)
                            ++ env1 ++ env2)
                           ++ Delta2) C
                     m2 (((B0 :: l)
                            ++ env1 ++ env2)
                           ++ Delta2) C
             H1') in H2'.

            destruct H2' as [k [Hyp1 Hyp2]].

            assert (Final1:
                      k;
                    A0 :: l ++ env1 ++ env2 ++ Delta2
                    |- C)
              by (repeat rewrite <- app_assoc in *;
                  auto).
            assert (Final2:
                      k;
                    B0 :: l ++ env1 ++ env2 ++ Delta2
                    |- C)
              by (repeat rewrite <- app_assoc in *;
                  auto).

            apply (OplusL k
                          (l ++ env1 ++ env2 ++ Delta2)
                          A0 B0 C Final1) in Final2.

            assert (Final:
                      S k; ((A0 # B0 :: l)
                             ++ (env1 ++ env2))
                             ++ Delta2
                           |- C)
              by (repeat rewrite <- app_assoc in *;
                  auto).
            apply exchange_subset in Final.

            destruct Final as [m [ _ H]].
            exists m.
            repeat rewrite <- app_assoc in *; auto.
        }

      (* RH is a OplusR1 *)
      + clear IHA1. clear IHA2.
        subst.

        (* We reapply TensorR - Coq undoes it *)
        pose proof (TensorR n env1 A env2 B LH1 LH2).
        rename H into LH.
        clear LH1. clear LH2.

        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 (env1 ++ env2) Delta1 Delta2
                   LH) in RH.
        clear eq1. clear eq2. clear LH.
        destruct RH as [z H].

        exists (S z).
        constructor; auto.

      (* RH is a OplusR2 *)
      + clear IHA1. clear IHA2.
        subst.

        (* We reapply TensorR - Coq undoes it *)
        pose proof (TensorR n env1 A env2 B LH1 LH2).
        rename H into LH.
        clear LH1. clear LH2.

        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 (env1 ++ env2) Delta1 Delta2
                   LH) in RH.
        clear eq1. clear eq2. clear LH.
        destruct RH as [z H].

        exists (S z).
        apply OplusR2; auto.

      (* RH is a Perm *)
      + subst.

          (* We reapply TensorR - Coq undoes it *)
          pose proof (TensorR n env1 A env2 B LH1 LH2).
          rename H into LH.
          clear LH1.
          clear LH2.

          (* We use the IH on l *)
          specialize (IHl  ((S n) + n0)).
          assert (eq1: S n + n0 < S n + S n0)
            by omega.
          specialize (IHl eq1 (S n) n0).
          assert (eq2: S n + n0 = S n + n0)
            by omega.

          specialize (IHl eq2 C (env1 ++ env2)).

          inversion HeqRHEnv as [H].
          apply elements_in_app in H.

          {
            destruct H.

            (* case:                                  *)
            (* In (A1 ** A2) Gamma /\                 *)
            (* (exists l : list formula,              *)
            (*     Gamma = Delta1 ++ [A1 ** A2] ++ l) *)
            - destruct H as [H' H].
              destruct H as [l].

              specialize (IHl
                            Delta1
                            (l ++ [A0] ++ [B0] ++ Delta)
                            LH
                         ).
              subst.
              repeat rewrite <- app_assoc in RH.
              specialize (IHl RH).
              destruct IHl.

              repeat rewrite <- app_assoc in HeqRHEnv.
              repeat apply app_inv_head in HeqRHEnv.

              rewrite <- HeqRHEnv.
              exists (S x).
              rewrite app_assoc.
              rewrite app_assoc.
              constructor.
              repeat rewrite <- app_assoc in *.
              assumption.

            (* Other cases *)
            - destruct H.

              (* Case:                  *)
              (* A1 ** A2 = B0 /\       *)
              (* Gamma = Delta1 /\      *)
              (* [A0] ++ Delta = Delta2 *)
              + destruct H as [H' H].
                destruct H.
                subst.

                specialize (IHl
                              (Delta1 ++ [A0])
                              Delta
                              LH
                           ).

                rewrite app_assoc in RH.
                specialize (IHl RH).
                destruct IHl.

                simpl in *.
                exists x.

                repeat rewrite <- app_assoc in *.

                assumption.

              (* Other Cases *)
              + destruct H.

                (* Case:                     *)
                (* A1 ** A2 = A0 /\          *)
                (* Gamma ++ [B0] = Delta1 /\ *)
                (* Delta = Delta2            *)
                * destruct H as [H' H].
                  destruct H.
                  subst.

                  specialize (IHl
                                Gamma
                                ([B0] ++ Delta2)
                                LH
                                RH
                             ).

                  simpl in *.
                  destruct IHl.
                  exists x.

                  repeat rewrite <- app_assoc in *.

                  assumption.

                (* Case: *)
                (* In (A1 ** A2) Delta /\ *)
                (* (exists l : list formula, *)
                (* Delta = l ++ [A1 ** A2] ++ Delta2) *)
                * destruct H as [H' H].
                  destruct H as [l].
                  specialize (IHl
                                (Gamma ++ [A0] ++ [B0] ++ l)
                                Delta2
                                LH
                             ).
                  subst.
                  repeat rewrite app_assoc in IHl.
                  repeat rewrite app_assoc in RH.
                  specialize (IHl RH).
                  destruct IHl as [x IHl].
                  repeat rewrite <- app_assoc in IHl.

                  rewrite app_assoc in HeqRHEnv.
                  rewrite app_assoc in HeqRHEnv.
                  rewrite app_assoc in HeqRHEnv.
                  apply app_inv_tail in HeqRHEnv.
                  subst.

                  exists (S x).
                  repeat rewrite <- app_assoc.
                  rewrite app_assoc.
                  rewrite app_assoc.
                  constructor.
                  repeat rewrite <- app_assoc in *.
                  assumption.
          }
      }

  (* 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 OplisL *)
  * 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 *)
  * discriminate.

  (* LH is OplusR2 *)
  * discriminate.

  (* 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.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
Require Import Classes DependentClasses Checker Show.

Require Import GenLow GenHigh Sets.
Import GenLow GenHigh.

(* TODO: Derive these *)
Instance arbST_eq {A} (a : A) : GenSuchThat A (fun x => x = a) :=
  {| arbitraryST := returnGen (Some a) |}.
Instance arbST_Correct {A} (a : A)
  : SuchThatCorrect (fun x => x = a) (genST (fun x => x = a)).
Proof.
  constructor.
  simpl; rewrite semReturn.
  split; intros H. now firstorder.
  destruct H as [x [Heq H]]. subst. inversion H. subst.
  split; eauto.
Defined.

Instance arbST_eq' {A} (a : A) : GenSuchThat A (fun x => a = x) :=
  {| arbitraryST := returnGen (Some a) |}.
Instance arbST_Correct' {A} (a : A)
  : SuchThatCorrect (fun x => a = x ) (genST (fun x => a = x)).
Proof.
  constructor.
  simpl; rewrite semReturn.
  split; intros H. now firstorder.
  destruct H as [x [Heq H]]. subst. inversion H. subst.
  split; eauto.
Defined.

(* Typeclass instances that derive checkable from dependent generators *)
(* Obvious TODO: Shrink *)

(* Is there another way of getting around the typeclass system? *)
Axiom ignore_generator_proofs : False.
Ltac ignore_gen_proofs := exfalso; apply ignore_generator_proofs.

Global Instance testSuchThat {A : Type} {pre : A -> Prop} {prop : A -> Type}
       `{Show A} `{GenSuchThat A (fun x => pre x)}
       `{forall (x : A), Checkable (prop x)} :
  Checkable (forall x, pre x -> prop x).
Proof.
refine
  {| checker f := forAllMaybe (genST (fun x => pre x))
                              (fun x => checker (f x _)) |}.
  ignore_gen_proofs.
Defined.

Global Instance testSuchThat2
       {A B : Type} {pre : A -> B -> Prop} {prop : A -> B -> Type}
       `{Show A} `{Show B}
       `{GenSuchThat (A * B) (fun x => let (a,b) := x in pre a b)}
       `{forall (a : A) (b : B), Checkable (prop a b)} :
  Checkable (forall a b , pre a b -> prop a b).
Proof.
refine
  {| checker f := forAllMaybe (genST (fun x : A * B => let (a,b) := x in pre a b))
                              (fun x =>
                                 let (a,b) := x in
                                 checker (f a b _)) |}.
ignore_gen_proofs.
Defined.

(*
Definition t := forall x, x = 17 -> x = 17.
Instance ct : Checkable t.
  eapply testSuchThat; eauto.
  Unshelve.

  QuickChck t.

  (fun mx => match mx with
                                    |
                              (fun mx H =>
                                 (* Leo: Is there a better way to do this? *)
                                 let mx' := mx in
                                 let Heq := erefl mx' : mx' = mx in
                                 match mx as mx'' return (mx' = mx'' -> Checker) with
                                 | Some x => fun _ => checker (f x _)
                                 | None => fun _ => checker tt
                                 end Heq) |}.
Proof.
  (* Annoying *)
  assert (Eq : mx = mx') by auto.
  rewrite -Eq in e.
  clear Heq Eq mx'.
  (* End annoying *)
  destruct H1. subst.
  (* Very annoying *)
  assert (Ha : (isSome :&: (semGen (genST [eta pre]))) (Some x)).
  { split; eauto. }
  apply STCorrect in Ha. destruct Ha as [y [Hin Heq]].
  inversion Heq. subst. eassumption.
Defined.

Global Instance testSuchThat2_1 {A B : Type} {pre : A -> B -> Prop} {prop : A -> B -> Type}
       `{Show A} `{Show B} `{Arbitrary B}
       `{forall (b : B), GenSuchThat A (fun x => pre x b)}
       `{forall (b : B), SuchThatCorrect (fun x => pre x b) (genST (fun x => pre x b))}
       `{forall (a : A) (b : B), Checkable (prop a b)} :
  Checkable (forall a b , pre a b -> prop a b) :=
  {| checker f :=
       forAllShrink arbitrary shrink (fun b =>
         forAllProof (genST (fun x => pre x b))
                     (fun mx H =>
                        (* Leo: Is there a better way to do this? *)
                        let mx' := mx in
                        let Heq := erefl mx' : mx' = mx in
                        match mx as mx'' return (mx' = mx'' -> Checker) with
                        | Some x => fun _ => checker (f x b _)
                        | None => fun _ => checker tt
                        end Heq)
                                     ) |}.
Proof.
  (* Annoying *)
  assert (Eq : mx = mx') by auto.
  rewrite -Eq in e.
  clear Heq Eq mx'.
  (* End annoying *)
  destruct (H5 b).
  (* Very annoying *)
  subst.
  assert (Ha : (isSome :&: semGen (genST pre^~ b)) (Some x)).
  { split; eauto. }
  apply STCorrect in Ha. destruct Ha as [y [Hin Heq]].
  inversion Heq. subst. eassumption.
Defined.

Global Instance testSuchThat2_2 {A B : Type} {pre : A -> B -> Prop} {prop : A -> B -> Type}
       `{Show A} `{Show B} `{Arbitrary A}
       `{forall (a : A), GenSuchThat B (fun x => pre a x)}
       `{forall (a : A), SuchThatCorrect (fun x => pre a x) (genST (fun x => pre a x))}
       `{forall (a : A) (b : B), Checkable (prop a b)} :
  Checkable (forall a b , pre a b -> prop a b) :=
  {| checker f :=
       forAllShrink arbitrary shrink (fun a =>
         forAllProof (genST (fun x => pre a x))
                     (fun mx H =>
                        (* Leo: Is there a better way to do this? *)
                        let mx' := mx in
                        let Heq := erefl mx' : mx' = mx in
                        match mx as mx'' return (mx' = mx'' -> Checker) with
                        | Datatypes.Some x => fun _ => checker (f a x _)
                        | Datatypes.None => fun _ => checker tt
                        end Heq)
                                     ) |}.
Proof.
  (* Annoying *)
  assert (Eq : mx = mx') by auto.
  rewrite -Eq in e.
  clear Heq Eq mx'.
  (* End annoying *)
  destruct (H5 a).
  (* Very annoying *)
  subst.
  assert (Ha : (isSome :&: semGen (genST [eta pre a])) (Some x)).
  { split; eauto. }
  apply STCorrect in Ha. destruct Ha as [y [Hin Heq]].
  inversion Heq. subst. eassumption.
Defined.

Global Instance testSuchThat_swap {A B C : Type} {pre : A -> B -> Prop}
       {prop : A -> B -> C -> Type}
       `{Checkable (forall a b, pre a b -> forall c, prop a b c)} :
  Checkable (forall a b c, pre a b -> prop a b c) :=
  {| checker f := @checker (forall a b, pre a b -> forall c, prop a b c) _ _ |}.
Proof. intros; eauto. Defined.

Global Instance GenSuchThatConj {A B : Type} (P : A -> Prop) (Q : B -> Prop)
       `{GenSuchThat A (fun x => P x)}
       `{GenSuchThat B (fun x => Q x)}
       : GenSuchThat (A * B) (fun xy => let (x,y) := xy in P x /\ Q y) :=
  {| arbitraryST :=
       bindGen (genST (fun x => P x)) (fun ma =>
       bindGen (genST (fun x => Q x)) (fun mb =>
       match ma, mb with
       | Some a, Some b => returnGen (Some (a,b))
       | _, _ => returnGen None
       end)) |}.

(*
Global Instance GenSuchThatConjCorrect {A B : Type} (P : A -> Prop) (Q : B -> Prop)
       `{GA: GenSizedSuchThat A (fun x => P x)}
       `{GB: GenSizedSuchThat B (fun x => Q x)}
       `{SizedSuchThatCorrectSuchThatSizedCorrect A (fun x => P x) (@arbitraryST _ _ GA)}
       `{SuchThatSizeCorrect B (fun x => Q x) (@arbitraryST _ _ GB)}
  : SuchThatCorrect (fun xy : A * B => let (x,y) := xy in P x /\ Q y)
                    (@arbitraryST _ (fun xy => let (x,y) := xy : A * B in P x /\ Q y)
                                  (@GenSuchThatConj A B P Q GA GB)) :=
  {| STComplete := _ ;
     STSound    := _ |}.
Proof.
- simpl. rewrite semBind
  *)

*)


(** * The generalization functions and lemmas
      This file contains the defintion of the generalization function [gen_ty].
      The generalization process is essential in the let case of algorithm W.
    *)

Require Import LibTactics.
Require Import Sublist.
Require Import Context.
Require Import ListIds.
Require Import Schemes.
Require Import SubstSchm.
Require Import Rename.
Require Import Disjoints.
Require Import Arith.Arith_base.
Require Import List.
Require Import SimpleTypes.
Require Import Subst.
Require Import MyLtacs.

(** * Generalization of non-free variables in a type *)

Fixpoint gen_ty_aux (tau : ty) (G : ctx) (l : list id) : schm * list id :=
  match tau with
  | var i => if in_list_id i (FV_ctx G) then (sc_var i, l) else
              match index_list_id i l with
              | None => (sc_gen (List.length l), (l ++ i::nil))
              | Some j => (sc_gen j, l)
              end
  | con i => (sc_con i, l)
  | arrow tau' tau'' => match gen_ty_aux tau' G l with
                       | (sc_tau, l') => match gen_ty_aux tau'' G l' with
                                        | (sc_tau', l'') =>
                                          (sc_arrow sc_tau  sc_tau', l'')
                                        end
                       end
  end.

Definition gen_ty (tau : ty) (G : ctx) :=
  @fst schm (list id) (gen_ty_aux tau G nil).

(** List of variables that can be generalized. *)
Fixpoint gen_ty_vars (tau : ty) (G : ctx) :=
  match tau with
  | con i => nil
  | var i => if in_list_id i (FV_ctx G) then nil else (i::nil)
  | arrow tau' tau'' => (gen_ty_vars tau' G) ++ (gen_ty_vars tau'' G)
  end.

(** * Several lemmas about the generalization function *)

(** gen_ty_vars distributes over arrow. *)
Lemma gen_ty_vars_arrow : forall t1 t2 G, gen_ty_vars (arrow t1 t2) G =
                                     gen_ty_vars t1 G ++ gen_ty_vars t2 G.
Proof.
  intros.
  reflexivity.
Qed.

Hint Resolve gen_ty_vars_arrow:core.
Hint Rewrite gen_ty_vars_arrow:RE.

Lemma fst_gen_aux_arrow_rewrite : forall (tau tau' : ty) (G : ctx) (l : list id),
    fst (gen_ty_aux (arrow tau tau') G l) = sc_arrow (fst (gen_ty_aux tau G l))
                                            (fst (gen_ty_aux tau' G (snd (gen_ty_aux tau G l)))).
Proof.
  intros; crush.
  destruct (gen_ty_aux tau G l); crush.
  destruct (gen_ty_aux tau' G l0 ); crush.
Qed.

Hint Resolve fst_gen_aux_arrow_rewrite:core.
Hint Rewrite fst_gen_aux_arrow_rewrite:RE.

(** snd gen_ty_aux distributes over arrow *)
Lemma snd_gen_ty_aux_arrow_rewrite : forall (tau tau': ty) (G : ctx) (l: list id),
    (snd (gen_ty_aux (arrow tau tau') G l)) =
    (snd (gen_ty_aux tau' G (snd (gen_ty_aux tau G l)))).
Proof.
  intros.
  cases (gen_ty_aux tau G l). simpl. rewrite Eq.
  cases (gen_ty_aux tau' G l0). reflexivity.
Qed.

Hint Resolve snd_gen_ty_aux_arrow_rewrite:core.
Hint Rewrite snd_gen_ty_aux_arrow_rewrite:RE.

Lemma free_and_bound_are_disjoints : forall (G : ctx) (tau: ty),
    (are_disjoints (gen_ty_vars tau G ) (FV_ctx G)).
Proof.
  intros.
  unfold are_disjoints.
  intros.
  induction tau.
  - simpl in *.
    cases (in_list_id i (FV_ctx G)).
    simpl in H.
    inversion H.
    simpl in H.
    cases (eq_id_dec i x).
    subst. assumption.
    inversion H.
  - simpl in *.
    inversion H.
  - simpl in H.
    apply in_list_id_or_append_inversion in H.
    destruct H.
    apply IHtau1.
    assumption.
    apply IHtau2.
    assumption.
Qed.

Hint Resolve free_and_bound_are_disjoints:core.

(** ** Lemmas related to the renaminng substitution *)

Lemma is_subst_list_gen_vars_aux : forall (rho: ren_subst) (G: ctx) (t: ty),
    (is_rename_subst rho) ->
    (are_disjoints (dom_ren rho) (FV_ctx G)) ->
    (are_disjoints (FV_ctx G) (img_ren rho)) ->
    (is_sublist_id (gen_ty_vars t G) (dom_ren rho)) ->
    (is_sublist_id (gen_ty_vars (apply_subst (rename_to_subst rho) t) G)
                       (img_ren rho)).
  induction t.
  - intros; simpl in *.
    cases (in_list_id i (FV_ctx G)).
    + fold (apply_subst (rename_to_subst rho) (var i)).
      rewrite <- (dom_rename_to_subst) in *.
      erewrite apply_subst_dom_false.
      simpl. destruct (in_list_id i (FV_ctx G)); try contradiction.
      apply nil_is_sublist.
      inversion Eq.
      eapply disjoint_inversion2. apply H0.
      mysimp.
    + inversion H2. inversion H. subst.
      specialize H3 with (st:=i).
      simpl in H3. destruct (eq_id_dec i i); intuition.
      fold (apply_subst (rename_to_subst rho) (var i)).
      rewrite apply_subst_rename_to_subst; auto.
      simpl.
      assert (in_list_id (apply_ren_subst rho i) (FV_ctx G) = false).
      { eapply disjoint_inversion2. apply H1. apply in_list_id_dom_img; auto. }
      rewrite H3. econstructor.
      intros. simpl in H5. destruct (eq_id_dec (apply_ren_subst rho i) st).
      rewrite <- e0. apply in_list_id_dom_img. auto. intuition.
  - intros. rewrite apply_subst_con. simpl. apply nil_is_sublist.
  - intros. rewrite apply_subst_arrow in *. simpl. simpl in H2.
    apply append_sublist.
    + eapply IHt1; auto. eapply sublist_of_append_inversion1.
      apply H2.
    + eapply IHt2; auto. eapply sublist_of_append_inversion2.
      apply H2.
Qed.

Hint Resolve is_subst_list_gen_vars_aux:core.

Lemma is_sublist_gen_vars : forall (rho : ren_subst) (s: substitution) (G : ctx) (tau: ty),
    (is_rename_subst rho) -> (dom_ren rho) = (gen_ty_vars tau G) ->
    (are_disjoints (FV_ctx G) (img_ren rho)) ->
    (is_sublist_id (gen_ty_vars (apply_subst (rename_to_subst rho) tau) G)
                       (img_ren rho)).
Proof.
  intros.
  inversion H.
  eapply is_subst_list_gen_vars_aux; auto.
  rewrite H0.
  eapply free_and_bound_are_disjoints. rewrite <- H0.
  apply sublist_reflexivity.
Qed.

Hint Resolve is_sublist_gen_vars:core.

(** The generalizable ids form a sublist of dom rho, for some conditions *)
Lemma is_sublist_gen_ty_dom_rho: forall (G : ctx) (rho : ren_subst) (tau: ty) (l : list id),
    (is_rename_subst rho) ->
    (are_disjoints (dom_ren rho) (FV_ctx G)) -> (are_disjoints (FV_ctx G) (img_ren rho)) ->
    (is_sublist_id l (dom_ren rho)) -> (is_sublist_id (gen_ty_vars tau G) (dom_ren rho)) ->
    (is_sublist_id  (snd (gen_ty_aux tau G l)) (dom_ren rho)).
Proof.
  induction tau; intros.
  - simpl.
    cases (in_list_id i (FV_ctx G)).
    + simpl. auto.
    + cases (index_list_id i l).
      * simpl. auto.
      * simpl.
        inversion H3. subst.
        apply sublist_cons_inv; auto.
        apply H4; auto.
        simpl.
        destruct (in_list_id i (FV_ctx G)); intuition.
        mysimp.
  - simpl. auto.
  - generalize dependent l.
    intros.
    erewrite snd_gen_ty_aux_arrow_rewrite.
    eapply IHtau2; auto.
    eapply IHtau1; auto.
    rewrite gen_ty_vars_arrow in H3.
    eapply sublist_of_append_inversion1.
    apply H3.
    eapply sublist_of_append_inversion2.
    apply H3.
Qed.

Hint Resolve is_sublist_gen_ty_dom_rho:core.

Lemma renaming_not_concerned_with_gen_vars: forall (rho : ren_subst) (s: substitution) (G : ctx) (tau: ty),
    (renaming_of_not_concerned_with rho (gen_ty_vars tau G) (FV_ctx G) (FV_subst s)) ->
    (are_disjoints (FV_subst s) (gen_ty_vars (apply_subst (rename_to_subst rho) tau) G)).
Proof.
  intros.
  inversion H.
  inversion H0.
  unfold FV_subst in *.
  apply disjoint_list_and_append.
  - eapply disjoint_sublist_bis.
    apply are_disjoints_symetry in H3.
    apply disjoint_list_and_append_inversion1 in H3.
    apply H3.
    eapply is_sublist_gen_vars; auto.
  - eapply disjoint_sublist_bis.
    apply are_disjoints_symetry in H3.
    apply disjoint_list_and_append_inversion2 in H3.
    apply H3.
    eapply is_sublist_gen_vars; auto.
Qed.

Hint Resolve renaming_not_concerned_with_gen_vars:core.

(** This lemma is used to prove gen_ty_renaming, which says that gen_ty
    works that same for a special renaming *)
Lemma gen_ty_renaming_aux: forall (tau : ty) (G: ctx) (rho : ren_subst) l,
    (is_rename_subst rho) ->
    (are_disjoints  (dom_ren rho) (FV_ctx G)) ->
    (is_sublist_id (gen_ty_vars tau G) (dom_ren rho)) ->
    (is_sublist_id l (dom_ren rho)) ->
    (are_disjoints  (FV_ctx G) (img_ren rho)) ->
    (gen_ty_aux (apply_subst (rename_to_subst rho) tau) G
                (List.map (apply_ren_subst rho) l)) =
    ((fst  (gen_ty_aux tau G l)), (List.map (apply_ren_subst rho) (snd (gen_ty_aux tau G l)))).
Proof.
  induction tau.
  - do 3 intro.
    simpl.
    cases (in_list_id i (FV_ctx G)).
    + intros.
      assert (in_list_id i (dom_ren rho) = false).
      {erewrite disjoint_inversion2. reflexivity.  apply H0. auto. }
      fold (apply_subst (rename_to_subst rho) (var i)).
      rewrite apply_subst_dom_false; auto.
      simpl.
      destruct (in_list_id i (FV_ctx G)); intuition.
      rewrite dom_rename_to_subst.
      auto.
    + intros.
      inversion H.
      repeat fold (apply_subst (rename_to_subst rho) (var i)).
      rewrite apply_subst_rename_to_subst; auto.
      simpl.
      inversion H1.
      simpl in H4.
      specialize H7 with (st:=i).
      simpl in H7.
      cases (eq_id_dec i i); intuition.
      subst.
      rewrite rename_img; auto.
      erewrite <- index_rename; auto.
      cases (index_list_id i l).
      reflexivity.
      repeat rewrite map_length.
      simpl.
      fequals; eauto.
      rewrite map_app.
      reflexivity.
  - intros.
    simpl.
    reflexivity.
  - intros.
    inversion H1.
    inversion H2.
    subst.
    rewrite apply_subst_arrow.
    simpl.
    rewrite IHtau1; auto.
    cases (gen_ty_aux tau1 G l).
    rewrite IHtau2; auto.
    cases (gen_ty_aux tau2 G l0).
    simpl.
    rewrite Eq0.
    simpl. reflexivity.
    rewrite gen_ty_vars_arrow in H1.
    apply sublist_of_append_inversion2 in H1.
    auto.
    rewrite gen_ty_vars_arrow in H1.
    apply sublist_of_append_inversion1 in H1.
    rewrite <- Eq.
    eapply is_sublist_gen_ty_dom_rho; auto.
    rewrite gen_ty_vars_arrow in H1.
    apply sublist_of_append_inversion1 in H1.
    auto.
Qed.

Hint Resolve gen_ty_renaming_aux:core.

(** gen_ty works that same for a special renaming *)
Lemma gen_ty_renaming: forall (G : ctx) (rho : ren_subst) (tau : ty) (s: substitution),
    (renaming_of_not_concerned_with rho (gen_ty_vars tau G) (FV_ctx G) (FV_subst s))
    -> (gen_ty tau G) = (gen_ty (apply_subst (rename_to_subst rho) tau) G).
Proof.
  intros.
  inversion H.
  unfold gen_ty in *.
  assert (nil = (List.map (apply_ren_subst rho) nil)).
  { reflexivity. }
  rewrite H8 at 2.
  subst.
  rewrite gen_ty_renaming_aux; auto.
  rewrite H1.
  apply free_and_bound_are_disjoints.
  rewrite <- H1.
  auto.
Qed.

Hint Resolve gen_ty_renaming:core.
Hint Rewrite gen_ty_renaming:RE.

Lemma gen_apply_rename_to_subst : forall (G : ctx) (rho : ren_subst) (tau : ty),
    is_rename_subst rho -> dom_ren rho = gen_ty_vars tau G ->
    are_disjoints (FV_ctx G) (img_ren rho) ->
    gen_ty tau G = gen_ty (apply_subst (rename_to_subst rho) tau) G.
Proof.
  intros; unfold gen_ty in |- *.
  inversion H.
  assert (nil = map (apply_ren_subst rho) nil).
  {reflexivity. }
  rewrite H5.
  rewrite gen_ty_renaming_aux; auto.
  rewrite H0.
  apply free_and_bound_are_disjoints.
  rewrite <- H0.
  apply sublist_reflexivity.
Qed.

Hint Resolve gen_apply_rename_to_subst:core.
Hint Rewrite gen_apply_rename_to_subst:RE.

(** ** Several other generalization lemmas *)

(** If the ids of a ty are free in the G, then gen_ty_aux is just ty_to_schm *)
Lemma is_not_generalizable : forall (G : ctx)  (tau : ty) (l: list id),
    is_sublist_id (ids_ty tau) (FV_ctx G) -> gen_ty_aux tau G l= (ty_to_schm tau, l).
Proof.
  induction tau; intros; auto; simpl;
    inversion H.
  - rewrite H0; auto. mysimp.
  - erewrite IHtau1.
    erewrite IHtau2. reflexivity.
    simpl in H.
    apply sublist_of_append_inversion2 in H. auto.
    apply sublist_of_append_inversion1 in H. auto.
Qed.

Hint Resolve is_not_generalizable:core.
Hint Rewrite is_not_generalizable:RE.

Lemma gen_ty_aux_in_subst_ctx : forall (tau: ty) (G : ctx) (s : substitution) (l : list id),
    (are_disjoints (dom s) (gen_ty_vars tau G)) ->
    (are_disjoints (img_ids s) (gen_ty_vars tau G)) ->
    (gen_ty_aux (apply_subst s tau) (apply_subst_ctx s G) l) =
    ((apply_subst_schm s (fst (gen_ty_aux tau G l))),
     (snd (gen_ty_aux tau G l))).
Proof.
  induction tau; intros.
  - simpl in *.
    cases (in_list_id i (FV_ctx G)).
    + fold (apply_subst s (var i)).
      rewrite is_not_generalizable.
      rewrite <- ty_to_subst_schm.
      reflexivity.
      eapply sublist_FV_ctx; auto.
    + repeat fold (apply_subst s (var i)).
      erewrite apply_subst_dom_false.
      simpl.
      rewrite not_in_FV_ctx; auto.
      cases (index_list_id i l);
        simpl; eauto.
      apply are_disjoints_symetry in H0.
      unfold are_disjoints in H0.
      specialize H0 with (x:=i).
      apply H0. mysimp.
      apply are_disjoints_symetry in H.
      unfold are_disjoints in H.
      specialize H with (x:=i).
      apply H. mysimp.
  - rewrite apply_subst_con.
    simpl. reflexivity.
  - rewrite apply_subst_arrow. simpl.
    erewrite IHtau1; auto.
    erewrite IHtau2; auto.
    cases (gen_ty_aux tau1 G l).
    cases (gen_ty_aux tau2 G l0).
    simpl.
    fequals.
    fequals.
    rewrite Eq0. reflexivity.
    rewrite Eq0. reflexivity.
    simpl in H. apply disjoint_list_and_append_inversion2 in H. auto.
    simpl in H0. apply disjoint_list_and_append_inversion2 in H0. auto.
    simpl in H. apply disjoint_list_and_append_inversion1 in H. auto.
    simpl in H0. apply disjoint_list_and_append_inversion1 in H0. auto.
Qed.

Hint Resolve gen_ty_aux_in_subst_ctx:core.
Hint Rewrite gen_ty_aux_in_subst_ctx:RE.

Lemma gen_ty_in_subst_ctx : forall (G : ctx) (s : substitution) (tau : ty),
    (are_disjoints (FV_subst s) (gen_ty_vars tau G)) ->
    (apply_subst_schm s (gen_ty tau G)) =
    (gen_ty (apply_subst s tau) (apply_subst_ctx s G)).
Proof.
  intros.
  unfold gen_ty. unfold FV_subst in H.
  erewrite gen_ty_aux_in_subst_ctx; auto;
    apply are_disjoints_symetry in H;
    apply are_disjoints_symetry.
  apply disjoint_list_and_append_inversion1 in H.
  auto.
  apply disjoint_list_and_append_inversion2 in H.
  auto.
Qed.

Hint Resolve gen_ty_in_subst_ctx:core.
Hint Rewrite gen_ty_in_subst_ctx:RE.

Lemma exists_snd_gen_aux_app : forall (G : ctx) (tau : ty) (l : list id),
    exists l', snd (gen_ty_aux tau G l) = l ++ l' /\ are_disjoints (FV_ctx G) l'.
Proof.
  induction tau.
  - intro. simpl.
    cases (in_list_id i (FV_ctx G)).
    exists (nil : list id).
    crush.
    cases (index_list_id i l).
    exists (nil : list id).
    crush.
    exists (i::nil : list id).
    crush.
  - crush.
    exists (nil : list id).
    crush.
  - intros.
    rewrite snd_gen_ty_aux_arrow_rewrite.
    edestruct IHtau1.
    destruct H.
    rewrite H.
    edestruct IHtau2.
    destruct H1.
    rewrite H1.
    exists (x ++ x0).
    split.
    rewrite app_assoc. reflexivity.
    eauto.
Qed.

Hint Resolve exists_snd_gen_aux_app:core.

Lemma disjoint_snd_gen_aux : forall (G : ctx) (l : list id) (tau : ty),
    are_disjoints (FV_ctx G) l -> are_disjoints (FV_ctx G) (snd (gen_ty_aux tau G l)).
Proof.
  intros.
  destruct (exists_snd_gen_aux_app G tau l).
  destruct H0. rewrite H0.
  eauto.
Qed.

Hint Resolve disjoint_snd_gen_aux:core.

Lemma length_snd_gen_aux : forall (G : ctx) (tau : ty) (l : list id),
    length (snd (gen_ty_aux tau G l)) = max (length l) (max_gen_vars (fst (gen_ty_aux tau G l))).
Proof.
  induction tau; crush.
  cases (in_list_id i (FV_ctx G)); crush.
  rewrite Nat.max_0_r. reflexivity.
  cases (index_list_id i l).
  simpl.
  symmetry.
  apply max_l.
  change (i0 < length l) in |- *.
  eapply index_lt; eauto.
  simpl.
  rewrite app_length.
  simpl.
  symmetry.
  assert (S (length l) = length l + 1). auto with *.
  rewrite H.
  apply max_r. auto with *.
  rewrite Nat.max_0_r. reflexivity.
  cases (gen_ty_aux tau1 G l).
  cases (gen_ty_aux tau2 G l0).
  simpl.
  specialize IHtau1 with (l:=l).
  rewrite Eq in IHtau1.
  specialize IHtau2 with (l:=l0).
  rewrite Eq0 in IHtau2.
  simpl in *.
  rewrite IHtau1 in IHtau2.
  rewrite Nat.max_assoc.
  assumption.
Qed.


Module FeatureModelSPL.
Require Export featuremodel_spl_int.
Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.

  Inductive Conf: Type.
  Inductive FM: Type.

  Parameter inline FMRef_Func :
    FM -> set Conf.

  Variable fm fm1 fm2: FM.
  Variable c c1 c2 c3: Conf.

  Axiom fm_dec : forall x y:FM, {x = y} + {x <> y}.
  Axiom conf_dec : forall x y:Conf, {x = y} + {x <> y}.

  (*Definition <Feature model refinement> -- definir com forall e exists?*)
  Definition FMRefinement_func (fm1 fm2: FM): Prop :=
    match (set_diff conf_dec (FMRef_Func fm1) (FMRef_Func fm2)) with
      | nil => True
      | _ => False
      end.

  (*   % Definition <Feature model equivalence> *)
  Definition equivalentFMs_func (fm1 fm2: FM): Prop :=
    (FMRefinement_func fm1 fm2) /\ (FMRefinement_func fm2 fm1).

  Axiom equalsSetDiff:
    forall a b: set Conf, a = b -> set_diff conf_dec a b = nil.

End FeatureModelSPL.


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
From mathcomp Require Import all_ssreflect.
From mathcomp Require boolp.
Require Import monae_lib.
From HB Require Import structures.
Require Import hierarchy monad_lib fail_lib state_lib.

(******************************************************************************)
(*                    Formalization of monad transformers                     *)
(*                                                                            *)
(* This file corresponds to the formalization of [Mauro Jaskelioff, Modular   *)
(* Monad Transformers, ESOP 2009] (roughly, up to Sect. 5, Example 22).       *)
(*                                                                            *)
(*  Module MonadMLaws == laws of monad morphisms                              *)
(*             monadM == type of monad morphisms                              *)
(*             monadT == type of monad transformers, i.e., functions t of     *)
(*                       type monad -> monad equipped with an operator Lift   *)
(*                       such that for any monad M Lift t M is a monad        *)
(*                       morphism from M to t M                               *)
(*                       instances:                                           *)
(*                       - stateT: the state monad transformer                *)
(*                       - exceptT: the exception monad transformer           *)
(*                       - envT: environment                                  *)
(*                       - outputT                                            *)
(*                       - contT: continuation                                *)
(*         mapStateT2 == standard utility function                            *)
(*            lifting == lifting of a sigma-operation along a monad morphism  *)
(*           alifting == algebraic operation defined using an algebraic       *)
(*                       operation op and a monad morphism e                  *)
(* uniform_algebraic_lifting == Theorem: alifting is a lifting                *)
(*                                                                            *)
(*         functorial == type of functors where the action on objects as type *)
(*                       monad -> monad                                       *)
(*                fmt == type of functorial monad transformers                *)
(*                       instances:                                           *)
(*                       - exceptFMT                                          *)
(*                       - stateFMT                                           *)
(*                       - envFMT                                             *)
(*                       - outputFMT                                          *)
(*                                                                            *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope monae_scope.

Module MonadMLaws.
Section monadmlaws.
Variables (M N : monad).
Definition ret (e : M ~~> N) := forall A : UU0, e A \o Ret = Ret.
Definition bind (e : M ~~> N) := forall (A B : UU0) (m : M A) (f : A -> M B),
  e B (m >>= f) = e A m >>= (e B \o f).
End monadmlaws.
End MonadMLaws.

HB.mixin Record isMonadM (M N : monad) (e : M ~~> N) := {
  monadMret : MonadMLaws.ret e ;
  monadMbind : MonadMLaws.bind e }.

#[short(type=monadM)]
HB.structure Definition MonadM (M N : monad) :=
  {e of isMonadM M N e & isNatural M N e}.

HB.factory Record isMonadM_ret_bind (M N : monad) (e : M ~~> N) := {
  monadMret : MonadMLaws.ret e ;
  monadMbind : MonadMLaws.bind e }.

HB.builders Context (M N : monad) (e : M ~~> N) of isMonadM_ret_bind M N e.

Lemma naturality_monadM : naturality M N e.
Proof.
move=> A B h; apply boolp.funext => m /=.
by rewrite !fmapE monadMbind (compA (e B)) monadMret.
Qed.

HB.instance Definition _ := isNatural.Build M N e naturality_monadM.
HB.instance Definition _ := isMonadM.Build M N e monadMret monadMbind.
HB.end.

HB.mixin Record isMonadT (T : monad -> monad) := {
  Lift : forall M, monadM M (T M) }.

#[short(type=monadT)]
HB.structure Definition MonadT := {T of isMonadT T}.
Arguments Lift : clear implicits.

Section state_monad_transformer.
Variables (S : UU0) (M : monad).

Definition MS := fun A : UU0 => S -> M (A * S)%type.

Definition retS : FId ~~> MS := fun (A : UU0) => curry Ret.

Definition bindS (A B : UU0) (m : MS A) f : MS B := fun s => m s >>= uncurry f.

Let bindSretf : BindLaws.left_neutral bindS retS.
Proof.
by move=> A B a f; rewrite /bindS; apply boolp.funext => s; rewrite bindretf.
Qed.

Let bindSmret : BindLaws.right_neutral bindS retS.
Proof.
move=> A m; rewrite /bindS; apply boolp.funext => s.
by rewrite -[in RHS](bindmret (m s)); bind_ext; case.
Qed.

Let bindSA : BindLaws.associative bindS.
Proof.
move=> A B C m f g; rewrite /bindS; apply boolp.funext => s.
by rewrite bindA; bind_ext; case.
Qed.

HB.instance Definition _ :=
  isMonad_ret_bind.Build MS bindSretf bindSmret bindSA.

Lemma MS_mapE (A B : UU0) (f : A -> B) (m : MS A) :
  ([the functor of MS] # f) m = (M # (fun x => (f x.1, x.2))) \o m.
Proof.
apply boolp.funext=> s.
rewrite {1}/actm /= /bindS /= fmapE.
congr bind.
by apply: boolp.funext; case.
Qed.

Definition liftS (A : UU0) (m : M A) : MS A :=
  fun s => m >>= (fun x => Ret (x, s)).

Let retliftS : MonadMLaws.ret liftS.
Proof.
move=> A; rewrite /liftS; apply boolp.funext => a /=; apply boolp.funext => s /=.
by rewrite bindretf.
Qed.

Let bindliftS : MonadMLaws.bind liftS.
Proof.
move=> A B m f; rewrite {1}/liftS; apply boolp.funext => s.
rewrite [in LHS]bindA.
transitivity ((liftS m s) >>= (uncurry (@liftS B \o f))) => //.
rewrite [in RHS]bindA.
bind_ext => a.
by rewrite [in RHS]bindretf.
Qed.

HB.instance Definition _ := isMonadM_ret_bind.Build
  M [the monad of MS] liftS retliftS bindliftS.

End state_monad_transformer.

Definition stateT (S : UU0) := fun M => [the monad of MS S M].

HB.instance Definition _ (S : UU0) := isMonadT.Build
  (stateT S) (fun M => [the monadM _ _ of @liftS S M]).

Definition mapStateT2 (A S : UU0) (N1 N2 N3 : monad)
    (f : N1 (A * S)%type -> N2 (A * S)%type -> N3 (A * S)%type)
    (m1 : stateT S N1 A) (m2 : stateT S N2 A) : stateT S N3 A :=
  fun s => f (m1 s) (m2 s).

Section stateMonad_of_stateT.
Variables (S : UU0) (M : monad).

Local Notation M' := (MS S M).
Let Put : S -> M' unit := fun s _ => Ret (tt, s).
Let Get : M' S := fun s => Ret (s, s).

Let bindputput (s s' : S) : Put s >> Put s' = Put s'.
Proof.
rewrite bindE /= /bindS.
apply boolp.funext => s0.
by rewrite MS_mapE bind_fmap bindretf.
Qed.

Let bindputget (s : S) : Put s >> Get = Put s >> Ret s.
Proof.
rewrite !bindE !MS_mapE /= /bindS.
apply boolp.funext => s'.
by rewrite !bind_fmap !bindretf.
Qed.

Let bindgetput : Get >>= Put = skip.
Proof.
rewrite bindE MS_mapE /= /bindS.
by apply boolp.funext => s; rewrite bind_fmap bindretf.
Qed.

Let bindgetget (A : UU0) (k : S -> S -> stateT S M A) :
  Get >>= (fun s => Get >>= k s) = Get >>= (fun s => k s s).
Proof.
apply boolp.funext => s.
rewrite /Get/=.
rewrite !bindE !MS_mapE /= /bindS /= /retS/=.
rewrite !bind_fmap !bindretf/=.
rewrite !bindE !MS_mapE /= /bindS /= /retS/=.
by rewrite bind_fmap bindretf.
Qed.

HB.instance Definition _ := @isMonadState.Build
  S (MS S M) Get Put bindputput bindputget bindgetput bindgetget.

End stateMonad_of_stateT.

Section exception_monad_transformer.
Local Obligation Tactic := idtac.
Variables (Z : UU0) (* the type of exceptions *) (M : monad).

(* action on objects of the transformed monad *)
Definition MX := fun X : UU0 => M (Z + X)%type.

(* unit and bind operator of the transformed monad *)
Definition retX : FId ~~> MX := fun X x => Ret (inr x).

Definition bindX X Y (t : MX X) (f : X -> MX Y) : MX Y :=
  t >>= fun c => match c with inl z => Ret (inl z) | inr x => f x end.

Let bindXretf : BindLaws.left_neutral bindX retX.
Proof. by move=> A B a f; rewrite /bindX bindretf. Qed.

Let bindXmret : BindLaws.right_neutral bindX retX.
Proof.
by move=> A m; rewrite /bindX -[in RHS](bindmret m); bind_ext; case.
Qed.

Let bindXA : BindLaws.associative bindX.
Proof.
move=> A B C m f g; rewrite /bindX bindA; bind_ext; case => //.
by move=> z; rewrite bindretf.
Qed.

HB.instance Definition _ :=
 isMonad_ret_bind.Build MX bindXretf bindXmret bindXA.

Lemma MX_mapE (A B : UU0) (f : A -> B) :
  [the functor of MX] # f = M # (fun x => match x with inl y => inl y | inr y => inr (f y) end).
Proof.
apply boolp.funext => m.
rewrite {1}/actm /= /bindX /= [in RHS]fmapE.
congr (_ _).
by apply: boolp.funext; case.
Qed.

Definition liftX X (m : M X) : MX X := m >>= (@ret [the monad of MX] _).

Let retliftX : MonadMLaws.ret liftX.
Proof.
by move=> A; apply boolp.funext => a; rewrite /liftX /= bindretf.
Qed.

Let bindliftX : MonadMLaws.bind liftX.
Proof.
move=> A B m f; rewrite {1}/liftX.
rewrite !bindE !fmapE.
rewrite /= /join_of_bind /bindX /= !bindA.
rewrite 2!joinE !bindA.
bind_ext => a.
rewrite 3!bindretf.
rewrite /liftX /=.
bind_ext => b.
by rewrite bindretf.
Qed.

HB.instance Definition _ := isMonadM_ret_bind.Build
  M [the monad of MX] liftX retliftX bindliftX.

End exception_monad_transformer.

Definition exceptT (Z : UU0) := fun M => [the monad of MX Z M].

HB.instance Definition _ (Z : UU0) := isMonadT.Build
  (exceptT Z) (fun M => [the monadM M [the monad of MX Z M] of @liftX Z M]).

Section failMonad_of_exceptT.
Variable M : monad.
Let N (B : UU0) := M (unit + B)%type.

Let Fail : forall B, N B := fun B => Ret (inl tt).

Let bindfail : BindLaws.left_zero (@bind (exceptT unit M)) Fail.
Proof.
move=> A B g; rewrite /Fail.
by rewrite bindE /= /join_of_bind /bindX /= fmapE /= bindA 2!bindretf.
Qed.

HB.instance Definition _ := @isMonadFail.Build (MX unit M) Fail bindfail.

End failMonad_of_exceptT.

Section exceptMonad_of_exceptT.
Variable (M : monad).
Let N (B : UU0) := M (unit + B)%type.

Let Catch (B : UU0) (x : N B) (y : N B) : N B :=
  x >>= (fun u => (fun k k' => match u with | inl a => k a | inr b => k' b end)
    (fun=> y) (fun b => Ret (inr b))).

Let Catchmfail (A : UU0) :
  right_id (@fail [the failMonad of MX unit M] A) (@Catch A).
Proof.
move=> x; rewrite /Catch /= /fail /= -[in RHS](bindmret x); bind_ext.
by case=> /= [[]|].
Qed.

Let Catchfailm (A : UU0) :
  left_id (@fail [the failMonad of MX unit M] A) (@Catch A).
Proof.
move=> x; rewrite /N in x *.
by rewrite /Catch /= /fail /= bindretf.
Qed.

Let CatchA (A : UU0) : associative (@Catch A).
Proof.
move=> x y z; rewrite /Catch bindA; bind_ext.
by case=> [[]//|b]; rewrite bindretf.
Qed.

Let Catchret (A : UU0) (ua : A%type) :
  @left_zero (N A) (N A) (Ret (inr ua)) (@Catch A).
Proof. by move=> n ; rewrite /Catch /= bindretf. Qed.

HB.instance Definition _ := @isMonadExcept.Build
  (MX unit M) Catch Catchmfail Catchfailm CatchA Catchret.

End exceptMonad_of_exceptT.

Section environment_monad_transformer.
Local Obligation Tactic := idtac.
Variables (R : UU0) (M : monad).

Definition MEnv := fun A : UU0 => R -> M A.

Definition retEnv : FId ~~> MEnv := fun (A : UU0) a r => Ret a.

Definition bindEnv A B (m : MEnv A) f : MEnv B :=
  fun r => m r >>= (fun a => f a r).

Let bindEnvretf : BindLaws.left_neutral bindEnv retEnv.
Proof.
by move=> A B a f; rewrite /bindEnv; apply boolp.funext => r; rewrite bindretf.
Qed.

Let bindEnvmret : BindLaws.right_neutral bindEnv retEnv.
Proof.
move=> A m; rewrite /bindEnv; apply boolp.funext => r.
rewrite -[in RHS](bindmret (m r)); by bind_ext; case.
Qed.

Let bindEnvA : BindLaws.associative bindEnv.
Proof.
move=> A B C m f g; rewrite /bindEnv; apply boolp.funext => r.
by rewrite bindA; bind_ext; case.
Qed.

HB.instance Definition _ :=
 isMonad_ret_bind.Build MEnv bindEnvretf bindEnvmret bindEnvA.

Lemma MEnv_mapE (A B : UU0) (f : A -> B) (m : MEnv A) :
  ([the functor of MEnv] # f) m = (M # f) \o m.
Proof. by apply boolp.funext=> r; rewrite /= fmapE. Qed.

Definition liftEnv A (m : M A) : MEnv A := fun r => m.

Let retliftEnv : MonadMLaws.ret liftEnv. Proof. by []. Qed.

Let bindliftEnv : MonadMLaws.bind liftEnv. Proof. by []. Qed.

HB.instance Definition envTmonadM := isMonadM_ret_bind.Build
  M [the monad of MEnv] liftEnv retliftEnv bindliftEnv.

End environment_monad_transformer.

Definition envT (E : UU0) := fun M => [the monad of MEnv E M].

HB.instance Definition _ (E : UU0) := isMonadT.Build (envT E)
  (fun M => [the monadM M [the monad of MEnv E M] of @liftEnv E M]).

(* traces monad transformer? *)
Section output_monad_transformer.
Local Obligation Tactic := idtac.
Variables (R : UU0) (M : monad).

Definition MO (X : UU0) := M (X * seq R)%type.

Definition retO : FId ~~> MO := fun (A : UU0) a => Ret (a, [::]).

Definition bindO A B (m : MO A) (f : A -> MO B) : MO B :=
  m >>= (fun o => let: (x, w) := o in f x >>=
  (fun o' => let (x', w') := o' in Ret (x', w ++ w'))).

Let bindOretf : BindLaws.left_neutral bindO retO.
Proof.
move=> A B a f; rewrite /bindO /= bindretf /=.
rewrite (_ : (fun o' : B * seq R => _) = (fun o => Ret o)) ?bindmret //.
by apply boolp.funext => -[].
Qed.

Let bindOmret : BindLaws.right_neutral bindO retO.
Proof.
move=> A m; rewrite /bindO /= /retO /= -[RHS]bindmret.
by bind_ext => -[a w]; rewrite bindretf cats0.
Qed.

Let bindOA : BindLaws.associative bindO.
Proof.
move=> A B C m f g; rewrite /bindO /=.
rewrite bindA; bind_ext; case=> x w.
rewrite !bindA; bind_ext; case=> x' w'.
rewrite !bindA bindretf; bind_ext; case=> x'' w''.
by rewrite bindretf catA.
Qed.

HB.instance Definition _ :=
 isMonad_ret_bind.Build MO bindOretf bindOmret bindOA.

Lemma MO_mapE (A B : UU0) (f : A -> B) (m : MO A) :
  ([the functor of MO] # f) m = (M # (fun x => (f x.1, x.2))) m.
Proof.
rewrite [in LHS]/actm /= /bindO /= [in RHS]fmapE.
congr (_ _).
apply boolp.funext => -[] ? ?.
by  rewrite bindretf cats0.
Qed.

Definition liftO A (m : M A) : MO A := m >>= (fun x => Ret (x, [::])).

Let retliftO : MonadMLaws.ret liftO.
Proof.
move=> a; rewrite /liftO /= /retO; apply boolp.funext => o /=.
by rewrite bindretf.
Qed.

Let bindliftO : MonadMLaws.bind liftO.
Proof.
move=> A B m f; rewrite {1}/liftO.
rewrite !bindE !fmapE /= /join_of_bind /bindO /= 2!joinE !bindA.
bind_ext => a.
rewrite /= !bindretf /liftO bindA.
bind_ext => b.
by rewrite bindretf /= bindretf.
Qed.

HB.instance Definition outputTmonadM := isMonadM_ret_bind.Build
  M [the monad of MO] liftO retliftO bindliftO.

End output_monad_transformer.

Definition outputT (R : UU0) := fun M => [the monad of MO R M].

HB.instance Definition _ (R : UU0) := isMonadT.Build (outputT R)
  (fun M => [the monadM M [the monad of MO R M] of @liftO R M]).

Section continuation_monad_tranformer.
Local Obligation Tactic := idtac.
Variables (r : UU0) (M : monad).

Definition MC : UU0 -> UU0 := fun A => (A -> M r) -> M r %type.

Definition retC : FId ~~> MC := fun (A : UU0) (a : A) k => k a.

Definition bindC A B (m : MC A) f : MC B := fun k => m (f^~ k).

Let bindCretf : BindLaws.left_neutral bindC retC.
Proof. by []. Qed.

Let bindCmret : BindLaws.right_neutral bindC retC.
Proof. by []. Qed.

Let bindCA : BindLaws.associative bindC.
Proof. by []. Qed.

HB.instance Definition _ :=
  isMonad_ret_bind.Build MC bindCretf bindCmret bindCA.

Lemma MC_mapE (A B : UU0) (f : A -> B) (m : MC A) :
  ([the functor of MC] # f) m = fun k : B -> M r => m (k \o f).
Proof. by []. Qed.

Definition liftC A (x : M A) : MC A := fun k => x >>= k.

Let retliftC : MonadMLaws.ret liftC.
Proof.
move => A; rewrite /liftC; apply boolp.funext => a /=.
by apply boolp.funext => s; rewrite bindretf.
Qed.

Let bindliftC : MonadMLaws.bind liftC.
Proof.
move => A B m f; rewrite /liftC; apply boolp.funext => cont.
by rewrite 3!bindA.
Qed.

HB.instance Definition contTmonadM := isMonadM_ret_bind.Build
  M [the monad of MC] liftC retliftC bindliftC.

End continuation_monad_tranformer.

Definition contT (r : UU0) := fun M => [the monad of MC r M].

HB.instance Definition _ (r : UU0) := isMonadT.Build (contT r)
  (fun M => [the monadM M [the monad of MC r M] of @liftC r M]).

Definition abortT r X (M : monad) A : contT r M A := fun _ : A -> M r => Ret X.
Arguments abortT {r} _ {M} {A}.

Section contMonad_of_contT.
Variables (r : UU0) (M : monad).
Let N := MC r M.

Let Callcc (A B : UU0) : ((A -> N B) -> N A) -> N A :=
  fun k f => k (fun a => fun=> f a) f.

Let Callcc0 (A B : UU0) (g : (A -> N B) -> N A) (k : B -> N B) :
  @Callcc _ _ (fun f => g (fun x => f x >>= k)) = @Callcc _ _ g.
Proof. by []. Qed.

Let Callcc1 (A B : UU0) (m : N B) : @Callcc _ _ (fun _ : B -> N A => m) = m.
Proof. by []. Qed.

Let Callcc2 (A B C : UU0) (m : N A) x (k : A -> B -> N C) :
  @Callcc _ _ (fun f : _ -> N _ => m >>= (fun a => f x >>= (fun b => k a b))) =
  @Callcc _ _ (fun f : _ -> N _ => m >> f x).
Proof. by []. Qed.

Let Callcc3 (A B : UU0) (m : N A) b :
  @Callcc _ _ (fun f : B -> N B => m >> f b) = @Callcc _ _ (fun _ : B -> N B => m >> Ret b).
Proof. by []. Qed.

HB.instance Definition _ := @isMonadContinuation.Build
  (MC r M) Callcc Callcc0 Callcc1 Callcc2 Callcc3.

End contMonad_of_contT.

Section continuation_monad_transformer_examples.

Fixpoint for_loop (M : monad) (it min : nat) (body : nat -> contT unit M unit) : M unit :=
  if it <= min then Ret tt
  else if it is it'.+1 then
      (body it') (fun _ => for_loop it' min body)
      else Ret tt.

Section for_loop_lemmas.
Variable M : monad.
Implicit Types body : nat  -> contT unit M unit.

Lemma loop0 i body : for_loop i i body = Ret tt.
Proof.
by case i => //= n; rewrite ltnS leqnn.
Qed.

Lemma loop1 i j body : for_loop (i.+1 + j) i body =
  (body (i + j)) (fun _ => for_loop (i + j) i body).
Proof.
rewrite /=.
by case : ifPn ; rewrite ltnNge leq_addr.
Qed.

Lemma loop2 i j body :
  body (i + j) = abortT tt -> for_loop (i + j).+1 i body = Ret tt.
Proof.
move=> Hbody /=.
case : ifPn => Hcond.
- reflexivity.
- by rewrite Hbody /= /abortT.
Qed.

End for_loop_lemmas.
(* TODO : instantiate with RunStateMonad *)

Definition foreach (M : monad) (items : list nat) (body : nat -> contT unit M unit) : M unit :=
  foldr
    (fun x next => (body x) (fun _ => next))
    (Ret tt)
    items.

(* Lemma loop3 : forall i j body, *)
(*      foreach (i + j).+1 i body = Ret tt -> body (i + j) = @abort_tt m unit. *)
(* Proof. *)
(* move => i j body /=. *)
(* case : ifPn => //; rewrite ltnNge; rewrite leq_addr. *)
(* by []. *)
(* move => _ /= Hfor. *)
(* have Hcont2 : forall cont, body (i + j) = @abort_tt m unit -> body (i + j) cont = Ret tt. *)
(*   (* split. *) *)
(*   rewrite /= /abort_tt /abort. *)
(*   by rewrite funeqE. *)
(* have Hcont1 : (forall cont, body (i + j) cont = Ret tt) -> body (i + j) = @abort_tt m unit.   *)
(*   move => Hcont. *)
(*   rewrite /= /abort_tt /abort. *)
(*   rewrite funeqE => k. *)
(*   exact: Hcont. *)
(* apply Hcont1. *)
(* move => cont. *)
(* rewrite Hcont2 //. *)

(* set bl := (fun _ : unit => foreach (i + j) i body). *)
(* (* Check (fun _ : unit => foreach (i + j) i body). *) *)
(* generalize (Hcont1 bl). *)

(* move => bl. *)
(* Qed *)

Section sum.
Variables M : stateMonad nat.

Let sum n : M unit := for_loop n O
  (fun i : nat => liftC (get >>= (fun z => put (z + i)))).

Lemma sum_test n :
  sum n = get >>= (fun m => put (m + sumn (iota 0 n))).
Proof.
elim: n => [|n ih].
  rewrite /sum.
  rewrite loop0.
  rewrite (_ : sumn (iota 0 0) = 0) //.
  rewrite -[LHS]bindskipf.
  rewrite -getputskip.
  rewrite bindA.
  bind_ext => a.
  rewrite addn0.
  rewrite -[RHS]bindmret.
  bind_ext.
  by case.
rewrite /sum -add1n loop1 /liftC bindA; bind_ext => m.
rewrite -/(sum n) {}ih -bindA.
rewrite putget bindA bindretf putput.
congr put.
by rewrite add0n (addnC 1) iotaD /= sumn_cat /= add0n addn0 /= addnAC addnA.
Qed.

Example sum_from_0_to_10 : M unit :=
  foreach (iota 100 0) (fun i => if i > 90 then
                            abortT tt
                          else
                            liftC (get >>= (fun z => put (z + i)))).

End sum.

End continuation_monad_transformer_examples.

(* laws about lifted fail *)

Lemma bindLfailf (M : failMonad) S :
  BindLaws.left_zero (@bind (stateT S M)) (Lift _ _ ^~ fail).
Proof.
move=> A B g /=; rewrite /liftS; apply boolp.funext => s; rewrite bindfailf.
set x := (X in X >>= _ = _).
by rewrite (_ : x = fail) ?bindfailf// /x bindfailf.
Qed.

Lemma bindmLfail (M : failR0Monad) S :
  BindLaws.right_zero (@bind (stateT S M)) (Lift _ _ ^~ fail).
Proof.
move=> A B m /=; rewrite /liftS/=; apply/boolp.funext => s; rewrite bindfailf.
set x := (X in _ >>= X = _).
rewrite (_ : x = fun=> fail) ?bindmfail//.
by apply/boolp.funext=> -[b s']; rewrite /x/= bindfailf.
Qed.

Section lifting.
Variables (E : functor) (M : monad) (op : E.-operation M)
          (N : monad) (e : monadM M N).
Definition lifting (f : E \o N ~~> N) :=
  forall X : UU0, e X \o op X = f X \o (E # e X).
End lifting.

Section liftingt.
Variables (E : functor) (M : monad) (op : E.-operation M)
          (t : monadT).
Definition lifting_monadT := lifting op (Lift t M).
End liftingt.

Section proposition17.

Section psi.
Variables (E : functor) (M : monad).

Definition psi' (n : E ~~> M) : E \o M ~~> M := fun X => Join \o n (M X).

Lemma natural_psi' (n : E ~> M) : naturality [the functor of E \o M] M (psi' n).
Proof.
move=> A B h; rewrite /psi'.
rewrite -/(Join \o n (M A)) [LHS]compA natural.
by rewrite -compA (natural n).
Qed.

HB.instance Definition _ (n : E ~> M) := isNatural.Build
  [the functor of E \o M] M (psi' n) (natural_psi' n).

Lemma algebraic_psi' (n : E ~> M) : algebraicity (psi' n).
Proof.
move=> A B g t.
rewrite bindE.
rewrite -(compE (M # g)).
rewrite {1}/psi'.
rewrite [in LHS](compA (M # g) Join).
rewrite /=.
rewrite -[in X in _ = Join X]compE.
rewrite -[in RHS](natural n).
transitivity (Join ((M # (Join \o (M # g))) (n (M A) t))); last first.
  rewrite -(compE _ (n (M A)) t).
  congr (Join ((M # _ \o _ ) t)).
  apply boolp.funext => ma.
  by rewrite bindE.
rewrite -[in X in Join X = _]compE.
rewrite (natural join).
rewrite functor_o.
rewrite -[in RHS]FCompE.
rewrite -[RHS]compE.
rewrite [in RHS]compA.
by rewrite joinA.
Qed.

HB.instance Definition _ (n : E ~> M) := isAOperation.Build
  E M (psi' n) (algebraic_psi' n).
Definition psi (n : E ~> M) := [the E.-aoperation M of psi' n].

Lemma psiE (n : E ~> M) A : psi n A = Join \o n (M A).
Proof. by []. Qed.

End psi.

Section phi.
Variables (E : functor) (M : monad).

Definition phi' (op : E.-operation M) : E ~~> M := fun X => op X \o (E # Ret).

Lemma natural_phi' (op : E.-operation M) : naturality E M (phi' op).
Proof.
move=> A B h; rewrite /phi'.
rewrite compA.
rewrite (natural op).
rewrite -compA.
rewrite -[in RHS]compA.
congr (_ \o _).
rewrite /=.
rewrite -2!(@functor_o E).
by rewrite (natural ret) FIdE.
Qed.

HB.instance Definition _ (op : E.-operation M) := isNatural.Build
  E M (phi' op) (natural_phi' op).

Definition phi (op : E.-operation M) := [the _ ~> _ of phi' op].

Lemma phiE (op : E.-operation M) (X : UU0) : phi op X = op X \o (E # Ret).
Proof. by []. Qed.

End phi.

Section bijection.
Variables (E : functor) (M : monad).

Lemma psiK (op : E ~> M) : phi (psi op) = op.
Proof.
apply/nattrans_ext => A.
rewrite phiE /= psiE; apply boolp.funext => m /=.
rewrite -(compE (op _)) -(natural op) -(compE Join).
by rewrite compA joinMret.
Qed.

Lemma phiK (op : E.-aoperation M) : psi (phi op) = op.
Proof.
apply/aoperation_ext => A.
rewrite /=.
rewrite psiE phiE; apply boolp.funext => m /=.
rewrite -(compE (op _)) joinE.
rewrite (algebraic op).
rewrite -(compE (E # _)) -functor_o.
rewrite -(compE (op _)).
set x := _^~ id.
rewrite (_ : x = Join); last first.
  apply boolp.funext => mma.
  by rewrite /x bindE functor_id (*TODO: lemma*).
by rewrite joinretM functor_id compfid.
Qed.

End bijection.
End proposition17.

Section uniform_algebraic_lifting.
Variables (E : functor) (M : monad) (op : E.-aoperation M).
Variables (N : monad) (e : monadM M N).

Definition alifting := psi (e \v phi op).

Lemma aliftingE : alifting =
  (fun X => Join \o e (N X) \o phi op (N X)) :> (_ ~~> _).
Proof. by rewrite /alifting/= /vcomp; unlock. Qed.

Theorem uniform_algebraic_lifting : lifting op e alifting.
Proof.
move=> X.
apply boolp.funext => Y.
rewrite /alifting.
rewrite [in RHS]/=.
rewrite psiE.
rewrite vcompE.
rewrite phiE.
rewrite !compE.
rewrite (_ : (E # Ret) ((E # e X) Y) =
             (E # (M # e X)) ((E # Ret) Y)); last first.
  rewrite -[in LHS]compE -functor_o.
  rewrite -[in RHS]compE -functor_o.
  by rewrite (natural ret) FIdE.
set x := (Z in Join (e (N X) Z)).
rewrite (_ : x =
             (M # e X) (op (M X) ((E # Ret) Y))); last first.
  rewrite -(compE (M # e X)).
  by rewrite (natural op).
transitivity (e X (Join (op (M X) ((E # Ret) Y)))); last first.
  rewrite joinE.
  rewrite monadMbind.
  rewrite bindE -(compE _ (M # e X)).
  by rewrite -natural.
by rewrite -[in LHS](phiK op).
Qed.
End uniform_algebraic_lifting.

HB.mixin Record isFunctorial (t : monad -> monad) := {
  hmap : forall {M N : monad}, (M ~> N) -> t M ~> t N ;
  functorial_id : forall M : monad,
    hmap [the _ ~> _ of NId M] = [the _ ~> _ of NId (t M)] ;
  functorial_o : forall (M N P : monad) (t : M ~> N) (s : N ~> P),
    hmap (s \v t) = hmap s \v hmap t }.

#[short(type=functorial)]
HB.structure Definition Functorial := {t of isFunctorial t}.
Arguments hmap _ {M N} _.

HB.mixin Record isFMT (t : monad -> monad) of MonadT t & Functorial t := {
  fmt_ret : forall M N (e : monadM M N),
    MonadMLaws.ret (hmap [the functorial of t] e) ;
  fmt_bind : forall M N (e : monadM M N),
    MonadMLaws.bind (hmap [the functorial of t] e) ;
  natural_hmap : forall (M N : monad) (n : M ~> N),
    hmap [the functorial of t] n \v Lift [the monadT of t] M =
    Lift [the monadT of t] N \v n }.

#[short(type=fmt)]
HB.structure Definition FMT := {t of isFMT t & isFunctorial t & isMonadT t}.

Section fmt_lemmas.

Lemma natural_hmapE (t : fmt) (M N : monad) (n : M ~> N) (X : UU0) :
  hmap t n X \o Lift t M X = Lift t N X \o n X.
Proof.
have /nattrans_ext/(_ X)/= := @natural_hmap t M N n.
by rewrite !vcompE.
Qed.

End fmt_lemmas.

Section exceptFMT.
Variable X : UU0.
Let T := [the monadT of exceptT X].
Definition hmapX' (F G : monad) (tau : F ~> G) : T F ~~> T G :=
  fun (A : UU0) t => tau _ t.

Let naturality_hmapX' (F G : monad) (tau : F ~> G) :
  naturality (T F) (T G) (hmapX' tau).
Proof.
move=> A B h.
by rewrite /hmapX' 2!MX_mapE (natural tau).
Qed.

HB.instance Definition hmapX (F G : monad) (tau : F ~> G) :=
  isNatural.Build (T F) (T G) (hmapX' tau) (naturality_hmapX' tau).

Let hmapX_NId (M : monad) :
  [the _ ~> _ of hmapX' [the _ ~> _ of NId M]] = [the _ ~> _ of NId (T M)].
Proof. by apply/nattrans_ext => A. Qed.

Let hmapX_v (M N P : monad) (t : M ~> N) (s : N ~> P) :
  [the _ ~> _ of hmapX' (s \v t)] =
  [the _ ~> _ of hmapX' s] \v [the _ ~> _ of hmapX' t].
Proof.
by apply/nattrans_ext => /= A; rewrite vcompE /= /hmapX'/= vcompE.
Qed.

HB.instance Definition _ := isFunctorial.Build (exceptT X) hmapX_NId hmapX_v.

Let monadMret_hmapX (F G : monad) (e : monadM F G) :
  MonadMLaws.ret (hmapX' e).
Proof.
move=> A; apply boolp.funext => /= a.
by rewrite /hmapX' /retX /= -(compE (e _)) monadMret.
Qed.

Let monadMbind_hmapX (F G : monad) (e : monadM F G) :
  MonadMLaws.bind (hmapX' e).
Proof.
move=> A B m f; rewrite /hmapX' /=.
rewrite !bindE /= !MX_mapE /bindX /= !bind_fmap.
rewrite !monadMbind /=.
congr (bind (e (X + A)%type m) _).
apply boolp.funext => -[x/=|//].
by rewrite -(compE (e _)) monadMret.
Qed.

Let hmapX_lift :
  let h := fun F G FG => [the _ ~> _ of hmapX' FG] in
  forall (M N : monad) (n : M ~> N),
  h M N n \v Lift T M = Lift T N \v n.
Proof.
move=> h M N t; apply/nattrans_ext => A/=; rewrite !vcompE/=.
rewrite /hmapX' /=.
rewrite /liftX /=.
rewrite /retX /=.
apply boolp.funext => ma /=.
rewrite (_ : (fun x : A => Ret (inr x)) = Ret \o inr) //.
rewrite -bind_fmap.
rewrite bindmret.
rewrite (_ : (fun x : A => Ret (inr x)) = Ret \o inr) //.
rewrite -bind_fmap.
rewrite bindmret.
rewrite -(compE (N # inr)).
by rewrite (natural t).
Qed.

HB.instance Definition _ := isFMT.Build (exceptT X)
  monadMret_hmapX monadMbind_hmapX  hmapX_lift.

End exceptFMT.

Section Fmt_stateT.
Variable S : UU0.
Let T := [the monadT of stateT S].
Definition hmapS (F G : monad) (tau : F ~> G) : T F ~~> T G :=
  fun (A : UU0) t s => tau _ (t s).

Let naturality_hmapS (F G : monad) (tau : F ~> G) :
  naturality (T F) (T G) (hmapS tau).
Proof.
move=> A B h.
rewrite /hmapS /=.
have H : forall G, [the monad of stateT S G] # h = [the functor of MS S G] # h by [].
rewrite !H {H}.

apply boolp.funext => m /=.
rewrite !MS_mapE.
apply boolp.funext => s /=.
rewrite -(compE  _ (tau (A * S)%type)).
by rewrite natural.
Qed.

HB.instance Definition _ (F G : monad) (tau : F ~> G) := isNatural.Build
  (T F) (T G) (hmapS tau) (naturality_hmapS tau).

Let hmapS_NId (M : monad) :
  [the _ ~> _ of hmapS [the _ ~> _ of NId M]] = [the _ ~> _ of NId (T M)].
Proof. by apply/nattrans_ext. Qed.

Let hmapS_v (M N P : monad) (t : M ~> N) (s : N ~> P) :
  [the _ ~> _ of hmapS (s \v t)] =
  [the _ ~> _ of hmapS s] \v [the _ ~> _ of hmapS t].
Proof.
by apply/nattrans_ext => A /=; rewrite vcompE/= /hmapS/= vcompE.
Qed.

HB.instance Definition _ := isFunctorial.Build (stateT S) hmapS_NId hmapS_v.

Let monadMret_hmapS (F G : monad) (e : monadM F G) :
  MonadMLaws.ret (hmapS e).
Proof.
move=> A; apply boolp.funext => /= a.
rewrite /hmapS /= /retS /=; apply boolp.funext => s.
by rewrite [in LHS]curryE monadMret.
Qed.

Let monadMbind_hmapS (F G : monad) (e : monadM F G) :
  MonadMLaws.bind (hmapS e).
Proof.
move=> A B m f.
rewrite /hmapS /=; apply boolp.funext => s.
rewrite /= 2!bindE /= !MS_mapE /bindS /= 2!bind_fmap.
by rewrite monadMbind.
Qed.

Let hmapS_lift :
  let h := fun F G FG => [the _ ~> _ of hmapS FG] in
  forall (M N : monad) (n : M ~> N),
  h M N n \v Lift T M = Lift T N \v n.
Proof.
move=> h M N t; apply/nattrans_ext => A /=; rewrite !vcompE/=.
rewrite /hmapS /=.
rewrite /liftS /=.
apply boolp.funext => ma /=.
apply boolp.funext => s /=.
rewrite ![in LHS]bindE ![in LHS]fmapE ![in LHS]bindE.
rewrite 2!(_ : (fun x : A => Ret (x, s)) = Ret \o (fun x => (x, s))) //.
rewrite functor_o.
rewrite -(compE Join (_ \o _)).
rewrite (compA Join (M # _)).
rewrite joinMret.
rewrite compidf.
rewrite functor_o.
rewrite compA.
rewrite joinMret.
rewrite compidf.
rewrite -(compE _ (t A)).
rewrite -(compE (t _)).
rewrite -natural.
rewrite /=.
rewrite ![in RHS]bindE ![in RHS]fmapE ![in RHS]bindE.
rewrite functor_o.
rewrite -(compE Join (_ \o _)).
rewrite (compA Join (N # _)).
rewrite joinMret.
rewrite compidf.
rewrite functor_o.
rewrite compA.
rewrite joinMret.
rewrite compidf.
by rewrite -(compE _ (t A)).
Qed.

HB.instance Definition _ := isFMT.Build (stateT S)
  monadMret_hmapS monadMbind_hmapS hmapS_lift.

End Fmt_stateT.

Section Fmt_envT.
Variable E : UU0.
Let T := [the monadT of envT E].
Definition hmapEnv (F G : monad) (tau : F ~> G) : T F ~~> T G :=
  fun (A : UU0) t s => tau _ (t s).

Let naturality_hmapEnv (F G : monad) (tau : F ~> G) :
  naturality (T F) (T G) (hmapEnv tau).
Proof.
move=> A B h.
rewrite /hmapEnv.
rewrite /=.
have H : forall G, [the monad of envT E G] # h = [the functor of MEnv E G] # h by [].
rewrite !H {H}.
apply boolp.funext => m /=.
rewrite !MEnv_mapE.
apply boolp.funext => s /=.
rewrite -(compE  _ (tau A)).
by rewrite natural.
Qed.

HB.instance Definition _ (F G : monad) (tau : F ~> G) :=
  isNatural.Build (T F) (T G) (hmapEnv tau) (naturality_hmapEnv tau).

Let hmapEnv_NId (M : monad) :
  [the _ ~> _ of hmapEnv [the _ ~> _ of NId M]] = [the _ ~> _ of NId (T M)].
Proof. by apply nattrans_ext. Qed.

Let hmapEnv_v (M N P : monad) (t : M ~> N) (s : N ~> P) :
  [the _ ~> _ of hmapEnv (s \v t)] =
  [the _ ~> _ of hmapEnv s] \v [the _ ~> _ of hmapEnv t].
Proof. by apply/nattrans_ext => A /=; rewrite vcompE/= /hmapEnv vcompE. Qed.

HB.instance Definition _ := isFunctorial.Build (envT E) hmapEnv_NId hmapEnv_v.

Let monadMret_hmapEnv (F G : monad) (e : monadM F G) :
  MonadMLaws.ret (hmapEnv e).
Proof.
move=> A; apply boolp.funext => /= a.
rewrite /hmapEnv /= /retEnv /=; apply boolp.funext => s.
by rewrite -[LHS](compE _ Ret) monadMret.
Qed.

Let monadMbind_hmapEnv (F G : monad) (e : monadM F G) :
  MonadMLaws.bind (hmapEnv e).
Proof.
move=> A B m f.
rewrite /hmapEnv /=; apply boolp.funext => s.
rewrite /= 2!bindE /= !MEnv_mapE /bindEnv /= 2!bind_fmap.
by rewrite monadMbind.
Qed.

Let hmapEnv_lift :
  let h := fun F G FG => [the _ ~> _ of hmapEnv FG] in
  forall (M N : monad) (n : M ~> N),
  h M N n \v Lift T M = Lift T N \v n.
Proof.
move=> h M N t; apply/nattrans_ext => A /=; rewrite !vcompE/=.
by rewrite /hmapEnv/= /liftEnv/=; exact: boolp.funext.
Qed.

HB.instance Definition _ := isFMT.Build (envT E)
  monadMret_hmapEnv monadMbind_hmapEnv hmapEnv_lift.

End Fmt_envT.

Section Fmt_outputT.
Variable R : UU0.
Let T := [the monadT of outputT R].
Definition hmapO (F G : monad) (tau : F ~> G) : T F ~~> T G :=
  fun (A : UU0) => tau _.

Let naturality_hmapO (F G : monad) (tau : F ~> G) :
  naturality (T F) (T G) (hmapO tau).
Proof.
move=> A B h.
rewrite /hmapO.
rewrite /=.
have H : forall G, [the monad of outputT R G] # h = [the functor of MO R G] # h by [].
rewrite !H {H}.
apply boolp.funext => m /=; rewrite !MO_mapE.
rewrite -[in LHS](compE  _ (tau _)).
by rewrite natural.
Qed.

HB.instance Definition _ (F G : monad) (tau : F ~> G) :=
  isNatural.Build (T F) (T G) (hmapO tau) (naturality_hmapO tau).

Let hmapO_NId (M : monad) :
  [the _ ~> _ of hmapO [the _ ~> _ of NId M]] = [the _ ~> _ of NId (T M)].
Proof. by apply nattrans_ext. Qed.

Let hmapO_v (M N P : monad) (t : M ~> N) (s : N ~> P) :
  [the _ ~> _ of hmapO (s \v t)] =
  [the _ ~> _ of hmapO s] \v [the _ ~> _ of hmapO t].
Proof. by apply/nattrans_ext => A /=; rewrite vcompE/= /hmapO/= vcompE. Qed.

HB.instance Definition _ := isFunctorial.Build (outputT R) hmapO_NId hmapO_v.

Let monadMret_hmapO (F G : monad) (e : monadM F G) :
  MonadMLaws.ret (hmapO e).
Proof.
move=> A; apply boolp.funext => /= a; rewrite /hmapO /= /retO /=.
by rewrite -[LHS](compE _ Ret) monadMret.
Qed.

Let monadMbind_hmapO (F G : monad) (e : monadM F G) :
  MonadMLaws.bind (hmapO e).
Proof.
move=> A B m f.
rewrite /hmapO /=.
rewrite 2!bindE /= !MO_mapE /bindO /= 2!bind_fmap.
rewrite !monadMbind.
bind_ext => -[x w].
rewrite /retO /=.
rewrite monadMbind.
bind_ext => /= -[h t] /=.
rewrite -[LHS](compE _ Ret (h, _)).
by rewrite monadMret.
Qed.

Let hmapO_lift :
  let h := fun F G FG => [the _ ~> _ of hmapO FG] in
  forall (M N : monad) (n : M ~> N),
  h M N n \v Lift T M = Lift T N \v n.
Proof.
move=> h M N t; apply/nattrans_ext => A /=; rewrite !vcompE/=.
rewrite /hmapO /= /liftO /=.
apply boolp.funext => ma /=.
rewrite -!fmapE.
rewrite -(compE _ (t A)).
by rewrite natural.
Qed.

HB.instance Definition _ := isFMT.Build (outputT R)
  monadMret_hmapO monadMbind_hmapO hmapO_lift.

End Fmt_outputT.


(**
A monad morphism induces a left module morphism [monad_mor_to_lmodule]
*)
(** TODO: move to UniMath *)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.

(** strangely enough, I didn't find the following lemma :
 *)
Lemma monad_mor_to_lmodule_law {C : precategory} {R S : Monad C}
           (f : Monad_Mor R S) :
  LModule_Mor_laws R (T := tautological_LModule R)
                   (T' := pb_LModule f (tautological_LModule S)) f.
Proof.
  intro x.
+
  cbn.
  rewrite assoc.
  apply pathsinv0.
  apply Monad_Mor_μ.
Qed.

Definition monad_mor_to_lmodule {C : precategory} {R S : Monad C}
  (f : Monad_Mor R S) : LModule_Mor R (tautological_LModule R) (pb_LModule f (tautological_LModule S))
  := (f : nat_trans _ _) ,, monad_mor_to_lmodule_law f.