(* This file is part of the Linear Logic formalization in Coq:
https://github.com/brunofx86/LL *)

(** ** Multisets

Representation of multisets and some needed results about them.
 *)

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 Omega.
Require Export Eqset.
Export ListNotations.

Module MultisetList (EQ : Eqset_dec).

  Definition A := EQ.A.
  Definition eqA_dec := EQ.eqA_dec.
  Definition eq_dec := EQ.eq_dec.
  Definition eqA := EQ.eqA.

  (*   Fixpoint countIn (a: A) (l: list A) : nat :=
    match l with
      | nil => 0
      | x::xs =>
        match eqA_dec a x with
          | left _ => S(countIn a xs)
          | right _ => countIn a xs
        end
    end.
   *)

  Fixpoint removeElem (el: A) (l: list A) : list A :=
    match l with
    | nil => nil
    | hd::tl =>
      match eq_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.

  Definition Multiset := list A.

  Definition empty : Multiset := nil.
  Definition singleton a : Multiset := a :: nil.
  Definition union := app (A:=A).

  Definition mult := count_occ eq_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).

  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 eq_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.

  Hint Resolve in_eq
       in_cons
       not_in_cons
       in_nil
       in_split
       in_inv.

  (*   Lemma count_occ_pos_in : forall a (l: list A),
     a # l > 0 -> exists b, a = b /\ In b l.

  Proof.
    induction l.
    simpl.
    intro w; omega.
    destruct (eq_dec a a0).
    intros _.
    exists a0; eauto.
    intro w.
    edestruct IHl. auto.
    destruct (IHl w) as [a' [aa' a'l]].
    exists a'; auto.
  Qed. *)

  Lemma mult_eqA_compat: forall x y M, x = y -> x # M = y # M.
  Proof.
    induction M; auto.
    intros.
    intuition. simpl.
    destruct (eq_dec a x); destruct (eq_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: list A, [] / 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 (eq_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 (eq_dec a a0); destruct (eq_dec a0 x); subst.
    auto with arith.
    contradiction.
    contradiction.
    simpl.
    destruct (eq_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 (eq_dec a0 a); subst.
    destruct (eq_dec x a); auto.
    contradiction.
    destruct (eq_dec a x); subst; auto.
    contradiction.
    simpl.
    destruct (eq_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 (eq_dec x a); case (eq_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 (eq_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; omega.
    (* induction step *)
    intro x; simpl.
    destruct (eq_dec a x); simpl.
    (* x = a *)
    fold rem.
    rewrite diff_mult_step_eq; auto.
    rewrite (IHN x).
    omega.
    (* 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 (eq_dec y x); [trivial | contradiction]. Qed.

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

  Hint Unfold meq
       empty
       singleton
       mult
       union
       diff.

  Hint Resolve mult_eqA_compat
       meq_multeq
       multeq_meq
       empty_mult
       union_mult
       diff_mult
       singleton_mult_in
       singleton_mult_notin.

  Hint Rewrite empty_mult
       union_mult
       diff_mult using trivial.

  (*   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 omega
            ; 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").

  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.

  Hint Resolve meq_refl meq_sym meq_trans.

  Instance meq_Equivalence : Equivalence meq.
  Proof.
    split; eauto.
  Qed.

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

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

  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.

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

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

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

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

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

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

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

  Instance remove_morph : Proper (eq ==> meq ==> meq) removeAll.

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

  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.

  (*  Section MultisetLemmas. *)

  (*      Lemma mset_ind : forall P : Multiset -> Prop,
      P empty -> (forall M a, P M -> P (M ++ [a])) -> forall M, P M.

    Proof. exact mset_ind_type. Qed.

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

    Proof. exact mset_ind_type. Qed. *)

  Lemma meq_cons_app a M : a :: M =mul= [a] ++ M.
  Proof. auto. Qed.
  Lemma union_comm_app : 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_app : forall M N P, M ++ N ++ P =mul= (M ++ N) ++ P.
  Proof. solve_meq. Qed.

  Section facts_remove.

    Lemma rem_a : forall a, rem a ([a]) =mul= [].
    Proof.
      intros; simpl.
      case (eq_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 (eq_dec a b); auto; intros.
      symmetry in e. contradiction.
    Qed.

    Lemma rem_aM_app : forall a M, rem a ([a] ++ M) =mul= M.
    Proof.
      intros; simpl.
      case (eq_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 (eq_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 (eq_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.

    Hint Resolve rem_a rem_ab rem_not_ab rem_aM_app rem_abM_app rem_not_abM_app rem_aM_cons.
  End facts_remove.

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

  Lemma emp_mult : forall M, M =mul= [] <-> M = [].
  Proof.
    split; intros; subst; auto.
    eapply (count_occ_inv_nil eq_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.
  Hint Resolve union_perm.

  Lemma union_nil M : M ++ [] =mul= M.
  Proof. solve_meq. Qed.

  Lemma notempty_member M : ~ M =mul= [] -> 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).
    omega.
    assert (x # [] = 0%nat); [auto | idtac].
    assert (x # M = x # []); [apply meq_multeq; trivial | idtac].
    omega.
  Qed.

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

  Lemma member_union_r a M N : a € N -> a € (M ++ N).
  Proof. unfold member; intro H. rewrite union_mult. omega. 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.
    omega.
    symmetry; auto.
    auto.
  Qed.

  Lemma singleton_member a : a € [a].
  Proof.
    unfold member. assert (a # [a] = 1%nat); [idtac | omega].
    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_diff_member a M N : a € (M / N) -> a € M.
  Proof. unfold member. rewrite (diff_mult M N). omega. Qed.
  Hint Resolve singleton_member  member_insert_app member_insert_cons.
  Lemma diff_member_ly_rn a M N : a € M -> ~a € N -> a € (M / N).
  Proof. unfold member; intros H H0. rewrite diff_mult. omega. 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 (eq_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). omega. 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.
    omega.
  Qed.

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

  Hint Resolve meq_union_meq meq_union_meq2.

  Lemma meq_meq_union M N P : M =mul= N -> M ++ P =mul= N ++ P.
  Proof. solve_meq. Qed.
  Hint Resolve meq_meq_union.
  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.
    omega.
  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 (eq_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.
    omega.
    (* ~ x =A= a *)
    rewrite !singleton_mult_notin; auto.
    rewrite mult_remove_not_in; 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_app, (union_comm_app N _).
    auto.
  Qed.
  Hint Resolve insert_meq.

  Lemma meq_insert_remove a M : a € M -> a :: (rem a M) =mul= M.
  Proof.
    intros. symmetry.
    change (a :: rem a M) with ([a] ++ rem a M).
    rewrite union_comm_app.
    apply meq_ins_rem; auto.
  Qed.

  Lemma insert_remove_noteq a a' M :
    a <> a' -> rem a (a' :: M) =mul= a' :: (rem a M).
  Proof.
    intros.
    change (a' :: M) with ([a'] ++ M).
    rewrite rem_not_abM_app. auto. firstorder. 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_app M [a]).
      apply member_insert_app.
      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. omega.
    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.
    omega.
  Qed.

  (*
 End Decidability. *)

  (*     Lemma insert_diff a M N :
       a :: M / N =mul= empty -> a € N /\ M / rem a N =mul= empty.

    Proof.
      intros.
      assert (a € N).
      destruct (member_dec a N); trivial.
      exfalso.
      apply not_empty with empty a; auto.
      fold (member a empty).
      rewrite <- H.
      apply member_insert.
      split; trivial.
      rewrite <- H.
      Check diff_remove_both.
      symmetry.
      erewrite diff_remove_both with (a:=a); auto.

       erewrite member_insert. a M).  H0).
      solve_meq.
    Qed.
   *)
  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]))%nat
            = ((x#N) + (x#P))%nat).
    rewrite <- !union_mult.
    apply meq_multeq; trivial.
    case (eq_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.
    omega.
    (* ~ 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.
    omega.
  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; omega.
    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 (eq_dec a x).
    rewrite singleton_mult_in; trivial.
    erewrite mult_eqA_compat with (y:=a); auto.
    unfold member in H; omega.
    rewrite singleton_mult_notin; trivial.
    omega.
  Qed.

  (*  End MultisetLemmas. *)
  (*
 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_cons.
    intro x_In_l; mset_unfold.
    change (a :: l) with ([a] ++ l).
    rewrite union_mult.
    assert ((x # l) > 0).
    apply (IHl x); trivial.
    omega.
  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 (eq_dec a x); [trivial | contradiction]. Qed.

  Lemma not_eq_zero : forall a x,
      a <> x -> x # [a] = 0%nat.
  Proof. intros. simpl. case (eq_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. omega.
  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. solve_meq. Qed.

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

  Hint Resolve union_left union_right.

  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.

  Hint Resolve union_rotate
       union_reverse
       meq_congr
       union_perm_left
       union_perm_left'
       union_perm_left''.

  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.

  Hint Resolve multiset_twist1 multiset_twist2.

  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.
    omega.
  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.
    omega.
  Qed.

  Hint Resolve treesort_twist1 treesort_twist2.

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

  Hint Resolve my_p.

  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.
    omega.
  Qed.

  Lemma meq_swap_cons a b M : (a :: b:: M) =mul= (b :: a :: M).
  Proof.
    rewrite meq_swap; 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.

  Hint Resolve meq_skip meq_swap meq_swap_cons union_rotate_cons.

  Lemma pair_app (F G: A) : [F; G] = [F]++[G].
  Proof. auto. Qed.

  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.
  Hint Resolve union_assoc_cons.

  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]).
    rewrite union_comm_app.
    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.

  Hint Resolve perm_cons_single perm_cons.

  Lemma union_middle : forall M N1 N2 : list A, N1 =mul= N2 -> N1 ++ M =mul= M ++ N2.
  Proof.
    intros.
    rewrite union_comm_app.
    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_app L1) at 1 ||
                                               rewrite (meq_cons_app L1) at 1 )
                                           | [ |- _  =mul= (?A1::_) ] => (
                                               rewrite union_perm_left' ||
                                               rewrite perm_cons ||
                                               rewrite <- meq_cons_app  ||
                                               rewrite perm_cons_single )
                                           | [ |- _ =mul= _ ] => fail
                                           end).

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

  Ltac solv_P :=
    try rewrite !union_perm_left';
    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 solve_permutation :=
    solve [auto | solv_P; unfold meq; intro; rewrite !union_mult; omega | 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.

  (** 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.
    omega.
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 (eq_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.
    rewrite meq_cons_app in I1, I2.

    split; rewrite meq_cons_app.
    rewrite I1 in I2.
    apply rem_to_union_app in I2.
    rewrite rem_perm_not in I2; auto.
    rewrite I2.
    simpl.
    case (eq_dec a a); intros; auto.
    contradiction.
    rewrite I2 in I1.
    apply rem_to_union_app in I1.
    rewrite rem_perm_not in I1; auto.
    rewrite I1.
    simpl.
    case (eq_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_app 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_cons in H.
    rewrite H.
    simpl.
    case (eq_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 X B M N P1 P2 P3.
    rewrite P3 in P1.
    rewrite P2 in P1.
    revert L X 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_app in P1.
    rewrite P1.
    simpl.
    case (eq_dec a a); intros; auto.
    contradiction.
  Qed.

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

   intros. inversion H0. Qed. *)

  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_app 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].
  Hint Resolve solsls.
  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_app, P1.
    symmetry. apply rem_aM_cons.
  Qed.

  Arguments solsls2 [M N X Y a].
  Hint Resolve solsls2.
  Lemma member_unit : forall a b,
      b = a <-> a € [b].
  Proof.
    split; intros.
    unfold member.
    simpl.
    destruct (eq_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_app 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_app in H.
    symmetry in H0.
    rewrite union_comm_app in H0.
    apply rem_to_union_app in H0.
    rewrite rem_aM_app in H, H0; auto.
    rewrite H, H0; rewrite union_comm_app; auto.
  Qed.

  Lemma aunion_comm : forall M L1 L2, M =mul= (L1 ++ L2) -> M =mul= (L2 ++ L1).
  Proof.
    intros.
    rewrite union_comm_app; 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_app in Heql0, Heql.
    eapply meq_eq_s.
    exact Heql0. exact Heql. rewrite union_comm_app; 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 union_empty : forall L a,
     [a] ++ L =mul= [a] -> L =mul= {}.
  Proof.
  intros.
  eapply rem_to_union in H.
  rewrite rem_a in H.
  auto.
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 (eq_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 (eq_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 (eq_dec a c); intros.
    right; auto.
    case (eq_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.
    split; intros; subst; auto.
    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 L : l :: L =mul= [] -> False.
  Proof.
    intro H.
    assert (l :: L =mul= []) by auto.
    symmetry in H.
    eapply rem_to_union_app in H. simpl in H.
    rewrite H in H0.
    eapply singleton_notempty; eauto.
  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_app in H.
    rewrite H.
    rewrite union_perm_left.
    rewrite rem_aM_app; auto.
  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_app in H.
    rewrite rem_aM_cons in H.
    auto.
  Qed.

  Lemma DestructMSet: forall F G M1 M2,
      F :: M1 =mul= G :: M2 ->
      (( F = G /\ M1 =mul= M2 )  \/
       exists M2', M2 =mul= F :: M2' /\ M1 =mul= G :: M2').
  Proof.
    intros.
    destruct (eq_dec F G).
    - left.
      rewrite e in H.
      apply right_union in H; auto.
    - right.
      apply seconda_sec'; 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 (eq_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 meq_cons_append : forall l x,
      (x :: l) =mul= (l ++ x :: nil).
  Proof.
    intros.
    solve_permutation.
  Qed.

End MultisetList.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** This module aggregates all DKA_* modules, to obtain the decision
    procedure for Kleene algebras [kleene_reflexivity]. *)

Require Import Common.
Require Import Classes.
Require Import Graph.
Require Import Converse.
Require Import DKA_Definitions.
Require        DKA_CheckLabels.
Require        DKA_Construction.
Require        DKA_Epsilon.
Require        DKA_Determinisation.
Require        DKA_Merge.
Require        DKA_DFA_Equiv.
Require        StrictStarForm.
Require        Reification.

Require Import List.

Definition word := list positive.
Inductive CounterExample: Set :=
| NotLeq: word -> CounterExample
| NotGeq: word -> CounterExample
| DifferentAtomSets: CounterExample.

Definition X_to_DFA (a: regex) :=
  let a' := StrictStarForm.ssf a in
  let A  := DKA_Construction.X_to_eNFA a' in
  let A  := DKA_Epsilon.eNFA_to_NFA A (DKA_Construction.well_founded (StrictStarForm.ssf_complete a)) in
  let A  := DKA_Determinisation.NFA_to_DFA A in
      A.

Definition translate_ce (ce: option (bool*word)) :=
  match ce with
    | None => None
    | Some(b,w) => Some ((if b then NotLeq else NotGeq) (List.rev w))
  end.

Notation clean := RegExp.Clean.rewrite.

Definition decide_kleene a b :=
  let a := clean a in
  let b := clean b in
    if negb (DKA_CheckLabels.same_labels a b) then Some DifferentAtomSets
    else translate_ce (DKA_Merge.compare_DFAs DKA_DFA_Equiv.equiv (X_to_DFA a) (X_to_DFA b)).

Lemma X_to_DFA_correct: forall a, DFA.eval (X_to_DFA a) == a.
Proof.
  intro a. unfold X_to_DFA.
  rewrite DKA_Determinisation.correct by apply DKA_Epsilon.bounded, DKA_Construction.bounded.
  rewrite DKA_Epsilon.correct by apply DKA_Construction.bounded.
  rewrite DKA_Construction.correct.
  apply StrictStarForm.ssf_correct.
Qed.

Lemma X_to_DFA_bounded: forall a, DFA.bounded (X_to_DFA a).
Proof.
  intro a. apply DKA_Determinisation.bounded, DKA_Epsilon.bounded, DKA_Construction.bounded.
Qed.

Lemma X_to_DFA_labels: forall a b,
  DKA_CheckLabels.same_labels (clean a) (clean b) = true ->
  DFA.max_label (X_to_DFA (clean a)) = DFA.max_label (X_to_DFA (clean b)).
Proof.
  intros. unfold X_to_DFA.
  rewrite 2 DKA_Determinisation.preserve_max_label.
  rewrite 2 DKA_Epsilon.preserve_max_label.
  apply DKA_Construction.same_labels_max_label.
  apply DKA_CheckLabels.same_labels_ssf.
  assumption.
Qed.

Lemma translate_correct: forall ce, translate_ce ce = None <-> ce = None.
Proof. intros [[b w]|]; simpl; intuition discriminate. Qed.

Theorem Kozen94: forall a b, decide_kleene a b = None <-> a == b.
Proof.
  unfold decide_kleene. intros a b.
  case_eq (DKA_CheckLabels.same_labels (clean a) (clean b)); simpl; intros Hm.

   rewrite translate_correct.
   rewrite DKA_Merge.correct; try apply X_to_DFA_bounded.
    setoid_rewrite X_to_DFA_correct.
    setoid_rewrite <- RegExp.Clean.correct.
    reflexivity.
    apply DKA_DFA_Equiv.correct.
    apply X_to_DFA_labels, Hm.

   split; intro H.
    discriminate H.
    exfalso. apply DKA_CheckLabels.complete in Hm. tauto.
Qed.

(* Print Assumptions Kozen94. *)

Import RegExp.Untype.
Import Reification.

Corollary dk_erase_correct `{KA: KleeneAlgebra} {env: Env}:
  forall n m (a b: KA.X n m), decide_kleene (erase a) (erase b) = None -> KA.eval a == KA.eval b.
Proof. intros. apply erase_faithful. apply Kozen94. assumption. Qed.

Ltac display_counter_example e ce :=
  let eval_word w :=
    let rec build w :=
      lazymatch w with
      | nil => fail 0
      | ?x::nil => constr:(Reification.unpack (@Reification.val _ e x))
      | ?x::?q => let q := build q in constr:(q * Reification.unpack (@Reification.val _ e x))
      end
    in
    let x := build w in
    let x := eval compute [e Reification.unpack Reification.tgt Reification.src
      Reification.sigma_get Reification.sigma_add Reification.sigma_empty
      FMapPositive.PositiveMap.find FMapPositive.PositiveMap.add
      FMapPositive.PositiveMap.empty Reification.val] in x
    in x
  in
  match ce with
    | DifferentAtomSets => fail 1 "Not a Kleene algebra theorem: different atom sets"
    | NotGeq ?w =>
      (try let u := eval_word w in
        fail 2 "Not a Kleene Algebra theorem: " u "does not belong to the left-hand side");
      fail 1 "Not a Kleene Algebra theorem: the empty word (1) does not belong to the left-hand side"
    | NotLeq ?w =>
      (try let u := eval_word w in
        fail 2 "Not a Kleene Algebra theorem: " u "does not belong to the right-hand side");
      fail 1 "Not a Kleene Algebra theorem: the empty word (1) does not belong to the right-hand side"
  end.

(** the tactic for solving Kleene algebras equations *)
Ltac kleene_reflexivity :=
  let e := fresh "e" in
  unfold leq;
  kleene_reify; intros t e l r;
  apply dk_erase_correct; vm_compute;
  (reflexivity || lazymatch goal with |- Some ?w = None => display_counter_example e w end).

(** extension to Kleene algebras with converse *)
Ltac ckleene_reflexivity := converse_down; kleene_reflexivity.

Ltac kleene_ssf := StrictStarForm.kleene_ssf.
Ltac kleene_clean_zeros := Model_RegExp.kleene_clean_zeros.

(*begintests
Section test.

  Context `{KA: KleeneAlgebra}.

  Goal forall A B (a: X A B) (b: X B A), a*(b*a)# == (a*b)#*a.
    intros.
    Time kleene_reflexivity.
  Abort.

  Goal forall A (a b: X A A), (a+b)# == a#*(b*a#)#.
    intros.
    Time kleene_reflexivity.
  Abort.

  Goal forall A (a b: X A A), a*b# + a#*b# == a#*b#.
    intros.
    Time kleene_reflexivity.
  Abort.

  Goal forall A B (a c: X A B) (b: X B A), (a+c)*(b*a+b*c)# == (a*b+c*b)#*(a+c).
    intros.
    Time kleene_reflexivity.
  Abort.

  Goal forall A (a b: X A A), (a*b)# == (a+b)# .
    intros.
    try kleene_reflexivity.
    idtac.
  Abort.

  Goal forall A B (a: X A B) (b: X B A), a*(b*a) == (a*b)#*a .
    intros.
    try kleene_reflexivity.
    idtac.
  Abort.

  Goal forall A B (a: X A B) (b: X B A), a*b*a*b == a*b + a*b*a*b .
    intros.
    try kleene_reflexivity.
    idtac.
  Abort.

  Goal forall A B (a: X A B) (b: X B A), a*b <== a*b*a*b.
    intros.
    try kleene_reflexivity.
    idtac.
  Abort.

  Goal forall A B (a: X A B) (b: X B A) (c: X B B), a*c*(b*a)# == (a*b)#*a.
    intros.
    try kleene_reflexivity.
    idtac.
  Abort.

  Goal forall A B (a: X A B) (b: X B A) (c: X B B), a*c*(b*a)# == (a*b)#*a*(1+c*0).
    intros.
    try kleene_reflexivity.
    idtac.
  Abort.

  Goal forall A (a b: X A A), (a*0)#*b == b+0*a#+b*0#.
    intros. kleene_clean_zeros.
  Abort.

  Goal forall A (a b: X A A), (a*0)# <== b+0*a#+0#.
    intros. kleene_clean_zeros.
  Abort.

  Goal forall A (a b: X A A), ((1+b)*(1+a))# == (a+b)#.
    intros. kleene_ssf.
  Abort.

End test.

Section ctest.

  Context `{KA: ConverseKleeneAlgebra}.

  Goal forall A B (a: X A B) (b: X B A), a`*(a*b)`# == (b*a)#`*a`.
    intros.
    Time ckleene_reflexivity.
  Abort.

End ctest.
endtests*)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Set Implicit Arguments.

Require Import ZArith.
Local Open Scope Z_scope.

Definition base digits := Z.pow 2 (Zpos digits).
Arguments base digits: simpl never.

Section Carry.

 Variable A : Type.

 Inductive carry :=
  | C0 : A -> carry
  | C1 : A -> carry.

 Definition interp_carry (sign:Z)(B:Z)(interp:A -> Z) c :=
  match c with
  | C0 x => interp x
  | C1 x => sign*B + interp x
  end.

End Carry.

Section Zn2Z.

 Variable znz : Type.

 (** From a type [znz] representing a cyclic structure Z/nZ,
     we produce a representation of Z/2nZ by pairs of elements of [znz]
     (plus a special case for zero). High half of the new number comes
     first.
 *)

 Inductive zn2z :=
  | W0 : zn2z
  | WW : znz -> znz -> zn2z.

 Definition zn2z_to_Z (wB:Z) (w_to_Z:znz->Z) (x:zn2z) :=
  match x with
  | W0 => 0
  | WW xh xl => w_to_Z xh * wB + w_to_Z xl
  end.

End Zn2Z.

Arguments W0 {znz}.

(** From a cyclic representation [w], we iterate the [zn2z] construct
    [n] times, gaining the type of binary trees of depth at most [n],
    whose leafs are either W0 (if depth < n) or elements of w
    (if depth = n).
*)

Fixpoint word (w:Type) (n:nat) : Type :=
 match n with
 | O => w
 | S n => zn2z (word w n)
 end.


(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(*
  Reduction from:
    Binary modified Post correspondence problem (BMPCP)
  to:
    Recognizing axiomatizations of Hilbert-style calculi (HSC_AX)
*)

Require Import List.
Import ListNotations.
Require Import Psatz.
Require Import ssreflect ssrbool ssrfun.

From Undecidability.HSC Require Import HSC_prelim HSC_AX.
From Undecidability.HSC.HSC Require Import HSC_util HSC_facts.

Definition bullet := var 0.
(* encodes symbol true *)
Definition b2 := (arr bullet bullet).
(* encodes symbol false *)
Definition b3 := arr bullet (arr bullet bullet).

Fixpoint append_word (s: formula) (v: list bool) :=
  match v with
  | [] => s
  | a :: v =>
    if a then
      append_word (arr b2 s) v else
      append_word (arr b3 s) v
  end.

Definition encode_word (v: list bool) := append_word bullet v.
Definition encode_pair (s t: formula) := arr b3 (arr s (arr t b3)).

Notation "⟨ s , t ⟩" := (encode_pair s t).
Notation "⟦ v ⟧" := (encode_word v).
Notation "s → t" := (arr s t) (at level 50).

(* environment encoding the instance ((v, w), P) of BMPCP *)
Definition Γ v w P :=
  (encode_pair (var 1) (var 1)) ::
  (arr (encode_pair (encode_word v) (encode_word w)) a_b_a) ::
  map (fun '(v, w) => arr (encode_pair (append_word (var 2) v) (append_word (var 3) w)) (encode_pair (var 2) (var 3))) ((v, w) :: P).

(* if t is derivable from a → b → a, then so is s → t *)
Lemma arr_allowed {s t} : hsc [a_b_a] t -> hsc [a_b_a] (arr s t).
Proof.
  move=> H. apply: hsc_arr; last by eassumption.
  pose ζ i := if i is 0 then t else if i is 1 then s else var i.
  have -> : arr t (arr s t) = substitute ζ a_b_a by done.
  apply: hsc_var. by left.
Qed.

(* • → • → • is derivable from a → b → a *)
Lemma b3_allowed : hsc [a_b_a] b3.
Proof.
  pose ζ i := if i is 0 then bullet else if i is 1 then bullet else var i.
  have -> : b3 = substitute ζ a_b_a by done.
  apply: hsc_var. by left.
Qed.

(* Γ v w P is derivable from a → b → a *)
Lemma Γ_allowed {v w P} : forall r, In r (Γ v w P) -> hsc [a_b_a] r.
Proof.
  rewrite - Forall_forall /Γ ? Forall_norm. constructor; last constructor; last constructor.
  - rewrite /encode_pair.
    do 3 (apply: arr_allowed). by apply: b3_allowed.
  - apply: arr_allowed.
    have -> : a_b_a = substitute var a_b_a by done.
    apply: hsc_var. by left.
  - rewrite /encode_pair.
    do 4 (apply: arr_allowed). by apply: b3_allowed.
  - rewrite Forall_forall => ?. rewrite in_map_iff => [[[x y]]] [<- _].
    rewrite /encode_pair.
    do 4 (apply: arr_allowed). by apply: b3_allowed.
Qed.

Lemma encode_word_last {a v} : encode_word (v ++ [a]) = arr (if a then b2 else b3) (encode_word v).
Proof.
  rewrite /encode_word. move: (bullet) => r. elim: v r.
    move=> r /=. by case: a.
  move=> b A IH r /=. case: b; by rewrite IH.
Qed.

Lemma encode_word_app {v x} : encode_word (v ++ x) = append_word (encode_word v) x.
Proof.
  elim: x v.
    move=> v. by rewrite app_nil_r.
  move=> a x IH v.
  rewrite -/(app [a] _) ? app_assoc IH encode_word_last.
  move=> /=. by case: a.
Qed.

(* unifiable words are equal *)
Lemma unify_words {v w ζ} : substitute ζ (encode_word v) = substitute ζ (encode_word w) -> v = w.
Proof.
  move: v w. elim /list_last_ind.
    elim /list_last_ind.
      done.
    move=> b w _. rewrite encode_word_last. case: b => /=.
      move /(f_equal size) => /=. by lia.
    move /(f_equal size) => /=. by lia.
  move=> a v IH. elim /list_last_ind.
    rewrite encode_word_last. case: a => /=.
      move /(f_equal size) => /=. by lia.
    move /(f_equal size) => /=. by lia.
  move=> b w _. rewrite ? encode_word_last.
  case: a; case: b; move=> /=; case.
  - by move /IH => ->.
  - move /(f_equal size) => /=. by lia.
  - move /(f_equal size) => /=. by lia.
  - by move /IH => ->.
Qed.

Lemma substitute_combine {ζ ξ r v x} :
  ζ 0 = ξ 0 ->
  substitute ζ r = substitute ξ (encode_word v) ->
  substitute ζ (append_word r x) = substitute ξ (encode_word (v ++ x)).
Proof.
  move=> ?. elim: x v r.
    move=> ? /=. by rewrite app_nil_r.
  move=> a x IH v r /=.
  have -> : v ++ a :: x = v ++ [a] ++ x by done.
  rewrite app_assoc. move=> ?. case: a.
  - apply: IH. rewrite encode_word_last. move=> /=. by congruence.
  - apply: IH. rewrite encode_word_last. move=> /=. by congruence.
Qed.

From Undecidability.PCP Require Import PCP.

Lemma tau1_lastP {x y: list bool} {A} : tau1 (A ++ [x / y]) = tau1 A ++ x.
Proof.
  elim: A.
    move=> /=. by rewrite app_nil_r.
  move=> [a b] A /= ->.
  by rewrite app_assoc.
Qed.

Lemma tau2_lastP {x y: list bool} {A} : tau2 (A ++ [x / y]) = tau2 A ++ y.
Proof.
  elim: A.
  move=> /=. by rewrite app_nil_r.
  move=> [a b] A /= ->.
  by rewrite app_assoc.
Qed.

(* derivability of an instance of a → b → a *)
Definition adequate v w P n :=
  exists p q, der (Γ v w P) n (arr p (arr q p)).

(* derivability of (v ++ v₁ ++...++ vₙ, w ++ w₁ ++...++ wₙ) *)
Definition solving (v w: list bool) P n :=
  exists A,
    (incl A ((v, w) :: P)) /\
    exists ζ, der (Γ v w P) n
      (substitute ζ (encode_pair
        (encode_word (v ++ tau1 A))
        (encode_word (w ++ tau2 A)))).

Lemma adequate_step {v w P n} : adequate v w P (S n) -> adequate v w P n \/ solving v w P n.
Proof.
  move=> [p [q /derE]] => [[ζ [s [k [_]]]]].
  rewrite {1}/Γ /In -/(In _ _). case. case; last case.
  (* case ⟨ a, a ⟩ *)
  {
    move=> ?. subst s. case: k.
      move=> [_] /=. case=> -> ->.
      move=> /(f_equal size) /=. by lia.
    move=> k /=. rewrite ? Forall_norm. move=> [[? _]] _. left.
    eexists. eexists. by eassumption.
  }
  (* case ⟨ v, w ⟩ → a → b → a *)
  {
    move=> ?. subst s. case: k.
      move=> [_] /=. case=> <- _.
      case=> _ /(f_equal size) /=. by lia.
    move=> k /=. rewrite ? Forall_norm. move=> [[? _]] _. right.
    exists []. constructor.
      done.
    eexists. rewrite /flat_map ? app_nil_r => /=. by eassumption.
  }
  (* case ⟨ va, wb ⟩ → ⟨ a, b ⟩ *)
  {
    move /in_map_iff => [[x y] [<- _]] /=. case: k; last case.
    - move=> [_] /=.
      case=> <- _. case=> _ _ _ /(f_equal size) /=. by lia.
    - move=> [_] /=. case=> <- _. move=> /(f_equal size) /=. by lia.
    - move=> k /=. rewrite ? Forall_norm. move=> [[_ [? _]] _].
      left. eexists. eexists. by eassumption.
  }
Qed.

Lemma solving_step {v w P n} : solving v w P (S n) -> adequate v w P n \/ solving v w P n \/ BMPCP ((v, w), P).
Proof.
  move=> [A [HA [ξ /derE]]]. move=> [ζ [s [k [_]]]].
  rewrite {1}/Γ /In -/(In _ _). case. case; last case.
  (* case ⟨ a, a ⟩ *)
  {
    move=> ?. subst s. case: k.
      move=> /= [_]. case=> _ _ _ -> /unify_words HA2 _ _ _.
      right. right. eexists. by constructor; eassumption.
    move=> k /=. rewrite ? Forall_norm. move => [[?]] *.
    left. eexists. eexists. by eassumption.
  }
  (* case ⟨ v, w ⟩ → a → b → a *)
  {
    move=> ?. subst s. case: k.
      move=> /= [_]. case=> <- _ /(f_equal size) /=. by lia.
    move=> k /=. rewrite ? Forall_norm. move=> [[?]] *.
    right. left. exists [].
    constructor.
      done.
    eexists. move=> /=. rewrite ? app_nil_r. by eassumption.
  }
  (* case ⟨ va, wb ⟩ → ⟨ a, b ⟩ *)
  {
    move /in_map_iff => [[x y]]. move=> [<- ?] /=. case: k; last case.
    (* k = 0 *)
    - move=> [_] /=. case=> -> _ /(f_equal size) /=. by lia.
    (* k = 1 *)
    - move=> /=. rewrite ? Forall_norm.
      move=> [H1]. case=> H2. move: H1. rewrite H2.
      rewrite - ? /(substitute ζ (var _)).
      move=> + _ _ /(substitute_combine H2 (x := x)) Hx.
      move=> + /(substitute_combine H2 (x := y)) Hy _ _ _.
      rewrite Hx Hy => HD.
      right. left.
      exists (A ++ [(x, y)]). constructor.
        move: HA. rewrite /incl - ? Forall_forall ? Forall_norm.
        move=> ?. by constructor.
      exists ξ => /=. by rewrite tau1_lastP tau2_lastP ? app_assoc.
    (* k = 2 *)
    - move=> k /=. rewrite ? Forall_norm. move=> [[_ [?]]] *.
      left. eexists. eexists. by eassumption.
  }
Qed.

Lemma adequate0E {v w P} : not (adequate v w P 0).
Proof. by move=> [? [?]] /der_0E. Qed.

Lemma solving0E {v w P} : not (solving v w P 0).
Proof. by move=> [? [? [?]]] /der_0E. Qed.

(* if ((v, w), P) is adequate, then BMPCP is solvable *)
Lemma complete_adequacy {v w P n}: adequate v w P n -> BMPCP ((v, w), P).
Proof.
  apply: (@proj1 _ (solving v w P n -> BMPCP ((v, w), P))).
  elim: n.
    constructor.
      by move /adequate0E.
    by move /solving0E.
  move=> n [IH1 IH2]. constructor.
    by case /adequate_step.
  by case /solving_step; last case.
Qed.

(* if a → b → a is derivable, then BMPCP is solvable *)
Lemma completeness {v w P} : hsc (Γ v w P) a_b_a -> BMPCP ((v, w), P).
Proof.
  move /hsc_der => [n ?].
  apply: complete_adequacy.
  eexists. eexists. by eassumption.
Qed.

Lemma transparent_encode_pair {ζ s t} : ζ 0 = var 0 ->
  substitute ζ (encode_pair s t) = encode_pair (substitute ζ s) (substitute ζ t).
Proof. by move=> /= ->. Qed.

Lemma transparent_append_word {ζ s v} : ζ 0 = var 0 ->
  substitute ζ (append_word s v) = append_word (substitute ζ s) v.
Proof.
  move=> Hζ. elim: v s.
    done.
  move=> a v IH s /=. case: a.
    rewrite /b2 /bullet IH => /=. by rewrite Hζ.
  rewrite /b3 /bullet IH => /=. by rewrite Hζ.
Qed.

Lemma substitute_arrP {ζ s t} : substitute ζ (arr s t) = arr (substitute ζ s) (substitute ζ t).
Proof. done. Qed.

(* key inductive argument for the soundness lemma *)
Lemma soundness_ind {v w P x y A} :
  incl A ((v, w) :: P) ->
  x ++ tau1 A = y ++ tau2 A ->
  hsc (Γ v w P) (encode_pair (encode_word x) (encode_word y)).
Proof.
  elim: A x y.
    move=> x y _ /=. rewrite ? app_nil_r => <-.
    pose ζ i := if i is 1 then encode_word x else var i.
    have -> : encode_pair (encode_word x) (encode_word x) =
      substitute ζ (encode_pair (var 1) (var 1)) by done.
    apply: hsc_var.
    rewrite /Γ /In. by left.
  move=> [a b] A IH x y /incl_consP [? ?].
  rewrite /tau1 -/tau1 /tau2 -/tau2 ? app_assoc.
  move /IH => /(_ ltac:(assumption)) ?.
  apply: hsc_arr; last eassumption.
  rewrite ? encode_word_app.
  pose ζ i := if i is 2 then encode_word x else if i is 3 then encode_word y else var i.
  have -> : encode_word x = substitute ζ (var 2) by done.
  have -> : encode_word y = substitute ζ (var 3) by done.
  rewrite - ? transparent_append_word; try done.
  rewrite - ? transparent_encode_pair; try done.
  rewrite - substitute_arrP.
  apply: hsc_var. rewrite /Γ.
  right. right. rewrite in_map_iff.
  exists (a, b). by constructor.
Qed.

Lemma soundness {v w P} : BMPCP ((v, w), P) -> hsc (Γ v w P) a_b_a.
Proof.
  move=> [A [/soundness_ind + H]] => /(_ _ _ H){H} ?.
  apply: hsc_arr; last eassumption.
  pose ζ i := var i.
  have Hζ: forall s, s = substitute ζ s.
    elim.
      done.
    by move=> ? {1}-> ? {1}->.
  rewrite (Hζ (arr _ _)).
  apply: hsc_var. rewrite /Γ. right. by left.
Qed.

From Undecidability Require Import Reduction.

(* Reduction from BMPCP to HSC_AX *)
Theorem BMPCP_to_HSC_AX : BMPCP ⪯ HSC_AX.
Proof.
  exists (fun '((v, w), P) => exist _ (Γ v w P) Γ_allowed).
  intros [[v w] P]. constructor.
    exact soundness.
  exact completeness.
Qed.

Check BMPCP_to_HSC_AX.
(* Print Assumptions BMPCP_to_HSC_AX. *)