(* This file is part of the Linear Logic  formalization in Coq: https://github.com/meta-logic/coq-ll *)

(** ** Multisets
This module is an adaptation of the standard library of Multisets in Coq #Coq.Sets.Multiset#
and the implementation of multisets in  CoLoR (http://color.inria.fr/)

 *)
Require Export Permutation.
Require Export Coq.Relations.Relations.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Sorting.PermutSetoid.
Require Export Coq.Sets.Multiset.
Require Export List.
Require Export PeanoNat Lia.
Require Export LL.Eqset.
Export ListNotations.

Module Type MultisetList (EQ : Eqset_dec).

  Import EQ.

  Fixpoint removeElem (el: A) (l: list A) : list A :=
    match l with
    | nil => nil
    | hd::tl =>
      match eqA_dec el hd with
      | left _ => tl
      | right _ => hd::removeElem el tl
      end
    end.

  Fixpoint removeAll (l m: list A) : list A :=
    match m with
    | nil => l
    | hd::tl => removeAll (removeElem hd l) tl
    end.

  Lemma removeElem_length_in : forall a l, (exists a', a = a' /\ In a' l) ->
                                           length (removeElem a l) = pred (length l).

  Proof.
    induction l; intros; destruct H as [b [ab bl]]; inversion bl.
    simpl; destruct (eqA_dec a a0); trivial.
    absurd (a = a0); trivial.
    rewrite H; trivial.
    simpl; destruct (eqA_dec a a0); trivial.
    simpl; rewrite IHl; trivial.
    destruct l; auto.
    contradiction.
    exists b; split; trivial.
  Qed.

  Definition Multiset := list A.

  Definition empty : Multiset := nil.
  Definition singleton a : Multiset := a :: nil.
  Definition union := app (A:=A).
  Definition mult := count_occ eqA_dec.
  Definition meq X Y := forall a, mult X a = mult Y a.

  Definition rem := removeElem.
  Definition diff := removeAll.

  Definition member x M := mult M x > 0.

  Notation "X =mul= Y" := (meq X Y) (at level 70).
  Notation "X <>mul Y" := (~meq X Y) (at level 50).
  Notation "X / Y" := (diff X Y) .
  Notation "x # M" := (mult M x)(at level 10).
  Notation "x € M" := (member x M) (at level  10).

  #[export] Hint Resolve count_occ_In
       count_occ_not_In
       count_occ_nil
       count_occ_inv_nil
       count_occ_cons_eq
       count_occ_cons_neq : core .

  Lemma in_countIn : forall a l, In a l -> a # l > 0.
  Proof.
    intros. apply count_occ_In; auto.
  Qed.

  (** count_occ_inv_nil *)

  Lemma empty_empty : forall M, (forall x, x # M = 0) -> M = [].
  Proof.
    intros.
    eapply (count_occ_inv_nil eqA_dec); eauto.
  Qed.

  (** count_occ_nil *)

  Lemma countIn_nil : forall (x : A), x # [] = 0%nat.
  Proof. auto. Qed.

  (** count_occ_not_In *)

  Lemma countIn_not_In: forall x l, ~ In x l <-> x # l = 0%nat.
  Proof.
    intros.
    apply count_occ_not_In.
  Qed.

  (** count_occ_inv_nil  *)

  Theorem countIn_inv_nil : forall (l : list A), (forall x:A, x # l = 0%nat) <-> l = [].
  Proof.
    intros. apply count_occ_inv_nil.
  Qed.

  (** count_occ_cons_eq *)

  Lemma countIn_cons_eq : forall (l : list A) (x y : A), y = x -> y # (x::l) = S (y # l).
  Proof.
    intros. apply count_occ_cons_eq; auto.
  Qed.

  (** count_occ_cons_neq *)

  Lemma countIn_cons_neq : forall (l : list A) (x y : A), y <> x -> y # (x::l) = y # l.
  Proof.
    intros. apply count_occ_cons_neq; auto.
  Qed.

  (** count_occ_In  *)

  Lemma countIn_In: forall x l, In x l <-> x # l > 0.
  Proof.
    intros. apply count_occ_In.
  Qed.

  #[export] Hint Resolve in_eq
       in_cons
       not_in_cons
       in_nil
       in_split
       in_inv : core .

  Lemma mult_eqA_compat: forall x y M, x = y -> x # M = y # M.
  Proof.
    induction M; auto.
    intros.
    intuition. simpl.
    destruct (eqA_dec a x); destruct (eqA_dec a y); auto.
    rewrite H in e. contradiction.
    rewrite <- H in e. contradiction.
  Qed.

  Lemma meq_multeq: forall M N, M =mul= N -> (forall x, x # M = x # N).
  Proof. auto. Qed.

  Lemma multeq_meq: forall M N, (forall x, x # M = x # N) -> M =mul= N.
  Proof. auto. Qed.

  Lemma diff_empty_l : forall M, [] / M = [].
  Proof.
    induction M; auto.
  Qed.

  Lemma diff_empty_r : forall M, M / [] = M.
  Proof.
    induction M; auto.
  Qed.

  Lemma empty_mult: forall x, x # [] = 0%nat.
  Proof. auto. Qed.

  Lemma union_mult: forall x M N, x # (M ++ N) = (x # M + x # N).
  Proof.
    induction M; auto.
    intros; simpl. destruct (eqA_dec a x); auto. rewrite IHM. auto.
  Qed.

  Lemma union_mult2: forall x a N, x # (a :: N) = (x # [a] + x # N).
  Proof.
    intros.
    change (a::N) with ([a] ++ N).
    apply union_mult.
  Qed.

  Lemma mult_remove_in : forall x a M,
      x = a -> (x # (rem a M)) = ((x # M) - 1)%nat.
  Proof.
    induction M; auto.
    intro x_a.
    simpl.
    destruct (eqA_dec a a0); destruct (eqA_dec a0 x); subst.
    auto with arith.
    contradiction.
    contradiction.
    simpl.
    destruct (eqA_dec a0 a); auto.
    contradiction.
  Qed.

  Lemma mult_remove_not_in : forall M a x,
      x <> a -> x # (rem a M) = x # M.

  Proof.
    induction M; intros; auto.
    simpl; destruct (eqA_dec a0 a); subst.
    destruct (eqA_dec x a); auto.
    contradiction.
    destruct (eqA_dec a x); subst; auto.
    contradiction.
    simpl.
    destruct (eqA_dec a x); subst; auto.
  Qed.

  Lemma remove_perm_single : forall x a b M,
      x # (rem a (rem b M)) = x # (rem b (rem a M)).
  Proof.
    intros x a b M.
    case (eqA_dec x a); case (eqA_dec x b); intros x_b x_a.
    (* x=b,  x=a *)
    rewrite !mult_remove_in; trivial.
    (* x<>b, x=a *)
    rewrite mult_remove_in; trivial.
    do 2 (rewrite mult_remove_not_in; trivial).
    rewrite mult_remove_in; trivial.
    (* x=b,  x<>a *)
    rewrite mult_remove_not_in; trivial.
    do 2 (rewrite mult_remove_in; trivial).
    rewrite mult_remove_not_in; trivial.
    (* x<>b, x<>a *)
    rewrite !mult_remove_not_in; trivial.
  Qed.

  Lemma remove_perm_single' : forall a b M,
      (rem a (rem b M)) =mul= (rem b (rem a M)).
  Proof.
    intros.
    apply multeq_meq; intros.
    apply remove_perm_single.
  Qed.

  Lemma diff_mult_comp : forall x N M M',
      M =mul= M' -> x # (M / N) = x # (M' / N).
  Proof.
    induction N.
    intros; apply meq_multeq; trivial.
    intros M M' MM'.
    simpl.
    apply IHN.
    apply multeq_meq.
    intro x'.
    case (eqA_dec x' a).
    intro xa; rewrite !mult_remove_in; trivial.
    erewrite meq_multeq with (N:=M'); trivial.
    intro xna; rewrite !mult_remove_not_in; trivial.
  Qed.

  Lemma diff_perm_single : forall x a b M N,
      x # (M / (a::b::N)) = x # (M / (b::a::N)).

  Proof.
    intros x a b M N.
    simpl; apply diff_mult_comp.
    apply multeq_meq.
    intro x'; apply remove_perm_single.
  Qed.

  Lemma diff_perm : forall M N a x,
      x # ((rem a M) / N) = x # (rem a (M / N)).

  Proof.
    intros M N; generalize M; clear M.
    induction N.
    auto.
    intros M b x.
    change (rem b M / (a::N)) with (M / (b::a::N)).
    rewrite diff_perm_single.
    simpl; apply IHN.
  Qed.

  Lemma diff_mult_step_eq : forall M N a x,
      x = a -> x # (rem a M / N) = (x # (M / N)) - 1%nat.

  Proof.
    intros M N a x x_a.
    rewrite diff_perm.
    rewrite mult_remove_in; trivial.
  Qed.

  Lemma diff_mult_step_neq : forall M N a x,
      x <> a -> x # (rem a M / N) = x # (M / N).

  Proof.
    intros M N a x x_a.
    rewrite diff_perm.
    rewrite mult_remove_not_in; trivial.
  Qed.

  Lemma diff_mult : forall M N x,
      x # (M / N) = (x # M) - (x # N).

  Proof.
    induction N.
    (* induction base *)
    simpl; intros; lia.
    (* induction step *)
    intro x; simpl.
    destruct (eqA_dec a x); simpl.
    (* x = a *)
    fold rem.
    rewrite diff_mult_step_eq; auto.
    rewrite (IHN x).
    lia.
    (* x <> a *)
    fold rem.
    rewrite diff_mult_step_neq; auto.
  Qed.

  Lemma singleton_mult_in: forall x y, y = x -> x # [y] = 1%nat.
  Proof. intros. simpl. destruct (eqA_dec y x); [trivial | contradiction]. Qed.

  Lemma singleton_mult_notin: forall x y, y <> x -> x # [y] = 0%nat.
  Proof. intros. simpl. destruct (eqA_dec y x); [ contradiction | trivial]. Qed.

  #[export] Hint Unfold meq
       empty
       singleton
       mult
       union
       diff : core .

  #[export] Hint Resolve mult_eqA_compat
       meq_multeq
       multeq_meq
       empty_mult
       union_mult
       diff_mult
       singleton_mult_in
       singleton_mult_notin : core .

  #[export] Hint Rewrite empty_mult
       union_mult
       diff_mult using trivial :core .

  (*   Parameter mset_ind_type: forall P : Multiset -> Type,
        P empty -> (forall M a, P M -> P (M ++ [a])) -> forall M, P M. *)

  Lemma rem_to_diff : forall a M, rem a M =mul= M / [a].
  Proof. auto. Qed.

  Ltac mset_unfold := repeat progress unfold member.

  Ltac try_solve_meq :=
    (intros; (* try rewrite !rem_to_diff; *)
     match goal with
     | |- _ =mul= _ =>
       ( apply multeq_meq
         ; intro
         ; try_solve_meq
       )
     | _ =>
       (    mset_unfold ; repeat progress (
                                   (*               try rewrite union_mult2; *)
	                           try rewrite !union_mult;
                                   try rewrite diff_mult;
                                   try rewrite countIn_nil
                                 (*               try rewrite count_occ_nil *)
                                 )
            ; try lia
            ; try congruence
            ; try solve [auto]
       )
     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 = ?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 <> ?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").

  #[export] Hint Unfold member remove : core .

  Section meq_equivalence.

    Lemma meq_refl : forall M, M =mul= M.
    Proof.  solve_meq. Qed.

    Lemma meq_sym : forall M N, M =mul= N -> N =mul= M.
    Proof. solve_meq_ext. Qed.

    Lemma meq_trans :
      forall M N P, M =mul= N -> N =mul= P -> M =mul= P.
    Proof. solve_meq_ext. Qed.

  End meq_equivalence.

  #[export] Hint Resolve meq_refl meq_sym meq_trans : core .

  #[export] Instance meq_Equivalence : Equivalence meq.
  Proof.
    split; eauto.
  Qed.

  #[export] Instance union_morph : Proper (meq ==> meq ==> meq) union.

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

  #[export] Instance insert_morph : Proper (eq ==> meq ==> meq) cons.

  Proof. intros a b ab c d cd.  subst.
         change (b::c) with ([b] ++ c).
         change (b::d) with ([b] ++ d).
         rewrite cd.  auto. Qed.

  #[export] Instance member_morph : Proper (eq ==> meq ==> iff) member.

  Proof. intros a b ab L1 L2 H; subst. unfold member. rewrite H. intuition. Qed.

  #[export] Instance union_morph': Proper (meq ==> meq ==> iff) (meq).
  Proof.
    intros a b ab c d cd; split;
      solve_meq_ext.
  Qed.

  #[export] Instance mult_morph : Proper (meq ==> eq ==> eq) mult.

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

  #[export] Instance diff_morph : Proper (meq ==> meq ==> meq) diff.

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

  #[export] Instance remove_morph : Proper (eq ==> meq ==> meq) removeAll.

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

  #[export] Instance rem_morph : Proper (eq ==> meq ==> meq) rem.

  Proof. intros a b ab c d cd; subst.
         assert (rem b c =mul= c / [b]) as H1 by auto.
         assert (rem b d =mul= d / [b]) as H2 by auto.
         rewrite H1, H2, cd; auto. Qed.

  Lemma meq_cons_app a M : a :: M =mul= [a] ++ M.
  Proof. auto. Qed.

  Lemma union_comm : forall M N, (M ++ N) =mul= (N ++ M).
  Proof. solve_meq. Qed.
  Lemma union_comm_cons : forall a M, (a :: M) =mul= (M ++ [a]).
  Proof. intros. rewrite meq_cons_app; solve_meq. Qed.
  Lemma union_assoc : forall M N P, M ++ N ++ P =mul= (M ++ N) ++ P.
  Proof. solve_meq. Qed.
  #[export] Hint Resolve meq_cons_app union_comm_cons union_comm union_assoc : core .

  Lemma member_singleton x y : x € [y] -> x = y.
  Proof.
    unfold member; intros.
    case (eqA_dec x y); [trivial | intro x_neq_y].
    assert (x # [y] = 0%nat); [auto | idtac].
    rewrite H0 in H; lia.
  Qed.

  Lemma rem_to_union: forall L M x, M =mul= [x] ++ L -> L =mul= (rem x M).
  Proof.
    intros.
    apply multeq_meq; intros.
    apply meq_multeq with (x:=x0) in H.
    rewrite union_mult in H.
    symmetry in H.
    rewrite Nat.add_comm in H.
    apply Nat.add_sub_eq_r in H.
    rewrite <- H.
    simpl; destruct (eqA_dec x x0); subst.
    symmetry. apply mult_remove_in; auto.
    symmetry. rewrite Nat.sub_0_r. apply mult_remove_not_in; auto.
  Qed.

  Lemma rem_a : forall a, rem a ([a]) =mul= [].
  Proof.
    intros; simpl.
    case (eqA_dec a a); auto.
  Qed.

  Lemma rem_ab : forall a b, b = a -> rem a ([b]) =mul= [ ].
  Proof.
    intros; subst. apply rem_a.
  Qed.

  Lemma rem_not_ab : forall a b, b <> a -> rem a ([b]) =mul= [b].
  Proof.
    intros; simpl.
    case (eqA_dec a b); auto; intros.
    symmetry in e. contradiction.
  Qed.

  Lemma rem_aM : forall a M, rem a (a :: M) =mul= M.
  Proof.
    intros.
    simpl.
    case (eqA_dec a a); auto; intros.
    contradiction.
  Qed.

  Lemma rem_aM_app : forall a M, rem a ([a] ++ M) =mul= M.
  Proof.
    intros; simpl.
    case (eqA_dec a a); auto; intros.
    contradiction.
  Qed.

  Lemma rem_abM_app : forall a b M, b = a -> rem a ([b] ++ M) =mul= M.
  Proof.
    intros; simpl.
    case (eqA_dec a b); auto; intros.
    symmetry in H.
    contradiction.
  Qed.

  Lemma rem_not_abM_app : forall a b M, b <> a -> rem a ([b] ++ M) =mul= [b] ++ rem a M.
  Proof.
    intros; simpl.
    case (eqA_dec a b); auto; intros.
    symmetry in e.
    contradiction.
  Qed.

  Lemma rem_aM_cons : forall a M, rem a (a :: M) =mul= M.
  Proof.
    intros.
    change (a :: M) with ([a] ++ M).
    apply rem_aM_app.
  Qed.

  Lemma rem_to_union_app: forall L M x, M =mul= [x] ++ L -> L =mul= (rem x M).
  Proof.
    intros. rewrite H. rewrite rem_aM_app. auto.
  Qed.
  Lemma rem_to_union_cons: forall L M x, M =mul= x :: L -> L =mul= (rem x M).
  Proof.
    intros. rewrite H. rewrite rem_aM_cons. auto.
  Qed.

  #[export] Hint Resolve rem_a rem_ab rem_not_ab rem_aM_app rem_abM_app rem_not_abM_app rem_aM_cons : core .
  Lemma emp_mult : forall M, M =mul= [] <-> M = [].
  Proof.
    split; intros; subst; auto.
    eapply (count_occ_inv_nil eqA_dec); intros.
    apply meq_multeq with (x:=x) in H; auto.
  Qed.

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

  Proof. solve_meq. Qed.
  #[export] Hint Resolve union_perm : core .
  Lemma union_empty M : M ++ [] =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.
    absurd ([] =mul= []); auto.
    exists M. exists a. auto.
  Qed.

  Lemma not_empty M x : x € M -> M =mul= [] -> False.

  Proof.
    unfold member; intros mult_x_M M_is_empty.
    absurd (x # M = 0%nat).
    lia.
    assert (x # [] = 0%nat); [auto | idtac].
    assert (x # M = x # []); [apply meq_multeq; trivial | idtac].
    lia.
  Qed.

  Lemma member_union_l a M N : a € M -> a € (M ++ N).
  Proof. unfold member; intro H. rewrite union_mult. lia. Qed.

  Lemma member_union_r a M N : a € N -> a € (M ++ N).
  Proof. unfold member; intro H. rewrite union_mult. lia. Qed.

  Lemma mult_insert : forall M a, (a # (M ++ [a])) > 0.
  Proof.
    intros M a.
    replace (a # (M ++ [a])) with ((a # M) + (a # [a]))%nat.
    replace (a # [a]) with 1%nat.
    lia.
    symmetry; auto.
    auto.
  Qed.

  Lemma singleton_member a : a € [a].
  Proof.
    unfold member. assert (a # [a] = 1%nat); [idtac | lia].
    apply singleton_mult_in; auto with sets.
  Qed.

  Lemma member_insert_app a M : a € ([a] ++ M).
  Proof. apply member_union_l. apply singleton_member. Qed.
  Lemma member_insert_cons a M : a € (a :: M).
  Proof. change (a :: M) with ([a] ++ M). apply member_union_l. apply singleton_member. Qed.

  Lemma member_insert a M : a € ([a] ++ M).
  Proof. apply member_union_l. apply singleton_member. Qed.

  Lemma member_diff_member a M N : a € (M / N) -> a € M.
  Proof. unfold member. rewrite (diff_mult M N). lia. Qed.

  Lemma diff_member_ly_rn a M N : a € M -> ~a € N -> a € (M / N).
  Proof. unfold member; intros H H0. rewrite diff_mult. lia. Qed.

  Lemma diff_remove_both a M N :
    a € M -> a € N -> M / N =mul= (rem a M) / (rem a N).
  Proof.
    unfold member; intros H H0.
    apply multeq_meq; intro x.
    rewrite !diff_mult.
    destruct (eqA_dec x a); subst.
    rewrite !mult_remove_in; auto.
    rewrite !Nat.sub_1_r.
    rewrite <- (Nat.sub_succ (Nat.pred (a # M)) _).
    rewrite !Nat.succ_pred_pos; auto.
    rewrite !mult_remove_not_in; auto.
  Qed.

  Lemma member_union a M N : a € (M ++ N) -> a € M \/ a € N.
  Proof. unfold member. rewrite (union_mult _ M N). lia. Qed.

  Lemma member_meq_union a M N M' N' :
    M ++ N =mul= M' ++ N' -> (a € M \/ a € N) -> ~a € N' -> a € M'.
  Proof.
    unfold member; intros.
    assert (((a#M)+ (a#N))%nat
            = ((a#M') + (a#N'))%nat).
    rewrite <- !union_mult.
    apply meq_multeq; trivial.
    lia.
  Qed.

  Lemma meq_union_meq M N P : M ++ P =mul= N ++ P -> M =mul= N.
  Proof.
    intros; try_solve_meq.
    assert (((x#M) + (x#P))%nat
            = ((x#N) + (x#P))%nat).
    rewrite <- !union_mult.
    apply meq_multeq; trivial.
    lia.
  Qed.

  Lemma meq_union_meq2 M N P : P ++ M =mul= P ++ N -> M =mul= N.
  Proof.
    intros; try_solve_meq.
    assert (((x#P) + (x#M))%nat
            = ((x#P) + (x#N))%nat).
    rewrite <- !union_mult.
    apply meq_multeq; trivial.
    lia.
  Qed.

  #[export] Hint Resolve meq_union_meq meq_union_meq2 : core .

  Lemma meq_meq_union M N P : M =mul= N -> M ++ P =mul= N ++ P.
  Proof. solve_meq. Qed.
  #[export] Hint Resolve meq_meq_union : core .
  Lemma meq_ins_ins_eq a a' M M' :
    M ++ [a] =mul= M' ++ [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 member_ins_ins_meq a a' M M' :
    M ++ [a] =mul= M' ++ [a'] -> a' <> a -> a € M'.

  Proof.
    unfold member; intros.
    assert (((a#M) + 1)%nat = ((a#M') + 0)%nat).
    erewrite <- singleton_mult_in with (x:=a) (y:=a); auto.
    erewrite  <- (singleton_mult_notin _ _ H0).
    rewrite <- !union_mult.
    apply meq_multeq; trivial.
    lia.
  Qed.

  Lemma meq_ins_rem a M : a € M -> M =mul= (rem a M) ++ [a].

  Proof.
    unfold member; intros.
    apply multeq_meq; intro.
    rewrite union_mult.
    (*       rewrite diff_mult. *)
    case (eqA_dec a x); intro x_a.
    (* x =A= a *)
    rewrite singleton_mult_in; trivial.
    assert (x#M = a#M).
    apply mult_eqA_compat; auto.
    rewrite mult_remove_in; auto.
    lia.
    (* ~ x =A= a *)
    rewrite !singleton_mult_notin; auto.
    rewrite mult_remove_not_in; auto.
  Qed.

  Lemma meq_remove_insert a M : rem a (M ++ [a]) =mul= M.
  Proof.
    induction M.
    * simpl;destruct (eqA_dec a a); auto.
    * simpl.
      destruct (eqA_dec a a0); subst; auto.

      rewrite IHM; auto.
  Qed.

  Lemma meq_remove a M N : a :: M =mul= N -> M =mul= rem a N.
  Proof. intros. rewrite <- H. rewrite rem_aM. auto. Qed.

  Lemma insert_meq M N a : a :: M =mul= a :: N -> M =mul= N.
  Proof.
    intros.
    eapply meq_union_meq with (P:=[a]).
    rewrite union_comm, (union_comm N _).
    auto.
  Qed.
  #[export] Hint Resolve insert_meq : core .
  Lemma insert_remove_eq a b M : a = b -> M =mul= rem a (b :: M).

  Proof.
    intros.
    apply multeq_meq.
    intro x.
    rewrite rem_to_diff.
    rewrite diff_mult.
    destruct (eqA_dec a x).
    rewrite union_mult2.
    rewrite !singleton_mult_in; subst; auto.
    lia.
    rewrite union_mult2.
    rewrite !singleton_mult_notin; subst; auto.
    lia.
  Qed.

  Lemma meq_insert_remove a M : a € M -> a :: (rem a M) =mul= M.

  Proof.
    intros.
    apply multeq_meq; intro x.
    rewrite rem_to_diff.
    rewrite union_mult2.
    rewrite diff_mult.
    destruct (eqA_dec x a).
    rewrite singleton_mult_in; auto.
    rewrite (mult_eqA_compat _ _ M e).
    unfold member in H.
    lia.
    rewrite singleton_mult_notin; auto.
    lia.
  Qed.

  Lemma insert_remove_noteq a a' M :
    a <> a' -> rem a (a' :: M) =mul= a' :: (rem a M).
  Proof.
    intros.
    apply multeq_meq.
    intro x.
    rewrite !rem_to_diff.
    change (a' :: M / [a]) with ([a'] ++ M / [a]).
    rewrite diff_mult.
    rewrite union_mult2.
    rewrite union_mult.
    rewrite diff_mult.
    destruct (eqA_dec a' x).
    rewrite singleton_mult_in; auto.
    rewrite e in H.
    rewrite singleton_mult_notin; auto.
    lia.
    rewrite (@singleton_mult_notin x a'); trivial.
  Qed.

  Lemma meq_cons a M N :
    M ++ [a] =mul= N -> exists N', N =mul= N' ++ [a] /\ M =mul= N'.
  Proof.
    intros.
    exists (rem a N); split.
    assert (aN: a € N).
    rewrite <- H.
    rewrite (union_comm M [a]).
    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.
    symmetry.
    apply meq_remove_insert.
  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 € M}+{~a € M}.

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

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

    Proof.
      induction M; intros.
      left; solve_meq.
      right; intro emp.
      absurd (a # (a :: M) = a # []); auto.
      rewrite empty_mult; rewrite union_mult2.
      set (w := singleton_member a); unfold member in w.
      lia.
    Qed.

    Lemma empty_decomp_dec : forall M,
        {Ma: (Multiset * A) | M =mul= fst Ma ++ [snd Ma]} + {M =mul= empty}.
    Proof.
      intros.
      induction M.
      right; auto.
      left. exists (M, a).
      simpl. rewrite union_comm; auto.
    Qed.

  End Decidability.

  Lemma diff_MM_empty M : M / M =mul= [].
  Proof. solve_meq. Qed.

  Lemma ins_meq_union M N P a :
    M ++ [a] =mul= N ++ P -> a € N -> M =mul= (N / [a]) ++ P.
  Proof.
    mset_unfold; intros.
    apply multeq_meq; intro x.
    assert (((x # M) + (x # [a]))
            = (( x # N) + (x # P))).
    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 union_mult.
    rewrite diff_mult.
    rewrite singleton_mult_in; auto.
    assert (((x#M) + 1)%nat = ((x#N) + (x#P))%nat).
    rewrite <- (singleton_mult_in _ _ (symmetry x_a)); trivial.
    lia.
    (* ~ x =A= a *)
    rewrite union_mult.
    rewrite diff_mult.
    assert ( a <> x) by auto.
    rewrite (singleton_mult_notin _ _ H2).
    assert (((x#M) + 0)%nat = ((x#N) + (x#P))%nat).
    rewrite <- (singleton_mult_notin _ _ H2); trivial.
    lia.
  Qed.

  Lemma mem_memrem M a b : a <> b -> a € M -> a € (M / [b]).
  Proof.
    unfold member; intros.
    rewrite diff_mult.
    rewrite singleton_mult_notin, Nat.sub_0_r;
      auto.
  Qed.

  Lemma member_notempty M x : x € M -> ~ M =mul= [].
  Proof.
    unfold not; intros.
    absurd (x # M = 0%nat).
    unfold member in H; lia.
    erewrite meq_multeq with (N:=[]); auto.
  Qed.

  Lemma singleton_notempty x : ~ [x] =mul= [].
  Proof. intro. apply emp_mult in H. inversion H. Qed.

  Lemma union_isempty M N : M ++ N =mul= [] -> M =mul= [].
  Proof.
    intros.
    eapply emp_mult in H.
    apply app_eq_nil in H.
    destruct H; subst; auto.
  Qed.

  Lemma union_notempty M N : ~ M =mul= [] -> ~ M ++ N =mul= [].
  Proof.
    compute in *; intros; apply H. apply union_isempty with N; trivial.
  Qed.

  Lemma remove_union a L R :
    a € L -> rem a (L ++ R) =mul= (rem a L) ++ R.
  Proof.
    intros.
    apply multeq_meq; intros.
    rewrite !rem_to_diff.
    repeat (rewrite diff_mult || rewrite union_mult).
    destruct (eqA_dec a x).
    rewrite singleton_mult_in; trivial.
    erewrite mult_eqA_compat with (y:=a); auto.
    unfold member in H; lia.
    rewrite singleton_mult_notin; trivial.
    lia.
  Qed.

  Lemma meq_remove_elem_right a M L R :
    M ++ [a] =mul= L ++ R -> a € R -> M =mul= L ++ (rem a R).
  Proof.
    intros. rewrite union_comm, <- remove_union, union_comm, <- H; auto.
    symmetry.
    apply meq_remove_insert.
  Qed.

  #[export] Hint Immediate member_singleton
       (* member_member_union *)
       member_diff_member
       member_union
       member_meq_union
       union_comm
       union_assoc : core  .

  #[export] 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 : core .

  Section Multiset.

    Lemma multiset_meq_non_empty : forall M,
      ~ M =mul= [] -> M <> nil.
    Proof.
      intros.
      destruct M; auto.
      intro.
      inversion H0.
    Qed.

    Lemma multiset_meq_empty : forall M,
        M =mul= [] ->  M = [].
    Proof.
      apply emp_mult.
    Qed.

    Lemma member_list_multiset : forall l,
        forall x, In x l -> member x 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.
      change (a :: l) with ([a] ++ l).
      rewrite union_mult.
      assert ((x # l) > 0).
      apply (IHl x); trivial.
      lia.
    Qed.

    Lemma member_multiset : forall l,
        forall x, member x l -> exists y, In y l /\ x = y.
    Proof.
      induction l.
      (* base step *)
      simpl; intros x x_in_empty.
      absurd (~ empty =mul= empty); eauto.
      change (a::l) with ([a] ++ l).
      (* induction step *)
      intros x x_in_al.
      case (member_union _ _ _ x_in_al).
      intro x_a; exists a; simpl; auto.
      intro x_l; destruct (IHl x x_l).
      destruct H.
      exists x0; simpl; auto with sets.
    Qed.

  End Multiset.

  Add Parametric Relation : Multiset meq
      reflexivity proved by meq_refl
      symmetry proved by meq_sym
      transitivity proved by meq_trans as eq_ms.

  (** Compatibility of Multiset and Permutation *)
  (* Lemma meq_nil : [] =mul= [].
Proof. solve_meq. Qed.
   *)
  Lemma eq_step : forall a x,
      a = x -> x # [a] = 1%nat.
  Proof. intros. simpl. case (eqA_dec a x); [trivial | contradiction]. Qed.

  Lemma not_eq_zero : forall a x,
      a <> x -> x # [a] = 0%nat.
  Proof. intros. simpl. case (eqA_dec a x); [contradiction | trivial]. Qed.

  Lemma union_mult_step_eq : forall M N a x,
      a = x -> x # ( [a] ++ (M ++ N)) = x # (M ++ N) + 1.
  Proof.
    intros M N a x x_a.
    rewrite union_mult.
    rewrite eq_step; auto. lia.
  Qed.

  Lemma eq_then_meq: forall M N,
      M = N -> M =mul= N.
  Proof. intros; destruct M; subst; apply multeq_meq; auto. Qed.

  Lemma union_left : forall M N1 N2, N1 =mul= N2 -> (N1 ++ M) =mul= (N2 ++ M).
  Proof. auto. Qed.

  Lemma union_right : forall M N1 N2, N1 =mul= N2 -> (M ++ N1) =mul= (M ++ N2).
  Proof. solve_meq. Qed.

  #[export] Hint Resolve union_left union_right : core .

  Lemma union_rotate x y z : x ++ (y ++ z) =mul= z ++ (x ++ y).
  Proof. solve_meq. Qed.

  Lemma union_reverse x y z : x ++ (y ++ z) =mul= z ++ (y ++ x).
  Proof. solve_meq. Qed.

  Lemma meq_congr x y z t : x =mul= y -> z =mul= t -> x ++ z =mul= y ++ t.
  Proof. solve_meq. Qed.

  Lemma union_perm_left x y z : x ++ (y ++ z) =mul= y ++ (x ++ z).
  Proof. solve_meq. Qed.

  Lemma union_perm_left' x a z : x ++ (a :: z) =mul= a :: (x ++ z).
  Proof. change ( x ++ (a :: z) =mul= a :: (x ++ z)) with
         (x ++ ([a] ++ z) =mul= [a] ++ (x ++ z)).
         apply union_perm_left. Qed.

  Lemma union_perm_left'' x a z : (a :: x) ++ z  =mul= a :: (x ++ z).
  Proof. auto. Qed.

  #[export] Hint Resolve union_rotate union_reverse meq_congr union_perm_left union_perm_left' union_perm_left'' : core .

  Lemma multiset_twist1 x y z t : x ++ ((y ++ z) ++ t) =mul= (y ++ (x ++ t)) ++ z.
  Proof. solve_meq. Qed.

  Lemma multiset_twist2 x y z t : x ++ ((y ++ z) ++ t) =mul= (y ++ (x ++ z)) ++ t.
  Proof. solve_meq. Qed.

  #[export] Hint Resolve multiset_twist1 multiset_twist2 : core .

  Lemma treesort_twist1 x y z t u :
    u =mul= (y ++ z) ->
    x ++ (u ++ t) =mul= (y ++ (x ++ t)) ++ z.
  Proof.
    intros.
    apply multeq_meq; intros.
    apply meq_multeq with (x:=x0) in H.
    rewrite !union_mult.
    rewrite !union_mult in H.
    lia.
  Qed.

  Lemma treesort_twist2 x y z t u :
    u =mul= (y ++ z) ->
    x ++ (u ++ t) =mul= (y ++ (x ++ z)) ++ t.
  Proof.
    intros.
    apply multeq_meq; intros.
    apply meq_multeq with (x:=x0) in H.
    rewrite !union_mult.
    rewrite !union_mult in H.
    lia.
  Qed.

  #[export] Hint Resolve treesort_twist1 treesort_twist2 : core .

  Lemma my_p x y z t : ((x ++ y) ++ z) ++ t =mul= t ++ (z ++ (x ++ y)).
  Proof. solve_meq. Qed.

  #[export] Hint Resolve my_p : core .

  Lemma meq_skip : forall a M1 M2, M1 =mul= M2 -> a :: M1 =mul= a :: M2.
  Proof. intros. change (a :: M1 =mul= a :: M2) with ([a] ++ M1 =mul= [a] ++ M2).
         apply union_right; auto.
  Qed.

  Lemma meq_swap : forall a b M1 M2, M1 =mul= M2 -> (a::b:: M1) =mul= (b::a:: M2).
  Proof.
    intros.
    change (a::b:: M1 =mul= b::a:: M2) with ([a]++ [b] ++ M1 =mul= [b]++ [a] ++ M2).
    apply multeq_meq; intros.
    apply meq_multeq with (x:=x) in H.
    rewrite !union_mult.
    lia.
  Qed.

  Lemma meq_swap_cons a b M : (a :: b:: M) =mul= (b :: a :: M).
  Proof.
    change ((a :: b:: M)) with (([a] ++ [b] ++ M)).
    rewrite meq_swap; simpl; auto.
  Qed.

  Lemma union_rotate_cons a b c M : (a :: b :: c :: M) =mul= (c :: a :: b :: M).
  Proof. change ((a :: b :: c :: M) =mul= (c :: a :: b :: M)) with
         (([a] ++ [b] ++ [c] ++ M) =mul= ([c] ++ [a] ++ [b] ++ M)).
         solve_meq. Qed.
  #[export] Hint Resolve meq_skip meq_swap meq_swap_cons union_rotate_cons : core .

  Lemma pair_app (F G: A) : [F; G] = [F]++[G].
  Proof. auto. Qed.
  (*
  Ltac app_normalize := repeat (
                            rewrite <- app_assoc ||
                            rewrite <- app_comm_cons ||
                            rewrite app_nil_l); auto. *)
  Ltac app_normalize_aux :=
    try rewrite !pair_app;
    repeat
      match goal with
      | |- _ =mul= ?a::?M => change (a :: M) with
                             ([a] ++ M)
      | |- ?a::?M =mul= _ => change (a :: M) with
                             ([a] ++ M)
      | |- _ =mul= _++?a::?M++?N => change (a::M++N) with
                                    ([a]++M++N)
      | |- _++?a::?M++?N =mul= _ => change (a::M++N) with
                                    ([a]++M++N)
      end.

  Lemma union_assoc_cons
    : forall a (M N P : list A), a :: M ++ N ++ P =mul= (a :: M ++ N) ++ P.
  Proof.
    intros. rewrite app_assoc.
    auto.
  Qed.
  #[export] Hint Resolve union_assoc_cons : core .

  Ltac app_normalize := repeat (
                            rewrite <- !union_assoc_cons ||
                            rewrite <- !app_assoc ||
                            rewrite app_nil_l); auto.

  Lemma perm_cons_single a b: a::[b] =mul= b::[a].
  Proof.
    change (a :: [b] =mul= b :: [a]) with
    ([a] ++ [b] =mul= [b] ++ [a]). auto. Qed.

  Lemma perm_cons a b L: a::b::L =mul= b::a::L.
  Proof.
    change (a :: b :: L =mul= b :: a :: L) with
    ([a] ++ [b] ++ L =mul= [b] ++ [a] ++ L). auto. Qed.

  #[export] Hint Resolve perm_cons_single perm_cons : core .

  Lemma union_middle : forall M N1 N2 : list A, N1 =mul= N2 -> N1 ++ M =mul= M ++ N2.
  Proof.
    intros.
    rewrite union_comm.
    auto.
  Qed.

  Ltac perm_simplify := app_normalize; repeat (
                                           rewrite app_nil_r || auto ||
                                           match goal with
                                           | [ |- ?L1 =mul= ?L1 ] => reflexivity
                                           | [ |- (?A1++_) =mul= (?A1++_) ] => apply union_right
                                           | [ |- (_++?A1) =mul= (?A1++_) ] => apply union_middle
                                           | [ |- (_++?A1) =mul= (_++?A1) ] => apply union_left
                                           | [ |- (?A1::_) =mul= (?A1::_) ] => apply meq_skip
                                           | [ |- _  =mul= (?L1++_) ] => (
                                               rewrite (union_perm_left L1) at 1 ||
                                               rewrite <- (union_perm_left' L1) at 1 ||
                                               rewrite (union_comm L1) at 1 ||
                                               rewrite (meq_cons_app L1) at 1 )
                                           | [ |- _  =mul= (?A1::_) ] => rewrite !(perm_cons _ A1)
                                           | [ |- _ =mul= _ ] => fail
                                           end).

  Ltac solv_P :=
    try rewrite !union_perm_left'; auto;
    repeat
      match goal with
      | |- _ =mul= ?a::?M => change (a :: M) with
                             ([a] ++ M); try rewrite !union_perm_left'
      | |- ?a::?M =mul= _ => change (a :: M) with
                             ([a] ++ M) ; try rewrite !union_perm_left'
      end.

  Ltac solver_permute :=
    match goal with
    | [ |- _ =mul= _ ] => perm_simplify; fail "perm failed"
    | [ |- _ ] => fail "perm can't solve this system."
    end.

  Ltac solve_permutation :=
    solve [auto |
           simpl; rewrite !union_perm_left'; timeout 3 perm_simplify |
           solv_P; unfold meq; intro; rewrite !union_mult; lia | timeout 3 solver_permute ].

  Lemma In_union_or : forall x N M, (x € (N ++ M)) <->  x € M \/ x € N.
  Proof.
    split; intros;
      unfold member in *; unfold mult in *. apply countIn_In in H.
    apply in_app_or in H. destruct H;[right;apply countIn_In | left;apply countIn_In]; auto.
    apply countIn_In.
    rewrite <- countIn_In in H. apply or_comm in H. rewrite <- countIn_In in H.
    apply in_or_app; auto.
  Qed.

  Lemma In_union_or' : forall x M, x € M -> forall N, x € (N ++ M).
  Proof.
    intros.
    apply In_union_or.
    left; auto.
  Qed.
  Lemma In_to_in : forall x M, In x M <-> x € M.
  Proof.
    split;intros;
      destruct M;
      unfold member in *;
      unfold mult in *;
      apply countIn_In; auto.
  Qed.

  Lemma meq_In_In: forall L1 L2, L1 =mul= L2 -> (forall x, x € L1 <-> x € L2).
  Proof.
    unfold meq in *.
    unfold member in *.
    split;
      intros P.
    rewrite <- H; auto.
    rewrite H; auto.
  Qed.

  Lemma meq_cons_In :
    forall l1 l2 e, ([e] ++ l1) =mul= l2 -> e € l2.
  Proof.
    intros.
    eapply meq_In_In with (L2:=[e] ++ l1).
    rewrite <- H; eauto.
    apply In_union_or.
    right.
    apply In_to_in.
    firstorder.
  Qed.
  Lemma meq_cons_append : forall l x,
      (x :: l) =mul= (l ++ x :: nil).
  Proof.
    intros.
    change (x::l) with ([x]++l).
    auto.
  Qed.

  (** Properties about diff *)

  Lemma nil_rem: forall M, [] / M = [].
  Proof. induction M; intros; auto. Qed.

  Lemma rem_nil: forall M, M / [] = M.
  Proof. auto. Qed.

  Lemma remove_in_not : forall x a M, x <> a -> x € M -> x € (rem a M).
  Proof.
    unfold member; intros.
    apply mult_remove_not_in with (M:=M) in H.
    rewrite H; auto.
  Qed.

  Lemma permut_remove_hd :
    forall l l1 l2 a,
      [a] ++ l =mul= l1 ++ ([a] ++ l2) -> l =mul= l1 ++ l2.
  Proof.
    intros.
    symmetry in H.
    apply rem_to_union in H.
    rewrite rem_to_diff in H.
    rewrite H.
    apply multeq_meq. intro x.
    rewrite diff_mult.
    rewrite !union_mult.
    lia.
  Qed.

  Lemma rem_skip : forall a M1 M2, M1 =mul= M2 -> (rem a M1) =mul= (rem a M2).
  Proof.
    intros.
    rewrite H; auto.
  Qed.

  Lemma rem_perm_not : forall M a x,
      x <> a -> rem a ([x] ++ M) =mul= [x] ++ (rem a M).
  Proof.
    simpl; intros.
    case (eqA_dec a x); auto; intros.
    symmetry in e.
    contradiction.
  Qed.

  Lemma principal : forall L M M0 a b,
      a <> b -> L =mul= [a] ++ M -> L =mul= [b] ++ M0 ->
      M0 =mul= [a] ++ (rem a M0) /\ M =mul= [b] ++ (rem b M) .
  Proof.
    intros L M M0 a b Eq I1 I2.
    split.
    rewrite I1 in I2.
    apply rem_to_union in I2.
    rewrite rem_perm_not in I2; auto.
    rewrite I2.
    simpl.
    case (eqA_dec a a); intros; auto.
    contradiction.
    rewrite I2 in I1.
    apply rem_to_union in I1.
    rewrite rem_perm_not in I1; auto.
    rewrite I1.
    simpl.
    case (eqA_dec b b); intros; auto.
    contradiction.
  Qed.

  Lemma seconda : forall L M M0 N a b,
      a <> b -> L =mul= [a] ++ M -> L =mul= [b] ++ (M0 ++ N) ->
      exists L', M0 ++ N =mul= [a] ++ L'.
  Proof.
    intros L M M0 N a b Eq I1 I2.
    exists (rem b M).
    rewrite I1 in I2.
    apply rem_to_union in I2.
    rewrite I2.
    apply rem_perm_not; auto.
  Qed.

  Lemma seconda_sec : forall L M M0 a b,
      a <> b -> L =mul= [a] ++ M -> L =mul= [b] ++ M0 ->
      exists L1 L2, M0 =mul= [a] ++ L1 /\  M =mul= [b] ++ L2.
  Proof.
    intros L M M0 a b NEq I1 I2.
    exists ((rem a M0)).
    exists ((rem b M)).
    refine (principal _ _ _ _ _ NEq I1 I2).
  Qed.

  Lemma meq_swap' : forall L a M N,
      L =mul= [a] ++ M ->
      L =mul= [a] ++ N ->
      M =mul= N.
  Proof.
    intros.
    rewrite H0 in H.
    apply rem_to_union in H.
    rewrite H.
    simpl.
    case (eqA_dec a a); intros; auto.
    contradiction.
  Qed.

  Lemma meq_eq_s : forall L A B M N,
      L =mul= A ++ M ->
      L =mul= B ++ N ->
      A =mul= B ->
      M =mul= N.
  Proof.
    intros L A B M N P1 P2 P3.
    rewrite P3 in P1.
    rewrite P2 in P1.
    revert L A M N P1 P2 P3.
    induction B; intros; auto.

    eapply IHB with (L:= B ++ N); auto.
    change (a :: B) with ([a] ++ B) in *.

    apply rem_to_union in P1.
    rewrite P1.
    simpl.
    case (eqA_dec a a); intros; auto.
    contradiction.
  Qed.

  Lemma mem_step : forall a x,
      a = x -> x € [a].
  Proof. intros. compute. case (eqA_dec a x); [trivial | contradiction]. Qed.
  Lemma mem_step_not : forall a x,
      a <> x -> ~ x € [a].
  Proof. intros. compute. case (eqA_dec a x); [contradiction | trivial].

         intros. inversion H0. Qed.

  #[export] Hint Resolve member_insert_cons : core .

  Lemma member_then_eq : forall a L,
      a € L -> exists P1 P2, L = P1 ++ [a] ++ P2.
  Proof.
    intros.
    apply in_split.
    apply In_to_in; auto.
  Qed.

  Lemma member_then_meq : forall a L,
      a € L -> exists P, L =mul= a :: P.
  Proof.
    intros.
    assert (exists P1 P2, L = P1 ++ [a] ++ P2).
    apply member_then_eq; auto.
    do 2 destruct H0.
    exists (x++x0).
    rewrite H0.
    solve_permutation.
  Qed.

  Lemma seconda_pri : forall L M M0 N a b,
      a <> b -> L =mul= a :: M -> L =mul= b :: (M0 ++ N) ->
      exists L1 L2, M0 =mul= a :: L1 \/ N =mul= a :: L2 .
  Proof.
    intros L M M0 N a b Eq I1 I2.
    rewrite meq_cons_app in I1, I2.
    assert (exists L1 L2, M0 ++ N =mul= [a] ++ L1 /\ M =mul= [b] ++ L2 ).
    refine (seconda_sec _ _ _ _ _ Eq I1 I2 ).
    repeat destruct H.
    rewrite H in I2.
    rewrite H0 in I1.
    rewrite union_perm_left in I2.
    assert (x0 =mul= x).
    rewrite union_assoc in I1, I2.
    eapply meq_eq_s.
    exact I1.
    exact I2.
    auto.

    assert (a € (M0 ++ N)).
    rewrite H. apply In_union_or.
    right. apply In_to_in.  firstorder.
    apply In_union_or in H2.
    destruct H2;
      apply member_then_meq in H2;
      destruct H2.
    exists x1, x1.
    right; auto.
    exists x1, x1.
    left; auto.
  Qed.

  Lemma solsls : forall M N X a,
      M ++ N =mul= a :: X ->
      (exists L1, M =mul= a :: L1 ) \/ (exists L2, N =mul= a :: L2).
  Proof.
    intros.
    assert (a € (M ++ N)).
    rewrite H. apply member_insert_cons.
    apply In_union_or in H0.
    destruct H0.
    apply member_then_meq in H0.
    destruct H0. right.
    exists x; auto.
    apply member_then_meq in H0.
    destruct H0. left.
    exists x; auto.
  Qed.
  Arguments solsls [M N X a].
  #[export] Hint Resolve solsls : core .
  Lemma solsls2 : forall M N X Y a,
      M ++ N =mul= a :: Y ->
      M =mul= a :: X -> Y =mul= N ++ X.
  Proof.
    intros M N X Y a P1 P2.
    symmetry in P1.
    rewrite P2 in P1.

    apply rem_to_union_app in P1.
    rewrite union_comm, P1.
    symmetry. apply rem_aM_cons.
  Qed.

  Arguments solsls2 [M N X Y a].
  #[export] Hint Resolve solsls2 : core .
  Lemma member_unit : forall a b,
      b = a <-> a € [b].
  Proof.
    split; intros.
    unfold member.
    simpl.
    destruct (eqA_dec b a); auto.
    contradiction.
    apply In_to_in in H.
    firstorder.
  Qed.

  Lemma member_due : forall a b L,
      b <> a -> a € ([b] ++ L) -> a € L.
  Proof.
    intros a b L notExp H.
    apply In_union_or in H.
    destruct H as [a_L | a_b]; auto.
    apply member_unit in a_b.
    contradiction.
  Qed.

  Lemma se_i3 : forall A B,
      A = B <-> [A] =mul= [B].
  Proof.
    split; intros.
    -
      rewrite H; auto.
    -
      eapply  meq_cons_In in H.
      unfold member in H.
      apply countIn_In in H.
      inversion H.
      rewrite H0; auto.
      inversion H0.
  Qed.

  Lemma se_i2 : forall A B L M,
      B = A -> ([A] ++ L =mul= [B] ++ M) -> [A] =mul= [B] /\ L =mul= M.
  Proof.
    intros.
    symmetry in H0.
    apply rem_to_union in H0.
    rewrite rem_abM_app in H0; auto.
    split; auto.
    apply se_i3; auto.
  Qed.

  Lemma se_i : forall A B L1 L2,
      [A] ++ L1 =mul= [A] ++ [B] ->
      [B] ++ L2 =mul= [A] ++ [B] -> L1 ++ L2 =mul= [A] ++ [B].
  Proof.
    intros.
    symmetry in H.
    apply rem_to_union in H.
    symmetry in H0.
    rewrite union_comm in H0.
    apply rem_to_union in H0.
    rewrite rem_abM_app in H, H0; auto.
    rewrite H, H0; auto.
  Qed.

  Lemma aunion_comm : forall M L1 L2, M =mul= (L1 ++ L2) -> M =mul= (L2 ++ L1).
  Proof.
    intros.
    rewrite union_comm; auto.
  Qed.

  Lemma seconda_sec' : forall M M0 a b,
      b <> a -> a :: M =mul= b :: M0 ->
      exists L, M0 =mul= a :: L /\  M =mul= b :: L.
  Proof.
    intros.
    change (a :: M =mul= b :: M0) with
    ([a] ++ M =mul= [b] ++ M0) in H0.
    remember ([a] ++ M).
    remember ([b] ++ M0).
    apply eq_then_meq in Heql.
    apply eq_then_meq in Heql0.
    rewrite H0 in Heql.
    assert(exists L1 L2, M0 =mul= [a] ++ L1 /\  M =mul= [b] ++ L2).
    refine ( seconda_sec _ _ _ _ _ _ Heql Heql0); auto.
    repeat destruct H1.
    assert (x =mul= x0).
    rewrite H1 in Heql0.
    rewrite H2 in Heql.
    rewrite union_assoc in Heql0, Heql.
    eapply meq_eq_s.
    exact Heql0. exact Heql. rewrite union_comm; auto.
    rewrite <- H3 in *.
    exists x; auto.
  Qed.

  Lemma seconda_pri' : forall M M0 N a b,
      a <> b -> a :: M =mul= b :: (M0 ++ N) ->
      exists L1 L2, M0 =mul= a :: L1 \/ N =mul= a :: L2 .
  Proof.
    intros.
    change (a :: M =mul= b :: M0 ++ N) with
    ([a] ++ M =mul= [b] ++ M0 ++ N) in H0.
    remember ([a] ++ M).
    remember ([b] ++ (M0 ++ N)).
    apply eq_then_meq in Heql.
    apply eq_then_meq in Heql0.
    rewrite H0 in Heql.
    eapply seconda_pri; eauto. Qed.

  Lemma not_eq_in : forall x y M, y <> x ->
                                  x € ([y] ++ M) ->  x € M.
  Proof.
    intros.
    apply In_union_or in H0.
    destruct H0; auto.
    apply member_unit in H0.
    contradiction.
  Qed.

  Lemma rem_not_abM a b M : b <> a -> rem a ([b] ++ M) =mul= [b] ++ rem a M.
  Proof.
    intros.
    simpl.
    destruct (eqA_dec a b); auto.
    symmetry in e. contradiction.
  Qed.

  Lemma resolvers2: forall a b M, a :: M =mul= [b] -> b = a /\ M = [].
  Proof.
    intros.
    change (a :: M) with ([a] ++ M) in H.
    split.
    apply meq_cons_In in H;
      apply member_unit; auto.

    assert (M =mul= []).
    destruct (empty_dec M); auto.
    destruct (eqA_dec a b);
      eapply rem_to_union_app in H.
    rewrite rem_abM_app in H; auto.
    rewrite rem_not_abM in H; auto.
    apply meq_multeq with (x:=a) in H.
    rewrite union_mult, singleton_mult_in in H; auto.
    simpl in H.
    inversion H.

    apply emp_mult in H0; auto.
  Qed.

  Lemma resolvers: forall a b c M, a :: M =mul= [b; c] ->
                                   a = b \/ a = c.
  Proof.
    intros.
    assert ([a] ++ M =mul= [b] ++ [c]) by auto.
    symmetry in H.
    apply rem_to_union_app in H.

    (*  simpl in *. *)
    case (eqA_dec a c); intros.
    right; auto.
    case (eqA_dec a b); intros.
    left; auto.

    assert (exists L, [c] =mul= [a] ++ L /\  M =mul= [b] ++ L).

    eapply seconda_sec'; auto.
    repeat destruct H1.

    symmetry in H1.
    apply meq_cons_In in H1.
    apply member_unit in H1.
    right; auto.
  Qed.

  Lemma resolvers3: forall a b, [a] =mul= [b] -> b = a.
  Proof.
    intros.
    apply meq_cons_In in H;
      apply member_unit; auto.
  Qed.

  Lemma MulSingleton : forall F M, [F] =mul= M -> M = [F].
  Proof.
    induction M; intros.
    *
      apply emp_mult in H; auto.
    *
      symmetry in H. apply resolvers2 in H.
      destruct H; subst; auto.
  Qed.

  Lemma DestructMulFalse (l : A) (L : list A) : l :: L =mul= [] -> False.
  Proof.
    intro H.
    assert (l :: L =mul= []) by auto.
    symmetry in H.
    eapply rem_to_union in H. simpl in H.
    rewrite H in H0.
    eapply singleton_notempty; eauto.
  Qed.

  Lemma Permutation_meq :
    forall M N, Permutation M N <-> M =mul= N.
  Proof.
    split; intros H.
    -
      induction H; intros; eauto.
    -
      revert N H.
      induction M; intros.
      symmetry in H.
      rewrite  emp_mult in H; subst; auto.
      assert (a :: M =mul= N) by apply H.
      apply meq_cons_In in H.
      apply In_to_in in H.
      destruct (In_split _ _ H) as (h2,(t2,H1)).
      subst N.
      apply Permutation_cons_app.
      apply IHM.
      eapply permut_remove_hd with a; auto.
  Qed.

  Lemma right_union : forall L M a,
      a :: L =mul= a :: M -> L =mul= M.
  Proof.
    intros.
    eapply rem_to_union in H.
    rewrite rem_aM in H.
    auto.
  Qed.

  Lemma DestructMSet: forall F G (M1 M2 : list A),
      F :: M1 =mul= G :: M2 ->
      (( F = G /\ M1 =mul= M2 )  \/
       exists M2', M2 =mul= F :: M2' /\ M1 =mul= G :: M2').
  Proof.
    intros.
    destruct (eqA_dec F G).
    - left.
      rewrite e in H.
      apply right_union in H; auto.
    - right.
      apply seconda_sec'; auto.
  Qed.

  Lemma DestructMSet': forall F G (M1 M2 : list A),
      F :: M1 =mul= G :: M2 ->
      (F = G \/ In G M1).
  Proof.
    intros.
    destruct (eqA_dec F G).
    - left; auto.
    - right.
      apply In_to_in.
      eapply not_eq_in with (y:=F); auto.
      rewrite H; auto.
  Qed.

  Lemma DestructMSet2_aux a L M: L =mul= [a] ++ M ->
                                 exists T1 T2, L = T1 ++ [a] ++ T2.
  Proof.
    intros.
    induction M.
    - rewrite app_nil_r in H.
      symmetry in H.
      apply MulSingleton in H.
      do 2 eexists [].
      simpl; auto.
    - assert (member a L) as Hm.
      rewrite H.
      apply In_union_or.
      right. apply member_unit; auto.
      apply member_then_eq in Hm.
      auto.
  Qed.

  Lemma DestructMSet2' l L l' L' x:  L =mul= l' :: x -> L' =mul= l :: x ->
                                     (exists L1 L2 L1' L2', L= L1 ++ [l'] ++ L2 /\ L' = L1' ++ [l] ++ L2').
  Proof.
    intros.
    apply DestructMSet2_aux in H.
    apply DestructMSet2_aux in H0.
    do 2 destruct H.
    do 2 destruct H0.
    exists x0, x1, x2, x3.
    auto.
  Qed.

  Lemma DestructMSet2 : forall l L l' L', l :: L =mul= l' :: L' ->
                                          (l = l' /\ L =mul= L') \/
                                          (exists L1 L2 L1' L2', L= L1 ++ [l'] ++ L2 /\ L' = L1' ++ [l] ++ L2' /\ L1 ++ L2 =mul= L1' ++ L2' ) .
  Proof.
    intros.
    destruct (eqA_dec l l'); [left | right].
    * rewrite e in H.
      apply right_union in H; auto.
    *
      eapply seconda_sec' in H; auto.
      do 2 destruct H.
      assert (L' =mul= l :: x) by auto.
      assert (L =mul= l' :: x) by auto.

      apply DestructMSet2_aux in H.
      apply DestructMSet2_aux in H0.
      do 2 destruct H.
      do 2 destruct H0.
      exists x2, x3, x0, x1.
      split; auto.
      split; auto.
      rewrite H0 in H2.
      rewrite H in H1.
      rewrite union_perm_left in H2, H1.
      apply right_union in H1.
      apply right_union in H2.
      rewrite H1, H2; auto.
  Qed.

  Lemma EmptyMS : forall a (M:list A), [] <> M ++ [a].
  Proof.
    intros; intro.
    symmetry in H.
    apply app_eq_nil in H.
    inversion H.
    inversion H1.
  Qed.

  Lemma nil_contradiction : forall (F: A) M, [] = M ++ [F] -> False.
    intros.
    destruct M. rewrite app_nil_l in H. inversion H.
    inversion H.
  Qed.

  Ltac MReplace M1 M2 :=
    let HS := fresh "HS" in
    assert(HS: M1 =mul= M2) by solve_permutation;
    rewrite HS;clear HS.

  Ltac MReplaceIn M1 M2 H :=
    let HS := fresh "HS" in
    assert(HS: M1 =mul= M2) by solve_permutation;
    rewrite HS in H;clear HS.

  (* Some Useful simplfications *)
  Ltac contradiction_multiset :=
    repeat
      match goal with
      | [H : [] = _ ++ [_] |- _] => apply nil_contradiction in H;contradiction
      | [ H : [?l] ++ ?L =mul= [] |- _ ] =>
        apply DestructMulFalse in H; contradiction
      | [ H : ?L ++ [?l] =mul= [] |- _ ] =>
        rewrite union_comm in H
      | [ H : [] =mul= [?l] ++ ?L |- _ ] =>
        symmetry in H
      | [ H : [] =mul= ?L ++ [?l] |- _ ] =>
        symmetry in H
      | [H : [] =mul= ?a :: ?L |- _ ] =>
        rewrite meq_cons_app in H
      end.

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

  #[export] Hint Resolve member_insert_cons : core .

  Lemma notInMul a F L M :
    ~ In a L  ->
    F :: L =mul= M ++ [a] -> F = a /\ L =mul= M.
  Proof.
    intros Hin Hm.
    rewrite union_comm in Hm.
    simpl in Hm.
    apply DestructMSet in Hm.
    destruct Hm; auto.
    do 2 destruct H.
    assert (False).
    apply Hin.
    apply In_to_in.
    rewrite H0; auto.
    inversion H1.
  Qed.

  Lemma lenghtList n (A: Type) (L:list A) :
    length L = S n -> exists x L1, L = x :: L1.
  Proof.
    intro Hl.
    destruct L.
    inversion Hl.
    eexists a, L. auto.
  Qed.

  Lemma multFalse a L M:
    L =mul= a :: M -> In a L.
  Proof.
    intro. apply In_to_in. rewrite H.
    auto.
  Qed.

  Ltac multisetContr :=
    repeat
      match goal with
      | [ H : In ?a ?L |- _ ] =>
        let Hf := fresh "Hf" in
        let Hn := fresh "Hn" in (inversion H as [Hf | Hn]);clear H
      | [ H : ?L =mul= ?a :: ?M |- _ ] =>
        apply multFalse in H; multisetContr
      end.

  Lemma axPair: forall F M A B,
      F :: M =mul= [A ; B] -> (F = A /\ M = [B]) \/ (F = B /\ M = [A]).
  Proof.
    intros.
    assert (F :: M =mul= [A0 ; B]) by auto.
    apply resolvers in H.
    destruct H; [left|right]; split; auto; subst; apply Permutation_length_1_inv.
    apply insert_meq in H0.
    apply Permutation_meq in H0.
    symmetry; auto.
    rewrite union_comm_cons in H0.
    change ([A0; B]) with ([A0] ++ [B]) in H0.
    apply meq_union_meq in H0.
    apply Permutation_meq in H0.
    symmetry; auto.
  Qed.
End MultisetList.


Require Import FinitaryContainer.
Require Import Coq.Program.Basics.

Variable C : Cont.
Variable Nodes : Set.
Variable eq_dec : forall x y : Nodes, { x = y } + { ~ x=y }.

Definition Edges : Type := Nodes -> Ext C Nodes.

Definition has_edge (E : Edges) n1 n2 : Prop
  := cexists (fun n => n = n2) (E n1).

Inductive reachable (E: Edges) : Nodes -> Nodes -> Prop :=
  | r_single n1 n2 : has_edge E n2 n1 ->  reachable E n1 n2
  | r_step n1 n2 n3 : has_edge E n2 n1 ->  reachable E n2 n3 -> reachable E n1 n3.

Hint Constructors reachable.

Lemma reachable_edge E n p : reachable E (elems (E n) p) n.
Proof.
  apply r_single. unfold has_edge, cexists, vexists. exists p. reflexivity.
Qed.

Hint Resolve reachable_edge.

Lemma reachable_all E n : cforall (fun m : Nodes => reachable E m n) (E n).
Proof.
  unfold cforall, vforall. auto.
Qed.

Hint Resolve reachable_all.

Record Graph : Type := graph {root : Nodes;
                             eqs : Nodes -> Ext C Nodes;
                             acy : well_founded (reachable eqs)}.

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

Lemma Node_ind_fun (P : Nodes -> Prop)
    (eqs : Nodes -> Ext C Nodes)
    (acy : well_founded (reachable eqs))
    (step : forall (root: Nodes), cforall P (eqs root) -> P root) :
  (forall n : Nodes, (forall m : Nodes, reachable eqs m n -> P m) -> P n).
Proof.
  intros. apply step. pose (acy n) as acyn.
  unfold cforall, vforall in *. intros. auto.
Qed.

Definition Node_ind (P : Nodes -> Prop)
         (eqs : Nodes -> Ext C Nodes)
         (acy : well_founded (reachable eqs))
         (step : forall (root: Nodes), cforall P (eqs root) -> P root) :
         forall root, P root := Fix acy P (Node_ind_fun P eqs acy step).

Lemma Graph_ind' (P : Graph -> Prop)
         (step : forall (g : Graph),
                 cforall (fun n => P (graph n (eqs g) (acy g))) ((eqs g) (root g))
                 -> P g)
         g : P g.
Proof.
  destruct g. remember (fun n => P (graph n eqs0 acy0)) as P'.
  assert (P' root0) as G. apply (Node_ind P' eqs0 acy0).
  intros. rewrite HeqP' in *. apply step. apply H.
  rewrite HeqP' in *. auto.
Qed.

(* This type captures algebras over a given signature and a given
carrier type [R]. *)

Definition Alg (R : Type) : Type := Ext C R -> R.

Definition gfold_step {R} (alg : Alg R) (g : Graph) (n : Nodes)
           (rec : forall m : Nodes, reachable (eqs g) m n -> R) : R  :=
  alg (cmap_prop rec (reachable_all (eqs g) n)).

Definition gfold {R} (alg : Alg R) (g : Graph) : R :=
  Fix (acy g) (fun _ => R) (gfold_step alg g) (root g).

Lemma gfold_rec {R} (alg : Alg R) (g : Graph) :
  gfold alg g = alg (cmap (fun n => gfold alg (graph n (eqs g) (acy g))) (eqs g (root g))).
Proof.
  unfold gfold. rewrite Fix_eq. unfold gfold_step at 1. reflexivity.
  intros. unfold gfold_step. f_equal. apply cmap_prop_eq. auto.
Qed.

Definition Map (A : Type) := Nodes -> option A.

Definition empty_map {A} : Map A := fun n => None.

Definition insert {A} (n : Nodes) (a : A) (m : Map A) : Map A :=
  fun x => if eq_dec x n then Some a else m x.

Definition lookup {A} (n : Nodes) (m : Map A) : option A := m n.

Lemma lookup_empty A n : lookup n empty_map = None (A:=A).
Proof.
  unfold lookup, empty_map. reflexivity.
Qed.

Hint Resolve lookup_empty.

Definition le_map {A} (m1 m2 : Map A) : Prop :=
  forall (n : Nodes) (a : A), lookup n m1 = Some a -> lookup n m2 = Some a.

Lemma le_map_refl A (m : Map A) : le_map m m.
Proof.
  unfold le_map. auto.
Qed.

Hint Resolve le_map_refl.

Lemma le_map_trans A (m1 m2 m3 : Map A) : le_map m1 m2 -> le_map m2 m3 -> le_map m1 m3.
Proof.
  unfold le_map. auto.
Qed.

Definition gfold_step' {R} (alg : Alg R) (g : Graph) (n : Nodes)
           (rec : forall m : Nodes, reachable (eqs g) m n -> Map R -> Map R) (m : Map R) : Map R  :=
  match lookup n m with
      | Some r => m
      | None => let maps := cmap_prop rec (reachable_all (eqs g) n)
                in let
                  oldmap := cfold (fun f m' => f m') m maps
                in match cseq (cmap (fun n => lookup n oldmap) (eqs g n)) with
                     | None => oldmap
                     | Some args => insert n (alg args) oldmap
                   end
  end.

Definition gfold_map {R} (alg : Alg R) (g : Graph) : Map R -> Map R :=
  Fix (acy g) (fun _ => Map R -> Map R) (gfold_step' alg g) (root g).

Lemma gfold_map_rec {R} (alg : Alg R) (g : Graph) (m : Map R):
  gfold_map alg g m =
  match lookup (root g) m with
      | Some r => m
      | None => let maps := cmap (fun n => gfold_map alg (graph n (eqs g) (acy g))) (eqs g (root g))
                in let
                  oldmap := cfold (fun f m' => f m') m maps
                in match cseq (cmap (fun n => lookup n oldmap) (eqs g (root g))) with
                     | None => oldmap (* this should never happen *)
                     | Some args => insert (root g) (alg args) oldmap
                   end
  end.
Proof.
  unfold gfold_map. rewrite Fix_eq. unfold gfold_step' at 1. reflexivity.
  intros. unfold gfold_step'.
  assert (cmap_prop f (reachable_all (eqs g) x) = cmap_prop g0 (reachable_all (eqs g) x)) as E.
  apply  cmap_prop_eq. auto. rewrite E. reflexivity.
Qed.

Definition incr {A} (f : Map A -> Map A) : Prop := forall m, le_map m (f m).

Lemma vfold_incr {A n} (v : vector (Map A -> Map A) n) :
  vforall incr v -> incr (fun m => vfold (fun f m' => f m') m v).
Proof.
  unfold incr. intros H. induction v using vector_ind; intros m.
  - erewrite vfold_nil. auto.
  - rewrite vfold_cons. pose H as H'. apply vforall_head in H'.
    apply vforall_tail in H. eapply IHv in H.
    eapply le_map_trans. apply H.  apply H'.
Qed.

Lemma cfold_incr {A C} (maps : Ext C (Map A -> Map A)) :
  cforall incr maps -> incr (fun m => cfold (fun f m' => f m') m maps).
Proof.
  unfold cforall, cfold. apply vfold_incr.
Qed.

Lemma gfold_map_incr {R} (alg : Alg R) (g : Graph) (m : Map R) :
  le_map m (gfold_map alg g m).
Proof.
  unfold le_map. induction g using Graph_ind'. intros.
  rewrite gfold_map_rec. remember (lookup (root g) m) as L.
  destruct L.
  - assumption.
  - simpl. admit.

Qed.

Theorem gfold_map_gfold {R} (alg : Alg R) (g : Graph) :
  lookup (root g) (gfold_map alg g empty_map) = Some (gfold alg g).
Proof.
  induction g using Graph_ind'.
  rewrite gfold_rec. rewrite gfold_map_rec. rewrite lookup_empty.
  simpl.

Inductive Tree : Type :=
| In : Ext C Tree -> Tree.

Fixpoint Tree_ind' (P : Tree -> Prop)
         (step : forall  (args : Ext C Tree),
                   cforall P args -> P (In args))
         g : P g :=
  match g with
    | In args => step args (fun p => Tree_ind' P step (elems args p))
  end.

(* This defines the fold corresponding to the given algebra. *)

Fixpoint fold {R} (alg : Alg R) (g : Tree) : R :=
  match g with
    | In args => alg (cmap (fold alg) args)
  end.

Definition unravel : Graph -> Tree := gfold In.

Theorem fold_unravel (g : Graph) {R} (alg : Alg R) : gfold alg g = fold alg (unravel g).
Proof.
  induction g using Graph_ind'. unfold unravel, fold. repeat rewrite gfold_rec.
  f_equal. cmap_eq.
Qed.

Definition Down (D : Type) : Type := forall (shape : shapes C), D -> pos C shape -> D.

Definition Up (U D : Type) : Type := D -> Ext C U -> U.

Fixpoint fold_env {U D} (up : Up U D) (down : Down D) (g : Tree) : D -> U :=
  fun d =>
  match g with
    | In args => up d (czipWith (fold_env up down) args (down (shape args) d))
  end.

Definition gfold_env_step {U D} (up : Up U D) (down : Down D) (g : Graph) (n : Nodes) (rec : forall m : Nodes, reachable (eqs g) m n -> (D -> U)) : (D -> U)  :=
      alg (cmap_prop rec (acy g n)).

Definition gfold_env {U D} (up : Up U D) (down : Down D) (g : Graph) : D -> U.


From Coq Require Import Arith.Arith.
From Coq Require Import Reals.Reals.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

From LF Require Import Utils.
From LF Require Import LE.
From LF Require Import App.
From LF Require Import Grammar.
From LF Require Import Span.

Open Scope R_scope.

(** The minimal cost of scanning the given terminal *)
Definition cost {vt nt} (g : @Grammar vt nt) (t : term) : weight :=
  min_arc_weight g t + min_tree_weight g t.

(** The minimal cost of scanning the given list of terminals *)
Definition costs {vt nt}
    (g : @Grammar vt nt) (ts : list term) : weight :=
  fold_left Rplus (map (cost g) ts) 0.

Lemma costs_nil :  forall {vt nt}
  (g : @Grammar vt nt),
    costs g [] = 0.
Proof.
  intros vt nt g.
  unfold costs. simpl. reflexivity.
Qed.

Lemma costs_ge_0 :  forall {vt nt}
  (g : @Grammar vt nt) (ts : list term),
    0 <= costs g ts.
Proof.
  intros vt nt g ts.
  unfold costs.
  induction ts as [|x ts' IH].
  - simpl. apply Rle_refl.
  - simpl. rewrite Rplus_0_l.
    rewrite fold_left_plus.
    rewrite <- (Rplus_0_l 0).
    apply Rplus_le_compat.
    + rewrite Rplus_0_l. apply IH.
    + unfold cost. rewrite <- (Rplus_0_l 0).
      apply Rplus_le_compat.
      * apply min_arc_weight_ge_0.
      * apply min_tree_weight_ge_0.
Qed.

Lemma costs_app : forall {vt nt}
    (g : @Grammar vt nt) (ts ts' : list term),
  costs g (ts ++ ts') = costs g ts + costs g ts'.
Proof.
  intros vt nt g ts ts'.
  generalize dependent ts'.
  induction ts as [|tsh tst IH].
  - intros ts'. simpl. rewrite costs_nil.
    rewrite Rplus_0_l. reflexivity.
  - intros ts'. rewrite <- app_comm_cons.
    unfold costs. simpl.
    unfold costs in IH.
    rewrite fold_left_plus. rewrite Rplus_0_l.
    rewrite (fold_left_plus (cost g tsh)).
    rewrite IH. rewrite Rplus_assoc.
    rewrite (Rplus_comm _ (cost _ _)).
    rewrite <- Rplus_assoc. reflexivity.
Qed.

Lemma shift_cost_sup : forall {vt nt}
  (g : @Grammar vt nt) (r r' : vt*nat) (v : vt),
    shift g r' = Some (v, r) ->
      costs g (sup' g r') = costs g (inf g v) + costs g (sup' g r).
Proof.
  intros vt nt g r r' v H.
  destruct (shift g r') as [(v', r'')|] eqn:E.
  - rewrite shift_sup with (r0 := r) (v0 := v).
    + rewrite <- costs_app. apply f_equal. reflexivity.
    + rewrite <- H. apply E.
  - discriminate H.
Qed.

Lemma shift_cost_sup' : forall {vt nt}
  (g : @Grammar vt nt) (r r' : vt*nat) (v : vt),
    shift g r' = Some (v, r) ->
      costs g (sup g v) = costs g (inf' g r') + costs g (sup' g r).
Proof.
  intros vt nt g r r' v H.
  destruct (shift g r') as [(v', r'')|] eqn:E.
  - injection H as H1 H2.
    rewrite H1 in E. rewrite H2 in E.
    apply (shift_sup' g r r' v) in E as E'.
    rewrite E'.
    rewrite costs_app. reflexivity.
  - discriminate H.
Qed.

Lemma cost_one : forall {vt nt} (g : @Grammar vt nt) (i : term),
  costs g [i] = cost g i.
Proof.
  intros vt nt g i.
  unfold costs.
  simpl.
  rewrite Rplus_0_l.
  reflexivity.
Qed.

(* TODO: prove based on cost_rest_plus_in_r *)
Lemma cost_rest_Sj : forall {vt nt} (g : @Grammar vt nt) (i j : term),
  (* j <= term_max g -> *)
  Nat.le j (term_max g) ->
    costs g (rest g i j) = costs g (rest g i (S j)) + cost g j.
Proof.
  intros vt nt g i j H2.
  unfold rest.
  rewrite costs_app.
  rewrite costs_app.
  (* rewrite <- plus_assoc. *)
  rewrite Rplus_assoc.
  apply f_equal2. { reflexivity. }
  (* apply (f_equal2_plus). { reflexivity. } *)
  (* simpl. *)
  rewrite <- in_span_Si.
  - rewrite costs_app. rewrite <- cost_one.
    rewrite Rplus_comm. reflexivity.
  - rewrite plus_comm. simpl.
    apply le_n_S. apply H2.
Qed.

Lemma cost_rest_plus_in_r : forall {vt nt}
  (g : @Grammar vt nt) (i j k : term),
    Nat.le j k ->
    Nat.le k (term_max g + 1) ->
      costs g (rest g i j) = costs g (rest g i k) + costs g (in_span j k).
Proof.
  intros vt nt g i j k H1 H2.
  unfold rest.
  rewrite costs_app. rewrite costs_app.
  rewrite Rplus_assoc.
  apply f_equal2. { reflexivity. }
  rewrite (in_span_split j k).
  - rewrite costs_app. rewrite Rplus_comm. reflexivity.
  - apply H1.
  - apply H2.
Qed.

Lemma cost_rest_plus_in_l : forall {vt nt}
  (g : @Grammar vt nt) (i j k : term),
    Nat.le i j ->
      costs g (rest g j k) = costs g (in_span i j) + costs g (rest g i k).
Proof.
  intros vt nt g i j k H1.
  unfold rest.
  rewrite costs_app.
  rewrite costs_app.
  rewrite <- Rplus_assoc.
  apply (f_equal2).
  Focus 2. reflexivity.
  rewrite Rplus_comm.
  rewrite (in_span_split 0 i j).
  - rewrite costs_app. reflexivity.
  - apply le_0_n.
  - apply H1.
Qed.

Lemma inf_cost_vs_omega : forall {vt nt} (g : @Grammar vt nt) (v w : vt),
  root g v = true ->
    costs g (inf g v) <= omega g v w.
Proof.
  intros vt nt g v w.
  intros RH.
  unfold omega.
  apply inf_root_anchor in RH as H.
  rewrite H.
  unfold costs. simpl. rewrite Rplus_0_l.
  unfold cost.
  apply (Rplus_le_compat).
  - apply min_arc_weight_le.
  - apply min_tree_weight_le. reflexivity.
Qed.

Lemma inf_cost_vs_omega' :
  forall {vt nt} (g : @Grammar vt nt) (r : vt*nat) (w : vt),
    shift g r = None ->
    root g (fst r) = true ->
      costs g (inf' g r) <= omega g (fst r) w.
Proof.
  intros vt nt g r w H.
  apply no_shift_inf in H as H'.
  rewrite H'.
  intros R.
  apply inf_cost_vs_omega.
  apply R.
Qed.

(** Span costs when ignoring the gap *)
Lemma costs_ignore_gap : forall {vt nt} i j k l (g : @Grammar vt nt),
  Nat.le i j ->
  Nat.le j k ->
  Nat.le k l ->
    costs g (in_span i j) + costs g (in_span k l) <= costs g (in_span i l).
Proof.
  intros vt nt i j k l g.
  intros Le_i_j Le_j_k Le_k_l.
  apply (Rle_trans _
    (costs g (in_span i j) + costs g (in_span j k) + costs g (in_span k l))).
  - apply Rplus_le_compat_r.
    rewrite <- (Rplus_0_r (_ _ (in_span i j))).
    rewrite Rplus_assoc.
    apply Rplus_le_compat_l.
    rewrite Rplus_0_l.
    apply costs_ge_0.
  - rewrite <- ?costs_app.
    rewrite <- in_span_split.
    Focus 2. apply Le_i_j.
    Focus 2. apply Le_j_k.
    rewrite <- in_span_split.
    + apply Rle_refl.
    + transitivity j.
      * apply Le_i_j.
      * apply Le_j_k.
    + apply Le_k_l.
Qed.

(** Rest cost of a gap *)
Lemma costs_rest_gap : forall {vt nt} i j k l (g : @Grammar vt nt),
  Nat.le 0 i ->
  Nat.le i j ->
  Nat.le j k ->
  Nat.le k l ->
  Nat.le l (term_max g + 1) ->
    costs g (rest g j k) =
      costs g (rest g i l) + costs g (in_span i j) + costs g (in_span k l).
Proof.
  intros vt nt i j k l g.
  intros Le_0_i Le_i_j Le_j_k Le_k_l Le_l_max.
  unfold rest.
  rewrite ?costs_app.
  rewrite ?(Rplus_shift_left (costs g (in_span i j))).
  rewrite Rplus_assoc.

  (* get rid of [costs g (in_span 0 j] *)
  assert (H: costs g (in_span 0%nat j) =
    costs g (in_span 0%nat i) + costs g (in_span i j)).
    { rewrite <- costs_app.
      rewrite <- in_span_split.
      - reflexivity.
      - apply Le_0_i.
      - apply Le_i_j.
    }
  rewrite <- H.
  apply Rplus_eq_compat_l.

  (* get rid of the rest *)
  rewrite Rplus_comm.
  rewrite <- costs_app.
  rewrite <- in_span_split.
  - reflexivity.
  - apply Le_k_l.
  - apply Le_l_max.
Qed.

Lemma costs_sup_le : forall {vt nt}
  (g : @Grammar vt nt) (v : vt) t,
    anchor g v = t ->
      costs g (sup g v) <= min_arc_weight g t + tree_weight g v.
Proof.
  intros vt nt g v t.
  intros A.
  destruct sup eqn:E.
  - unfold costs. simpl.
    rewrite <- (Rplus_0_l 0).
    apply Rplus_le_compat.
    + apply min_arc_weight_ge_0.
    + apply tree_weight_ge_0.
  - apply sup_destr in E as [H Lempty].
    rewrite Lempty. rewrite cost_one.
    unfold cost.
    rewrite A in H. rewrite H.
    apply Rplus_le_compat.
    + apply Rle_refl.
    + apply min_tree_weight_le.
      apply A.
Qed.

Lemma costs_sup'_le : forall {vt nt}
  (g : @Grammar vt nt) r v t,
    fst r = v ->
    anchor g v = t ->
      costs g (sup' g r) <= min_arc_weight g t + tree_weight g v.
Proof.
  intros vt nt g r v t.
  intros F A.
  destruct sup' eqn:E.
  - unfold costs. simpl.
    rewrite <- (Rplus_0_l 0).
    apply Rplus_le_compat.
    + apply min_arc_weight_ge_0.
    + apply tree_weight_ge_0.
  - apply sup'_destr in E as [H Lempty].
    rewrite Lempty. rewrite cost_one.
    unfold cost.
    rewrite F in H.
    rewrite A in H. rewrite H.
    apply Rplus_le_compat.
    + apply Rle_refl.
    + apply min_tree_weight_le.
      apply A.
Qed.

Close Scope R_scope.


Require Import Arith.
Require Import Ascii.
Require Import Bool.
Require Import Coq.Strings.Byte.
Import IfNotations.

Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.

Inductive EOExpr : Type :=
  | EOUnit : EOExpr
  | EOInt : nat -> EOExpr
  | EOBool : bool -> EOExpr
  | EOVar : string -> EOExpr
  | EOAssign : EOExpr -> EOExpr -> EOExpr
  | EOPlus : EOExpr -> EOExpr -> EOExpr
  | EOMinus : EOExpr -> EOExpr -> EOExpr
  | EOMult : EOExpr -> EOExpr -> EOExpr
  | EODiv : EOExpr -> EOExpr -> EOExpr
  | EOIf : EOExpr -> EOExpr -> EOExpr -> EOExpr
  | EOLambda : string -> EOExpr -> EOExpr
  | EOClosure : string -> EOExpr -> EOEnv -> EOExpr
  | EOApply : EOExpr -> EOExpr -> EOExpr

with EOEnv : Type :=
  | EOEmptyEnv : EOEnv
  | EOBind : string -> EOExpr -> EOEnv -> EOEnv.

(* TODO: Write an evaluation of EO ebnf *)


Require Import Strings.String.
Require Import List.
Require Import ZArith.
Require Import LinearLogic.
Require Import Group.
Require Import AsynchronousGames.
Require Import Dual.
Require Import Lifting.
Require Import Sum.
Require Import Tensor.
Require Import Exponential.

Definition interpretation := string -> AsynchronousGame.

Inductive empty_type : Type := .

Definition zero_partial_order : PartialOrder.
refine({|
            I := empty_type;
            N i := empty_type;
            leq m n := True;
         |}).
Defined.

Definition zero_event_structure : EventStructure.
refine({|
            P := zero_partial_order;
            incompatible m n := True;
            ideal m := nil;
         |}).
Defined.

Definition zero_asynchronous_arena : AsynchronousArena.
  refine({|
            E := zero_event_structure;
            polarity m := true;
            finite_payoff_position l := (-1)%Z;
            finite_payoff_walk w := 0%Z;
            infinite_payoff f inf := True;
            positive_or_negative := true;
         |}).
Defined.

Definition ZERO : AsynchronousGame.
  refine({|
             A := zero_asynchronous_arena;
             X := trivial_group;
             Y := trivial_group;
             action g m h := m
        |}).
Defined.

Definition TOP : AsynchronousGame := dual ZERO.

Definition ONE : AsynchronousGame := lifting TOP 0%Z true.

Definition BOTTOM : AsynchronousGame := dual ONE.

Fixpoint convert (A : formula) (f : interpretation) :
AsynchronousGame :=
match A with
| prop_variable A => f A
| neg_prop_variable A => dual (f A)
| one => ONE
| bottom => BOTTOM
| zero => ZERO
| top => TOP
| times A B => tensor (convert A f) (convert B f)
| par A B => dual (tensor (dual (convert A f)) (dual (convert B f)))
| plus A B => asynchronous_game_sum (convert A f) (convert B f)
| conj A B => dual (asynchronous_game_sum (dual (convert A f)) (dual (convert B f)))
| of_course A => exponential (convert A f)
| why_not A => dual (exponential (dual (convert A f)))
end.

Definition game_par A B := dual (tensor (dual A) (dual B)).

Fixpoint parify l :=
match l with
| nil => ZERO
| A :: nil => A
| A :: xs => game_par A (parify xs)
end.

Definition interpret (l : sequent) (f : interpretation) :=
parify (map (fun x => convert x f) l).


Require Coq.Classes.RelationClasses.
Require Coq.Relations.Relations.
Require Coq.Classes.Morphisms.

Require Import Coq.Setoids.Setoid.

Require Import Turing.Turing.
Require Import Turing.LangDec.

(*
Module Reducibility (T: Turing.Turing).
  Import T.
  Module D := LangDec.Decidability T.
  Import D.
  Import D.B.
*)
  Section HALT_TM. (* ---------------------- Theorem 5.1 --------------------- *)

  Definition HALT_tm : lang := fun p =>
    let (M, w) := decode_machine_input p in
    run M w <> Loop.

  Local Definition HALT_tm_to_A_tm D : lang :=
    (fun p =>
      let (M, w) := decode_machine_input p in
      run D p = Accept /\ run M w = Accept
    ).

  Local Definition halt_mach D :=
    Build (fun p =>
      let (M, w) := decode_machine_input p in
      mlet b <- Call D p in
      if b then Call M w else REJECT
    ).

  Local Lemma halt_tm_mach_spec:
    forall D,
    Recognizes (halt_mach D) (HALT_tm_to_A_tm D).
  Proof.
    unfold Recognizes.
    split; intros.
    - unfold HALT_tm_to_A_tm.
      unfold halt_mach in *.
      apply run_build in H.
      remember (decode_machine_input i).
      destruct p as (M, w).
      inversion H; subst; clear H; run_simpl_all.
      inversion H3; subst; clear H3; run_simpl_all.
      intuition.
    - unfold HALT_tm_to_A_tm in *.
      destruct (decode_machine_input i) as (M,w) eqn:Heq.
      destruct H.
      unfold halt_mach.
      run_simpl_all.
      rewrite Heq.
      apply run_seq_accept; auto using run_call_eq.
  Qed.

  Local Lemma halt_mach_loop:
    forall D p,
    run (halt_mach D) p = Loop ->
    let (M, w) := decode_machine_input p in
    (run D p = Accept /\ run M w = Loop) \/ run D p = Loop.
  Proof.
    intros.
    apply run_build in H.
    remember (decode_machine_input p) as q.
    destruct q as (M, w).
    inversion H; subst; clear H; run_simpl_all.
    - inversion H3; subst; clear H3; run_simpl_all.
      intuition.
    - intuition.
  Qed.

  (** Theorem 5.1 *)
  Theorem HALT_tm_undecidable:
    ~ Decidable HALT_tm.
  Proof.
    intros N.
    destruct N as (R, H).
    assert (Hx: Decidable A_tm). {
      apply decidable_def with (m:=halt_mach R).
      apply decides_def.
      + apply recognizes_impl with (L1:=HALT_tm_to_A_tm R); auto using halt_tm_mach_spec.
        unfold Equiv.
        intros.
        split; unfold HALT_tm_to_A_tm, A_tm; intros. {
          destruct (decode_machine_input i).
          intuition.
        }
        rename i into p.
        destruct (decode_machine_input p) as (M, w) eqn:Heq.
        split; auto.
        apply decides_accept with (L:=HALT_tm); auto.
        unfold HALT_tm.
        rewrite Heq.
        rewrite H0.
        intros N; inversion N.
      + unfold Decider.
        intros.
        intros N.
        apply halt_mach_loop in N.
        destruct (decode_machine_input i) as (M,w) eqn:Heqp.
        destruct N as [(Hx,Hy)|N].
        - apply H in Hx.
          unfold HALT_tm in Hx.
          rewrite Heqp in Hx.
          contradiction.
        - apply H in N.
          assumption.
    }
    apply a_tm_undecidable in Hx.
    assumption.
  Qed.

  End HALT_TM. (* ------------------------------------------------------------ *)

  Section E_TM. (* --------------------- Theorem 5.2 ------------------------- *)

  Definition E_tm : lang := fun p =>
    let M := decode_machine p in
    IsEmpty M.

  (* We modify M to guarantee that M rejects all strings except w, but on input
     w it works as usual. *)
  Local Definition E_tm_M1 M w :=
    Build (fun x =>
      if input_eq_dec x w then (
        Call M w
      ) else REJECT
    ).
  Local Definition E_tm_M1_lang M w : lang := fun x =>
    x = w /\ run M w = Accept.

  Local Lemma E_tm_M1_spec:
    forall M w,
    Recognizes (E_tm_M1 M w) (E_tm_M1_lang M w).
  Proof.
    intros.
    unfold Recognizes, E_tm_M1, E_tm_M1_lang; split; intros.
    - apply run_build in H.
      destruct (input_eq_dec i w). {
        run_simpl_all.
        intuition.
      }
      inversion H.
    - destruct H.
      subst.
      apply run_build.
      destruct (input_eq_dec w w). {
        auto using run_call_eq.
      }
      contradiction.
  Qed.

  (*
    The only string the machine can now accept is w, so its
    language will be nonempty iff it accepts w.
  *)
  Local Definition E_tm_A_tm D :=
    Build (fun p =>
      let (M, w) := decode_machine_input p in
      mlet b <- Call D [[ E_tm_M1 M w ]] in
      halt_with (negb b)
    ).

  Local Definition E_tm_A_tm_spec :=
    fun p =>
      let (M, w) := decode_machine_input p in
      ~ IsEmpty (E_tm_M1 M w).

  Local Lemma e_tm_reject_inv:
    forall D M,
    Decides D E_tm ->
    run D [[ M ]] = Reject ->
     ~ IsEmpty M.
  Proof.
    intros.
    apply decides_run_reject with (L:=E_tm) in H0; auto.
    unfold E_tm in *.
    rewrite decode_encode_machine_rw in *.
    assumption.
  Qed.

  Local Lemma E_tm_A_tm_recognizes:
    forall D,
    Decides D E_tm ->
    Recognizes (E_tm_A_tm D) E_tm_A_tm_spec.
  Proof.
    intros.
    unfold E_tm_A_tm_spec, E_tm_A_tm, Recognizes.
    split; intros.
    - run_simpl.
      destruct (decode_machine_input i) as (M, w).
      intros N.
      inversion H0; subst; clear H0.
      run_simpl_all.
      apply e_tm_reject_inv in H1; auto.
    - run_simpl.
      destruct (decode_machine_input _) as (M, w).
      apply run_seq_reject.
      + apply run_call_eq.
        apply decides_reject with (L:=E_tm); auto.
        unfold E_tm.
        rewrite decode_encode_machine_rw.
        assumption.
      + apply run_ret.
  Qed.

  Local Lemma not_accept_to_empty:
    forall M w,
    run M w <> Accept ->
    IsEmpty (E_tm_M1 M w).
  Proof.
    intros.
    rewrite is_empty_never_accept_rw.
    unfold NeverAccept.
    intros x.
    intros N.
    unfold E_tm_M1 in *.
    run_simpl.
    destruct (input_eq_dec x w). {
      subst.
      run_simpl.
      contradiction.
    }
    run_simpl.
  Qed.

  Local Lemma not_empty_to_accept:
    forall M w,
    ~ IsEmpty (E_tm_M1 M w) ->
    run M w = Accept.
  Proof.
    intros.
    remember (run M w) as r.
    symmetry in Heqr.
    destruct r; auto.
    - contradict H.
      apply not_accept_to_empty.
      intros N.
      rewrite N in *.
      inversion Heqr.
    - contradict H.
      apply not_accept_to_empty.
      intros N.
      rewrite N in *.
      inversion Heqr.
  Qed.

  Local Lemma accept_to_not_empty:
    forall M w,
    run M w = Accept ->
    ~ IsEmpty (E_tm_M1 M w).
  Proof.
    intros.
    intros N.
    unfold E_tm_M1 in *.
    rewrite is_empty_never_accept_rw in *.
    unfold NeverAccept in *.
    assert (N := N w).
    contradict N.
    run_simpl.
    destruct (input_eq_dec w w).
    - auto using run_call_eq.
    - contradiction.
  Qed.

  Local Lemma e_tm_a_tm_spec:
    forall D,
    Decides D E_tm ->
    Recognizes (E_tm_A_tm D) A_tm.
  Proof.
    intros.
    apply recognizes_impl with (L1:=E_tm_A_tm_spec); auto using E_tm_A_tm_recognizes.
    unfold Equiv, E_tm_A_tm_spec, A_tm; split; intros;
    destruct (decode_machine_input i) as (M, w).
    - unfold E_tm in *.
      auto using not_empty_to_accept.
    - auto using accept_to_not_empty.
  Qed.

  Local Lemma decider_E_tm_A_tm:
    forall D,
    Decider D ->
    Decider (E_tm_A_tm D).
  Proof.
    unfold Decider, E_tm_A_tm.
    intros.
    intros N.
    run_simpl.
    destruct (decode_machine_input _) as (M, w).
    inversion N; subst; clear N.
    - destruct b; inversion H5.
    - run_simpl.
      apply H in H4.
      assumption.
  Qed.

  Theorem E_tm_undecidable:
    ~ Decidable E_tm.
  Proof.
    intros HD.
    destruct HD as (R, H).
    assert (Hx: Decidable A_tm). {
      apply decidable_def with (m:=E_tm_A_tm R).
      apply decides_def.
      + auto using e_tm_a_tm_spec.
      + destruct H.
        auto using decider_E_tm_A_tm.
    }
    apply a_tm_undecidable in Hx.
    assumption.
  Qed.

End E_TM. (* --------------------------------------------------------------- *)

  Import Morphisms.
  Definition Reduction f (A B:lang) := forall w, A w <-> B (f w).

  Definition Reducible A B := exists f, Reduction f A B.

  Infix "<=m" := Reducible (at level 80, right associativity).

  Section CompFuncs.
    Global Instance reduction_equiv_proper f: Proper (Equiv ==> Equiv ==> iff) (Reduction f).
    Proof.
      unfold Proper, respectful.
      intros.
      split; intros;
      unfold Reduction in *; intros.
      - split; intros.
        + apply H in H2.
          apply H1 in H2.
          apply H0 in H2.
          assumption.
        + apply H0 in H2.
          apply H1 in H2.
          apply H.
          assumption.
      - split; intros.
        + apply H in H2.
          apply H1 in H2.
          apply H0 in H2.
          assumption.
        + apply H0 in H2.
          apply H1 in H2.
          apply H.
          assumption.
    Qed.

    Global Instance reducible_equiv_proper: Proper (Equiv ==> Equiv ==> iff) Reducible.
    Proof.
      unfold Proper, respectful.
      intros.
      split; intros;
      unfold Reducible in *; destruct H1 as (f, H1);
      exists f; rewrite H in *; rewrite H0 in *; assumption.
    Qed.

    Lemma reducible_def:
      forall f A B,
      Reduction f A B ->
      Reducible A B.
    Proof.
      intros.
      exists f.
      assumption.
    Qed.

    Lemma reducible_iff:
      forall f A B,
      (forall w, A w <-> B (f w)) ->
      Reducible A B.
    Proof.
      intros.
      exists f.
      assumption.
    Qed.

    Lemma co_red_co_1:
      forall A B,
      A <=m B ->
      compl A <=m compl B.
    Proof.
      intros.
      unfold Reducible in *.
      destruct H as (f, Hr).
      unfold Reduction in *.
      exists f.
      intros.
      unfold compl.
      split; intros.
      + intros N.
        apply Hr in N.
        contradiction.
      + intros N.
        apply Hr in N.
        contradiction.
    Qed.

    Lemma co_red_co_2:
      forall A B,
      compl A <=m compl B ->
      A <=m B.
    Proof.
      intros.
      unfold Reducible in *.
      destruct H as (f, Hr).
      unfold Reduction in *.
      exists f.
      intros.
      unfold compl.
      split; intros.
      + apply co_co_rw.
        intros N.
        apply Hr in N.
        contradiction.
      + apply co_co_rw.
        intros N.
        apply Hr in N.
        contradiction.
    Qed.

    Lemma co_red_co_rw:
      forall A B,
      compl A <=m compl B <-> A <=m B.
    Proof.
      split; auto using co_red_co_1, co_red_co_2.
    Qed.

    Lemma co_red_1:
      forall A B,
      compl A <=m B ->
      A <=m compl B.
    Proof.
      intros.
      assert (R: Equiv B (compl (compl B))) by (rewrite co_co_rw; reflexivity).
      rewrite R in H.
      rewrite co_red_co_rw in H.
      assumption.
    Qed.

    Lemma co_red_2:
      forall A B,
      A <=m compl B ->
      compl A <=m B.
    Proof.
      intros.
      assert (R: Equiv A (compl (compl A))) by (rewrite co_co_rw; reflexivity).
      rewrite R in H.
      rewrite co_red_co_rw in H.
      assumption.
    Qed.

    Theorem reducible_decidable: (*------------ Theorem 5.22 ---------------- *)
      forall A B,
      A <=m B ->
      Decidable B ->
      Decidable A.
    Proof.
      intros A B (f, Hred) (M, (Hr, Hd)).
      apply decidable_def with (m:= Build (fun w => Call M (f w))).
      split.
      - unfold Recognizes.
        split; intros. {
          run_simpl_all.
          apply Hred.
          apply Hr.
          assumption.
        }
        apply run_build.
        apply run_call_eq.
        apply Hr.
        apply Hred.
        assumption.
      - unfold Decider in *.
        intros.
        intros N.
        apply run_build in N.
        run_simpl_all.
        apply Hd in H.
        assumption.
    Qed.

    Theorem reducible_recognizable: (*------------ Theorem 5.28 ------------- *)
      forall A B,
      A <=m B ->
      Recognizable B ->
      Recognizable A.
    Proof.
      intros A B Hred Ha.
      unfold Recognizes in *.
      destruct Hred as (f, Hr).
      destruct Ha as (M, Ha).
      apply recognizable_def with (m:= Build (fun w => Call M (f w))).
      unfold Recognizes.
      split; intros. {
        run_simpl_all.
        apply Ha in H3.
        apply Hr in H3.
        assumption.
      }
      apply run_build.
      apply run_call_eq.
      apply Hr in H.
      apply Ha.
      assumption.
    Qed.

    Corollary reducible_undecidable: (* ---------- Corollary 5.29 ----------- *)
      forall A B,
      A <=m B ->
      ~ Decidable A ->
      ~ Decidable B.
    Proof.
      intros.
      intros Hd.
      contradict H0.
      eauto using reducible_decidable.
    Qed.

    Corollary reducible_unrecognizable: (* ---------- Theorem 5.28 ---------- *)
      forall A B,
      A <=m B ->
      ~ Recognizable A ->
      ~ Recognizable B.
    Proof.
      intros A B Hred Ha Hb.
      contradict Ha.
      eauto using reducible_recognizable.
    Qed.

  End CompFuncs.

  Section EQ_TM.

    (** We formally define EQ_TM: *)
    Definition EQ_tm := fun p =>
      let (w1, w2) := decode_pair p in
      let M1 := decode_machine w1 in
      let M2 := decode_machine w2 in
      Equiv (Lang M1) (Lang M2).

    Local Definition F1 p :=
      let (M, w) := decode_machine_input p in
      let M1 : input := [[ Build (fun _ => REJECT) ]] in
      let M2 : input := [[ Build (fun _ => Call M w) ]] in
      encode_pair (M1 , M2).

    Lemma co_a_tm_red_eq_tm:
      compl A_tm <=m EQ_tm.
    Proof.
      apply reducible_iff with (f:=F1).
      unfold F1, EQ_tm; split; intros.
      - unfold A_tm, compl, Equiv, Lang in *.
        destruct (decode_machine_input w) as (M, x) eqn:Heq.
        run_simpl_all.
        destruct (run M x) eqn:Hr.
        + contradiction.
        + split; intros; run_simpl_all.
          rewrite Hr in *.
          run_simpl.
        + split; intros; run_simpl_all.
          rewrite Hr in *.
          run_simpl.
      - destruct (decode_machine_input w) as (M, x) eqn:Heq.
        run_simpl_all.
        intros N.
        unfold Equiv in *.
        assert (Hm: run (Build (fun _ => Call M x)) w = Accept). {
          unfold A_tm in *.
          rewrite Heq in *.
          run_simpl.
          apply run_call_eq.
          assumption.
        }
        clear N.
        repeat rewrite decode_encode_machine_rw in *.
        apply H in Hm.
        run_simpl_all.
    Qed.

    Let F2 p :=
      let (M, w) := decode_machine_input p in
      let M1 : input := [[ Build (fun _ => ACCEPT) ]] in
      let M2 : input := [[ Build (fun _ => Call M w) ]] in
      encode_pair (M1 , M2).

    Lemma a_tm_red_eq_tm:
      A_tm <=m EQ_tm.
    Proof.
      apply reducible_iff with (f:=F2).
      unfold F2, EQ_tm; split; intros.
      - destruct (decode_machine_input w) as (M, x) eqn:Heq.
        run_simpl_all.
        unfold Equiv, Lang; split; intros; run_simpl_all.
        + apply run_call_eq.
          unfold A_tm in *.
          rewrite Heq in *.
          assumption.
        + apply run_ret.
      - unfold A_tm.
        destruct (decode_machine_input w) as (M, x) eqn:Heq.
        run_simpl_all.
        unfold Equiv, Lang in *.
        assert (Ha: run (Build (fun _ => ACCEPT)) w = Accept). {
          run_simpl.
          apply run_ret.
        }
        apply H in Ha.
        run_simpl_all.
        reflexivity.
    Qed.

    Theorem eq_tm_not_recognizable:
      ~ Recognizable EQ_tm.
    Proof.
      apply reducible_unrecognizable with (A:=compl A_tm); auto.
      - apply co_a_tm_red_eq_tm.
      - apply co_a_tm_not_recognizable.
    Qed.

    Theorem co_eq_tm_not_recognizable:
      ~ Recognizable (compl EQ_tm).
    Proof.
      apply reducible_unrecognizable with (A:=compl A_tm); auto.
      - rewrite co_red_co_rw.
        apply a_tm_red_eq_tm.
      - apply co_a_tm_not_recognizable.
    Qed.

    Theorem eq_tm_not_decidable:
      ~ Decidable EQ_tm.
    Proof.
      intros N.
      apply dec_rec_co_rec in N.
      destruct N as (N, _).
      apply eq_tm_not_recognizable in N.
      assumption.
    Qed.

  End EQ_TM.
(*
End Reducibility.
*)


Set Implicit Arguments.

Require Export LNameless_Isomorphism.
Require Export Equality.

(* begin hide *)

(***********************************************************)
(* specialized tactics for the proof of [From_To]. *)
(***********************************************************)
(* Creation of a Rewrite Hint database  *)

Hint Rewrite refl_equal : iso_module.

Ltac from_to_Rep T H :=
  dependent destruction T;
  destruct T;
  try discriminate;
  repeat (
  match goal with
    | [H : InterpretRep _ _ |- _] => destruct H; try discriminate
  end);
  simpl;
  match goal with
    | H : PLUS _ _ = _ |- _ => inversion H; subst
  end;
  try (
  match goal with
    | q : QQ |- _ => destruct q
  end);
  match goal with
    | H : JMeq _ _ |- _ => rewrite <- (JMeq_eq H); simpl
  end;
  try repeat rewrite H; auto;
  try autorewrite with iso_module; auto.

Ltac from_to T H:=
  let v := fresh "v" in
  destruct T as [v | ]; simpl;
  [destruct v | idtac]; auto using H.

(* end hide *)

(***********************************************************)
(** * Step 1. Defining syntax *)
(***********************************************************)

(** [atm] stands for the set of atomic types. *)

Notation atm := nat.

(** Grammar of pseudo-type  *)

Inductive typ : Type :=
| typ_var : atm -> typ
| typ_arrow  : typ -> typ -> typ.

(** [var] stands for the set of parameters (free variables). *)

Notation var := nat.

(** Grammar of pseudo-term *)

Inductive trm : Set :=
| trm_bvar : nat -> trm
| trm_fvar : var -> trm
| trm_abs  : trm -> trm
| trm_app  : trm -> trm -> trm.

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

(** * Step 2. Defining isomorphisms *)

(***********************************************************)
(** ** Isomorphism module for natural number *)

Module Iso_nat.

  Definition TT := nat.

  Definition RR :=  PLUS UNIT REC.

  Fixpoint From (T: TT) : Interpret RR :=
    match T with
      | O => Term (InL _ Unit)
      | S n => Term (InR _ (Rec (From n)))
    end.

  Fixpoint To_ (T : InterpretRep RR RR) : TT :=
    match T return _ with
      | InL _ _ Unit => 0
      | InR _ _ (Rec U) => S (To U)
      | _  => 0
    end

  with To (T:Interpret RR) : TT :=
    match T with
      | Var _ => 0
      | Term U => To_ U
    end.

  Lemma To_From : forall (T:TT), To (From T) = T.
  Proof.
    intro T; induction T; simpl; f_equal; auto.
  Qed.

End Iso_nat.

(***********************************************************)
(** For automation of some proofs:
   - This should be mentioned every time a iso module is used
     below in another definition using [Repr].

   - Example: [Iso_typ.RR] occurs in the defintion of
     [Iso_trm.RR] below. *)
(***********************************************************)

Hint Resolve Iso_nat.To_From.

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

(** ** Isomorphism module for type *)

(** Note that [atm] stands for atomic types, not for type variables. *)

Module Iso_typ <: Iso_partial.

  Definition TT := typ.

  Definition RR := PLUS (CONST Iso_nat.RR) (PROD REC REC).

  Fixpoint From (x : TT) : Interpret RR :=
    match x with
      | typ_var k => Term (InL _ (Const _ (Iso_nat.From k)))
      | typ_arrow e1 e2 =>
        Term (InR _ (Pair (Rec (From e1)) (Rec (From e2))))
    end.

  Fixpoint To_ (T : InterpretRep RR RR) : typ :=
    match T return _ with
      | InL _ _ (Const (PLUS UNIT REC) k) =>
        typ_var (Iso_nat.To k)
      | InR _ _ (Pair _ _ (Rec k1) (Rec k2)) =>
        typ_arrow (To k1) (To k2)
      | _ => typ_var O
    end

  with To (T : Interpret RR) : typ :=
    match T with
      | Term T0 => To_ T0
      | _ => typ_var O
    end.

  Lemma To_From : forall (T:TT), To (From T) = T.
  (* begin hide *)
  Proof.
    intro T; induction T; simpl; f_equal; auto.
  Qed.
  (* end hide *)

  Lemma From_inj : forall T U : TT, From T = From U -> T = U.
  Proof.
    intros T U H.
    rewrite <- (To_From T), <- (To_From U).
    rewrite H; auto.
  Qed.

  Definition ISO : Iso TT (Interpret RR) := (From, To).

End Iso_typ.

Hint Resolve Iso_typ.To_From.

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

(** ** Isomorphism module for term *)

(** For the generic representation of [trm],
   the case of [abs] case needs special care:
   - [PROD] should come before [BIND],

   - otherwise, the definition of substitution would be impossible. *)

Module Iso_trm <: Iso_full.

  Definition TT := trm.

  Definition RR := PLUS (BIND REC REC) (PROD REC REC).

  Fixpoint From (x : TT) : Interpret RR :=
    match x with
      | trm_bvar j => Var _ (inr j)
      | trm_fvar n => Var _ (inl n)
      | trm_abs e => Term (InL _ (Bind REC tt (Rec (From e))))
      | trm_app e1 e2 =>
        Term (InR _ (Pair (Rec (From e1)) (Rec (From e2))))
    end.

  Fixpoint To_ (T : InterpretRep RR RR) : trm :=
    match T return _ with
      | InL _ _ (Bind REC _ _ (Rec T1)) =>
        trm_abs (To T1)
      | InR _ _ (Pair _ _ (Rec T0) (Rec T1)) =>
        trm_app (To T0) (To T1)
      | _ =>
        trm_fvar 0 (* garbage needed *)
    end

  with To (T : Interpret RR) : trm :=
    match T with
      | Var (inl k) => trm_fvar k
      | Var (inr j) => trm_bvar j
      | Term T0 => To_ T0
    end.

  Lemma To_From : forall (T:TT), To (From T) = T.
  (* begin hide *)
  Proof.
    intro T; induction T; simpl; f_equal; auto.
  Qed.
  (* end hide *)

  Lemma From_inj : forall T U : TT, From T = From U -> T = U.
  (* begin hide *)
  Proof.
    intros.
    rewrite <- (To_From T), <- (To_From U).
    rewrite H; auto.
  Qed.
  (* end hide *)

  Lemma From_To_Rep : forall (T : InterpretRep RR RR), From (To_ T) = Term T

    with From_To : forall (T : Interpret RR), From (To T) = T.
  Proof.
    from_to_Rep T From_To.
    from_to T From_To_Rep.
  Qed.

  Lemma To_inj : forall T U : Interpret RR, To T = To U -> T = U.
  Proof.
    intros.
    rewrite <- (From_To T), <- (From_To U).
    rewrite H; auto.
  Qed.

  Definition ISO : Iso TT (Interpret RR) := (From, To).

End Iso_trm.

(** Making arguments implicit *)

Implicit Arguments Iso_typ.From_inj [T U].

Implicit Arguments Iso_trm.From_inj [T U].
Implicit Arguments Iso_trm.To_inj [T U].


Require Export Coq.Unicode.Utf8.
Require Export FOmega.

(*************************************************************************)
(* Evaluation.                                                           *)
(*************************************************************************)

Fixpoint Value (t : Tm) : Prop :=
  match t with
    | abs _ _  => True
    | tyabs _ _ => True
    | _        => False
  end.

Inductive red : Tm → Tm → Prop :=
  | appfun {t1 t1' t2} :
      red t1 t1' → red (app t1 t2) (app t1' t2)
  | apparg {t1 t2 t2'} :
      Value t1 → red t2 t2' → red (app t1 t2) (app t1 t2')
  | appabs {T11 t12 t2} :
      Value t2 → red (app (abs T11 t12) t2) (substTm X0 t2 t12)
  | typefun {t1 t1' T2} :
      red t1 t1' → red (tyapp t1 T2) (tyapp t1' T2)
  | tapptabs {K11 T2 t12} :
      red (tyapp (tyabs K11 t12) T2) (tsubstTm X0 T2 t12).


(** * Fundamental Pregroupoids *)
Require Import Category.Core Category.Morphisms.
Require Import HoTT.Truncations PathGroupoids.
Require Import HoTT.Basics HoTT.Types.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope path_scope.

Local Open Scope category_scope.

(** Quoting the HoTT Book:

    Example. For _any_ type [X], there is a precategory with [X] as
    its type of objects and with [hom(x,y) : ∥x = y∥₀]. The
    composition operation [∥y = z∥₀ → ∥x = y∥₀ → ∥x = z∥₀] is defined
    by induction on truncation from concatenation [(y = z) → (x = y) →
    (x = z)]. We call this the fundamental pregroupoid of [X]. *)

(** We don't want access to all of the internals of a groupoid category at top level. *)
Module FundamentalPreGroupoidCategoryInternals.
  Section fundamental_pregroupoid_category.
    Variable X : Type.

    Local Notation object := X (only parsing).
    Local Notation morphism s d := (Trunc 0 (s = d :> X)) (only parsing).

    Definition compose s d d' (m : morphism d d') (m' : morphism s d)
    : morphism s d'.
    Proof.
      revert m'; apply Trunc_rec; intro m'.
      revert m; apply Trunc_rec; intro m.
      apply tr.
      exact (m' @ m).
    Defined.

    Definition identity x : morphism x x
      := tr (reflexivity _).

    Global Arguments compose [s d d'] m m' / .
    Global Arguments identity x / .
  End fundamental_pregroupoid_category.
End FundamentalPreGroupoidCategoryInternals.

(** ** Categorification of the fundamental pregroupoid of a type *)
Definition fundamental_pregroupoid_category (X : Type) : PreCategory.
Proof.
  refine (@Build_PreCategory
            X
            _
            (@FundamentalPreGroupoidCategoryInternals.identity X)
            (@FundamentalPreGroupoidCategoryInternals.compose X)
            _
            _
            _
            _);
  simpl; intros;
  abstract (
      repeat match goal with
               | [ m : Trunc _ _ |- _ ]
                 => revert m;
               apply Trunc_ind;
               [ intro;
                 match goal with
                   | [ |- IsHSet (?a = ?b :> ?T) ]
                     => generalize a b; intros;
                        let H := fresh in
                        assert (H : forall x y : T, IsHProp (x = y))
                 end;
                 typeclasses eauto
               | intro ]
             end;
      simpl;
      apply ap;
      first [ apply concat_p_pp
            | apply concat_1p
            | apply concat_p1 ]
    ).
Defined.