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

  #[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 (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; lia.
    (* induction step *)
    intro x; simpl.
    destruct (eq_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 (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.

  #[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").

  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.

  #[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.

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

  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; lia.
  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.
  #[export] Hint Resolve union_perm : core.

  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).
    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_diff_member a M N : a € (M / N) -> a € M.
  Proof. unfold member. rewrite (diff_mult M N). lia. Qed.
  #[export] Hint Resolve singleton_member  member_insert_app member_insert_cons: core.
  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 (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). 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 (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.
    lia.
    (* ~ 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.
  #[export] Hint Resolve insert_meq : core.

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

  (*
 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]))
            = ((x#N) + (x#P))).
    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.
    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 (eq_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.

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

  #[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_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]).
    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.

  #[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_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; 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.

  (** 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 (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].
  #[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_app, 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 (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.


Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Rsqr.
Require Import XR_Ropp_lt_cancel.
Require Import XR_Rmult_le_0_lt_compat.
Require Import XR_Ropp_mult_distr_l.
Require Import XR_Ropp_mult_distr_r.
Require Import XR_Ropp_0.

Local Open Scope R_scope.

Lemma Rsqr_lt_abs_1 : forall x y:R, Rabs x < Rabs y -> Rsqr x < Rsqr y.
Proof.
  intros x y h.
  unfold Rabs in h.
  unfold Rsqr.
  destruct (Rcase_abs x) as [ hx | hx ] ;
  destruct (Rcase_abs y) as [ hy | hy ].
  {
  apply Ropp_lt_cancel.
  repeat rewrite Ropp_mult_distr_l.
  apply Ropp_lt_cancel.
  repeat rewrite Ropp_mult_distr_r.
  apply Rmult_le_0_lt_compat.
  {
    left.
    rewrite <- Ropp_0.
    apply Ropp_lt_contravar.
    exact hx.
  }
  {
    left.
    rewrite <- Ropp_0.
    apply Ropp_lt_contravar.
    exact hx.
  }
  { exact h. }
  { exact h. }
  }
  {
  rewrite <- (Ropp_involutive (x*x)).
  rewrite Ropp_mult_distr_l.
  rewrite Ropp_mult_distr_r.
  apply Rmult_le_0_lt_compat.
  {
    left.
    rewrite <- Ropp_0.
    apply Ropp_lt_contravar.
    exact hx.
  }
  {
    left.
    rewrite <- Ropp_0.
    apply Ropp_lt_contravar.
    exact hx.
  }
  { exact h. }
  { exact h. }
}
{
  rewrite <- (Ropp_involutive (y*y)).
  rewrite Ropp_mult_distr_l.
  rewrite Ropp_mult_distr_r.
  apply Rmult_le_0_lt_compat.
  { exact hx. }
  { exact hx. }
  { exact h. }
  { exact h. }
}
{
  apply Rmult_le_0_lt_compat.
  { exact hx. }
  { exact hx. }
  { exact h. }
  { exact h. }
}
Qed.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                       L-Calculus                                   *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                          L_opred.v                                 *)
(*                                                                    *)
(* adapted from Terms.v for Lambda Calculus                           *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import General.
Require Import L_Combinators.
Require Import L_combinator_tactics.

(* combinator-reduction  *)

Inductive opred1 : combred :=
  | op_opred : forall o, opred1 (Op o) (Op o)
  | app_opred :
      forall M M' ,
      opred1 M M' ->
      forall N N' : combinator, opred1 N N' -> opred1 (Ap M N) (Ap M' N')
  | plus_zero_red : forall j j', opred1 j j' -> opred1 (Ap (Ap (Op Plus) (Op Zero)) j) j'
  | plus_next_red: forall i i' j j', opred1 i i' -> opred1 j j' ->
                                     opred1 (Ap (Ap (Op Plus) (Ap (Op Next) i)) j)
                                            (Ap (Ap (Op Plus) i') (Ap (Op Next) j'))
  | pred_zero_red: opred1 (Ap (Op Pred) (Op Zero)) (Op Zero)
  | pred_next_red: forall i i', opred1 i i' -> opred1 (Ap (Op Pred) (Ap (Op Next) i)) i'
  | disc_zz_red: forall s t u u', opred1 u u' ->
     opred1 (Ap (Ap (Ap (Ap (Ap (Op Discriminate) (Op Zero)) (Op Zero)) s) t) u) u'
  | disc_zn_red: forall j s s' t u, opred1 s s' ->
   opred1 (Ap (Ap (Ap (Ap (Ap (Op Discriminate) (Op Zero)) (Ap (Op Next) j)) s) t) u) s'
  | disc_nz_red: forall i s t t' u, opred1 t t' ->
   opred1 (Ap (Ap (Ap (Ap (Ap (Op Discriminate) (Ap (Op Next) i)) (Op Zero)) s) t) u) t'
  | disc_nn_red: forall i i' j j' s s' t t' u u', opred1 i i' -> opred1 j j' -> opred1 s s' ->
                                            opred1 t t' -> opred1 u u' ->
   opred1 (Ap (Ap (Ap (Ap (Ap (Op Discriminate)(Ap (Op Next) i)) (Ap (Op Next) j)) s) t) u)
          (Ap (Ap (Ap (Ap (Ap (Op Discriminate) i') j') s') t') u')
  | var_red : forall i i' s s' u u', opred1 i i' -> opred1 s s' -> opred1 u u' ->
            opred1(Ap (Ap (Ap (Op Var) i) s) u)
                  (Ap (Ap (Op Var) i') (Ap (Ap (Op Pr) s') u'))
  | raise_un_red: forall j k, opred1 (Ap (Ap (Ap (Op Rase) (Op Un)) j) k) (Op Un)
  | raise_pair_red:  forall j j' k k' s s' t t', opred1 j j' ->
                                  opred1 k k' -> opred1 s s' -> opred1 t t' ->
                                  opred1 (Ap (Ap (Ap (Op Rase)(Ap (Ap (Op Pr) s) t)) j) k)
                                         (Ap (Ap (Op Pr) (Ap (Ap (Ap (Op Rase) s') j') k'))
                                             (Ap (Ap (Ap (Op Rase) t') j') k'))
  | raise_var_red : forall i i' j j' k k' s s' ,  opred1 i i' -> opred1 j j' ->
                                  opred1 k k' -> opred1 s s' ->
         opred1 (Ap (Ap (Ap (Op Rase) (Ap (Ap (Op Var) i) s)) j) k)
                (Ap (Ap (Op Var) (Ap (Ap (Ap (Ap (Ap (Op Discriminate) i') k') i')
                                         (Ap (Ap (Op Plus) i') j'))
                                     (Ap (Ap (Op Plus) i') j')))
                    (Ap (Ap (Ap (Op Rase) s') j') k'))
  | raise_abs_red : forall i i' t t' j j' k k', opred1 i i' -> opred1 t t' ->
                                                opred1 j j' -> opred1 k k' ->
                     opred1 (Ap (Ap (Ap (Op Rase) (Ap (Ap (Op Lam) i) t)) j) k)
                            (Ap (Ap (Op Lam) i')
                                (Ap (Ap (Ap (Op Rase) t') (Ap (Op Next) (Ap (Ap (Op Plus) i') j'))) k'))
  | lam_var_un_red : forall j j' i i' u u', opred1 j j' -> opred1 i i' -> opred1 u u' ->
                        opred1 (Ap(Ap(Ap(Op Lam) j) (Ap (Ap (Op Var) i) (Op Un))) u)
                               (Ap (Ap (Ap (Ap (Ap (Op Discriminate) i') j')
                                           (Ap (Ap (Op Var) i') (Op Un)))
                                       (Ap (Ap (Op Var) (Ap (Op Pred) i')) (Op Un)))
                                   (Ap (Ap (Ap (Op Rase) u') (Op Zero)) j'))
  | lam_var_pr_red : forall j j' i i' s s' t t' u u', opred1 j j' -> opred1 i i' ->
                                      opred1 s s' -> opred1 t t' -> opred1 u u' ->
               opred1 (Ap(Ap(Ap(Op Lam) j) (Ap (Ap (Op Var) i) (Ap (Ap (Op Pr) s) t))) u)
                      (Ap(Ap(Ap(Ap(Op Lam) j') (Ap (Ap (Op Var) i') s')) u')
                           (Ap(Ap(Ap(Op Lam) j') t') u'))
  | lam_lam_red : forall j j' i i' t t' u u' , opred1 j j' -> opred1 i i' ->
                         opred1 t t' -> opred1 u u' ->
                        opred1 (Ap (Ap (Ap (Op Lam) j) (Ap (Ap (Op Lam) i) t)) u)
                               (Ap (Ap (Op Lam) i') (Ap (Ap (Ap (Op Lam)
                                                                (Ap (Op Next) (Ap (Ap (Op Plus) i') j')))
                                                            t') u'))
.

Hint Constructors opred1.

Definition opred := multi_step opred1.

Lemma reflective_opred1 : reflective opred1.
Proof. red; induction M; split_all. Qed.
Hint Resolve reflective_opred1.

Lemma reflective_opred : reflective opred.
Proof. unfold opred; eapply2 refl_multi_step. Qed.
Hint Resolve reflective_opred.

Lemma preserves_app_opred : preserves_app opred.
Proof. eapply2 preserves_app_multi_step. red; split_all. Qed.
Hint Resolve  preserves_app_opred.

(* Diamond Lemmas *)

Lemma diamond0_opred1_opred1 : diamond0 opred1 opred1.
Proof.
red;intros M N OR; induction OR; split_all; eauto; inv opred1; eauto.
(* 40 *)
elim(IHOR1 M'0); elim(IHOR2 N'0); split_all. eauto.
(* 39 *)
inv opred1. elim(IHOR2 P); split_all; eauto.
(* 38 *)
inv opred1. elim(IHOR1 (Ap (Op Plus) (Ap (Op Next) i'))); elim(IHOR2 j'); split_all.
inv opred1. invsub. exist(Ap (Ap (Op Plus) N'2)(Ap (Op Next) x)) .
(* 37 *)
inv opred1. eauto.
(* 36 *)
inv opred1. elim(IHOR2 (Ap (Op Next) P)); split_all; inv opred1; invsub; eauto.
(* 35 *)
inv opred1. elim(IHOR2 P); split_all; eauto.
(* 34 *)
inv opred1. elim(IHOR1 (Ap (Ap (Ap (Ap (Op Discriminate) (Op Zero)) (Ap (Op Next) N'3)) P)
               N'0)); split_all.
inv opred1.   invsub. eauto.
(* 33 *)
inv opred1. elim(IHOR1 (Ap (Ap (Ap (Ap (Op Discriminate) (Ap (Op Next) N'4)) (Op Zero)) N'1)
               P)); split_all.
inv opred1.   invsub. eauto. auto 10.
(* 32 *)
inv opred1. elim(IHOR1 (Ap (Ap (Ap (Ap (Op Discriminate) (Ap (Op Next) i')) (Ap (Op Next) j')) s')
               t')); split_all.
elim(IHOR2 u'); split_all.
inv opred1.   invsub. exist (Ap (Ap (Ap (Ap (Ap (Op Discriminate) N'9) N'7) N'4) N'2) x0).
auto 10. auto 10.
(* 31 *)
inv opred1. elim(IHOR2 u');elim(IHOR1(Ap (Ap (Op Var) i') s')); split_all.
inv opred1; invsub; eauto.
exist(Ap (Ap (Op Var) N'3) (Ap (Ap (Op Pr) N'2)  x0)).
(* 30 *)
inv opred1. eauto.
(* 29 *)
inv opred1.
elim(IHOR2 k');elim(IHOR1(Ap (Ap (Op Rase) (Ap (Ap (Op Pr) s') t')) j')); split_all.
inv opred1; invsub; eauto.
exist (Ap (Ap (Op Pr) (Ap (Ap (Ap (Op Rase) N'6) N'1) x0))
          (Ap (Ap (Ap (Op Rase) N'5) N'1) x0)).
auto 10.
(* 28 *)
inv opred1.
elim(IHOR2 k');elim(IHOR1(Ap (Ap (Op Rase) (Ap (Ap (Op Var) i') s')) j')); split_all.
inv opred1; invsub; eauto.
exist (Ap
          (Ap (Op Var)
             (Ap
                (Ap (Ap (Ap (Ap (Op Discriminate) N'6) x0) N'6)
                    (Ap (Ap (Op Plus) N'6) N'1))
                (Ap (Ap (Op Plus) N'6) N'1)))
       (Ap (Ap (Ap (Op Rase) N'5) N'1) x0)).
auto 10.
(* 27 *)
inv opred1.
elim(IHOR2 k');
elim(IHOR1(Ap (Ap (Op Rase) (Ap (Ap (Op Lam) i') t')) j')); split_all.
inv opred1; invsub; eauto.
exist (Ap (Ap (Op Lam) N'6) (Ap (Ap (Ap (Op Rase) N'5) (Ap (Op Next) (Ap (Ap (Op Plus) N'6) N'1))) x0)) .
auto 10.
(* 26 *)
inv opred1.
elim(IHOR2 u');
elim(IHOR1(Ap (Ap (Op Lam) j') (Ap (Ap (Op Var) i') (Op Un)))); split_all.
inv opred1; invsub; eauto.
exist (Ap
          (Ap
             (Ap (Ap (Ap (Op Discriminate) N'4) N'5)
                (Ap (Ap (Op Var) N'4) (Op Un)))
             (Ap (Ap (Op Var) (Ap (Op Pred) N'4)) (Op Un)))
          (Ap (Ap (Ap (Op Rase) x0) (Op Zero)) N'5)).
auto 10.
(* 25 *)
inv opred1.
elim(IHOR2 u');
elim(IHOR1(Ap (Ap (Op Lam) j') (Ap (Ap (Op Var) i') (Ap (Ap (Op Pr) s') t')))); split_all.
inv opred1; invsub; eauto.
exist (Ap (Ap (Ap (Ap (Op Lam) N'9) (Ap (Ap (Op Var) N'8) N'7)) x0)
          (Ap (Ap (Ap (Op Lam) N'9) N'6) x0)).
auto 10.
(* 24 *)
inv opred1.
elim(IHOR2 u');
elim(IHOR1(Ap (Ap (Op Lam) j') (Ap (Ap (Op Lam) i') t'))); split_all.
inv opred1; invsub; eauto.
exist (Ap (Ap (Op Lam) N'5)
          (Ap (Ap (Ap (Op Lam) (Ap (Op Next) (Ap (Ap (Op Plus) N'5) N'6))) N'4) x0)).
auto 10.
(* 23 *)
elim(IHOR N'); split_all.  eauto.
(* 22 *)
elim(IHOR1 N'1); elim(IHOR2 N'); split_all. exist (Ap (Ap (Op Plus) x0) (Ap (Op Next) x)).
(* 21 *)
elim(IHOR1 i'0); elim(IHOR2 j'0); split_all. exist (Ap (Ap (Op Plus) x0) (Ap (Op Next) x)).
(* 20 *)
elim(IHOR N'0); split_all.  eauto.
(* 19 *)
elim(IHOR N'); split_all.  eauto.
(* 18 *)
elim(IHOR N'1); split_all; eauto.
(* 17 *)
elim(IHOR N'0); split_all; eauto.
(* 16 *)
elim(IHOR1 N'5); elim(IHOR2 N'3); elim(IHOR3 N'1); elim(IHOR4 N'0); elim(IHOR5 N'); split_all.
exist(Ap (Ap (Ap (Ap (Ap (Op Discriminate) x3) x2) x1) x0) x).
auto 10.
(* 15 *)
elim(IHOR1 i'0); elim(IHOR2 j'0); elim(IHOR3 s'0); elim(IHOR4 t'0); elim(IHOR5 u'0); split_all.
exist(Ap (Ap (Ap (Ap (Ap (Op Discriminate) x3) x2) x1) x0) x).
auto 10. auto 10.
(* 14 *)
elim(IHOR1 N'1); elim(IHOR2 N'0); elim(IHOR3 N'); split_all.
exist(Ap (Ap (Op Var) x1) (Ap (Ap (Op Pr) x0) x)).
(* 13 *)
elim(IHOR1 i'0); elim(IHOR2 s'0); elim(IHOR3 u'0); split_all.
exist(Ap (Ap (Op Var) x1) (Ap (Ap (Op Pr) x0) x)).
(* 12 *)
elim(IHOR1 N'0); elim(IHOR2 N'); elim(IHOR3 N'3); elim(IHOR4 N'2); split_all.
exist (Ap (Ap (Op Pr) (Ap (Ap (Ap (Op Rase) x0) x2) x1))
          (Ap (Ap (Ap (Op Rase) x) x2) x1)).
auto 10.
(* 11 *)
elim(IHOR1 j'0); elim(IHOR2 k'0); elim(IHOR3 s'0); elim(IHOR4 t'0); split_all.
exist (Ap (Ap (Op Pr) (Ap (Ap (Ap (Op Rase) x0) x2) x1))
          (Ap (Ap (Ap (Op Rase) x) x2) x1));
auto 10.
(* 10 *)
elim(IHOR1 N'3); elim(IHOR2 N'0); elim(IHOR3 N'); elim(IHOR4 N'2); split_all.
exist  (Ap
          (Ap (Op Var)
             (Ap
                (Ap (Ap (Ap (Ap (Op Discriminate) x2) x0) x2)
                   (Ap (Ap (Op Plus) x2) x1)) (Ap (Ap (Op Plus) x2) x1)))
          (Ap (Ap (Ap (Op Rase) x) x1) x0)).
auto 10.
(* 9 *)
elim(IHOR1 i'0); elim(IHOR2 j'0); elim(IHOR3 k'0); elim(IHOR4 s'0); split_all.
exist  (Ap
          (Ap (Op Var)
             (Ap
                (Ap (Ap (Ap (Ap (Op Discriminate) x2) x0) x2)
                   (Ap (Ap (Op Plus) x2) x1)) (Ap (Ap (Op Plus) x2) x1)))
          (Ap (Ap (Ap (Op Rase) x) x1) x0));
auto 10.
(* 8 *)
elim(IHOR1 N'3); elim(IHOR2 N'2); elim(IHOR3 N'0); elim(IHOR4 N'); split_all.
exist(Ap (Ap (Op Lam) x2)
          (Ap (Ap (Ap (Op Rase) x1) (Ap (Op Next) (Ap (Ap (Op Plus) x2) x0))) x)).
auto 10.
(* 7 *)
elim(IHOR1 i'0); elim(IHOR2 t'0); elim(IHOR3 j'0); elim(IHOR4 k'0); split_all.
exist(Ap (Ap (Op Lam) x2)
          (Ap (Ap (Ap (Op Rase) x1) (Ap (Op Next) (Ap (Ap (Op Plus) x2) x0))) x)).
auto 10. auto 10.
(* 6 *)
elim(IHOR1 N'3); elim(IHOR2 N'2); elim(IHOR3 N'); split_all.
exist(Ap
          (Ap
             (Ap (Ap (Ap (Op Discriminate) x0) x1)
                (Ap (Ap (Op Var) x0) (Op Un)))
             (Ap (Ap (Op Var) (Ap (Op Pred) x0)) (Op Un)))
          (Ap (Ap (Ap (Op Rase) x) (Op Zero)) x1)).
auto 10.
(* 5 *)
elim(IHOR1 j'0); elim(IHOR2 i'0); elim(IHOR3 u'0); split_all.
exist(Ap
          (Ap
             (Ap (Ap (Ap (Op Discriminate) x0) x1)
                (Ap (Ap (Op Var) x0) (Op Un)))
             (Ap (Ap (Op Var) (Ap (Op Pred) x0)) (Op Un)))
          (Ap (Ap (Ap (Op Rase) x) (Op Zero)) x1)).
auto 10. auto 10.
(* 4 *)
elim(IHOR1 N'5); elim(IHOR2 N'4); elim(IHOR3 N'3); elim(IHOR4 N'2); elim(IHOR5 N'); split_all.
exist(Ap (Ap (Ap (Ap (Op Lam) x3) (Ap (Ap (Op Var) x2) x1)) x)
          (Ap (Ap (Ap (Op Lam) x3) x0) x)).
auto 10.
(* 3 *)
elim(IHOR1 j'0); elim(IHOR2 i'0); elim(IHOR3 s'0); elim(IHOR4 t'0); elim(IHOR5 u'0); split_all.
exist(Ap (Ap (Ap (Ap (Op Lam) x3) (Ap (Ap (Op Var) x2) x1)) x)
          (Ap (Ap (Ap (Op Lam) x3) x0) x)).
auto 10. auto 10.
(* 2 *)
elim(IHOR1 N'3); elim(IHOR2 N'2); elim(IHOR3 N'1); elim(IHOR4 N'); split_all.
exist(Ap (Ap (Op Lam) x1)
          (Ap (Ap (Ap (Op Lam) (Ap (Op Next) (Ap (Ap (Op Plus) x1) x2))) x0) x)).
auto 10.
(* 7 *)
elim(IHOR1 j'0); elim(IHOR2 i'0); elim(IHOR3 t'0); elim(IHOR4 u'0); split_all.
exist(Ap (Ap (Op Lam) x1)
          (Ap (Ap (Ap (Op Lam) (Ap (Op Next) (Ap (Ap (Op Plus) x1) x2))) x0) x)).
auto 10. auto 10.
Qed.

Hint Resolve diamond0_opred1_opred1.

Lemma diamond0_opred1_opred : diamond0 opred1 opred.
Proof. eapply2 diamond0_strip. Qed.

Lemma diamond0_opred : diamond0 opred opred.
Proof.  eapply2 diamond0_tiling. Qed.
Hint Resolve diamond0_opred.

(* Confluence *)

Definition confluence (A : Set) (R : A -> A -> Prop) :=
  forall x y : A,
  R x y -> forall z : A, R x z -> exists u : A, R y u /\ R z u.

Theorem combinator_confluence: confluence combinator opred.
Proof. red. eapply2 diamond0_tiling.  Qed.

(* combinator-sequential-reduction *)

Inductive seq_opred1 : combinator -> combinator -> Prop :=
  | appl_seq_opred :  forall M M' N, seq_opred1 M M' ->
                                      seq_opred1 (Ap M N) (Ap M' N)
  | appr_seq_opred :  forall M N N', seq_opred1 N N' ->
                                      seq_opred1 (Ap M N) (Ap M N')
  | plus_zero_seqred : forall j, seq_opred1 (Ap (Ap (Op Plus) (Op Zero)) j) j
  | plus_next_seqred: forall i j,
                                     seq_opred1 (Ap (Ap (Op Plus) (Ap (Op Next) i)) j)
                                            (Ap (Ap (Op Plus) i) (Ap (Op Next) j))
  | pred_zero_seqred: seq_opred1 (Ap (Op Pred) (Op Zero)) (Op Zero)
  | pred_next_seqred: forall i, seq_opred1 (Ap (Op Pred) (Ap (Op Next) i)) i
  | disc_zz_seqred: forall s t u ,
     seq_opred1 (Ap (Ap (Ap (Ap (Ap (Op Discriminate) (Op Zero)) (Op Zero)) s) t) u) u
  | disc_zn_seqred: forall j s t u,
   seq_opred1 (Ap (Ap (Ap (Ap (Ap (Op Discriminate) (Op Zero)) (Ap (Op Next) j)) s) t) u) s
  | disc_nz_seqred: forall i s t u,
   seq_opred1 (Ap (Ap (Ap (Ap (Ap (Op Discriminate) (Ap (Op Next) i)) (Op Zero)) s) t) u) t
  | disc_nn_seqred: forall i j s t u,
   seq_opred1 (Ap (Ap (Ap (Ap (Ap (Op Discriminate)(Ap (Op Next) i)) (Ap (Op Next) j)) s) t) u)
          (Ap (Ap (Ap (Ap (Ap (Op Discriminate) i) j) s) t) u)
  | var_seqred : forall i s u,
            seq_opred1(Ap (Ap (Ap (Op Var) i) s) u)
                  (Ap (Ap (Op Var) i) (Ap (Ap (Op Pr) s) u))
  | raise_un_seqred: forall j k, seq_opred1 (Ap (Ap (Ap (Op Rase) (Op Un)) j) k) (Op Un)
  | raise_pair_seqred:  forall j k s t,
                                  seq_opred1 (Ap (Ap (Ap (Op Rase)(Ap (Ap (Op Pr) s) t)) j) k)
                                         (Ap (Ap (Op Pr) (Ap (Ap (Ap (Op Rase) s) j) k))
                                             (Ap (Ap (Ap (Op Rase) t) j) k))
  | raise_var_seqred : forall i j k s ,
         seq_opred1 (Ap (Ap (Ap (Op Rase) (Ap (Ap (Op Var) i) s)) j) k)
                (Ap (Ap (Op Var) (Ap (Ap (Ap (Ap (Ap (Op Discriminate) i) k) i)
                                         (Ap (Ap (Op Plus) i) j))
                                     (Ap (Ap (Op Plus) i) j)))
                    (Ap (Ap (Ap (Op Rase) s) j) k))
  | raise_abs_seqred : forall i t j k,
                     seq_opred1 (Ap (Ap (Ap (Op Rase) (Ap (Ap (Op Lam) i) t)) j) k)
                            (Ap (Ap (Op Lam) i)
                                (Ap (Ap (Ap (Op Rase) t) (Ap (Op Next) (Ap (Ap (Op Plus) i) j))) k))
  | lam_var_un_seqred : forall j i u,
                        seq_opred1 (Ap(Ap(Ap(Op Lam) j) (Ap (Ap (Op Var) i) (Op Un))) u)
                               (Ap (Ap (Ap (Ap (Ap (Op Discriminate) i) j)
                                           (Ap (Ap (Op Var) i) (Op Un)))
                                       (Ap (Ap (Op Var) (Ap (Op Pred) i)) (Op Un)))
                                   (Ap (Ap (Ap (Op Rase) u) (Op Zero)) j))
  | lam_var_pr_seqred : forall j i s t u,
               seq_opred1 (Ap(Ap(Ap(Op Lam) j) (Ap (Ap (Op Var) i) (Ap (Ap (Op Pr) s) t))) u)
                      (Ap(Ap(Ap(Ap(Op Lam) j) (Ap (Ap (Op Var) i) s)) u)
                           (Ap(Ap(Ap(Op Lam) j) t) u))
  | lam_lam_seqred : forall j i t u,
                        seq_opred1 (Ap (Ap (Ap (Op Lam) j) (Ap (Ap (Op Lam) i) t)) u)
                               (Ap (Ap (Op Lam) i) (Ap (Ap (Ap (Op Lam)
                                                               (Ap (Op Next) (Ap (Ap (Op Plus) i) j)))
                                                            t) u))
.

Definition seq_opred := multi_step seq_opred1.

Hint Constructors seq_opred1 .

Lemma reflective_seq_opred: reflective seq_opred.
Proof. red; red; reflect. Qed.
Hint Resolve reflective_seq_opred.

Definition preserves_apl (red : combred) :=
forall M M' N, red M M' -> red (Ap M N) (Ap M' N).

Definition preserves_apr (red : combred) :=
forall M N N', red N N' -> red (Ap M N) (Ap M N').

Lemma preserves_apl_multi_step : forall (red: combred), preserves_apl red -> preserves_apl (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (Ap N0 N); auto. Qed.

Lemma preserves_apr_multi_step : forall (red: combred), preserves_apr red -> preserves_apr (multi_step red).
Proof. red. induction 2; split_all. apply succ_red with (Ap M N); auto. Qed.

Lemma preserves_apl_seq_opred: preserves_apl seq_opred.
Proof. eapply2 preserves_apl_multi_step. red; split_all.  Qed.
Hint Resolve preserves_apl_seq_opred.

Lemma preserves_apr_seq_opred: preserves_apr seq_opred.
Proof. eapply2 preserves_apr_multi_step. red; split_all.  Qed.
Hint Resolve preserves_apr_seq_opred.

Lemma preserves_app_seq_opred: preserves_app seq_opred.
Proof.
red; split_all.
apply transitive_red with (Ap M' N); split_all.
eapply2 preserves_apl_seq_opred.
eapply2 preserves_apr_seq_opred.
Qed.
Hint Resolve preserves_app_seq_opred.

Lemma seq_opred1_to_opred1 : implies_red seq_opred1 opred1.
Proof. red. intros M N B; induction B; split_all.  Qed.

Lemma seq_opred_to_opred: implies_red seq_opred opred.
Proof.
eapply2 implies_red_multi_step.
red; split_all; one_step; eapply2 seq_opred1_to_opred1.
Qed.

Lemma to_seq_opred_multi_step: forall red, implies_red red seq_opred -> implies_red (multi_step red) seq_opred.
Proof.
red.  intros red B M N R; induction R; split_all.
red; split_all.
assert(seq_opred M N) by eapply2 B.
apply transitive_red with N; auto.
eapply2 IHR.
Qed.

Lemma opred1_to_seq_opred: implies_red opred1 seq_opred .
Proof.
red.  intros M N OR; induction OR; split_all; eapply succ_red;
auto; repeat eapply2 preserves_app_seq_opred. auto.
Qed.

Hint Resolve opred1_to_seq_opred.

Lemma opred_to_seq_opred: implies_red opred seq_opred.
Proof. eapply2 to_seq_opred_multi_step. Qed.

Lemma diamond_seq_opred: diamond seq_opred seq_opred.
Proof.
red; split_all.
assert(opred M N) by eapply2 seq_opred_to_opred.
assert(opred M P) by eapply2 seq_opred_to_opred.
elim(diamond0_opred M N H1 P); split_all.
exist x; eapply2 opred_to_seq_opred.
Qed.
Hint Resolve diamond_seq_opred.

Theorem abstraction_combinator_confluence: confluence combinator seq_opred.
Proof. red. split_all. eapply2 diamond_seq_opred.  Qed.


Require Import Bedrock.Examples.AutoSep.

(** Swapping two pointers *)

Definition swapS : spec := SPEC("x", "y") reserving 2
  Al v, Al w,
  PRE[V] V "x" =*> v * V "y" =*> w
  POST[_] V "x" =*> w * V "y" =*> v.

Definition swap := bmodule "swap" {{
  bfunction "swap"("x", "y", "v", "w") [swapS]
    "v" <-* "x";;
    "w" <-* "y";;
    "x" *<- "w";;
    "y" *<- "v";;
    Return 0
  end
}}.

Theorem swapOk : moduleOk swap.
(*TIME Clear Timing Profile. *)
  vcgen; abstract sep_auto.
(*TIME Print Timing Profile. *)
Qed.


Require Import Ascii String.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.DecidableTypeEx.
Require Import Coq.ZArith.Znat.
Require Import Coq.Arith.Peano_dec.

Module Type IndexedType.
  Variable t: Type.
  Variable index: t -> nat.
  Hypothesis index_inj: forall (x y: t), index x = index y <-> x = y.
  Variable eq: forall (x y: t), {x = y} + {x <> y}.
End IndexedType.

Module IndexedAscii <: IndexedType.

Definition t := ascii.
Definition index := nat_of_ascii.
Definition eq := ascii_dec.
Hypothesis index_inj: forall (x y: t), index x = index y <-> x = y.

End IndexedAscii.

Module OrderedAscii(A: IndexedType) <: OrderedType.

Definition t := A.t.
Definition eq (x y: t) := x = y.
Definition lt (x y: t) := lt (A.index x) (A.index y).

Lemma eq_refl : forall x : t, eq x x.
Proof (@refl_equal t).
Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof (@sym_equal t).
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof (@trans_equal t).

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof.
  unfold lt; intros. rewrite <- H in H0. exact H0.
Qed.

Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof.
  unfold lt; unfold eq; intros.
  red. intro. subst y. generalize dependent H. apply lt_irrefl.
Qed.

Lemma compare : forall x y : t, Compare lt eq x y.
Proof.
  intros.
  case_eq ( nat_compare (A.index x) (A.index y)); intro.
  - apply EQ. apply nat_compare_eq in H. apply A.index_inj. assumption.
  - apply LT. apply nat_compare_lt in H. unfold lt. assumption.
  - apply GT. apply nat_compare_gt in H. unfold lt. intuition.
Qed.

Lemma eq_dec : forall x y, { eq x y } + { ~ eq x y }.
Proof.
  intros. case_eq (nat_compare (A.index x) (A.index y)); intros.
  - left. apply nat_compare_eq in H. apply A.index_inj. assumption.
  - right. red. intro. inversion H0. apply nat_compare_lt in H. apply A.index_inj in H1.
    intuition.
  - right. red. intro. inversion H0. apply nat_compare_gt in H. apply A.index_inj in H1.
    intuition.
Defined.

End OrderedAscii.

Module AsciiVars := OrderedAscii (IndexedAscii).

Module RegionVars := PairOrderedType Nat_as_OT Nat_as_OT.


Definition L1 : bool <> nat.
Proof.
Admitted.

(* bool = nat type-checks since bool and nat have same sort Set                 *)
(*
Check bool.
Check nat.
*)

(* This is going to be true for bool but not for nat.                          *)
Definition P1 (X:Type) : Prop := forall (x y z:X), x = y \/ x = z \/ y = z.

Definition L2 : P1 bool.
Proof.
    unfold P1. intros x y z. destruct x; destruct y; destruct z.
    - left. reflexivity.
    - left. reflexivity.
    - right. left. reflexivity.
    - right. right. reflexivity.
    - right. right. reflexivity.
    - right. left. reflexivity.
    - left. reflexivity.
    - left. reflexivity.
Qed.

Definition L3 : ~ (0 = 1 \/ 0 = 2 \/ 1 = 2).
Proof.
    intros [H|[H|H]]; inversion H.
Qed.

Definition L4 : ~ P1 nat.
Proof.
    unfold P1, not. intros H. apply L3. apply H.
Qed.

Definition L5 : bool <> nat.
Proof.
    intros H. apply L4. rewrite <- H. apply L2.
Qed.

(*
Check True. (* Prop *)
Check unit. (* Set  *)
Check bool. (* Set  *)
*)

(* Different sorts but still seems ok                                           *)
Definition L6 : bool <> True.
Proof.
Admitted.

Definition L7 : bool <> unit.
Proof.
Admitted.

(* true for unit but not for bool.                                              *)
Definition P2 (X:Type) : Prop := forall (x y:X), x = y.

Definition L8 : P2 unit.
Proof.
    intros x y. destruct x; destruct y. reflexivity.
Qed.

Definition L9 : P2 unit.
Proof.
refine (
    fun (x y:unit) =>
        match x, y with
        | tt, tt    => eq_refl tt
        end
).
Qed.

Definition L10 : true <> false.
Proof.
    intros H. inversion H.
Qed.

Definition L11 : ~ P2 bool.
Proof.
    unfold P2. intros H. apply L10. apply H.
Qed.

Definition L12 : bool <> unit.
Proof.
    intros H. apply L11. rewrite H. apply L9.
Qed.

Definition L13 : ~ ( (true,true) = (true,false)
                  \/ (true,true) = (false,false)
                  \/ (true, false) = (false, false)).
Proof. intros [H|[H|H]]; inversion H. Qed.

Open Scope type_scope.

Definition L14 : ~ P1 (bool * bool).
Proof.
    unfold P1. intros H. apply L13. apply H.
Qed.

Definition L15 : bool * bool <> bool.
Proof.
    intros H. apply L14. rewrite H. apply L2.
Qed.


Require Export NaturalDeduction.
Require Import Subcontext.
Require Import NDSCEquiv.

Section Classical_ND.

Context {atom : Type}.

Reserved Notation "Γ ⊢c P" (no associativity, at level 61).

Inductive classic_ND_proves : list (prop atom) -> prop atom -> Prop :=
| classic_ND_exfalso_quodlibet {Γ P} :
  Γ ⊢c ⊥ ->
  Γ ⊢c P
| classic_ND_True_intro {Γ} :
  Γ ⊢c ⊤
| classic_ND_or_introl {Γ P Q} :
  Γ ⊢c P ->
  Γ ⊢c P ∨ Q
| classic_ND_or_intror {Γ P Q} :
  Γ ⊢c Q ->
  Γ ⊢c P ∨ Q
| classic_ND_proof_by_cases {Γ P Q R} :
  Γ ⊢c P ∨ Q ->
  P :: Γ ⊢c R ->
  Q :: Γ ⊢c R ->
  Γ ⊢c R
| classic_ND_and_intro {Γ P Q} :
  Γ ⊢c P ->
  Γ ⊢c Q ->
  Γ ⊢c P ∧ Q
| classic_ND_and_elim {Γ P Q R} :
  Γ ⊢c P ∧ Q ->
  P :: Q :: Γ ⊢c R ->
  Γ ⊢c R
| classic_ND_cond_proof {Γ P Q} :
  P :: Γ ⊢c Q ->
  Γ ⊢c P ⊃ Q
| classic_ND_modus_ponens {Γ P Q} :
  Γ ⊢c P ⊃ Q ->
  Γ ⊢c P ->
  Γ ⊢c Q
| classic_ND_assumption {Γ P} :
  In P Γ ->
  Γ ⊢c P
| classic_ND_cut {Γ P Q} :
  Γ ⊢c P ->
  P :: Γ ⊢c Q ->
  Γ ⊢c Q
| classic_ND_proof_by_contradiction {Γ P} :
  ¬P :: Γ ⊢c ⊥ ->
  Γ ⊢c P
where "Γ ⊢c P" := (classic_ND_proves Γ P).

Proposition ND_impl_classic_ND {Γ P} :
  Γ ⊢ P -> Γ ⊢c P.
Proof.
induction 1;
[ econstructor 1 | econstructor 2 | econstructor 3 |
  econstructor 4 | econstructor 5 | econstructor 6 |
  econstructor 7 | econstructor 8 | econstructor 9 |
  econstructor 10 | econstructor 11 ]; eauto.
Qed.

Proposition classic_ND_NNPP {Γ P} :
  Γ ⊢c (¬ ¬ P) ⊃ P.
Proof.
apply @classic_ND_cond_proof. apply @classic_ND_proof_by_contradiction.
apply @classic_ND_modus_ponens with (P := ¬ P);
apply @classic_ND_assumption; unfold not_prop; prove_In.
Qed.

Proposition classic_ND_excluded_middle {Γ P} :
  Γ ⊢c P ∨ ¬ P.
Proof.
apply @classic_ND_proof_by_contradiction.
apply @classic_ND_modus_ponens with (P := P ∨ ¬ P).
+ apply @classic_ND_assumption; unfold not_prop; prove_In.
+ apply @classic_ND_or_intror. apply @classic_ND_cond_proof.
  apply @classic_ND_modus_ponens with (P := P ∨ ¬ P).
  - apply @classic_ND_assumption; unfold not_prop; prove_In.
  - apply @classic_ND_or_introl.
    apply @classic_ND_assumption; prove_In.
Qed.

Proposition classic_ND_Peirce {Γ P Q} :
  Γ ⊢c ((P ⊃ Q) ⊃ P) ⊃ P.
Proof.
apply @classic_ND_cond_proof.
apply @classic_ND_proof_by_contradiction.
apply @classic_ND_modus_ponens with (P := P).
+ apply @classic_ND_assumption; unfold not_prop; prove_In.
+ apply @classic_ND_modus_ponens with (P := P ⊃ Q).
  - apply @classic_ND_assumption; prove_In.
  - apply @classic_ND_cond_proof. apply @classic_ND_exfalso_quodlibet.
    apply @classic_ND_modus_ponens with (P := P);
    apply @classic_ND_assumption; unfold not_prop; prove_In.
Qed.

Class ND_normal (P : prop atom) : Prop :=
| ND_normality : forall Γ, Γ ⊢ (¬ ¬ P) ⊃ P.

Lemma ND_double_neg_elim_for_normal {Γ P Q} `{ND_normal Q} :
  Γ ⊢ (¬ ¬ P) -> P :: Γ ⊢ Q -> Γ ⊢ Q.
Proof.
intros. apply @ND_modus_ponens with (P := ¬ ¬ Q).
+ apply H.
+ apply @ND_cond_proof. apply @ND_cut with (P := ¬ ¬ P).
  - eapply @ND_context_extension with (3 := H0);
    (prove_subcontext || reflexivity).
  - apply @ND_modus_ponens with (P := ¬ P).
    * apply @ND_assumption; unfold not_prop; prove_In.
    * apply @ND_cond_proof. apply @ND_modus_ponens with (P := Q).
      { apply @ND_assumption; unfold not_prop; prove_In. }
      { eapply @ND_context_extension with (3 := H1);
        (prove_subcontext || reflexivity). }
Qed.

Instance ND_normal_bot : ND_normal ⊥.
Proof.
intro Γ. unfold not_prop. apply @ND_cond_proof.
apply @ND_modus_ponens with (P := ⊥ ⊃ ⊥).
+ apply @ND_assumption; prove_In.
+ apply @ND_cond_proof. apply @ND_assumption; prove_In.
Qed.

Instance ND_normal_impl {P Q} : ND_normal Q -> ND_normal (P ⊃ Q).
Proof.
intros ? Γ. do 2 apply @ND_cond_proof.
apply @ND_double_neg_elim_for_normal with (P := P ⊃ Q); auto.
+ apply @ND_assumption; prove_In.
+ apply @ND_modus_ponens with (P := P);
  apply @ND_assumption; prove_In.
Qed.

Theorem classic_ND_equiv {Γ P} :
  Γ ⊢c P <-> Γ ⊢ ¬ (¬ P).
Proof.
split; intros.
+ induction H.
  - apply @ND_exfalso_quodlibet. apply @ND_modus_ponens with (P := ¬ ⊥).
    * assumption.
    * apply @ND_cond_proof. apply @ND_assumption; prove_In.
  - apply @ND_cond_proof. apply @ND_modus_ponens with (P := ⊤).
    * apply @ND_assumption; unfold not_prop; prove_In.
    * apply @ND_True_intro.
  - apply (ND_double_neg_elim_for_normal IHclassic_ND_proves).
    apply @ND_cond_proof. apply @ND_modus_ponens with (P := P ∨ Q).
    * apply @ND_assumption; unfold not_prop; prove_In.
    * apply @ND_or_introl. apply @ND_assumption; prove_In.
  - apply (ND_double_neg_elim_for_normal IHclassic_ND_proves).
    apply @ND_cond_proof. apply @ND_modus_ponens with (P := P ∨ Q).
    * apply @ND_assumption; unfold not_prop; prove_In.
    * apply @ND_or_intror. apply @ND_assumption; prove_In.
  - apply (ND_double_neg_elim_for_normal IHclassic_ND_proves1).
    apply @ND_proof_by_cases with (P := P) (Q := Q).
    * apply @ND_assumption; prove_In.
    * apply @ND_context_extension with (3 := IHclassic_ND_proves2);
      (prove_subcontext || reflexivity).
    * apply @ND_context_extension with (3 := IHclassic_ND_proves3);
      (prove_subcontext || reflexivity).
  - apply (ND_double_neg_elim_for_normal IHclassic_ND_proves1).
    apply (ND_double_neg_elim_for_normal (P := Q)).
    * apply @ND_context_extension with (3 := IHclassic_ND_proves2);
      (prove_subcontext || reflexivity).
    * apply @ND_cond_proof. apply @ND_modus_ponens with (P := P ∧ Q).
      { apply @ND_assumption; unfold not_prop; prove_In. }
      { apply @ND_and_intro; apply @ND_assumption; prove_In. }
  - apply (ND_double_neg_elim_for_normal IHclassic_ND_proves1).
    apply @ND_and_elim with (P := P) (Q := Q).
    * apply @ND_assumption; prove_In.
    * apply @ND_context_extension with (3 := IHclassic_ND_proves2);
      (prove_subcontext || reflexivity).
  - apply @ND_cond_proof. apply @ND_modus_ponens with (P := P ⊃ Q).
    * apply @ND_assumption; unfold not_prop; prove_In.
    * apply @ND_cond_proof. apply @ND_cut with (P := ¬ ¬ Q).
      { apply @ND_context_extension with (3 := IHclassic_ND_proves);
        (prove_subcontext || reflexivity). }
      { apply @ND_exfalso_quodlibet. apply @ND_modus_ponens with (P := ¬ Q).
        + apply @ND_assumption; unfold not_prop; prove_In.
        + apply @ND_cond_proof. apply @ND_modus_ponens with (P := P ⊃ Q).
          - apply @ND_assumption; unfold not_prop; prove_In.
          - apply @ND_cond_proof. apply @ND_assumption; prove_In. }
  - apply (ND_double_neg_elim_for_normal IHclassic_ND_proves1).
    apply (ND_double_neg_elim_for_normal (P := P)).
    * apply @ND_context_extension with (3 := IHclassic_ND_proves2);
      (prove_subcontext || reflexivity).
    * apply @ND_cond_proof. apply @ND_modus_ponens with (P := Q).
      { apply @ND_assumption; unfold not_prop; prove_In. }
      { apply @ND_modus_ponens with (P := P);
        apply @ND_assumption; prove_In. }
  - apply @ND_cond_proof. apply @ND_modus_ponens with (P := P).
    * apply @ND_assumption; unfold not_prop; prove_In.
    * apply @ND_assumption; right; assumption.
  - apply (ND_double_neg_elim_for_normal IHclassic_ND_proves1).
    assumption.
  - apply @ND_cond_proof. apply @ND_modus_ponens with (P := ¬ ⊥).
    * assumption.
    * apply @ND_cond_proof. apply @ND_assumption; prove_In.
+ apply @classic_ND_modus_ponens with (P := ¬ (¬ P));
  auto using @ND_impl_classic_ND, @classic_ND_NNPP.
Qed.

Corollary classic_ND_consistent : ~ (nil ⊢c ⊥).
Proof.
rewrite classic_ND_equiv. intro. eapply @ND_consistent.
eapply @ND_modus_ponens with (P := ¬ ⊥).
+ eassumption.
+ apply @ND_cond_proof. apply @ND_assumption; prove_In.
Qed.

End Classical_ND.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.omega.Omega.
 Require Import maps.
Require Import imp.

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

Ltac inv H := inversion H; subst; clear H.

Theorem ceval_deterministic': forall c st st1 st2,
     c / st \\ st1 ->
     c / st \\ st2 ->
     st1 = st2.
Proof.
intros c st st1 st2 E1 E2;
  generalize dependent st2;
  induction E1; intros st2 E2; inv E2.
  - reflexivity.
  -  reflexivity.
  - assert (st' = st'0) as EQ1.
    {  apply IHE1_1; apply H1. }
 subst st'0.
    apply IHE1_2. assumption.
  -  apply IHE1. assumption.
  -  rewrite H in H5. inversion H5.
  -  rewrite H in H5. inversion H5.
  -  apply IHE1. assumption.
 - reflexivity.
 - rewrite H in H2. inversion H2.
-  rewrite H in H4. inversion H4.
- assert (st' = st'0) as EQ1.
{ apply IHE1_1; assumption. }
 subst st'0.
apply IHE1_2. assumption. Qed.

Example auto_example_2 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
   Show Proof.
  intros P Q R H1 H2 H3.
  apply H2. apply H1. apply H3. Qed.

(** The auto tactic solves goals that are solvable by any combination of
intros and
**)

Lemma le_antisym : forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof. intros. omega. Qed.
Hint Resolve le_antisym.
Example auto_example_6' : forall n m p : nat,
  (n<= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  intros.
  auto. (**using le_antisym.**)
Qed.

Definition is_fortytwo x := (x = 42).

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  unfold is_fortytwo. auto. Qed.

Ltac find_eqn :=
  match goal with
    H1: forall x, ?P x -> ?L = ?R,
    H2: ?P ?X
    |- _ => rewrite (H1 X H2) in *
  end.


(***************************************************************************
* Calculus of Constructions - Subject Reduction                            *
* Arthur Charguéraud, April 2007, Coq v8.1                                 *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory CoC_Definitions CoC_Infrastructure CoC_Conversion.

(* ********************************************************************** *)
(** ** Inversion Lemmas for Subtyping *)

Lemma less_type_any_inv : forall T1 T2,
  less T1 T2 -> forall i1, conv T1 (trm_type i1) ->
  exists i2, i1 <= i2 /\ conv T2 (trm_type i2).
Proof.
  induction 1; intros i1 C1.
  exists* i1.
  puts (conv_type_type_inv C1). subst. exists* j.
  contradictions. apply (conv_type_prod_inv (equiv_sym C1)).
  exists* i1.
  destruct (IHless1 _ C1) as [i2 [Le2 C2]].
   destruct (IHless2 _ C2) as [i3 [Le3 C3]].
   exists i3. use (Le.le_trans i1 i2 i3).
Qed.

Lemma less_type_type_inv : forall i j,
  less (trm_type i) (trm_type j) -> i <= j.
Proof.
  introv Le.
  destruct (@less_type_any_inv _ _ Le i) as [i' [Lei C]]. auto.
  puts (conv_type_type_inv C). subst*.
Qed.

Lemma less_prod_any_inv : forall P1 P2,
  less P1 P2 -> forall U1 T1, conv P1 (trm_prod U1 T1) ->
  exists U2, exists T2, conv P2 (trm_prod U2 T2)
  /\ conv U1 U2
  /\ exists L, forall x, x \notin L -> less (T1 ^ x) (T2 ^ x).
Proof.
  induction 1; intros U1 T1 C1.
  exists U1 T1.
   asserts* K (term (trm_prod U1 T1)). inversions K.
   splits.
     apply* (@equiv_trans beta t1).
     auto.
     exists_fresh. auto.
  contradictions. apply (conv_type_prod_inv C1).
  exists U' T'. asserts* K (less (trm_prod U T) (trm_prod U' T')).
   destruct (conv_prod_prod_inv C1) as [C11 [L1 C12]].
   splits.
    auto.
    apply* (@equiv_trans beta U).
    exists_fresh. intros. apply (@less_trans (T ^ x)).
      forward* (C12 x). auto.
  exists U1 T1. asserts* K (term (trm_prod U1 T1)). inversions* K.
  destruct (IHless1 _ _ C1) as [U2 [T2 [C2 [C21 [L2 C22]]]]].
   destruct (IHless2 _ _ C2) as [U3 [T3 [C3 [C31 [L3 C32]]]]].
   exists U3 T3. splits.
     auto.
     apply* (@equiv_trans beta U2).
     exists_fresh. intros. apply* (@less_trans (T2 ^ x)).
Qed.

Lemma less_prod_prod_inv : forall U1 T1 U2 T2,
  less (trm_prod U1 T1) (trm_prod U2 T2) ->
     conv U1 U2
  /\ exists L, forall x, x \notin L -> less (T1 ^ x) (T2 ^ x).
Proof.
  introv Le.
  destruct (@less_prod_any_inv _ _ Le U1 T1)
    as [U2' [T2' [C [C1' [L' C2']]]]]; auto.
  destruct (conv_prod_prod_inv C) as [C1 [L C2]].
  splits.
    apply* (@equiv_trans beta U2').
    exists_fresh. intros. apply (@less_trans (T2' ^ x)).
      auto.
      forward* (C2 x).
Qed.

(* ********************************************************************** *)
(** ** Inversion Lemmas for Typing *)

Lemma typing_prod_inv : forall E U T P,
  typing E (trm_prod U T) P -> exists i, exists k,
     less (trm_type i) P
  /\ typing E U (trm_type k)
  /\ (i = k \/ i = 0)
  /\ exists L, forall x, x \notin L -> typing (E & x ~ U) (T ^ x) (trm_type i).
Proof.
  introv Typ. gen_eq (trm_prod U T) as P1.
  induction Typ; intros; subst; try solve [contradictions].
  inversions H2. exists* i k.
  destructi~ IHTyp1 as [i' [k' [EQi [TypU [Univ [L TypT]]]]]].
  exists i' k'. use (@less_trans T0).
Qed.

Lemma typing_abs_inv : forall E V t P,
  typing E (trm_abs V t) P -> exists T, exists i,
     typing E (trm_prod V T) (trm_type i)
  /\ less (trm_prod V T) P
  /\ exists L, forall x, x \notin L -> typing (E & x ~ V) (t ^ x) (T ^ x).
Proof.
  introv Typ. gen_eq (trm_abs V t) as u.
  induction Typ; intros; subst; try solve [contradictions].
  inversions H1. exists* T i.
  destructi~ IHTyp1 as [T' [i' [TypP [LeP [L TypB]]]]].
  exists T' i'. use (@less_trans T).
Qed.

Lemma typing_prod_type_inv : forall E U T i,
  typing E (trm_prod U T) (trm_type i) ->
  exists L, forall x, x \notin L ->
      typing (E & x ~ U) (T ^ x) (trm_type i).
Proof.
  introv Typ.
  destruct (typing_prod_inv Typ) as [i' [k' [Le [TypU [Uni [L TypT]]]]]].
  exists (L \u dom E). intros.
  inversion Le; apply* (@typing_sub (trm_type i') (i+1)).
Qed.

(* ********************************************************************** *)
(** Typing preserved by Weakening *)

Lemma typing_weaken : forall G E F t T,
  typing (E & G) t T ->
  wf (E & F & G) ->
  typing (E & F & G) t T.
Proof.
  introv Typ. gen_eq (E & G) as Env. gen G.
  induction Typ; introv EQ W; subst; eauto.
  (* case: var *)
  apply* typing_var. apply* binds_weaken.
  (* case: trm_prod *)
  apply_fresh* (@typing_prod k) as y. apply_ih_bind* H0.
  (* case: trm_abs *)
  apply_fresh* (@typing_abs i) as y.
  destructi (IHTyp G) as TypP; auto.
  destruct (typing_prod_inv TypP) as [i' [k' [_ [TypU _]]]].
  apply_ih_bind* H0.
Qed.

(* ********************************************************************** *)
(** ** Subtyping preserved by Substitution *)

Lemma less_red_out : red_out less.
Proof.
  introz. puts conv_red_out; induction H0; simpl; auto.
  apply_fresh* less_prod as y. cross*.
  apply* (@less_trans ([x ~> u]U)).
Qed.

(* ********************************************************************** *)
(** Typing preserved by Substitution *)

Lemma typing_substitution : forall V F v E x t T,
  typing E v V ->
  typing (E & x ~ V & F) t T ->
  typing (E & (map (subst x v) F)) (subst x v t) (subst x v T).
Proof.
  introv Typv Typt.
  gen_eq (E & x ~ V & F) as G. gen F.
  apply typing_induct with
   (P := fun G t T (Typt : typing G t T) =>
      forall F, G = E & x ~ V & F ->
      typing (E & map (subst x v) F) ([x ~> v]t) ([x ~> v]T))
   (P0 := fun G (W:wf G) =>
      forall F, G = E & x ~ V & F ->
      wf (E & (map (subst x v) F)));
   intros; subst; simpls subst.
  (* case: trm_type *)
  auto*.
  (* case: var *)
  case_var.
    binds_get b.
     rewrite* subst_fresh. apply_empty* typing_weaken.
    binds_cases b.
      rewrite* subst_fresh.
      auto*.
  (* case: trm_prod *)
  apply_fresh* (@typing_prod k) as y.
   cross; auto. apply_ih_map_bind* H0.
  (* case: trm_abs *)
  apply_fresh* (@typing_abs i) as y.
   cross; auto. apply_ih_map_bind* H0.
  (* case: trm_app *)
  rewrite* subst_open.
  (* case: sub *)
  apply* (@typing_sub ([x ~> v]T0)). apply* less_red_out.
  (* case: wf nil *)
  contradictions. apply (eq_empty_inv H).
  (* case: wf cons *)
  destruct F as [|(y,a)]; simpls; env_fix.
    auto.
    destruct (eq_push_inv H0) as [e1 [e2 e3]].
     subst. apply* (@wf_cons i).
  (* case: conclusion *)
  auto.
Qed.

(* ********************************************************************** *)
(** Types are Themselves Well-typed *)

Lemma typing_wf_from_context : forall x U E,
  binds x U E ->
  wf E ->
  exists i, typing E U (trm_type i).
Proof.
  introv B W. induction E as [|(y,a)]; env_fix.
  inversion B.
  inversions B. inversions W. case_var.
    inversions H0. exists i. apply_empty* typing_weaken.
    destructi~ IHE as [k P]. exists k. apply_empty* typing_weaken.
Qed.

Lemma typing_wf_from_typing : forall E t T,
  typing E t T ->
  exists i, typing E T (trm_type i).
Proof.
  induction 1.
  exists* ((i+1)+1).
  destruct* (typing_wf_from_context H0).
  exists* (i+1).
  exists* i.
  destruct IHtyping1 as [i Typ].
   destruct (typing_prod_inv Typ) as [i' [k' [Le [TypU [Uni [L TypT]]]]]].
   exists i'.
   pick_fresh x. rewrite~ (@subst_intro x).
   unsimpl ([x ~> u](trm_type i')).
   apply_empty* (@typing_substitution U).
  exists* i.
Qed.

(* ********************************************************************** *)
(** Typing preserved by Subtyping in Environment *)

Inductive env_less : env -> env -> Prop :=
  | env_less_head : forall E U U' x,
      less U U' ->
      env_less (E & x ~ U) (E & x ~ U')
  | env_less_tail : forall E E' x U,
      term U -> env_less E E' -> env_less (E & x ~ U) (E' & x ~ U).

Hint Constructors env_less.

Lemma env_less_binds : forall x U E E',
  env_less E' E -> wf E -> wf E' -> binds x U E ->
     binds x U E'
  \/ exists U', exists i,
      binds x U' E' /\ less U' U /\ typing E' U (trm_type i).
Proof.
  induction 1; intros WfE WfE' Has;
  unfolds binds; simpls; case_var; env_fix.
    right. inversions Has. inversions WfE. exists U0 i.
     splits. auto. apply_empty* typing_weaken.
    left*.
    left*.
    inversions WfE. inversions WfE'.
    destruct~ IHenv_less as [|[U' [i' [P1 [P2 P3]]]]].
      right. exists U' i'. splits; auto. apply_empty* typing_weaken.
Qed.

Lemma typing_sub_env : forall E E' t T,
  typing E t T ->
  env_less E' E ->
  wf E' ->
  typing E' t T.
Proof.
 introv Typ. gen E'. induction Typ; intros E' C W; eauto.
 destruct (env_less_binds C H W H0) as [B |[U' [i [B [Le Typ]]]]].
   apply* typing_var.
   apply* (@typing_sub U' i).
  apply_fresh (@typing_prod k) as y; auto. apply* (H0 y).
  destructi~ (IHTyp E') as TypP.
  destruct (typing_prod_inv TypP) as [i' [k [_ [Typt1 _]]]].
  apply_fresh (@typing_abs i) as y; auto. apply* (H0 y).
Qed.

(* ********************************************************************** *)
(** Subject Reduction - Induction *)

Lemma subject_reduction_ind : forall E t t' T,
  typing E t T -> beta t t' -> typing E t' T.
Proof.
  introv Typ. gen t'.
  induction Typ; introv Red;
   try solve [ apply* typing_sub ]; inversions Red.

  (* case: trm_prod 1 *)
  apply_fresh* (@typing_prod k) as y.
   apply (@typing_sub_env (E & y ~ U)); eauto 7.

  (* case: trm_prod 2 *)
  apply_fresh* (@typing_prod k) as y.

  (* case: trm_abs 1 *)
  destructi~ (IHTyp (trm_prod t1' T)) as Typt1'T.
  destruct (typing_prod_type_inv Typt1'T) as [L2 TypT].
  apply* (@typing_sub (trm_prod t1' T) i).
    apply_fresh less_prod as y.
      auto.
      forward* (H y).
    apply_fresh* (@typing_abs i) as y.
     forward~ (TypT y) as K.
     apply (@typing_sub_env (E & y ~ U)); eauto 7.

  (* case: trm_abs 2 *)
  apply_fresh* (@typing_abs i) as y.

  (* case: trm_app - beta reduction *)
  destruct (typing_abs_inv Typ1) as [T' [i [TypP [LeP [L1 Typt2]]]]].
  destruct (typing_prod_inv TypP) as [i' [k [EQi [Typt1 [Uni [L2 TypT']]]]]].
  destruct (less_prod_prod_inv LeP) as [C [L3 LeT]].
  destruct (typing_wf_from_typing Typ1) as [j TypUT].
  destruct (typing_prod_type_inv TypUT) as [L4 TypT].
  pick_fresh x.
   rewrite* (@subst_intro x t2).
   rewrite* (@subst_intro x T).
  apply_empty (@typing_substitution t1).
    apply* (@typing_sub U k).
    apply (@typing_sub (T' ^ x) j); auto.
     apply* (@typing_sub_env (E & x ~ U)).

  (* case: trm_app 1 *)
  auto*.

  (* case: trm_app 2 *)
  destruct (typing_wf_from_typing Typ1) as [i TypUT].
  destruct (typing_prod_type_inv TypUT) as [L TypT].
  apply* (@typing_sub (T ^^ t2') i).
    apply less_conv. apply* conv_from_open_beta.
    pick_fresh x. rewrite* (@subst_intro x T).
     unsimpl (subst x u (trm_type i)).
     apply_empty* (@typing_substitution U).

Qed.

(* ********************************************************************** *)
(** Subject Reduction - Beta preserves typing  *)

Lemma subject_reduction_result : subject_reduction beta.
Proof.
  introv Red Typ. apply* subject_reduction_ind.
Qed.

(* ********************************************************************** *)
(** Subject Reduction - Beta Star preserves typing  *)

Lemma subject_reduction_star_result :
  subject_reduction (beta star).
Proof.
  introv H. induction* H. apply* subject_reduction_result.
Qed.