(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2004-09-06
- William Delobel, 2005-10-07

This file provides a development of (part of) the theory of finite
multisets.
*)

Set Implicit Arguments.

From Coq Require Import Min List Setoid Morphisms.
From CoLoR Require Import RelExtras MultisetCore ListPermutation NatUtil
     ListExtras LogicUtil.

Module Multiset (MC : MultisetCore).

  Export MC.

  Section NewOperations.

    Definition member x M := (x/M)%msets > 0.

    Definition insert x M : Multiset := {{x}}+M.

    Definition pair a b : Multiset := insert a {{b}}.

    Definition remove a A : Multiset := A - {{a}}.

    Fixpoint list2multiset (l : list A) : Multiset :=
      match l with
      | List.nil => empty
      | List.cons x xs => insert x (list2multiset xs)
      end.

  End NewOperations.

  Notation "{{ x , y }}" := (pair x y) (at level 5) : msets_scope.
  Notation "x 'in' M" := (member x M) (at level 10) : msets_scope.

  Ltac mset_unfold := repeat progress unfold insert,remove,pair,member.

  Ltac try_solve_meq :=
     (intros;
     match goal with
     | |- _ =mul= _ =>
         ( apply multeq_meq
         ; intro
         ; try_solve_meq
         )
     | _ =>
         ( mset_unfold
         ; repeat progress (
	      try rewrite union_mult;
              try rewrite diff_mult;
              try rewrite empty_mult;
              try rewrite intersection_mult
           )
         ; try omega
         ; try congruence
         ; try solve [auto with multisets]
         )
     end
     ).

  Ltac solve_meq :=
   (solve [try_solve_meq] ||
   fail "Goal is not an equality between multisets or fails to prove").

  Ltac try_solve_meq_ext :=
       (
       let go x := (solve [clear x; try_solve_meq_ext]) in (
       mset_unfold;
       intros;
       try solve_meq;
       (match goal with
       | H : ?A =mul= ?B |- _ =>
           (  (try_solve_meq; rewrite (meq_multeq H); go H)
           || (try_solve_meq; rewrite <- (meq_multeq H); go H)
           )
       | H : ?a =A= ?b |- _ =>
           (  (rewrite (singleton_mult_in H); go H)
           || (rewrite H; go H)
           || (rewrite <- H; go H)
           || (rewrite (mult_eqA_compat H); go H)
           || (rewrite <- (mult_eqA_compat H); go H)
           )
       | H : ~ ?a =A= ?b |- _ =>
           (rewrite (singleton_mult_notin H); go H)
       | |- _ =mul= _ =>
            ( apply multeq_meq; try_solve_meq_ext )
       end || try_solve_meq))).

  Ltac solve_meq_ext :=
     (solve [try_solve_meq_ext] ||
      fail "Couldn't show multisets equality").

  Hint Unfold member
              insert
              pair
              remove : multisets.

  Section meq_equivalence.

    Lemma meq_refl M : M =mul= M.

    Proof. solve_meq. Qed.

    Lemma meq_trans M N P : M =mul= N -> N =mul= P -> M =mul= P.

    Proof. solve_meq_ext. Qed.

    Lemma meq_sym M N : M =mul= N -> N =mul= M.

    Proof. solve_meq_ext. Qed.

  End meq_equivalence.

  Hint Resolve meq_refl meq_trans meq_sym : multisets.

  Instance meq_Equivalence : Equivalence meq.

  Proof.
    split.
    intro x. apply meq_refl.
    intros x y. apply meq_sym.
    intros x y z. apply meq_trans.
  Qed.

  Instance union_morph : Proper (meq ==> meq ==> meq) union.

  Proof. intros a b ab c d cd. solve_meq. Qed.

  Instance singleton_morph : Proper (eqA ==> meq) singleton.

  Proof.
    intros x y H. try_solve_meq_ext; case (eqA_dec x0 x); intros.
    assert (x0 =A= y); [rewrite <- H; trivial | idtac].
    assert (x0/{{y}} = 1);
      assert (x0/{{x}} = 1);
      solve [auto with multisets | congruence].
    assert (~x0 =A= y); [rewrite <- H; trivial | idtac].
    assert (x0/{{x}} = 0);
      assert (x0/{{y}} = 0);
      solve [auto with multisets | congruence].
  Qed.

  Instance pair_morph : Proper (eqA ==> eqA ==> meq) pair.

  Proof. intros a b ab c d cd. solve_meq_ext. Qed.

  Instance mult_morph : Proper (eqA ==> meq ==> eq) mult.

  Proof. intros a b ab c d cd. solve_meq_ext. Qed.

  Instance diff_morph : Proper (meq ==> meq ==> meq) diff.

  Proof. intros a b ab c d cd. solve_meq_ext. Qed.

  Instance insert_morph : Proper (eqA ==> meq ==> meq) insert.

  Proof. intros a b ab c d cd. solve_meq_ext. Qed.

  Instance member_morph : Proper (eqA ==> meq ==> iff) member.

  Proof. mset_unfold; intros a a0 h m m0 H. rewrite h, H. intuition. Qed.

  Instance remove_morph : Proper (eqA ==> meq ==> meq) remove.

  Proof. intros a b ab c d cd. solve_meq_ext. Qed.

  Instance intersection_morph : Proper (meq ==> meq ==> meq) intersection.

  Proof. intros a b ab c d cd. solve_meq. Qed.

  Section MultisetLemmas.

    Lemma mset_ind : forall P : Multiset -> Prop,
      P empty -> (forall M a, P M -> P (M + {{a}})) -> forall M, P M.

    Proof. exact mset_ind_type. Qed.

    Lemma mset_ind_set : forall P : Multiset -> Set,
        P empty -> (forall M a, P M -> P (M + {{a}})) -> forall M, P M.

    Proof. exact mset_ind_type. Qed.

    Lemma union_comm M N : M + N =mul= N + M.

    Proof. solve_meq. Qed.

    Lemma intersection_comm M N : M # N =mul= N # M.

    Proof. try_solve_meq. lia. Qed.

    Lemma union_assoc M N P : M + (N + P) =mul= (M + N) + P.

    Proof. solve_meq. Qed.

    Lemma member_singleton x y : x in {{y}} -> x =A= y.

    Proof.
      mset_unfold; intros.
      case (eqA_dec x y); [trivial | intro x_neq_y].
      assert (x/{{y}} = 0); [auto with multisets | idtac].
      rewrite H0 in H; omega.
    Qed.

    Lemma singleton_member_eqA a b : a in {{b}} -> a =A= b.

    Proof.
      intro h. destruct (eqA_dec a b); trivial.
      absurd (mult a {{b}} > 0); trivial.
      rewrite singleton_mult_notin; trivial.
      omega.
    Qed.

    Lemma singleton_mult_union_empty a a' M :
        {{a}} =mul= {{a'}} + M -> M =mul= empty.

    Proof.
      intros.
      destruct M using mset_ind; auto with multisets.
      assert ({{a}} =mul= {{a'}} + {{a0}} + M).
      rewrite H; solve_meq.
      clear H IHM.
      destruct (eqA_dec a a').
      destruct (eqA_dec a a0).
      absurd (a/{{a}} = a/({{a'}} + {{a0}} + M)).
      rewrite !union_mult, !singleton_mult_in; auto with sets.
      omega.
      apply meq_multeq; trivial.
      absurd ((a0/({{a'}} + {{a0}} + M))%msets > 0).
      rewrite <- (meq_multeq H0 a0).
      rewrite singleton_mult_notin; auto with sets arith.
      rewrite !union_mult, singleton_mult_in with a0 a0; auto with sets arith.
      absurd ((a'/({{a'}} + {{a0}} + M))%msets > 0).
      rewrite <- (meq_multeq H0 a').
      rewrite singleton_mult_notin; auto with sets arith.
      rewrite !union_mult, singleton_mult_in with a' a'; auto with sets arith.
    Qed.

    Lemma member_pair x y z : x in {{y,z}} -> x =A= y \/ x =A= z.

    Proof.
      intro H.
      case (eqA_dec x y); [auto | intro x_neq_y].
      case (eqA_dec x z); [auto | intro x_neq_z].
      assert (x/{{y, z}} = 0).
      mset_unfold.
      rewrite union_mult.
      rewrite !singleton_mult_notin; trivial.
      unfold member in H.
      rewrite H0 in H; omega.
    Qed.

    Lemma union_perm M N P : M + N + P =mul= M + P + N.

    Proof. solve_meq. Qed.

    Lemma union_empty M : M + empty =mul= M.

    Proof. solve_meq. Qed.

    Lemma notempty_member M : M <>mul empty -> exists N a, M =mul= {{a}} + N.

    Proof.
      intros H.
      destruct M using mset_ind.
      absurd (empty =mul= empty); auto with multisets.
      ex M a. apply union_comm.
    Qed.

    Lemma not_empty M x : x in M -> M =mul= empty -> False.

    Proof.
      unfold member; intros mult_x_M M_is_empty.
      absurd (x/M = 0).
      omega.
      assert (x/empty = 0); [auto with multisets | idtac].
      assert (x/M = x/empty); [apply meq_multeq; trivial | idtac].
      omega.
    Qed.

    Lemma member_union_l a M N : a in M -> a in (M + N).

    Proof. unfold member; intro H. rewrite union_mult. omega. Qed.

    Lemma member_union_r a M N : a in N -> a in (M + N).

    Proof. unfold member; intro H. rewrite union_mult. omega. Qed.

    Lemma mult_insert : forall M a, (a/(M + {{a}}))%msets > 0.

    Proof.
      intros M a.
      replace (a/(M + {{a}})) with ((a/M)%msets + (a/{{a}})%msets)%nat.
      replace (a/{{a}}) with 1.
      omega.
      sym; auto with multisets sets.
      auto with multisets.
    Qed.

    Lemma singleton_member a : a in {{a}}.

    Proof.
      unfold member. assert (a/{{a}} = 1); [idtac | omega].
      apply singleton_mult_in; auto with sets.
    Qed.

    Lemma member_insert a M : a in (insert a M).

    Proof. apply member_union_l. apply singleton_member. Qed.

    Lemma member_member_union a M N : a in M -> a in (M+N).

    Proof.
      unfold member; intros.
      replace (a/(M+N)) with ((a/M)%msets + (a/N)%msets)%nat.
      omega.
      auto with multisets.
    Qed.

    Lemma member_diff_member a M N : a in (M-N) -> a in M.

    Proof. unfold member. rewrite (diff_mult M N). omega. Qed.

    Lemma diff_member_ly_rn a M N : a in M -> ~a in N -> a in (M - N).

    Proof. unfold member; intros H H0. rewrite diff_mult. omega. Qed.

    Lemma diff_remove_both a M N :
      a in M -> a in N -> M - N =mul= (remove a M) - (remove a N).

    Proof.
      unfold member; intros H H0.
      mset_unfold.
      apply multeq_meq; intro x.
      rewrite !diff_mult.
      destruct (eqA_dec x a).
      rewrite !singleton_mult_in; trivial.
      rewrite (mult_eqA_compat M e), (mult_eqA_compat N e).
      omega.
      rewrite !singleton_mult_notin; trivial.
      omega.
    Qed.

    Lemma member_union a M N : a in (M+N) -> a in M \/ a in N.

    Proof. unfold member. rewrite (union_mult M N). omega. Qed.

    Lemma member_meq_union a M N M' N' :
      M + N =mul= M' + N' -> (a in M \/ a in N) -> ~a in N' -> a in M'.

    Proof.
      mset_unfold; intros.
      assert (((a/M)%msets + (a/N)%msets)%nat
              = ((a/M')%msets + (a/N')%msets)%nat).
      rewrite <- !union_mult.
      apply meq_multeq; trivial.
      omega.
    Qed.

    Lemma meq_union_meq M N P : M + P =mul= N + P -> M =mul= N.

    Proof.
      intros; try_solve_meq.
      assert (((x/M)%msets + (x/P)%msets)%nat
              = ((x/N)%msets + (x/P)%msets)%nat).
      rewrite <- !union_mult.
      apply meq_multeq; trivial.
      omega.
    Qed.

    Lemma meq_meq_union M N P : M =mul= N -> M + P =mul= N + P.

    Proof. solve_meq. Qed.

    Lemma meq_ins_ins_eq a a' M M' :
      M + {{a}} =mul= M' + {{a'}} -> a =A= a' -> M =mul= M'.

    Proof.
      intros.
      cut (M + {{a}} =mul= M' + {{a'}}).
      rewrite H0; intro; apply meq_union_meq with {{a'}}; trivial.
      trivial.
    Qed.

    Lemma meq_ins_ins a a' M M' :
      M + {{a}} =mul= M' + {{a'}} -> M =mul= M' + {{a'}} - {{a}}.

    Proof.
      intros.
      try_solve_meq.
      assert ((x/M)%msets + (x/{{a}})%msets
              = (x/M')%msets + (x/{{a'}})%msets)%nat.
      rewrite <- !union_mult.
      apply meq_multeq; trivial.
      omega.
    Qed.

    Lemma member_ins_ins_meq a a' M M' :
      M + {{a}} =mul= M' + {{a'}} -> ~a =A= a' -> a in M'.

    Proof.
      intros.
      assert (((a/M)%msets + 1)%nat = ((a/M')%msets + 0)%nat).
      rewrite <- (singleton_mult_in ((Seq_refl A eqA eqA_Equivalence) a)),
        <- (singleton_mult_notin H0), <- !union_mult.
      apply meq_multeq; trivial.
      mset_unfold; omega.
    Qed.

    Lemma meq_ins_rem a M : a in M -> M =mul= M - {{a}} + {{a}}.

    Proof.
      mset_unfold; intros.
      apply multeq_meq; intro.
      rewrite union_mult.
      rewrite diff_mult.
      case (eqA_dec x a); intro x_a.
      (* x =A= a *)
      rewrite singleton_mult_in; trivial.
      assert (x/M = a/M).
      apply mult_eqA_compat; trivial.
      omega.
      (* ~ x =A= a *)
      rewrite !singleton_mult_notin.
      omega.
      trivial.
    Qed.

    Lemma meq_remove_insert a M : remove a (M + {{a}}) =mul= M.

    Proof. solve_meq. Qed.

    Lemma meq_remove a M N : insert a M =mul= N -> M =mul= remove a N.

    Proof. intros. rewrite <- H. solve_meq. Qed.

    Lemma insert_meq M N a : insert a M =mul= insert a N -> M =mul= N.

    Proof.
      intros; apply multeq_meq; intro.
      set (w := (meq_multeq H) x).
      unfold insert in w.
      rewrite !union_mult in w.
      omega.
    Qed.

    Lemma insert_remove_eq a a' M : a =A= a' -> M =mul= remove a (insert a' M).

    Proof.
      intros.
      apply multeq_meq.
      intro x; mset_unfold.
      rewrite diff_mult.
      rewrite union_mult.
      destruct (eqA_dec x a).
      rewrite !singleton_mult_in; eauto with sets.
      omega.
      rewrite !singleton_mult_notin; eauto with sets.
      omega.
    Qed.

    Lemma meq_insert_remove a M : a in M -> insert a (remove a M) =mul= M.

    Proof.
      intros.
      apply multeq_meq; intro x.
      unfold insert, remove.
      rewrite union_mult.
      rewrite diff_mult.
      destruct (eqA_dec x a).
      rewrite singleton_mult_in; trivial.
      rewrite (mult_eqA_compat M e).
      unfold member in H.
      omega.
      rewrite singleton_mult_notin; trivial.
      omega.
    Qed.

    Lemma insert_remove_noteq a a' M :
      ~a =A= a' -> remove a (insert a' M) =mul= insert a' (remove a M).

    Proof.
      intros.
      apply multeq_meq.
      intro x; mset_unfold.
      repeat progress (try rewrite union_mult; try rewrite diff_mult).
      destruct (eqA_dec x a).
      rewrite !(singleton_mult_in e), (@singleton_mult_notin x a').
      omega.
      rewrite e; auto with sets.
      rewrite (@singleton_mult_notin x a); trivial.
      destruct (eqA_dec x a').
      solve_meq.
      solve_meq.
    Qed.

    Lemma meq_cons a M N :
      M + {{a}} =mul= N -> exists N', N =mul= N' + {{a}} /\ M =mul= N'.

    Proof.
      intros.
      exists (remove a N); split.
      assert (aN: a in N).
      rewrite <- H.
      rewrite (union_comm M {{a}}).
      fold (insert a M); apply member_insert.
      set (N' := N) in |- * at 1.
      rewrite (meq_ins_rem aN); unfold N'; clear N'.
      rewrite (meq_remove_insert a (N - {{a}})).
      apply meq_ins_rem; trivial.
      rewrite <- H.
      solve_meq.
    Qed.

    Lemma meq_diff_meq M N P : M =mul= N -> M - P =mul= N - P.

    Proof. solve_meq. Qed.

    Section Decidability.

      Lemma member_dec a M : {a in M}+{~a in M}.

      Proof.
        intros; case (Compare_dec.zerop (mult a M)); intro.
        right; mset_unfold; omega.
        left; auto.
      Qed.

      Lemma empty_dec : forall M, {M =mul= empty}+{M <>mul empty}.

      Proof.
        apply mset_ind_type with
          (P := fun M => {M =mul= empty}+{M <>mul empty}).
        left; solve_meq.
        intros M a cmp; right; intro emp.
        absurd (a/(M + {{a}}) = a/empty); auto with multisets.
        rewrite empty_mult; rewrite union_mult.
        set (w := singleton_member a); unfold member in w.
        omega.
      Qed.

      Lemma empty_decomp_dec : forall M,
          {Ma: (Multiset * A) | M =mul= fst Ma + {{snd Ma}}} + {M =mul= empty}.

      Proof.
        induction M using mset_ind_type.
        right; auto with multisets.
        left; exists (M, a); auto with multisets.
      Qed.

    End Decidability.

    Lemma insert_diff a M N :
      insert a M - N =mul= empty -> a in N /\ M - remove a N =mul= empty.

    Proof.
      intros.
      assert (a in N).
      destruct (member_dec a N); trivial.
      exfalso.
      apply not_empty with empty a; auto with multisets.
      fold (member a empty).
      rewrite <- H.
      apply diff_member_ly_rn; eauto with multisets.
      apply member_insert.
      split; trivial.
      rewrite <- H.
      rewrite (diff_remove_both (member_insert a M) H0).
      solve_meq.
    Qed.

    Lemma diff_MM_empty M : M - M =mul= empty.

    Proof. solve_meq. Qed.

    Lemma ins_meq_union M N P a :
      M + {{a}} =mul= N + P -> a in N -> M =mul= N - {{a}} + P.

    Proof.
      mset_unfold; try_solve_meq.
      assert (((x/M)%msets + (x/{{a}})%msets)%nat
              = ((x/N)%msets + (x/P)%msets)%nat).
      rewrite <- !union_mult.
      apply meq_multeq; trivial.
      case (eqA_dec x a); intro x_a.
      (* x =A= a *)
      assert (x/N = a/N).
      apply mult_eqA_compat; trivial.
      rewrite singleton_mult_in.
      assert (((x/M)%msets + 1)%nat = ((x/N)%msets + (x/P)%msets)%nat).
      rewrite <- (singleton_mult_in x_a); trivial.
      omega.
      trivial.
      (* ~ x =A= a *)
      rewrite (singleton_mult_notin x_a).
      assert (((x/M)%msets + 0)%nat = ((x/N)%msets + (x/P)%msets)%nat).
      rewrite <- (singleton_mult_notin x_a); trivial.
      omega.
    Qed.

    Lemma mem_memrem M a b : ~ a =A= b -> a in M -> a in (M - {{b}}).

    Proof.
      compute; intros.
      rewrite diff_mult.
      rewrite singleton_mult_notin.
      omega.
      trivial.
    Qed.

    Lemma member_notempty M x : x in M -> M <>mul empty.

    Proof.
      unfold not; intros.
      absurd (mult x M = 0).
      unfold member in H; omega.
      rewrite (meq_multeq H0); auto with multisets.
    Qed.

    Lemma singleton_notempty x : {{x}} <>mul empty.

    Proof. apply member_notempty with x. apply singleton_member. Qed.

    Lemma union_isempty M N : M + N =mul= empty -> M =mul= empty.

    Proof.
      intros; try_solve_meq.
      assert (((x/M)%msets + (x/N)%msets)%nat = x/empty).
      rewrite <- (meq_multeq H); auto with multisets.
      rewrite empty_mult in H0.
      omega.
    Qed.

    Lemma union_notempty M N : M <>mul empty -> M + N <>mul empty.

    Proof.
      compute in *; intros; apply H. apply union_isempty with N; trivial.
    Qed.

    Lemma remove_union a L R :
      a in L -> remove a (L + R) =mul= (remove a L) + R.

    Proof.
      intros.
      apply multeq_meq; intros.
      unfold remove.
      repeat (rewrite diff_mult || rewrite union_mult).
      destruct (eqA_dec x a).
      rewrite singleton_mult_in; trivial.
      rewrite (mult_eqA_compat L e).
      unfold member in H; omega.
      rewrite singleton_mult_notin; trivial.
      omega.
    Qed.

    Lemma meq_remove_elem_right a M L R :
      M + {{a}} =mul= L + R -> a in R -> M =mul= L + (remove a R).

    Proof.
      intros. rewrite (union_comm L (remove a R)), <- (remove_union L H0),
        (union_comm R L), <- H. solve_meq.
    Qed.

  End MultisetLemmas.

  Hint Immediate member_singleton
       member_member_union
       member_diff_member
       member_union
       member_meq_union
       union_comm
       intersection_comm
       union_assoc : multisets.

  Hint Resolve union_empty
       not_empty
       singleton_member
       meq_union_meq
       meq_meq_union
       meq_ins_ins_eq
       meq_ins_ins
       member_ins_ins_meq
       meq_ins_rem
       meq_diff_meq
       diff_MM_empty
       ins_meq_union
       mem_memrem
       member_union_r
       member_union_l
       member_notempty
       singleton_notempty
       union_isempty
       union_notempty : multisets.

  Section MultisetLemmas2.

    Lemma double_split L R U D :
      L + R =mul= U + D -> R =mul= (R # D) + (U - L).

    Proof.
      intros; try_solve_meq.
      assert (((x/L)%msets + (x/R)%msets)%nat
              = ((x/U)%msets + (x/D)%msets)%nat).
      rewrite <- (union_mult L R).
      rewrite <- (union_mult U D).
      auto with multisets.
      case (Compare_dec.le_lt_dec (x/L)%msets (x/U)%msets); intro l_u.
      (* u >= l *)
      assert ((x/R)%msets >= (x/D)%msets); [omega | idtac].
      rewrite (Min.min_r (x/R)%msets (x/D)%msets); omega.
      (* l > u *)
      assert ((x/R)%msets < (x/D)%msets); [omega | idtac].
      rewrite Minus.not_le_minus_0.
      rewrite (Min.min_l (x/R)%msets (x/D)%msets); omega.
      omega.
    Qed.

    Variables (P Q : A -> Prop) (PQ_dec : forall a, {P a}+{Q a}).

    Definition comp_eqA P := forall a b, a =A= b -> P a -> P b.

    Variables (P_comp : comp_eqA P) (Q_comp : comp_eqA Q).

    Lemma partition : forall M, exists Mp, exists2 Mq, M =mul= Mp + Mq
      & (forall p, p in Mp -> P p) /\ (forall q, q in Mq -> Q q).

    Proof.
      induction M using mset_ind.
      (* induction base *)
      exists empty; exists empty.
      solve_meq.
      split; intros.
      absurd (p in empty); eauto with multisets.
      absurd (q in empty); eauto with multisets.
      (* induction step *)
      decompose record IHM.
      case (PQ_dec a); intro wa.
      (* a goes to left part *)
      exists (x + {{a}}); exists x0.
      rewrite (union_perm x {{a}} x0); auto with multisets.
      split; intros.
      case (member_union H1); intro wp.
      apply H; trivial.
      assert (pa : a =A= p); [ auto with multisets sets
                             | apply (P_comp pa); trivial].
      apply H2; trivial.
      (* a goes to right part *)
      exists x; exists (x0 + {{a}}).
      rewrite (union_assoc x x0 {{a}}); auto with multisets.
      split; intros.
      apply H; trivial.
      case (member_union H1); intro wp.
      apply H2; trivial.
      assert (pa : a =A= q); [ auto with multisets sets
                             | apply (Q_comp pa); trivial].
    Qed.

  End MultisetLemmas2.

  Section List2Multiset.

    Lemma member_list_multiset : forall l,
      forall x, In x l -> member x (list2multiset l).

    Proof.
      induction l.
      (* base step *)
      intros x x_In_nil; absurd (In x nil); auto.
      (* induction step *)
      simpl; intros x x_In_al; case x_In_al.
      intro ax; rewrite ax; apply member_insert.
      intro x_In_l; mset_unfold.
      rewrite union_mult.
      assert ((x/(list2multiset l))%msets > 0).
      apply (IHl x); trivial.
      omega.
    Qed.

    Lemma member_multiset_list : forall l,
        forall x, member x (list2multiset l) -> exists2 y, In y l & x =A= y.

    Proof.
      induction l.
      (* base step *)
      simpl; intros x x_in_empty.
      absurd (empty <>mul empty); eauto with multisets.
      (* induction step *)
      unfold insert; simpl; intros x x_in_al.
      case (member_union x_in_al).
      intro x_a; exists a; auto with multisets.
      intro x_l; destruct (IHl x x_l).
      exists x0; auto with sets.
    Qed.

    Lemma list2multiset_app : forall M1 M2,
        list2multiset (M1 ++ M2) =mul= list2multiset M1 + list2multiset M2.

    Proof.
      induction M1; intros.
      (* induction base *)
      simpl.
      eauto with multisets.
      (* induction step *)
      simpl.
      unfold insert.
      rewrite (IHM1 M2).
      solve_meq.
    Qed.

    Lemma list2multiset_mult : forall l a,
        a / (list2multiset l) = multiplicity (list_contents eqA_dec l) a.

    Proof.
      induction l; intros.
      auto with multisets.
      simpl; unfold insert.
      rewrite union_mult.
      destruct (eqA_dec a a0).
      rewrite singleton_mult_in; auto with sets.
      rewrite singleton_mult_notin; auto with sets.
    Qed.

    Lemma meq_permutation l l' :
        list2multiset l =mul= list2multiset l' -> permutation eqA_dec l l'.

    Proof.
      intros; intro a. rewrite <- !list2multiset_mult.
      apply meq_multeq; trivial.
    Qed.

    Lemma permutation_meq l l' :
      permutation eqA_dec l l' -> list2multiset l =mul= list2multiset l'.

    Proof.
      intros. apply multeq_meq. intro x. rewrite !list2multiset_mult. apply H.
    Qed.

    Lemma list2multiset_eq_length l l' :
      list2multiset l =mul= list2multiset l' -> length l = length l'.

    Proof.
      intros.
      apply permutation_length with eqA eqA_dec.
      exact eqA_Equivalence.
      apply meq_permutation; trivial.
    Qed.

    Lemma list2multiset_cons_length l l' : forall a,
      list2multiset l + {{a}} =mul= list2multiset l' ->
      length l' = S (length l).

    Proof.
      destruct l'.
      simpl; intros.
      exfalso.
      apply not_empty with (list2multiset l + {{a}}) a; trivial.
      apply member_union_r; auto with multisets.
      intros.
      change (S (length l)) with (length (a0 :: l)).
      apply permutation_length with eqA eqA_dec.
      exact eqA_Equivalence.
      apply meq_permutation.
      rewrite <- H.
      simpl; solve_meq.
    Qed.

    Lemma list2multiset_remove_in a : forall m,
        remove a (list2multiset m)
        =mul= list2multiset (removeElem eqA eqA_dec a m).

    Proof.
      induction m; simpl; intros.
      solve_meq.
      destruct (eqA_dec a a0); simpl.
      rewrite <- (insert_remove_eq (list2multiset m) e); auto with multisets.
      rewrite (insert_remove_noteq (list2multiset m) n).
      rewrite IHm; auto with multisets.
    Qed.

    Lemma diff_empty : forall l m,
        list2multiset l - list2multiset m =mul= empty ->
        (length l - length m = 0)%nat.

    Proof.
      induction l.
      auto.
      intros.
      simpl in H.
      destruct (insert_diff H).
      assert (length m > 0).
      destruct (member_multiset_list m H0).
      destruct m.
      inversion H2.
      simpl; auto with arith.
      assert ((length l - pred (length m) = 0)%nat).
      set (w := IHl (removeElem eqA eqA_dec a m)).
      rewrite removeElem_length_in in w.
      apply w.
      rewrite <- H1.
      rewrite (list2multiset_remove_in a m); auto with multisets.
      destruct (member_multiset_list m H0).
      exists x; split; trivial.
      destruct (length m); simpl in *; omega.
    Qed.

    Lemma list2multiset_union_length : forall l m n,
        list2multiset l =mul= list2multiset m + list2multiset n ->
        length l = (length m + length n)%nat.

    Proof.
      induction l; simpl; intros.
      destruct m.
      destruct n; trivial.
      exfalso; apply not_empty with (list2multiset (a::n)) a.
      simpl; unfold insert; auto with multisets.
      rewrite H; solve_meq.
      exfalso; apply not_empty with
                      (list2multiset (a::m) + list2multiset n) a.
      simpl; unfold insert; auto with multisets.
      rewrite H; solve_meq.
      destruct (@member_union a (list2multiset m) (list2multiset n)).
      rewrite <- H; auto with multisets.
      unfold insert; apply member_union_l; auto with multisets.
      rewrite (IHl (removeElem eqA eqA_dec a m) n).
      rewrite (removeElem_length_in).
      destruct m; simpl; trivial.
      exfalso; apply not_empty with (list2multiset nil) a; trivial.
      simpl; auto with multisets.
      destruct (member_multiset_list m H0).
      exists x; split; trivial.
      rewrite <- (list2multiset_remove_in a m).
      rewrite <- (remove_union (list2multiset n) H0).
      apply insert_meq with a.
      assert (a in (list2multiset m + list2multiset n)).
      apply member_union_l; trivial.
      rewrite (meq_insert_remove H1); trivial.
      rewrite (IHl m (removeElem eqA eqA_dec a n)).
      rewrite (removeElem_length_in).
      destruct n; simpl; trivial.
      exfalso; apply not_empty with (list2multiset nil) a; trivial.
      simpl; auto with multisets.
      destruct (member_multiset_list n H0).
      exists x; split; trivial.
      rewrite <- (list2multiset_remove_in a n).
      rewrite (union_comm (list2multiset m) (remove a (list2multiset n))).
      rewrite <- (remove_union (list2multiset m) H0).
      apply insert_meq with a.
      assert (a in (list2multiset m + list2multiset n)).
      apply member_union_r; trivial.
      rewrite (union_comm (list2multiset n) (list2multiset m)).
      rewrite (meq_insert_remove H1); trivial.
    Qed.

    Lemma list2multiset_diff_length : forall l m n,
        list2multiset l =mul= list2multiset m - list2multiset n ->
        length l >= length m - length n.

    Proof.
      induction l.
      simpl; intros.
      rewrite (diff_empty m n); auto with multisets arith.
      intros; simpl.
      assert (length l >= length m - (length (a :: n))).
      apply IHl.
      simpl in H.
      rewrite (meq_remove H).
      simpl; solve_meq.
      simpl in H0; omega.
    Qed.

    Lemma list2multiset_insert_nth a l p :
      list2multiset (insert_nth l p a) =mul= insert a (list2multiset l).

    Proof.
      intros.
      change (insert a (list2multiset l)) with (list2multiset (a :: l)).
      apply permutation_meq.
      apply insert_nth_permut.
    Qed.

  End List2Multiset.

  Section Multiset2List. (* William Delobel *)

    Definition mult_to_list : forall M, {l : list A | M =mul= list2multiset l}.

    Proof.
      induction M as [ | M a IHM] using mset_ind_type.
      (* base case *)
      exists (nil (A := A)).
      simpl; auto with multisets.
      (* induction step *)
      elim IHM; clear IHM; intros l IHM.
      exists (a::l).
      simpl; unfold insert; rewrite <- IHM; apply union_comm.
    Defined.

    Definition multiset2list M :=
      match mult_to_list M with @exist _ _ l _ => l end.

    Lemma multiset2list_empty : multiset2list empty = nil.

    Proof.
      unfold multiset2list.
      elim (mult_to_list empty).
      intros x Hx; destruct x as [ | a x]; trivial.
      gen (meq_sym Hx); clear Hx; intro Hx.
      gen (union_isempty Hx); clear Hx; intro Hx.
      elim (singleton_notempty Hx).
    Qed.

    Lemma double_convertion : forall M, list2multiset (multiset2list M) =mul= M.

    Proof.
      induction M as [ | M a IHM] using mset_ind.
      (* base case *)
      rewrite multiset2list_empty; simpl; auto with multisets.
      (* induction step *)
      unfold multiset2list; elim (mult_to_list (M + {{a}})).
      intros l Hl.
      rewrite Hl; auto with multisets.
    Qed.

  End Multiset2List.

  Section Multiset2List_Results.

    Lemma multiset2list_meq_non_empty : forall M,
      M <>mul empty -> multiset2list M <> nil.

    Proof.
      destruct M using mset_ind.
      auto with multisets.
      intros _.
      unfold multiset2list; elim (mult_to_list (M + {{a}})).
      destruct x; auto with datatypes.
      simpl; intro abs.
      absurd (M + {{a}} =mul= empty); trivial.
      apply member_notempty with a; trivial.
      apply member_union_r; auto with multisets.
    Qed.

    Lemma multiset2list_meq_empty : forall M,
        M =mul= empty -> multiset2list M = nil.

    Proof.
      destruct M using mset_ind.
      unfold multiset2list.
      elim (mult_to_list empty).
      destruct x; trivial.
      simpl; intro abs.
      absurd (insert a (list2multiset x) =mul= empty); auto with multisets.
      apply member_notempty with a; unfold insert; auto with multisets.
      intro abs.
      absurd (M + {{a}} =mul= empty); trivial.
      apply member_notempty with a; trivial.
      apply member_union_r; auto with multisets.
    Qed.

    Lemma in_multiset_in_multiset2list : forall M x,
        x in M -> exists y, x =A= y /\ In y (multiset2list M).

    Proof.
      destruct M using mset_ind.
      intros x abs.
      absurd (empty =mul= empty); auto with multisets.
      apply member_notempty with x; trivial.
      unfold multiset2list.
      elim (mult_to_list (M + {{a}})).
      intros l Ml x xin.
      assert (x in (list2multiset l)).
      rewrite <- Ml; trivial.
      destruct (member_multiset_list l H).
      exists x0; auto.
    Qed.

    Lemma in_multiset2list_in_multiset : forall M x,
        In x (multiset2list M) -> x in M.

    Proof.
      destruct M using mset_ind.
      rewrite multiset2list_empty.
      inversion 1.
      unfold multiset2list.
      destruct (mult_to_list (M + {{a}})) as [l Mal]; intros x xl.
      rewrite Mal.
      apply member_list_multiset; trivial.
    Qed.

    Lemma multiset2list_insert a M :
    exists a' p, a =A= a' /\
                 permutation eqA_dec (multiset2list M)
                             (drop_nth (multiset2list (insert a M)) p)
                 /\ nth_error (multiset2list (insert a M)) p = Some a'.

    Proof.
      unfold multiset2list; intros.
      destruct (mult_to_list M).
      destruct (mult_to_list (insert a M)).
      destruct (@member_multiset_list x0 a) as [a' a'x0 a'a].
      rewrite <- m0; apply member_insert.
      destruct (list_In_nth x0 a' a'x0) as [p x0p].
      exists a'; exists p; split; trivial; split; trivial.
      apply permutation_drop with a a'; trivial.
      exact eqA_Equivalence.
      apply meq_permutation.
      simpl.
      rewrite <- m; trivial.
    Qed.

    Lemma multiset2list_cons_length M a :
        length (multiset2list (M + {{a}})) = S (length (multiset2list M)).

    Proof.
      intros; unfold multiset2list.
      destruct (mult_to_list (M + {{a}})).
      destruct (mult_to_list M); simpl.
      apply list2multiset_cons_length with a.
      rewrite <- m0; trivial.
    Qed.

    Lemma multiset2list_union_length M N :
      length (multiset2list (M + N))
      = (length (multiset2list M) + length (multiset2list N))%nat.

    Proof.
      intros; unfold multiset2list.
      destruct (mult_to_list (M + N));
        destruct (mult_to_list M);
	destruct (mult_to_list N); simpl.
      apply list2multiset_union_length.
      rewrite <- m; rewrite <- m0; rewrite <- m1; auto with multisets.
    Qed.

    Lemma multiset2list_diff_length M N :
      length (multiset2list (M - N))
      >= length (multiset2list M) - length (multiset2list N).

    Proof.
      intros; unfold multiset2list.
      destruct (mult_to_list (M - N));
        destruct (mult_to_list M);
	destruct (mult_to_list N); simpl.
      apply list2multiset_diff_length.
      rewrite <- m; rewrite <- m0; rewrite <- m1; auto with multisets.
    Qed.

    Lemma multiset2list_meq_length M M' :
      M =mul= M' -> length (multiset2list M) = length (multiset2list M').

    Proof.
      intros; unfold multiset2list.
      destruct (mult_to_list M); destruct (mult_to_list M'); simpl.
      apply list2multiset_eq_length.
      rewrite <- m; rewrite <- m0; trivial.
    Qed.

    Lemma cons_eq_cons_cons_absurd a a' a'' M :
      {{a}} =mul= {{a'}} + {{a''}} + M -> False.

    Proof.
      intro.
      absurd ({{a}} =mul= insert a' (insert a'' M)); trivial.
      assert (M + {{a'}} + {{a''}} =mul= {{a}}).
      rewrite H; solve_meq.
      destruct (meq_cons H0) as [m' [am'a1 xa0m']].
      absurd (m' =mul= empty).
      intro mempty.
      apply not_empty with m' a'; trivial.
      unfold member; rewrite <- (meq_multeq xa0m' a').
      fold (member a' (M + {{a'}})).
      apply member_union_r; auto with multisets.
      apply (@singleton_mult_union_empty a a'' m').
      rewrite am'a1; auto with multisets.
      rewrite H; solve_meq.
    Qed.

    Lemma multiset2list_singleton a :
      exists a', a =A= a' /\ multiset2list {{a}} = a' :: nil.

    Proof.
      unfold multiset2list.
      destruct (mult_to_list {{a}}).
      destruct x; simpl in m.
      exfalso; apply not_empty with {{a}} a; trivial.
      unfold member; rewrite singleton_mult_in; auto with sets.
      destruct x; simpl in m.
      unfold insert in m.
      destruct (eqA_dec a a0).
      exists a0; split; trivial.
      exfalso.
      absurd (a/{{a}} = a/{{a0}}).
      rewrite singleton_mult_in with a a; auto with sets.
      rewrite singleton_mult_notin with a a0; auto with sets.
      apply meq_multeq.
      rewrite m; auto with multisets.
      exfalso.
      apply cons_eq_cons_cons_absurd with a a0 a1 (list2multiset x).
      rewrite m; solve_meq.
    Qed.

  End Multiset2List_Results.

  Section MultisetCardinality.

    Definition card_def (M : Multiset) : { n | length (multiset2list M) = n}.

    Proof.
      induction M as [ | M a IHM] using mset_ind_type.
      exists 0.
      rewrite multiset2list_empty; trivial.
      destruct IHM.
      exists (S x).
      rewrite multiset2list_cons_length; try_solve.
    Defined.

    Definition card (M : Multiset) := proj1_sig (card_def M).

    Lemma empty_card : card empty = 0.

    Proof.
      intros.
      unfold card.
      destruct (card_def empty); simpl.
      rewrite <- e.
      rewrite multiset2list_empty; trivial.
    Qed.

    Instance card_morph : Proper (meq ==> eq) card.

    Proof.
      intros m m0; unfold card.
      destruct (card_def m).
      destruct (card_def m0); simpl.
      rewrite <- e; rewrite <- e0.
      apply multiset2list_meq_length; trivial.
    Qed.

    Lemma multiset2list_card M : length (multiset2list M) = card M.

    Proof. intros. unfold card; destruct (card_def M); trivial. Qed.

    Lemma card_non_empty M : M <>mul empty -> card M > 0.

    Proof.
      intros.
      unfold card; destruct (card_def M); simpl.
      assert (w := multiset2list_meq_non_empty H).
      destruct (multiset2list M); try_solve.
      rewrite <- e; auto with arith.
    Qed.

    Lemma singleton_card x : card {{x}} = 1.

    Proof.
      unfold card.
      destruct (card_def {{x}}); simpl.
      rewrite <- e.
      destruct (multiset2list_singleton x) as [x' [_ xx']].
      rewrite xx'; trivial.
    Qed.

    Lemma pair_card x y : card {{x, y}} = 2.

    Proof.
      unfold card, pair, insert.
      destruct (card_def ({{x}} + {{y}})); simpl.
      rewrite <- e.
      rewrite multiset2list_cons_length.
      destruct (multiset2list_singleton x) as [x' [_ xx']].
      rewrite xx'; trivial.
    Qed.

    Lemma union_card M N : card (M + N) = (card M + card N)%nat.

    Proof.
      unfold card.
      destruct (card_def (M + N)); destruct (card_def M);
      destruct (card_def N); simpl.
      rewrite <- e; rewrite <- e0; rewrite <- e1.
      apply multiset2list_union_length.
    Qed.

    Lemma diff_card M N : card (M - N) >= card M - card N.

    Proof.
      unfold card.
      destruct (card_def (M - N)); destruct (card_def M);
      destruct (card_def N); simpl.
      rewrite <- e; rewrite <- e0; rewrite <- e1.
      apply multiset2list_diff_length.
    Qed.

  End MultisetCardinality.

  Section Pair.

    Lemma pair_eq a b c d :
      {{a, b}} =mul= {{c, d}} -> (a =A= c /\ b =A= d) \/ (a =A= d /\ b =A= c).

    Proof.
      intros.
      destruct (eqA_dec a c).
      destruct (eqA_dec b d).
      left; split; trivial.
      destruct (eqA_dec a d).
      absurd (mult b {{a, b}} = mult b {{c, d}}).
      unfold pair, insert.
      rewrite !union_mult.
      rewrite (@singleton_mult_in b b); auto with sets.
      rewrite (@singleton_mult_notin b a); eauto with sets.
      rewrite (@singleton_mult_notin b c); eauto with sets.
      rewrite (@singleton_mult_notin b d); eauto with sets.
      omega.
      setoid_replace c with d; eauto with sets.
      apply meq_multeq; trivial.
      absurd (mult d {{a, b}} = mult d {{c, d}}).
      unfold pair, insert.
      rewrite !union_mult.
      rewrite (@singleton_mult_notin d a); auto with sets.
      rewrite (@singleton_mult_notin d b); auto with sets.
      rewrite (@singleton_mult_in d d); auto with sets.
      omega.
      apply meq_multeq; trivial.
      destruct (eqA_dec a d).
      destruct (eqA_dec b c).
      right; split; trivial.
      absurd (mult c {{a, b}} = mult c {{c, d}}).
      unfold pair, insert.
      rewrite !union_mult.
      rewrite (@singleton_mult_notin c a); auto with sets.
      rewrite (@singleton_mult_notin c b); auto with sets.
      rewrite (@singleton_mult_in c c); auto with sets.

      apply meq_multeq; trivial.
      absurd (mult a {{a, b}} = mult a {{c, d}}).
      unfold pair, insert.
      rewrite !union_mult.
      rewrite (@singleton_mult_notin a c); auto with sets.
      rewrite (@singleton_mult_notin a d); auto with sets.
      rewrite (@singleton_mult_in a a); auto with sets.

      apply meq_multeq; trivial.
    Qed.

    Lemma pair_decomp a b X Y : {{a, b}} =mul= X + Y ->
      (X =mul= {{a, b}} /\ Y =mul= empty) \/
      (X =mul= empty /\ Y =mul= {{a, b}}) \/
      (X =mul= {{a}} /\ Y =mul= {{b}}) \/
      (X =mul= {{b}} /\ Y =mul= {{a}}).

    Proof.
      intros.
      destruct (empty_decomp_dec X) as [[[X1 c] X1c] | Xempty].
      simpl in X1c.
      destruct (empty_decomp_dec X1) as [[[X2 d] X2d] | X1empty].
      simpl in X2d.
      destruct (empty_decomp_dec X2) as [[[X3 e] X3e] | X2empty].
      simpl in X3e.
      absurd (card {{a, b}} = card (X + Y)).
      repeat (rewrite union_card; try rewrite (card_morph X1c);
              try rewrite (card_morph X2d); try rewrite (card_morph X3e)).
      rewrite pair_card, !singleton_card; omega.
      apply (card_morph H).
      assert (Y =mul= empty).
      destruct (empty_decomp_dec Y) as [[[Y1 e] Y1e] | Yempty]; trivial.
      simpl in Y1e.
      absurd (card {{a, b}} = card (X + Y)).
      repeat (rewrite union_card; try rewrite (card_morph X1c);
              try rewrite (card_morph X2d); try rewrite (card_morph Y1e)).
      rewrite pair_card, !singleton_card; omega.
      apply (card_morph H).
      left; split; trivial.
      rewrite H, X1c, X2d, X2empty, H0; solve_meq.
      destruct (empty_decomp_dec Y) as [[[Y1 d] Y1d] | Yempty]; trivial.
      simpl in Y1d.
      destruct (empty_decomp_dec Y1) as [[[Y2 e] Y2e] | Y1empty]; trivial.
      simpl in Y2e.
      absurd (card {{a, b}} = card (X + Y)).
      repeat (rewrite union_card; try rewrite (card_morph X1c);
              try rewrite (card_morph Y1d); try rewrite (card_morph Y2e)).
      rewrite pair_card, !singleton_card; omega.
      apply (card_morph H).
      destruct (@pair_eq a b c d) as [[ac bd] | [ad bc]].
      rewrite H, X1c, Y1d, X1empty, Y1empty; solve_meq.
      right; right; left; split.
      rewrite X1c, X1empty, ac; solve_meq.
      rewrite Y1d, Y1empty, bd; solve_meq.
      right; right; right; split.
      rewrite X1c, X1empty, bc; solve_meq.
      rewrite Y1d, Y1empty, ad; solve_meq.
      absurd (card {{a, b}} = card (X + Y)).
      repeat (rewrite union_card; try rewrite (card_morph X1c);
              try rewrite (card_morph X1empty);
              try rewrite (card_morph Yempty)).
      rewrite pair_card, !singleton_card; omega.
      apply (card_morph H).
      destruct (empty_decomp_dec Y) as [[[Y1 c] Y1c] | Yempty]; trivial.
      simpl in Y1c.
      destruct (empty_decomp_dec Y1) as [[[Y2 d] Y2d] | Y1empty]; trivial.
      simpl in Y2d.
      destruct (empty_decomp_dec Y2) as [[[Y3 e] Y3e] | Y2empty]; trivial.
      simpl in Y3e.
      absurd (card {{a, b}} = card (X + Y)).
      repeat (rewrite union_card; try rewrite (card_morph Y1c);
              try rewrite (card_morph Y2d); try rewrite (card_morph Y3e)).
      rewrite pair_card, !singleton_card; omega.
      apply (card_morph H).
      right; left; split; trivial.
      rewrite H, Y1c, Y2d, Y2empty, Xempty; solve_meq.
      absurd (card {{a, b}} = card (X + Y)).
      repeat (rewrite union_card; try rewrite (card_morph Xempty);
              try rewrite (card_morph Y1c); try rewrite (card_morph Y1empty)).
      rewrite pair_card, !singleton_card; omega.
      apply (card_morph H).
      absurd (card {{a, b}} = card (X + Y)).
      repeat (rewrite union_card; try rewrite (card_morph Xempty);
              try rewrite (card_morph Yempty)).
      rewrite pair_card; rewrite empty_card; omega.
      apply (card_morph H).
    Qed.

  End Pair.

  Hint Immediate double_split : multisets.

(*COQ: At the moment I extended module Eqset to include the requirement of
decidable equality. Hence to instantiate multisets to Eqset module decidability
of multiset equality needs to be proven; or Eqset needs to be split to Eqset
and Eqset_dec, with the latter one introducing the requirement for decidable
equality. I tried to do just that but with the present pre-version of Coq 8.2
was getting error: "Anomaly: Not_found", so I abandoned this. At the moment
MultisetEqset is not used anywhere anyway.

Module MultisetEqset <: Eqset.

  Definition A := Multiset.
  Definition eqA := meq.
  Definition eqA_Equivalence := MultisetSetoidTheory.

End MultisetEqset.
*)

End Multiset.


From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples.
From Mon Require Import SPropBase.
Set Warnings "-notation-overridden".
From mathcomp Require Import all_ssreflect.
Set Warnings "notation-overridden".
From Crypt Require Import FreeProbProg ChoiceAsOrd.

Import SPropNotations.

(*
in theory there is a free-forgetful adjunction between choiceType relative monads on one side,
and operations and arities on the other side (the involved category is the slice Ty / chTy).
Here we describe the object part of the forgetful functor U.
*)
Section ForgetFromRmonToOpar.
  Context (T : ord_relativeMonad choice_incl).

  Definition forgOps : Type := {A : choiceType & T A}.
  Definition forgAr : forgOps -> choiceType := fun op => match op with |existT A _ => A end.

End ForgetFromRmonToOpar.

Section UnivFreeMap.
  (*start with a morphism of signatures (given as operations and arities) σ → U(T) *)

  (*domain signature = arbitrary signature*)
  Context {sigma_ops : Type} {sigma_ar : sigma_ops -> choiceType}.

  (*codomain signature = coming from a relative monad*)
  Context {T : ord_relativeMonad choice_incl}.
  Let T_ops := forgOps T.
  Let T_ar := forgAr T.

  (*here is an arrow in the slice cat Ty / chTy *)
  (* Context (sigMap : sigma_ops -> T_ops). *)
  (* Hypothesis (slicemorph : forall op : sigma_ops, T_ar (sigMap (op)) = sigma_ar op). *)
  (*To avoid the need for equality transports we remark that to give such a morphism is
   the same as giving a section like this:*)
  Context  (sigMap : forall op : sigma_ops , T (sigma_ar op) ).

  Let Free_sigma := rFree sigma_ops sigma_ar. (*the domain relative monad*)

  Definition trivialChi :
  natIso choice_incl (ord_functor_comp choice_incl (ord_functor_id TypeCat)) :=
    natIso_sym( ord_functor_unit_right choice_incl ).

  Notation η := ord_relmon_unit.
  Notation dnib := ord_relmon_bind.

  Fixpoint outOfFree0 (A:choiceType) (tree : Free_sigma A) {struct tree} : T A.
  move: tree=>[|]. exact (η T A).
  move=> op opk.
  unshelve eapply (dnib T _).
    exact (sigma_ar op).
    simpl. move=> a0. apply outOfFree0. apply opk. exact a0.
    apply sigMap.
  Defined.

  Program Definition outOfFree : relativeMonadMorphism (ord_functor_id _) trivialChi Free_sigma T :=
    mkRelMonMorph (ord_functor_id _) trivialChi Free_sigma T _ _ _.
  Next Obligation.
    exact outOfFree0.
  Defined.
  Next Obligation.
    move=> A B f.
    rewrite /outOfFree_obligation_1. rewrite /FreeProbProg.rFree_obligation_2.
    apply boolp.funext. move=> tree.
    elim: tree.
    (*ret case*)
    simpl. move=> a. pose (bind_vs_ret := ord_relmon_law2 T A B  (fun x : A => outOfFree0 B (f x))).
    simpl in bind_vs_ret.
    unshelve eapply FunctionalExtensionality.equal_f in bind_vs_ret. exact a.
    rewrite -bind_vs_ret. reflexivity.
    (*bind case*)
    move=> op opk Hind.
    simpl.
    epose (bind_bind := ord_relmon_law3 T _ _ _ _ _).
    eapply FunctionalExtensionality.equal_f in bind_bind.
      cbn in bind_bind.
      erewrite <- bind_bind. clear bind_bind.
    f_equal.
    apply boolp.funext. move=> ans. apply Hind.
  Qed.

End UnivFreeMap.

Section ufmap_vs_callrFree.
  Context (sigma_ops : Type) (sigma_ar : sigma_ops -> choiceType)
          (T : ord_relativeMonad choice_incl).
  Context (sigMap : (forall op : sigma_ops , T ( sigma_ar op ))).

  Lemma outOfFree_vs_callrFree :
  forall op : sigma_ops, outOfFree sigMap _ (callrFree _ _ op) = sigMap op.
  Proof.
    move=> op.
    cbn. epose (T_bindRet := ord_relmon_law1 T _).
    eapply FunctionalExtensionality.equal_f in T_bindRet.
    cbn in T_bindRet. erewrite T_bindRet.
    reflexivity.
  Qed.

End ufmap_vs_callrFree.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Logic.Classical.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import Classes.Morphisms.
From Coq Require Export ZArith_base.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import QArith.Qround.
From Coq Require Import Logic.Classical.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Logic.PropExtensionality.
From Coq Require Import Classes.Equivalence.
From Coq Require Import setoid_ring.Ring_theory.
From Coq Require Import Classes.RelationClasses.
From Coq Require Import setoid_ring.Ring.
From Coq Require Import setoid_ring.Field.
From Coq Require Import omega.Omega.
From Coq Require Import micromega.Psatz.
From Coq Require Import Logic.ProofIrrelevance.
Import ListNotations.
From CReal Require Import Countable.
From CReal Require Import QArith_base_ext.

Module Type R_SINGLE_SIMPLE.
  Parameter Inline R : Type.
  Delimit Scope R_scope with R.
  Bind Scope R_scope with R.
  Local Open Scope R_scope.
  Parameter Inline Req : R -> R -> Prop.

  Axiom R_Setoid : Equivalence Req.
  Existing Instance R_Setoid .

  Infix "==" := Req : R_scope.

  Definition P_singlefun (X : R -> Prop) := (forall x1 x2, X x1 -> X x2 -> x1 == x2)
         /\ (exists x, X x) /\ Proper (Req ==> iff) X.
  Parameter Inline Rsinglefun : {X: R -> Prop | P_singlefun X} -> R.
  Axiom Rsinglefun_correct: forall X H, X (Rsinglefun (exist _ X H)).

End R_SINGLE_SIMPLE.

Module RSignleLemmas (RSS : R_SINGLE_SIMPLE).
  Import RSS.
  Local Open Scope R_scope.
  Definition If_fun (P : Prop) (x y : R) := (fun z => (P /\ x == z) \/ (~ P /\ y == z)).

  Theorem If_fun_single : forall (P : Prop)(x y : R), P_singlefun (If_fun P x y).
  Proof.
    intros.
    repeat split ; intros.
    - destruct H , H0 , H , H0.
      + rewrite <- H1. auto.
      + exfalso. auto.
      + exfalso. auto.
      + rewrite <- H1. auto.
    - destruct (classic P).
      + exists x. hnf. left. split ; auto. reflexivity.
      + exists y. hnf. right. split ; auto. reflexivity.
    - hnf in *. rewrite H in H0. auto.
    - hnf in *. rewrite H . auto.
  Qed.

  Instance If_fun_comp : Proper (eq(A:=Prop) ==> Req ==> Req ==> Req ==> iff) If_fun.
  Proof.
    hnf ; red ; intros ; hnf ; red ; intros.
    split ; intros ; hnf in * ; rewrite H , H0 , H1 , H2 in *; auto.
  Qed.

  Definition Rif (P : Prop)(x y  : R) : R.
    apply Rsinglefun.
    exists (If_fun P x y).
    apply If_fun_single.
  Defined.

  Instance Rif_comp : Proper (eq(A:=Prop) ==> Req ==> Req ==> Req) Rif.
  Proof.
    hnf ; red ; intros ; hnf ; intros.
    unfold Rif.
    pose proof If_fun_single x x0 x1.
    pose proof If_fun_single y y0 y1.
    assert (If_fun x x0 x1 = If_fun y y0 y1).
    { rewrite H. apply functional_extensionality_dep.
      intros. apply propositional_extensionality.
      rewrite H0 , H1. reflexivity.
    }
    subst.
    pose proof Rsinglefun_correct (If_fun y x0 x1) H2.
    pose proof Rsinglefun_correct (If_fun y y0 y1) H3.
    assert (H3 = If_fun_single y y0 y1). { apply proof_irrelevance. }
    assert (H2 = If_fun_single y x0 x1). { apply proof_irrelevance. }
    rewrite H6 , H7 in *. clear H6 H7.
    destruct H , H5 , H , H5.
    - rewrite <- H7. rewrite <- H6. auto.
    - exfalso. auto.
    - exfalso. auto.
    - rewrite <- H7. rewrite <- H6. auto.
  Qed.

  Theorem Rif_left : forall (P:Prop) (x y:R), P -> Rif P x y == x.
  Proof.
    intros. unfold Rif.
    assert (If_fun P x y x). {
      hnf; left.
      split; auto.
      reflexivity.
    }
    pose proof If_fun_single P x y.
    pose proof Rsinglefun_correct (If_fun P x y) (If_fun_single P x y).
    pose proof proj1 H1.
    apply H3; auto.
  Qed.

  Theorem Rif_right : forall (P:Prop) (x y:R), ~ P -> Rif P x y == y.
  Proof.
    intros. unfold Rif.
    assert (If_fun P x y y). {
      hnf; right.
      split; auto.
      reflexivity.
    }
    pose proof If_fun_single P x y.
    pose proof Rsinglefun_correct (If_fun P x y) (If_fun_single P x y).
    pose proof proj1 H1.
    apply H3; auto.
  Qed.

  Definition If_fun_rich (P : Prop) (x : P -> R) (y : ~ P -> R) :=
    (fun z => (exists H : P , x H == z) \/ (exists H : ~ P , y H == z)).

  Theorem If_fun_single_rich : forall (P : Prop) x y ,
    Proper ((fun _ _ => True) ==> Req) x ->
    Proper ((fun _ _ => True) ==> Req) y ->
    P_singlefun (If_fun_rich P x y).
  Proof.
    intros P x y Px Py.
    repeat split ; intros.
    - destruct H , H0 , H , H0.
      + pose proof Px x0 x3 I. rewrite <- H, H1, H0. reflexivity.
      + exfalso. auto.
      + exfalso. auto.
      + pose proof Py x0 x3 I. rewrite <- H, H1, H0. reflexivity.
    - destruct (classic P).
      + exists (x H). hnf. left.
        exists H. reflexivity.
      + exists (y H). hnf. right.
        exists H. reflexivity.
    - hnf in *. destruct H0 , H0 ; rewrite H in H0.
      + left. exists x1. auto.
      + right. exists x1. auto.
    - hnf in *. destruct H0 , H0 ; rewrite <- H in H0.
      + left. exists x1. auto.
      + right. exists x1. auto.
  Qed.

  Definition Rif_rich (P : Prop)(x : P -> R)(y : ~ P -> R)
                      {_: Proper ((fun _ _ => True) ==> Req) x}
                      {_: Proper ((fun _ _ => True) ==> Req) y}: R.
    apply Rsinglefun.
    exists (If_fun_rich P x y).
    apply If_fun_single_rich; auto.
  Defined.

  Theorem Rif_rich_left : forall (P:Prop) x y
    {Px: Proper ((fun _ _ => True) ==> Req) x}
    {Py: Proper ((fun _ _ => True) ==> Req) y},
    P -> exists H : P,Rif_rich P x y == x H.
  Proof.
    intros. unfold Rif_rich.
    assert (If_fun_rich P x y (x H)). {
      hnf; left.
      eexists; reflexivity.
    }
    pose proof If_fun_single_rich P x y _ _.
    pose proof Rsinglefun_correct (If_fun_rich P x y) (If_fun_single_rich P x y _ _).
    pose proof proj1 H1.
    exists H.
    apply H3; auto.
  Qed.

  Theorem Rif_rich_right : forall (P:Prop) x y
    {Px: Proper ((fun _ _ => True) ==> Req) x}
    {Py: Proper ((fun _ _ => True) ==> Req) y},
    ~ P -> exists H : ~ P,Rif_rich P x y == y H.
  Proof.
    intros. unfold Rif_rich.
    assert (If_fun_rich P x y (y H)). {
      hnf; right.
      eexists; reflexivity.
    }
    pose proof If_fun_single_rich P x y _ _.
    pose proof Rsinglefun_correct (If_fun_rich P x y) (If_fun_single_rich P x y _ _).
    pose proof proj1 H1.
    exists H.
    apply H3; auto.
  Qed.

End RSignleLemmas.

Module Type RINV_PARTIAL (RSS : R_SINGLE_SIMPLE).
  Module RL := RSignleLemmas (RSS).
  Import RL RSS.
  Local Open Scope R_scope.
  Parameter R0 : R.
  Parameter R1 : R.
  Parameter Rmult : R -> R -> R.
  Infix "*" := Rmult : R_scope.
  Axiom Rmult_comp : Proper (Req==>Req==>Req) Rmult.
  Existing Instance Rmult_comp .
  Parameter Rinv': forall (a : R) (H : ~ (a == R0)), R.
  Parameter Rinv'_comp : forall (r1 r2 : R)(H1 : ~ r1 == R0) (H2 : ~r2 == R0), r1 == r2 -> Rinv' r1 H1 == Rinv' r2 H2.
  Parameter Rinv'_l : forall (r : R)(H : ~ r == R0), Rinv' r H * r == R1.
End RINV_PARTIAL.

Module Rinv_Partial_To_Total (RSS : R_SINGLE_SIMPLE) (RP : RINV_PARTIAL RSS).
  Module RSL := RSignleLemmas (RSS).
  Import RP RSS RSL.
  Local Open Scope R_scope.
  Local Instance RinvL' (a: R):
    Proper ((fun _ _ : a == R0 => True) ==> Req) (fun _ : a == R0 => R0).
  Proof. hnf; intros. reflexivity. Qed.

  Local Instance RinvR' (a: R):
    Proper ((fun _ _ : ~ a == R0 => True) ==> Req) (fun H : ~ a == R0 => Rinv' a H).
  Proof. hnf; intros. apply Rinv'_comp. reflexivity. Qed.

  Program Definition Rinv (a : R): R :=
    Rif_rich (a == R0) (fun _ => R0) (fun H => Rinv' a H).

  Theorem Rinv_1 : forall r : R , r == R0 -> Rinv r == R0.
  Proof.
    intros.
    unfold Rinv.
    pose proof (Rif_rich_left (r==R0) (fun _ : r == R0 => R0) (fun H0 : ~ r == R0 => Rinv' r H0) H).
    destruct H0.
    auto.
  Qed.

  Theorem Rinv_Rinv' : forall r : R , ~ r == R0 -> exists H: ~ r == R0, Rinv r == (Rinv' r H).
  Proof.
    intros.
    unfold Rinv.
    pose proof (Rif_rich_right (r==R0) (fun _ : r == R0 => R0) (fun H0 : ~ r == R0 => Rinv' r H0)) H.
    destruct H0.
    auto.
    exists x. auto.
  Qed.

  Theorem Rinv_comp : Proper (Req ==> Req) Rinv.
  Proof.
    hnf. intros.
    intros.
    destruct (classic (x == R0)).
    - rewrite H0 in H.
      symmetry in H.
      apply Rinv_1 in H.
      apply Rinv_1 in H0.
      rewrite H , H0. reflexivity.
    - destruct (classic (y == R0)).
      + exfalso. apply H0. rewrite H. auto.
      + apply Rinv_Rinv' in H0.
        apply Rinv_Rinv' in H1.
        destruct H0,H1.
        rewrite H0 , H1.
        apply Rinv'_comp;  auto.
  Qed.

  Theorem Rinv_l : forall r : R , ~ r == R0 -> Rinv r * r == R1.
  Proof.
    intros.
    apply Rinv_Rinv' in H.
    destruct H.
    rewrite H.
    apply Rinv'_l.
  Qed.
End Rinv_Partial_To_Total.


From Coq Require Import ssreflect ssrfun FunctionalExtensionality.
From Mon Require Export Base.
From Mon Require Import sprop.SPropBase.
From Mon.SRelation Require Import SRelation_Definitions SMorphisms.

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

(***************************************************************)
(* Preorder srelations                                         *)
(***************************************************************)

Definition SProp_order : srelation SProp := s_impl.
Instance SProp_order_preorder : PreOrder SProp_order.
Proof. constructor ; cbv ; intuition. Qed.

Definition SProp_op_order : srelation SProp := Basics.flip s_impl.
Instance SProp_op_order_preorder : PreOrder SProp_op_order.
Proof. unfold SProp_op_order. typeclasses eauto. Qed.

Instance pointwise_preorder A {B} (R:srelation B) `{PreOrder _ R} :
  PreOrder (pointwise_srelation A R).
Proof. constructor ; cbv ; intuition ; stransitivity (y a) ; auto. Qed.

Definition Pred_op_order A : srelation (A -> SProp) :=
  pointwise_srelation A SProp_op_order.
Instance Pred_op_order_prorder A : PreOrder (@Pred_op_order A).
Proof. unfold Pred_op_order ; typeclasses eauto. Qed.

(***************************************************************)
(* Monads, in Kleisli triple form                              *)
(***************************************************************)

Record Monad : Type :=
  mkMonad
    { monad_tyop :> Type -> Type
    ; monad_ret  : forall A, A -> monad_tyop A
    ; monad_bind : forall A B,
        monad_tyop A -> (A -> monad_tyop B) -> monad_tyop B
    ; monad_law1 : forall A B a (f : A -> monad_tyop B),
        monad_bind (monad_ret a) f = f a
    ; monad_law2 : forall A c, monad_bind c (@monad_ret A) = c
    ; monad_law3 : forall A B C c (f : A -> monad_tyop B) (g : B -> monad_tyop C),
        monad_bind (monad_bind c f) g
        = monad_bind c (fun a => monad_bind (f a) g)
    }.

Definition ret {M : Monad} {A} := @monad_ret M A.
Definition bind {M : Monad} {A} {B} := @monad_bind M A B.
Definition map {M:Monad} {A B} (f : A -> B) (m : M A) : M B :=
  bind m (fun x => ret (f x)).
Notation "f <$> m" := (@map _ _ _ f m) (at level 60).
Ltac intro_map :=
  change (bind ?a (fun x => ret (?f x))) with (f <$> a).

Section MapLemmas.
  Context (M : Monad).
  Import FunctionalExtensionality.
  Lemma map_id : forall A (m : M A), id <$> m = m.
  Proof. intros ; rewrite /map /id /= /bind monad_law2 //. Qed.

  Lemma map_functorial : forall A B C (f : A -> B) (g : B -> C) (m : M A),
      g <$> (f <$> m) = (fun x => g (f x)) <$> m.
  Proof.
    intros ; cbv. rewrite monad_law3. f_equal. extensionality a.
    rewrite monad_law1. reflexivity.
  Qed.

  Lemma map_bind : forall A B C (f : B -> C) (m:M A) g,
      (f <$> bind m g = bind m (fun x => f <$> (g x))).
  Proof.
    intros ; cbv. rewrite monad_law3. reflexivity.
  Qed.
  Lemma bind_map : forall A B C (f : A -> B) (m:M A) (g : B -> M C),
      bind (f <$> m) g = bind m (fun x => g (f x)).
  Proof.
    intros ; cbv. rewrite monad_law3.
    f_equal ; extensionality a. rewrite monad_law1.
    reflexivity.
  Qed.
End MapLemmas.

(***************************************************************)
(* Ordered Monads, where the bind respects the order           *)
(***************************************************************)

Record OrderedMonad : Type :=
  mkOrderedMonad
    { omon_monad :> Monad
      ; omon_rel : forall A, srelation (omon_monad A)
      ; omon_order : forall A, PreOrder (@omon_rel A)
      ; omon_bind  : forall A B,
          SProper (@omon_rel A s==> pointwise_srelation A (@omon_rel B) s==> @omon_rel B) bind
    }.

Existing Instance omon_order.
Notation "x ≤[ M ] y" := (@omon_rel M _ x y) (at level 70).
Notation "x ≤ y" := (@omon_rel _ _ x y) (at level 70).

Section DiscreteMonad.
  Import SPropNotations.
  Program Definition DiscreteMonad (M:Monad) : OrderedMonad :=
    @mkOrderedMonad M (fun A x y => x ≡ y) _ _.
  Next Obligation.
    constructor. intuition. move=> ? ? ? H ; induction H ; by [].
  Qed.
  Next Obligation.
    move=> ? ? ? f g H ;enough (f ≡ g) ; subst_sEq. constructor.
    apply SPropAxioms.funext_sprop=> ? ; apply H.
  Qed.
End DiscreteMonad.

(***************************************************************)
(* Monad algebras, and algebras on ordered monads              *)
(***************************************************************)
Record MonadAlgebra (M : Monad) : Type :=
  mkMonadAlgebra
    { malg_carrier : Type
    ; malg_map     :> M malg_carrier -> malg_carrier
    ; malg_ret     : forall c, malg_map (ret c) = c
    ; malg_bind    : forall X (m : M X) f,
        malg_map (bind m (fun x => ret (malg_map (f x)))) = malg_map (bind m f)
    }.

Record OrderedAlgebra (M : Monad) : Type :=
  mkOrderedAlgebra
    { oalg_alg     :> MonadAlgebra M
    ; oalg_rel     : srelation (malg_carrier oalg_alg)
    ; oalg_order   : PreOrder oalg_rel
    ; oalg_mono    : forall A, SProper
                            (pointwise_srelation A oalg_rel s==> pointwise_srelation (M A) oalg_rel)
                            (fun k m => oalg_alg (map k m))}.

Section OrderedMonadAlgebra.
  Context (OM : OrderedMonad).

  Record OrderedMonadAlgebra : Type :=
    mkOrderedMonadAlgebra
      { omalg_alg     :> MonadAlgebra OM
      ; omalg_rel     : srelation (malg_carrier omalg_alg)
      ; omalg_order   : PreOrder omalg_rel
      ; omalg_mono    : forall A, SProper
                              (pointwise_srelation A omalg_rel s==> (@omon_rel OM A) s==> omalg_rel)
                              (fun k m => omalg_alg (map k m))}.

End OrderedMonadAlgebra.

Section AssertAssumeStructure.
  Context A (rel : srelation A) `{PreOrder _ rel}.

  Notation "x ≤ y" := (rel x y).
  Import SPropNotations.
  Class aa :=
    mkAa
      { assert_p : SProp -> A -> A
      ; assume_p : SProp -> A -> A
      ; aa_assert_stronger : forall p x, assert_p p x ≤ x
      ; aa_assume_weaker : forall p x, x ≤ assume_p p x
      ; aa_assert_assume_adjoint : forall p x1 x2,
          assert_p p x1 ≤ x2 s<-> x1 ≤ assume_p p x2
      }.

End AssertAssumeStructure.

(**************************************************************************)
(* Left/Right kan extensions in the Kleisli category of an ordered monad  *)
(**************************************************************************)

Section KleisliKanExtension.
  Context (W:OrderedMonad) (B C : Type) (f : W C) (p : W B).
  Import SPropNotations.

  (* Right Kan extension of f along p *)
  Definition ran :=
    { ext : B -> W C ≫
      bind p ext  ≤[W] f s/\
      forall (w' : B -> W C), bind p w' ≤[W] f -> forall b, w' b ≤[W] ext b
    }.

  Definition lan :=
    { ext : B -> W C ≫
      f ≤ bind p ext s/\
      forall (w' : B -> W C), f ≤ bind p w' -> forall b, w' b ≤ ext b
    }.

End KleisliKanExtension.

Section KanExtensionMonotonic.
  Context (W:OrderedMonad) (B C : Type).
  Context (f : W C) (p : W B) (Hran:ran f p).
  Context (f':W C) (p':W B) (Hran':ran f' p').
  Context (Hf : f ≤ f') (Hp : p' ≤ p).
  Definition ran_mono : forall b, Spr1 Hran b ≤ Spr1 Hran' b.
  Proof.
    move:Hran Hran' => [w [H1 H2]] [w' [H1' H2']] b /=.
    apply H2'. stransitivity f ; [|assumption].
    stransitivity (bind p w).
    apply omon_bind ; [assumption|sreflexivity].
    assumption.
  Qed.
End KanExtensionMonotonic.

Section KanExtensionIsoStable.
  Context (W:OrderedMonad) (B C : Type) (f : W C) (p : W B).
  Import SPropNotations.
  Notation "w ≅ w'" := (w ≤ w' s/\ w' ≤ w) (at level 65).
  Context (Hran:ran f p) (f':W C) (p':W B) (Hf : f ≅ f') (Hp : p ≅ p').
  Program Definition ran_iso : ran f' p' := Sexists _ (Spr1 Hran) _.
  Next Obligation.
    destruct Hf as [Hf1 Hf2] ; destruct Hp as [Hp1 Hp2] ; destruct (Spr2 Hran) as [Hran1 Hran2].
    split.
    stransitivity (bind p (Spr1 Hran)).
    apply omon_bind. assumption.  move=> //= ?. sreflexivity.
    stransitivity f ; assumption.
    move=> w' Hw'. apply Hran2.
    stransitivity (bind p' w'). apply omon_bind. assumption.
    move=> //= ? ; sreflexivity.
    stransitivity f' ; assumption.
  Qed.
End KanExtensionIsoStable.

(***************************************************************)
(* Monad morphisms                                             *)
(***************************************************************)

Record MonadMorphism (M W : Monad) : Type :=
  mkMorphism
    { mon_morph :> forall {A}, M A -> W A
    ; mon_morph_ret : forall A (a : A), mon_morph (ret a) = ret a
    ; mon_morph_bind : forall A B (m : M A) (f : A -> M B),
        mon_morph (bind m f) = bind (mon_morph m) (fun a => mon_morph (f a))
    }.

Program Definition identity_monad_morphism M : MonadMorphism M M :=
  @mkMorphism M M (fun A => id) _ _.

Program Definition comp_monad_morphism {M1 M2 M3}
  : MonadMorphism M1 M2 -> MonadMorphism M2 M3 -> MonadMorphism M1 M3
  := fun f12 f23 => @mkMorphism M1 M3 (fun A a => f23 A (f12 A a)) _ _.
Next Obligation. rewrite !mon_morph_ret //. Qed.
Next Obligation. rewrite !mon_morph_bind //. Qed.

Section MonadMorphismRefinement.
  Context {M : Monad} {W : OrderedMonad} (ϕ ψ : MonadMorphism M W).
  Definition monad_morph_refines :=
    forall A, pointwise_srelation (M A) (@omon_rel W A) (ϕ A) (ψ A).
End MonadMorphismRefinement.

Instance mon_morph_refines_preorder M W : PreOrder (@monad_morph_refines M W).
Proof.
  constructor ; cbv ; intuition.
  stransitivity (y A a) ; auto.
Qed.

Section MonadMorphismNatural.
  Context {M1 M2 : Monad} (θ : MonadMorphism M1 M2).
  Import FunctionalExtensionality.
  Lemma monad_morphism_natural : forall A B f m, f <$> (θ A m) = θ B (f <$> m).
  Proof.
    intros. cbv. rewrite mon_morph_bind. cbv ; f_equal.
    extensionality a. rewrite mon_morph_ret ; reflexivity.
  Qed.
End MonadMorphismNatural.

(***************************************************************)
(* Monotonic Monad morphisms                                   *)
(***************************************************************)

Record MonotonicMonadMorphism (M W : OrderedMonad) : Type :=
  mkMonMorphism
    { monmon_morph :> MonadMorphism M W
    ; monmon_monotonic : forall A,
          SProper (@omon_rel M A s==> @omon_rel W A) (monmon_morph A)
    }.

Program Definition identity_monmon M : MonotonicMonadMorphism M M :=
  @mkMonMorphism _ _ (identity_monad_morphism M) _.
Next Obligation. cbv ; intuition. Qed.

Program Definition comp_monmon {M1 M2 M3}
  : MonotonicMonadMorphism M1 M2 ->
    MonotonicMonadMorphism M2 M3 ->
    MonotonicMonadMorphism M1 M3
  := fun f12 f23 => @mkMonMorphism M1 M3 (comp_monad_morphism f12 f23) _.
Next Obligation.
  cbv ; intuition.
  do 2 apply monmon_monotonic => //.
Qed.

Program Definition from_discrete_monad_monotonic
           (M:Monad) (W:OrderedMonad) (θ : MonadMorphism M W)
  : MonotonicMonadMorphism (DiscreteMonad M) W
  := @mkMonMorphism _ _ θ _.

(* An ordered monad equipped with a morphism from M *)
Record OrderedMonadUnder (M:OrderedMonad) :=
  mkMonadUnder {
    mu_carrier :> OrderedMonad ;
    mu_lift : MonotonicMonadMorphism M mu_carrier
  }.

(***************************************************************)
(* Monad Relations                                             *)
(***************************************************************)

Record MonadRelation (M W : Monad) : Type :=
  mkMonadRelation
    { mrel      :> forall A, M A -> W A -> SProp
    ; mrel_ret  : forall A (a:A), mrel (ret a) (ret a)
    ; mrel_bind : forall A B m w (f : A -> M B)  g,
        mrel m w -> (forall a, mrel (f a) (g a)) -> mrel (bind m f) (bind w g)
    }.

Section MonadIdeal.
  Context (M : Monad) (W:OrderedMonad).
  Record MonadIdeal : Type :=
    mkMonadIdeal
      { mid_rel :> MonadRelation M W
      ; mid_upper_closed : forall A, SProper (pointwise_srelation (M A) (@omon_rel W A s==> SProp_order)) (@mid_rel A)
      }.
End MonadIdeal.

Section MonadMorphismToIdeal.
  Context (M : Monad) (W:OrderedMonad) (θ : MonadMorphism M W).
  Program Definition relation_from_mmorph : MonadRelation M W :=
    @mkMonadRelation _ _ (fun A m w => θ A m ≤ w) _ _.
  Next Obligation. rewrite mon_morph_ret. sreflexivity. Qed.
  Next Obligation.
    rewrite mon_morph_bind.
    apply omon_bind; [|move=> ?] ; auto.
  Qed.

  Program Definition ideal_from_mmorph : MonadIdeal M W :=
    @mkMonadIdeal _ _ relation_from_mmorph _.
  Next Obligation. cbv ; intuition ; estransitivity ; eassumption. Qed.

End MonadMorphismToIdeal.

(***************************************************************)
(* Monad Transformer                                           *)
(***************************************************************)

Record OrderedMonadTransformer :=
  mkOrderedMonadTransformer
    { mt_monad :> forall (M:OrderedMonad), OrderedMonadUnder M
    ; mt_map : forall (M1 M2:OrderedMonad),
        MonotonicMonadMorphism M1 M2 ->
        MonotonicMonadMorphism (mt_monad M1) (mt_monad M2)
    ; mt_map_id : forall M A m,
        mt_map (identity_monmon M) A m = identity_monmon _ A m
    ; mt_map_comp : forall (M1 M2 M3 : OrderedMonad)
                      (θ12 : MonotonicMonadMorphism M1 M2)
                      (θ23 : MonotonicMonadMorphism M2 M3) A m,
        mt_map θ23 _ (mt_map θ12 A m)  = mt_map (comp_monmon θ12 θ23) A m
    ; mt_natural_lift :
        forall (M1 M2 : OrderedMonad) (θ : MonotonicMonadMorphism M1 M2) A m,
          mt_map θ  _(mu_lift (mt_monad M1) A m)
        = mu_lift (mt_monad M2) _ (θ A m)
    }.

(***************************************************************)
(* Dijkstra Monads over specification (i.e. ordered) monads    *)
(***************************************************************)

Import SPropNotations.
Record Dijkstra (W : OrderedMonad) : Type := mkDM
  { dm_tyop :> forall A, W A -> Type
  ; dm_ret  : forall A, forall (a : A), dm_tyop (ret a)
  ; dm_bind : forall A B (w : W A) (f : A -> W B)
                     (d : dm_tyop w) (g : forall a, dm_tyop (f a)),
      dm_tyop (bind w f)
  ; dm_wkn : forall {A} {w w' : W A}, dm_tyop w -> w ≤[W] w' -> dm_tyop w'
  ; dm_law1 : forall A B (a : A) (f : A -> W B) (g : forall a, dm_tyop (f a)),
      dm_bind (dm_ret a) g =⟨monad_law1 a f⟩ g a
  ; dm_law2 : forall A c m ,
      dm_bind m (@dm_ret A) =⟨monad_law2 c⟩  m
  ; dm_law3 : forall A B C c f g (m : dm_tyop c)
                     (f' : forall (a : A), dm_tyop (f a))
                     (g' : forall (b : B), @dm_tyop C (g b)),
      dm_bind (dm_bind m f') g' =⟨monad_law3 c f g⟩
                                   dm_bind m (fun a => dm_bind(f' a) g')
  ; dm_law4 : forall A w (m:@dm_tyop A w), dm_wkn m (reflexivity _) = m
  ; dm_law5 : forall A w1 w2 w3 (m:@dm_tyop A w1) (H12 :w1 ≤ w2) (H23 :w2 ≤ w3),
      dm_wkn m (transitivity H12 H23) = dm_wkn (dm_wkn m H12) H23
  ; dm_law6 : forall A B wm wm' wf wf' (m:@dm_tyop A wm) (f : forall (a:A), @dm_tyop B (wf a)) (Hm : wm ≤ wm') (Hf : forall a, wf a ≤ wf' a),
       (dm_wkn (dm_bind m f) (omon_bind Hm Hf) ≡ dm_bind (dm_wkn m Hm) (fun a => dm_wkn (f a) (Hf a)))
  }.

Definition dret {W} {D : Dijkstra W} {A} := @dm_ret W D A.
Definition dbind {W} {D : Dijkstra W} {A} {B} {w} {f} := @dm_bind W D A B w f.
Definition wkn {W} {D : Dijkstra W} {A} {w w'} := @dm_wkn W D A w w'.

(* Generic if-then-else for Dijkstra monads *)
Definition ifTE {A} {W} {D : Dijkstra W} {w1 w2 : W A} :
  forall (b: bool), D A w1 -> D A w2 -> D A (if b then w1 else w2) :=
  fun b tt ff =>
    match b as b return D A (if b then w1 else w2) with
    | true => tt
    | false => ff
    end.

Module DijkstraMonadNotations.
  Notation "x <- m1 ; m2" := (dbind m1 (fun x => m2)) (at level 80, right associativity).
  Notation "'ifDM' b 'then' c1 'else' c2 'end'" := (@ifTE _ _ _ _ _ b c1 c2).
End DijkstraMonadNotations.

(***********************************************************************)
(* Deriving Dijkstra Monads from Effect Observations / Monad morphisms *)
(***********************************************************************)
Section OfMorphism.
  Import SPropNotations.

  Variable M : Monad.
  Variable W : OrderedMonad.
  Variable θ : MonadMorphism M W.

  Definition Dθ_carrier A (w : W A) : Type :=
    { m : M A ≫ θ A m ≤ w }.

  Program Definition Dθ_ret A (a : A): Dθ_carrier (ret a) :=
    Sexists _ (ret a) _.
  Next Obligation.
    rewrite mon_morph_ret ; sreflexivity.
  Qed.

  Program Definition Dθ_bind A B (w : W A) (f : A -> W B)
          (d : Dθ_carrier w) (g : forall a, Dθ_carrier (f a)) :
    Dθ_carrier (bind w f) :=
    Sexists _ (bind (Spr1 d) (fun a => Spr1 ( g a))) _.
  Next Obligation.
    rewrite mon_morph_bind.
    apply (omon_bind (Spr2 d) (fun a => Spr2 (g a))).
  Qed.

  Program Definition Dθ_wkn A (w w' : W A) (d: Dθ_carrier w) (H : w ≤[W] w') : Dθ_carrier w' :=
    Sexists _ (Spr1 d) _.
  Next Obligation.
    stransitivity w. exact (Spr2 d). assumption.
  Qed.

  Program Definition Dθ : Dijkstra W :=
    @mkDM W Dθ_carrier Dθ_ret Dθ_bind Dθ_wkn _ _ _ _ _ _.
  (* Anomaly when trying to factorize *)
  Next Obligation. apply eq_above_Ssig ; cbv ; by rewrite monad_law1. Qed.
  Next Obligation. apply eq_above_Ssig ; cbv ; by rewrite monad_law2. Qed.
  Next Obligation. apply eq_above_Ssig ; cbv ; by rewrite monad_law3. Qed.
  Next Obligation. constructor=> //. Qed.

  Program Definition lift {A} (m : M A) : Dθ A (θ A m) := Sexists _ m _.
  Next Obligation. sreflexivity. Qed.

End OfMorphism.

(*****************************************************************)
(* Deriving Dijkstra monads from Monadic Relations               *)
(*****************************************************************)

Section OfRelation.
  Context (M:Monad) (W:OrderedMonad) (R:MonadIdeal M W).
  Import SPropNotations.

  Definition Drel_carrier A (w : W A) :=
    { m : M A ≫ R A m w }.

  Program Definition Drel_ret A (a : A): Drel_carrier (ret a) :=
    Sexists _ (ret a) (mrel_ret R a).

  Program Definition Drel_bind A B (wm : W A) (wf : A -> W B)
          (m : Drel_carrier wm) (f : forall a, Drel_carrier (wf a)):
    Drel_carrier (bind wm wf) :=
    Sexists _ (bind (Spr1 m) (fun a => Spr1 (f a))) _.
  Next Obligation.
    apply mrel_bind ; [exact (Spr2 m)| intros a ; apply (Spr2 (f a))].
  Qed.

  Program Definition Drel_wkn A (w w' : W A) (m : Drel_carrier w) (Hww' : w ≤[W] w')
    : Drel_carrier w' :=
    Sexists _ (Spr1 m) (mid_upper_closed Hww' (Spr2 m)).

  Program Definition Drel : Dijkstra W :=
    @mkDM W Drel_carrier Drel_ret Drel_bind Drel_wkn _ _ _ _ _ _.
  Next Obligation. apply eq_above_Ssig ; cbv ; rewrite !monad_law1 //. Qed.
  Next Obligation. apply eq_above_Ssig ; cbv ; rewrite !monad_law2 //. Qed.
  Next Obligation. apply eq_above_Ssig ; cbv ; rewrite !monad_law3 //. Qed.
  Next Obligation. constructor=> //. Qed.

End OfRelation.