Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import Lia.
Require Import Language Tactical.
Require Import Subtyping.Splitable.

Set Printing Parentheses.

(** * Definition *)

Inductive sub : type -> type -> Prop :=
| Sub_Int :
    sub Int Int
| Sub_Top : forall A,
    sub A Top
| Sub_Arr : forall A B C D,
    sub C A -> sub B D ->
    ordinary D ->
    sub (Arr A B) (Arr C D)
| Sub_Rcd : forall A B l,
    ordinary B ->
    sub A B ->
    sub (Rcd l A) (Rcd l B)
| Sub_And : forall A B B1 B2,
    splitable B B1 B2 ->
    sub A B1 -> sub A B2 ->
    sub A B
| Sub_And_L : forall A B C,
    sub A C -> ordinary C ->
    sub (And A B) C
| Sub_And_R : forall A B C,
    sub B C -> ordinary C ->
    sub (And A B) C.

Hint Constructors sub : core.

Notation "A <: B" := (sub A B) (at level 40).

(** * Generlization *)

(** generlization of [Sub_Arrow] *)

Lemma sub_arrow :
  forall A B C D,
    sub B D ->
    sub C A ->
    sub (Arr A B) (Arr C D).
Proof.
  introv H. dependent induction H; eauto.
Qed.

(** generlization of [Sub_Rcd] *)

Lemma sub_record :
  forall l A B,
    sub A B ->
    sub (Rcd l A) (Rcd l B).
Proof.
  introv H. dependent induction H; eauto.
Qed.

(** generlization of [Sub_And_L] *)

Lemma sub_and_l :
  forall A B C,
    sub A C -> sub (And A B) C.
Proof.
  introv H.
  dependent induction H; eauto.
Qed.

(** generlization of [Sub_And_R] *)

Lemma sub_and_r :
  forall A B C,
    sub B C -> sub (And A B) C.
Proof.
  introv H.
  dependent induction H; eauto.
Qed.

(** add it to local and global hint base **)

Hint Resolve sub_arrow : core.
Hint Resolve sub_record : core.
Hint Resolve sub_and_l : core.
Hint Resolve sub_and_r : core.

(** * Reflexivity *)

Lemma sub_reflexivity:
  forall A,
    sub A A.
Proof.
  dependent induction A; eauto.
Qed.

Hint Resolve sub_reflexivity : core.

(** * Subtyping & Splitable *)

Lemma sub_splitable_l :
  forall A A1 A2,
    splitable A A1 A2 -> sub A A1.
Proof.
  introv H. dependent induction H; eauto.
Qed.

Lemma sub_splitable_r :
  forall A A1 A2,
    splitable A A1 A2 -> sub A A2.
Proof.
  introv H. dependent induction H; eauto.
Qed.

Hint Resolve sub_splitable_l : subtyping.
Hint Resolve sub_splitable_r : subtyping.

Lemma sub_splitable:
  forall A A1 A2,
    splitable A A1 A2 -> sub A (And A1 A2) /\ sub (And A1 A2) A.
Proof.
  introv H. split.
  - eapply Sub_And; eauto with subtyping.
  - dependent induction H; eauto with subtyping.
Qed.

Hint Resolve sub_splitable : subtyping.

(** * Inversion Lemmas *)

Lemma sub_inv_splitable_l :
  forall A B A1 A2,
    sub A B -> splitable A A1 A2 -> ordinary B -> sub A1 B \/ sub A2 B.
Proof.
  introv Sub Spl Ord. gen A1 A2.
  induction Sub; eauto; intros.
  - dependent destruction Spl.
    dependent destruction Ord.
    pose proof (IHSub2 H _ _ Spl) as IH.
    destruct IH; eauto with subtyping.
  - dependent destruction Spl.
    dependent destruction Ord.
    pose proof (IHSub Ord _ _ Spl) as IH.
    destruct IH; eauto with subtyping.
  - dependent destruction Spl.
    left. assumption.
  - dependent destruction Spl.
    right. assumption.
Qed.

Lemma sub_inv_splitable_r :
  forall A B B1 B2,
    sub A B -> splitable B B1 B2 -> sub A B1 /\ sub A B2.
Proof.
  introv Sub Spl.
  dependent destruction Sub; eauto with subtyping.
  subst_splitable; intuition.
Qed.

(** * Proper Types *)

(** ** Definition *)

Inductive proper : type -> Prop :=
| Pr_Int : proper Int
| Pr_Top : proper Top
| Pr_Arr : forall A B,
    ordinary B ->
    proper A -> proper B ->
    proper (Arr A B)
| Pr_Rcd : forall l A,
    ordinary A ->
    proper A ->
    proper (Rcd l A)
| Pr_Spl : forall A A1 A2,
    splitable A A1 A2 ->
    proper A1 -> proper A2 ->
    proper A.

Hint Constructors proper : core.

(** ** Completeness *)

Lemma proper_arrow :
  forall A B,
    proper A -> proper B ->
    proper (Arr A B).
Proof.
  introv Pr_A Pr_B.
  gen A.
  induction Pr_B; eauto.
Qed.

Lemma proper_record :
  forall l A,
    proper A ->
    proper (Rcd l A).
Proof.
  introv Pr_A.
  induction Pr_A; eauto.
Qed.

Lemma proper_complete:
  forall (A : type), proper A.
Proof.
  induction A; eauto.
  eapply proper_arrow; eauto.
  eapply proper_record; eauto.
Qed.

(** We build a new induction principle for [type] *)

(** ** Proper Induction Principle *)

Ltac proper_ind A := assert (Pr: proper A)
    by apply (proper_complete A); induction Pr.

(** * Transitivity *)

Lemma sub_transitivity:
  forall A B C,
    sub A B -> sub B C -> sub A C.
Proof.
  introv Sub1 Sub2.
  gen A C.
  proper_ind B; intros.
  - dependent induction Sub2; eauto.
  - dependent induction Sub2; eauto.
  - dependent induction Sub2; eauto.
    clear IHSub2_1 IHSub2_2.
    dependent induction Sub1; eauto with subtyping.
  - dependent induction Sub2; eauto.
    clear IHSub2.
    dependent induction Sub1; eauto with subtyping.
  - gen A A1.
    proper_ind C; introv Sub1 Sub2 Spl IPr IH; eauto with subtyping.
    + eapply sub_inv_splitable_r in Sub1; eauto. destruct Sub1.
      eapply sub_inv_splitable_l in Sub2; eauto. intuition.
    + eapply sub_inv_splitable_r in Sub1; eauto. destruct Sub1.
      eapply sub_inv_splitable_l in Sub2; eauto. intuition.
    + eapply sub_inv_splitable_r in Sub1; eauto. destruct Sub1.
      eapply sub_inv_splitable_l in Sub2; eauto. intuition.
    + eapply sub_inv_splitable_r in Sub2; eauto.
      destruct Sub2; eauto.
Qed.

(** * Isomorphic Subtyping *)

(** ** Definition *)

Inductive isosub : type -> type -> Prop :=
| Isub_Refl : forall (A : type),
    isosub A A
| Isub_Rcd : forall l A B,
    isosub A B ->
    isosub (Rcd l A) (Rcd l B)
| Isub_And : forall (A1 A2 B B1 B2 : type),
    splitable B B1 B2 ->
    isosub A1 B1 ->
    isosub A2 B2 ->
    isosub (And A1 A2) B.

Hint Constructors isosub : core.

Notation "A ≋ B" := (isosub A B) (at level 40).

(** ** Transitivity *)

Lemma isosub_inv_splitable :
  forall A A1 A2 B,
    isosub A B ->
    splitable A A1 A2 ->
    exists B1 B2, splitable B B1 B2 /\ isosub A1 B1 /\ isosub A2 B2.
Proof.
  introv Isub Spl. gen A1 A2.
  induction Isub; intros.
  - eexists. eexists. eauto.
  - dependent destruction Spl.
    pose proof (IHIsub _ _ Spl). destruct H. destruct H. destruct_conjs.
    exists (Rcd l x). exists (Rcd l x0). intuition.
  - dependent destruction Spl.
    exists B1. exists B2. split; eauto.
Qed.

Lemma isosub_transitivity :
  forall A B C,
    isosub A B -> isosub B C ->
    isosub A C.
Proof.
  introv Isub1 Isub2. ind_type_size (size_type B).
  dependent destruction Isub2; eauto.
  - dependent destruction Isub1; simpl in SizeInd; eauto.
    + eapply Isub_Rcd. eapply IH; eauto; try lia.
    + dependent destruction H.
      pose proof (isosub_inv_splitable _ _ _ _ Isub2 H) as Isubs.
      pose proof (splitable_decrease_size _ _ _ H). destruct_conjs.
      eapply Isub_And; eauto; eapply IH; eauto; simpl in *; try lia.
  - dependent destruction Isub1; simpl in SizeInd; eauto.
    dependent destruction H.
    pose proof (splitable_decrease_size _ _ _ H0).
    destruct_conjs.
    eapply Isub_And; eauto; eapply IH; eauto; simpl in *; try lia.
Qed.

(** ** Specficiation *)

Definition isomorphic_spec A B :=
  sub A B /\ sub B A.

Lemma isosub_sound :
  forall A B,
    isosub A B -> isomorphic_spec A B.
Proof.
  introv Isub. unfold isomorphic_spec.
  split.
  - Case "sub A B".
    induction Isub; eauto with subtyping.
  - Case "sub B A".
    induction Isub; eauto with subtyping.
    eapply Sub_And; eauto.
    + eapply sub_splitable in H. destruct H.
      pose proof (sub_and_l B1 B2 A1 IHIsub1).
      eapply sub_transitivity; eauto.
    + eapply sub_splitable in H. destruct H.
      pose proof (sub_and_r B1 B2 A2 IHIsub2).
      eapply sub_transitivity; eauto.
Qed.

(** * Subtyping & Isomorphic Subtyping *)

Lemma isosub_to_sub1 :
  forall A B,
    isosub A B -> sub A B.
Proof.
  introv Isub.
  pose proof (isosub_sound _ _ Isub).
  unfold isomorphic_spec in H.
  destruct H; assumption.
Qed.

Lemma isosub_to_sub2 :
  forall A B,
    isosub A B -> sub B A.
Proof.
  introv Isub.
  pose proof (isosub_sound _ _ Isub).
  unfold isomorphic_spec in H.
  destruct H; assumption.
Qed.

(** * Automations *)

(** ** Absurd Cases *)

Lemma sub_arrow_int :
  forall A B,
    sub (Arr A B) Int -> False.
Proof.
  introv Sub.
  dependent destruction Sub; eauto.
Qed.

Ltac solve_sub :=
  match goal with
  | [H: sub (Arr _ _) Int |- _] =>
      (pose proof (sub_arrow_int _ _ H) as Contra; inversion Contra)
  end.

Hint Extern 5 => solve_sub : core.


Require Import init.

Require Export card_base.
Require Import card_order.
Require Import card_plus.
Require Import card_mult.
Require Import card_nat.
Require Import set.
Require Import set_induction.
Require Import function.
Require Export nat.
Require Import mult_div.
Require Import nat_domain.

(* begin hide *)
Open Scope card_scope.
(* end hide *)
Definition finite κ := κ < |nat|.
Definition countable κ := κ ≤ |nat|.
Definition denumerable κ := κ = |nat|.
Definition infinite κ := |nat| ≤ κ.
Definition uncountable κ := |nat| < κ.

Theorem finite_is_countable : ∀ κ, finite κ → countable κ.
Proof.
    intros κ H.
    apply H.
Qed.
Theorem denumerable_is_countable : ∀ κ, denumerable κ → countable κ.
Proof.
    intros κ H.
    unfold denumerable, countable in *.
    rewrite H.
    apply refl.
Qed.
Theorem denumerable_is_infinite : ∀ κ, denumerable κ → infinite κ.
Proof.
    intros κ H.
    unfold denumerable, infinite in *.
    rewrite H.
    apply refl.
Qed.
Theorem uncountable_is_infinite : ∀ κ, uncountable κ → infinite κ.
Proof.
    intros κ H.
    apply H.
Qed.

Theorem nat_is_finite : ∀ n, finite (nat_to_card n).
Proof.
    assert (∀ n, nat_to_card n ≤ |nat|) as n_countable.
    {
        intros n.
        unfold nat_to_card, le; equiv_simpl.
        exists (λ x, [x|]).
        split.
        intros a b eq.
        apply set_type_eq.
        exact eq.
    }
    intros n.
    split; try apply n_countable.
    nat_induction n.
    -   intro contr.
        unfold nat_to_card in contr; equiv_simpl in contr.
        destruct contr as [f f_bij].
        pose proof (sur f 0) as [x x_eq].
        exact (nat_lt_0_false x).
    -   intro eq.
        apply IHn; clear IHn.
        apply antisym.
        1: apply n_countable.
        symmetry in eq.
        unfold nat_to_card in eq; unfold nat_to_card, le.
        equiv_simpl; equiv_simpl in eq.
        destruct eq as [f f_bij].
        pose proof (sur f [n|nat_lt_suc n]) as [m m_eq].
        pose (g x := If x < m then f x else f (nat_suc x)).
        assert (∀ x, [g x|] < n) as g_lt.
        {
            intros x.
            unfold g.
            case_if.
            -   pose proof [|f x] as fx_lt.
                cbn in fx_lt.
                rewrite nat_lt_suc_le in fx_lt.
                split; try exact fx_lt.
                intro contr.
                assert (f x = [n|nat_lt_suc n]) as eq
                    by (apply set_type_eq; exact contr).
                rewrite <- eq in m_eq.
                apply f_bij in m_eq.
                symmetry in m_eq.
                destruct s; contradiction.
            -   pose proof [|f (nat_suc x)] as fx_lt.
                cbn in fx_lt.
                rewrite nat_lt_suc_le in fx_lt.
                split; try exact fx_lt.
                intro contr.
                assert (f (nat_suc x) = [n|nat_lt_suc n]) as eq
                    by (apply set_type_eq; exact contr).
                rewrite <- eq in m_eq.
                apply f_bij in m_eq.
                rewrite m_eq in n0.
                pose proof (nat_lt_suc x).
                contradiction.
        }
        exists (λ x, [[g x|] | g_lt x]).
        split.
        intros a b eq.
        unfold g in eq.
        inversion eq as [eq2].
        apply set_type_eq in eq2.
        clear eq.
        do 2 case_if.
        all: apply f_bij in eq2.
        +   exact eq2.
        +   rewrite eq2 in s.
            rewrite nlt_le in n0.
            pose proof (trans (le_lt_trans n0 (nat_lt_suc b)) s) as [eq neq].
            contradiction.
        +   rewrite <- eq2 in s.
            rewrite nlt_le in n0.
            pose proof (trans (le_lt_trans n0 (nat_lt_suc a)) s) as [eq neq].
            contradiction.
        +   inversion eq2.
            reflexivity.
Qed.

Theorem greater_all_nat_inf : ∀ κ, (∀ a, nat_to_card a < κ) → infinite κ.
Proof.
    intros A A_gt.
    equiv_get_value A.
    assert (∀ (p : nat) (f : set_type (λ x, x < p) → A),
        ∃ a, ∀ n, f n ≠ a) as h_ex.
    {
        intros fp ff; cbn.
        classic_case (Surjective ff).
        -   assert (|A| ≤ nat_to_card fp) as leq.
            {
                unfold nat_to_card, le; equiv_simpl.
                apply (partition_principle ff s).
            }
            pose proof (lt_le_trans (A_gt fp) leq) as [C0 C1].
            contradiction.
        -   assert (∃ a, ∀ x, ff x ≠ a) as [a A_nsur].
            {
                classic_contradiction contr.
                apply n; split.
                rewrite not_ex in contr.
                intros y.
                specialize (contr y).
                rewrite not_all in contr.
                destruct contr as [a neq].
                exists a.
                rewrite not_not in neq.
                exact neq.
            }
            exists a; clear n.
            intros n.
            apply A_nsur.
    }
    pose proof (transfinite_recursion A (λ p f, ex_val (h_ex p f))) as [f f_rec].
    unfold infinite.
    unfold le; equiv_simpl.
    exists f.

    assert (∀ m n, m < n → f m ≠ f n) as wlog.
    {
        intros m n ltq.
        specialize (f_rec n).
        rewrite_ex_val a a_eq; cbn in *.
        specialize (a_eq [m|ltq]).
        cbn in a_eq.
        rewrite <- f_rec in a_eq.
        exact a_eq.
    }
    split.
    intros m n eq.
    classic_contradiction contr.
    destruct (trichotomy m n) as [[ltq|eq2]|ltq]; try contradiction.
    -   specialize (wlog _ _ ltq).
        contradiction.
    -   specialize (wlog _ _ ltq).
        symmetry in eq.
        contradiction.
Qed.

Theorem fin_nat_ex : ∀ κ, finite κ → ∃ n, nat_to_card n = κ.
Proof.
    intros κ κ_fin.
    assert (∃ n, κ ≤ nat_to_card n) as κ_le.
    {
        classic_contradiction contr.
        rewrite not_ex in contr.
        unfold finite in κ_fin.
        rewrite <- nle_lt in κ_fin.
        apply κ_fin; clear κ_fin.
        apply greater_all_nat_inf.
        intros a.
        rewrite <- nle_lt.
        apply contr.
    }
    pose proof (well_ordered _ κ_le) as [m [κ_le_m m_min]]; clear κ_le.
    exists m.
    classic_contradiction contr.
    rewrite neq_sym in contr.
    nat_destruct m.
    -   pose proof (antisym κ_le_m (card_le_zero κ)).
        contradiction.
    -   assert (κ ≤ nat_to_card m) as κ_le_m2.
        {
            equiv_get_value κ.
            rename κ into A.
            unfold le, nat_to_card; equiv_simpl.
            unfold le, nat_to_card in κ_le_m; equiv_simpl in κ_le_m.
            destruct κ_le_m as [f f_inj].
            unfold nat_to_card in contr; equiv_simpl in contr.
            rewrite not_ex in contr.
            specialize (contr f).
            assert (∃ y, ∀ x, f x ≠ y) as [y no_x].
            {
                classic_contradiction contr2.
                apply contr.
                split; [>exact f_inj|].
                split.
                intros y.
                rewrite not_ex in contr2.
                specialize (contr2 y).
                rewrite not_all in contr2.
                destruct contr2 as [a neq].
                exists a.
                rewrite not_not in neq.
                exact neq.
            }
            clear contr.
            classic_case ([y|] = m) as [eq|neq].
            -   assert (∀ x, [f x|] < m) as f_lt.
                {
                    intros x.
                    pose proof [|f x] as fx_lt; cbn in fx_lt.
                    rewrite nat_lt_suc_le in fx_lt.
                    split; try exact fx_lt.
                    intro contr.
                    rewrite <- eq in contr.
                    apply set_type_eq in contr.
                    exact (no_x _ contr).
                }
                exists (λ x, [[f x|]|f_lt x]).
                split.
                intros a b eq2.
                inversion eq2 as [eq3].
                apply set_type_eq in eq3.
                apply f_inj in eq3.
                exact eq3.
            -   pose (g x := If [f x|] = m then [y|] else [f x|]).
                assert (∀ x, g x < m) as g_lt.
                {
                    intros x; unfold g.
                    case_if.
                    -   destruct y as [y y_lt]; cbn in *.
                        pose proof y_lt as y_lt2.
                        rewrite nat_lt_suc_le in y_lt2.
                        split; assumption.
                    -   split; try exact n.
                        pose proof [|f x] as fx_lt; cbn in fx_lt.
                        rewrite nat_lt_suc_le in fx_lt.
                        exact fx_lt.
                }
                exists (λ x, [g x|g_lt x]).
                split.
                intros a b eq.
                inversion eq as [eq2].
                unfold g in eq2.
                do 2 case_if; apply set_type_eq in eq2.
                +   rewrite <- e0 in e; clear e0.
                    apply set_type_eq in e.
                    apply f_inj in e.
                    exact e.
                +   specialize (no_x b).
                    symmetry in eq2; contradiction.
                +   specialize (no_x a).
                    contradiction.
                +   apply f_inj in eq2.
                    exact eq2.
        }
        specialize (m_min _ κ_le_m2).
        rewrite <- nlt_le in m_min.
        apply m_min.
        apply nat_lt_suc.
Qed.

Theorem simple_finite_finite : ∀ U, simple_finite U ↔ finite (|U|).
Proof.
    intros U.
    split; intros fin.
    -   apply simple_finite_bij in fin as [n [f f_bij]].
        assert (|U| = nat_to_card n) as eq.
        {
            unfold nat_to_card; equiv_simpl.
            exists f.
            exact f_bij.
        }
        rewrite eq.
        apply nat_is_finite.
    -   apply fin_nat_ex in fin.
        destruct fin as [n n_eq].
        symmetry in n_eq.
        unfold nat_to_card in n_eq; equiv_simpl in n_eq.
        destruct n_eq as [f f_bij].
        exists n, f.
        apply f_bij.
Qed.

Theorem inf_not_nat : ∀ κ, infinite κ → ∀ n, nat_to_card n ≠ κ.
Proof.
    intros κ κ_inf n eq.
    subst.
    pose proof (nat_is_finite n) as fin.
    unfold infinite, finite in *.
    pose proof (lt_le_trans fin κ_inf) as [C0 C1]; contradiction.
Qed.

Theorem inf_plus_fin : ∀ κ μ, infinite κ → finite μ → κ + μ = κ.
Proof.
    intros A B A_inf B_fin.
    pose proof (fin_nat_ex B B_fin) as [n n_eq].
    subst; clear B_fin.
    equiv_get_value A.
    unfold nat_to_card, plus; equiv_simpl.
    unfold infinite, le in A_inf; equiv_simpl in A_inf.
    destruct A_inf as [f f_inj].
    exists (λ x, match x with
        | inl a =>
            match (sem (∃ n, f n = a)) with
                | strong_or_left H => f (ex_val H + n)
                | strong_or_right _ => a
                end
        | inr n => f [n|]
        end
    ).
    split; split.
    -   intros [a|[a a_lt]] [b|[b b_lt]] eq.
        +   do 2 destruct (sem _).
            *   apply f_inj in eq.
                apply plus_rcancel in eq.
                rewrite_ex_val aa aaa.
                rewrite_ex_val bb bbb.
                subst.
                reflexivity.
            *   rewrite_ex_val x xH.
                subst.
                rewrite not_ex in n0.
                specialize (n0 (x + n)).
                contradiction.
            *   rewrite_ex_val x xH.
                subst.
                rewrite not_ex in n0.
                specialize (n0 (x + n)).
                contradiction.
            *   rewrite eq; reflexivity.
        +   destruct (sem _).
            *   cbn in eq.
                apply f_inj in eq.
                exfalso.
                rewrite <- eq in b_lt.
                rewrite <- (plus_lid n) in b_lt at 2.
                apply lt_plus_rcancel in b_lt.
                contradiction (nat_neg2 b_lt).
            *   cbn in eq.
                rewrite not_ex in n0.
                specialize (n0 b).
                symmetry in eq; contradiction.
        +   cbn in eq.
            destruct (sem _).
            *   apply f_inj in eq.
                exfalso.
                rewrite eq in a_lt.
                rewrite <- (plus_lid n) in a_lt at 2.
                apply lt_plus_rcancel in a_lt.
                contradiction (nat_neg2 a_lt).
            *   rewrite not_ex in n0.
                specialize (n0 a).
                contradiction.
        +   cbn in eq.
            apply f_inj in eq.
            apply f_equal.
            apply set_type_eq; cbn.
            exact eq.
    -   intros y.
        classic_case (∃ m, f m = y) as [ex|not_ex].
        +   destruct ex as [m m_eq].
            classic_case (m < n) as [ltq|nltq].
            *   exists (inr [m|ltq]).
                exact m_eq.
            *   rewrite nlt_le in nltq.
                apply nat_le_ex in nltq as [c c_eq].
                exists (inl (f c)).
                destruct (sem _) as [ex|nex].
                --  rewrite_ex_val x xH.
                    apply f_inj in xH.
                    subst.
                    rewrite plus_comm.
                    reflexivity.
                --  rewrite not_ex in nex.
                    subst.
                    specialize (nex c).
                    contradiction.
        +   exists (inl y).
            destruct (sem _) as [ex|nex]; try contradiction.
            reflexivity.
Qed.

Theorem nat_mult_nat : |nat| * |nat| = |nat|.
Proof.
    assert (|nat| = |set_type (λ n, 0 ≠ n)|) as eq.
    {
        assert (∀ n, 0 ≠ nat_suc n) as suc_neq by (intros n c; inversion c).
        equiv_simpl.
        exists (λ n, [nat_suc n | suc_neq n]).
        split; split.
        -   intros a b eq.
            inversion eq.
            reflexivity.
        -   intros [y y_neq].
            nat_destruct y; try contradiction.
            exists y.
            apply set_type_eq; reflexivity.
    }
    rewrite eq at 3; clear eq.
    unfold mult; equiv_simpl.
    pose (f (x : nat * nat) := (2 ^ (fst x) * (2 * snd x + 1))%nat).
    assert (∀ x, 0 ≠ f x) as f_in.
    {
        intros [x1 x2] eq.
        unfold f in eq; cbn in eq.
        apply mult_zero in eq.
        destruct eq as [eq|eq].
        -   apply nat_pow_not_zero in eq; try contradiction.
            intro contr; inversion contr.
        -   apply nat_plus_zero in eq.
            destruct eq as [C0 C1]; inversion C1.
    }
    exists (λ x, [f x|f_in x]).
    assert ((zero (U := nat)) ≠ 2) as two_nz by (intro C; inversion C).
    split; split.
    -   intros [a1 a2] [b1 b2] eq.
        unfold f in eq; cbn in eq.
        inversion eq as [eq2].
        clear eq.
        revert b1 eq2.
        nat_induction a1.
        +   intros b1 eq.
            rewrite nat_pow_zero, mult_lid in eq.
            nat_destruct b1.
            *   rewrite nat_pow_zero, mult_lid in eq.
                apply plus_rcancel in eq.
                apply nat_mult_lcancel in eq; try exact two_nz.
                rewrite eq; reflexivity.
            *   rewrite nat_pow_suc in eq.
                rewrite (mult_comm _ 2) in eq.
                rewrite <- mult_assoc in eq.
                do 2 rewrite (mult_comm 2) in eq.
                symmetry in eq.
                apply nat_even_neq_odd in eq.
                contradiction.
        +   intros b1 eq.
            nat_destruct b1.
            *   rewrite nat_pow_zero, mult_lid in eq.
                rewrite nat_pow_suc in eq.
                rewrite (mult_comm _ 2) in eq.
                rewrite <- mult_assoc in eq.
                do 3 rewrite (mult_comm 2) in eq.
                apply nat_even_neq_odd in eq.
                contradiction.
            *   do 2 rewrite nat_pow_suc in eq.
                do 2 rewrite (mult_comm _ 2) in eq.
                do 2 rewrite <- mult_assoc in eq.
                apply mult_lcancel in eq; try exact two_nz.
                specialize (IHa1 _ eq).
                inversion IHa1.
                reflexivity.
    -   intros [y y_nz].
        pose (S n := ¬((2 ^ n)%nat ∣ y)).
        assert (∃ n, S n) as S_ex.
        {
            exists y.
            unfold S.
            intros div.
            apply nat_div_le in div; try exact y_nz.
            assert (∀ n, nat_suc n < (2^(nat_suc n))%nat) as ltq.
            {
                clear.
                nat_induction n.
                -   rewrite nat_pow_one.
                    split.
                    +   unfold le, one, plus; cbn.
                        exact true.
                    +   intro contr; inversion contr.
                -   rewrite nat_pow_suc.
                    apply lt_lplus with 1 in IHn.
                    change (1 + nat_suc n) with (nat_suc (nat_suc n)) in IHn.
                    apply (trans IHn).
                    rewrite ldist.
                    rewrite mult_rid.
                    apply lt_rplus.
                    clear IHn.
                    nat_induction n.
                    +   rewrite nat_pow_one.
                        split.
                        *   unfold one, plus, le; cbn.
                            exact true.
                        *   intro contr; inversion contr.
                    +   apply (trans IHn).
                        rewrite (nat_pow_suc _ (nat_suc n)).
                        rewrite ldist.
                        rewrite mult_rid.
                        rewrite <- plus_lid at 1.
                        apply lt_rplus.
                        split; try apply nat_pos.
                        intro contr.
                        rewrite <- contr in IHn.
                        pose proof (lt_le_trans IHn (nat_pos 1))
                            as [C0 C1]; contradiction.
            }
            nat_destruct y.
            -   rewrite nat_pow_zero in div.
                pose proof (le_lt_trans div (make_and (nat_pos 1) not_trivial_one))
                    as [C0 C1]; contradiction.
            -   specialize (ltq y).
                pose proof (lt_le_trans ltq div) as [C0 C1]; contradiction.
        }
        pose proof (well_ordered S S_ex) as [x1 [Sx1 x1_min]].
        nat_destruct x1.
        {
            unfold S in Sx1.
            rewrite nat_pow_zero in Sx1.
            pose proof (one_divides y).
            contradiction.
        }
        unfold S in Sx1.
        assert ((2^x1)%nat ∣ y) as x1_div.
        {
            classic_contradiction contr.
            specialize (x1_min _ contr).
            rewrite <- nlt_le in x1_min.
            pose proof (nat_lt_suc x1).
            contradiction.
        }
        destruct x1_div as [c c_eq].
        assert (odd c) as c_odd.
        {
            intros [d d_eq].
            subst c.
            rewrite <- (nat_pow_one 2) in c_eq at 1.
            rewrite <- mult_assoc in c_eq.
            rewrite <- nat_pow_plus in c_eq.
            change (1 + x1) with (nat_suc x1) in c_eq.
            unfold divides in Sx1.
            rewrite not_ex in Sx1.
            specialize (Sx1 d).
            contradiction.
        }
        apply nat_odd_plus_one in c_odd as [x2 x2_eq].
        exists (x1, x2).
        apply set_type_eq; cbn.
        unfold f; cbn.
        rewrite <- c_eq.
        rewrite x2_eq.
        apply mult_comm.
Qed.
(* begin hide *)
Close Scope card_scope.
(* end hide *)


(******************************************)
(*   Finite multiset library              *)
(*   Developped for the PACTOLE project   *)
(*   L. Rieg                              *)
(*                                        *)
(*   This file is distributed under       *)
(*   the terms of the CeCILL-C licence    *)
(*                                        *)
(******************************************)

(* Require Import MMapInterface. *)
Require Import Arith_base.
Require Import Lia.
Require Import PArith.
Require Import Bool.
Require Import RelationPairs.
Require Import SetoidList.
Require Import Pactole.Util.FMaps.FMapInterface.
Require Import Pactole.Util.FMaps.FMapFacts.
Require Import Pactole.Util.MMultiset.Preliminary.
Require Import Pactole.Util.MMultiset.MMultisetInterface.
Require Import SetoidDec.

Section WMapImplementation.
Context (elt : Type).
Context (elt_Setoid : Setoid elt).
Context (elt_EqDec : @EqDec elt elt_Setoid).
Context (MapImpl : @FMap elt elt_Setoid elt_EqDec).
Context (MapSpec : FMapSpecs MapImpl).

Definition m_multiplicity :=
  fun x m => match find x m with Some n => Pos.to_nat n | None => 0 end.
Definition m_add := fun x n m =>
    if eq_nat_dec n 0 then m else FMapInterface.add x (Pos.of_nat (m_multiplicity x m + n)) m.
Definition m_fold := fun {A} (f : elt -> nat -> A -> A) m =>
  FMapInterface.fold (fun x y => f x (Pos.to_nat y)) m.

Global Instance FMOps_WMap : FMOps elt elt_EqDec := {|
  multiset := Map[elt, positive];
  empty := FMapInterface.empty positive;
  is_empty := FMapInterface.is_empty;
  multiplicity := m_multiplicity;
  add := m_add;
  singleton x n :=
    if eq_nat_dec n 0 then FMapInterface.empty _ else FMapInterface.add x (Pos.of_nat n) (FMapInterface.empty _);
  remove x n m := if eq_nat_dec n 0 then m else
    if le_lt_dec (m_multiplicity x m) n then FMapInterface.remove x m
    else FMapInterface.add x (Pos.of_nat (m_multiplicity x m - n)) m;
  union := fun m m' => m_fold m_add m m';
  inter := fun m m' => m_fold (fun x n acc => m_add x (min (m_multiplicity x m) n) acc) m' (FMapInterface.empty _);
  diff := fun m m' => m_fold (fun x n acc => m_add x (n - m_multiplicity x m') acc) m (FMapInterface.empty _);
  lub := fun m m' => m_fold (fun x n acc => m_add x (n - (m_multiplicity x m')) acc) m m';
  equal := fun m m' => FMapInterface.equal Pos.eqb m m';
  subset := fun m m' => FMapInterface.is_empty
              (m_fold (fun x n acc => m_add x (n - m_multiplicity x m') acc) m (FMapInterface.empty _));
  fold := @m_fold;
  for_all := fun f m => m_fold (fun x n b => b && f x n) m true;
  exists_ := fun f m => m_fold (fun x n b => b || f x n) m false;
  nfilter := fun f m => m_fold (fun x n acc => if f x n then m_add x n acc else acc) m (FMapInterface.empty _);
  filter := fun f m => m_fold (fun x n acc => if f x then m_add x n acc else acc) m (FMapInterface.empty _);
  npartition := fun (f : elt -> nat -> bool) m => m_fold
                  (fun x n acc => if f x n then (m_add x n (fst acc), snd acc) else (fst acc, m_add x n (snd acc)))
                  m (FMapInterface.empty _, FMapInterface.empty _);
  partition := fun (f : elt -> bool) m => m_fold
                 (fun x n acc => if f x then (m_add x n (fst acc), snd acc) else (fst acc, m_add x n (snd acc)))
                  m (FMapInterface.empty _, FMapInterface.empty _);
  elements := fun m => List.map (fun xy => (fst xy, Pos.to_nat (snd xy))) (FMapInterface.elements m);
  support := fun m => FMapInterface.fold (fun x _ l => cons x l) m nil;
  cardinal := fun m => FMapInterface.fold (fun _ n acc => Pos.to_nat n + acc) m 0;
  size := fun m => FMapInterface.fold (fun _ _ n => S n) m 0;
  choose := fun m =>  FMapInterface.fold (fun x _ _ => Some x) m None |}.
Local Arguments multiplicity : simpl nomatch.

(** **  Compatibility properties  **)

Instance pre_multiplicity_compat : Proper (equiv ==> Equal ==> Logic.eq) multiplicity.
Proof using MapSpec.
intros x y Hxy m m' Hm. simpl. unfold m_multiplicity. rewrite Hm.
assert (Heq : find x m' = find y m') by now apply find_m.
now rewrite Heq.
Qed.

Instance m_add_compat : Proper (equiv ==> Logic.eq ==> Equal ==> Equal) m_add.
Proof using MapSpec.
intros x y Hxy ? n ? m m' Hm z. subst. unfold m_add.
destruct (Nat.eq_dec n 0).
- apply Hm.
- cbn. apply add_m; trivial. do 2 f_equal. rewrite Hxy. unfold m_multiplicity. now rewrite Hm.
Qed.

Global Instance eq_pair_equiv : Equivalence eq_pair.
Proof using . split. easy. easy. intros ? y ? ? ?. now transitivity y. Qed.

Global Instance eq_pair_Setoid : Setoid (elt * positive)%type := _.

Global Instance eq_pair_EqDec : @EqDec (elt * positive)%type _.
Proof.
intros [x n] [y p]. destruct (equiv_dec x y).
+ destruct (Pos.eq_dec n p).
  - left. now split; cbn.
  - right. intro Heq. now destruct Heq.
+ right. intro Heq. now destruct Heq.
Defined.

Global Instance eq_elt_equiv : Equivalence eq_elt.
Proof using . split. easy. easy. intros ? y ? ? ?. now transitivity y. Qed.

Global Instance eq_elt_Setoid : Setoid (elt * nat)%type := {| equiv := eq_elt; setoid_equiv := _ |}.

Global Instance eq_elt_EqDec : @EqDec (elt * nat)%type _.
Proof.
intros [x n] [y p]. destruct (equiv_dec x y); now left + right; cbn.
Defined.

Global Instance eq_pair_elt_subrelation : subrelation eq_pair eq_elt.
Proof using . intros x y [H _]. apply H. Qed.

Global Instance eq_key_eq_key_elt_subrelation : subrelation (@eq_key_elt elt _ _ _ positive) eq_key.
Proof using . intros x y [H _]. apply H. Qed.

Global Instance multiset_Setoid : Setoid (multiset elt).
refine {| equiv := fun m m' => forall x, m[x] = m'[x] |}.
Proof. split; repeat intro; solve [ eauto | etransitivity; eauto ]. Defined.

Global Instance multiplicity_compat : Proper (equiv ==> equiv ==> Logic.eq) MMultisetInterface.multiplicity.
Proof using MapSpec.
intros x y Hxy m m' Hm. rewrite Hm. simpl. unfold m_multiplicity.
assert (Heq : find x m' = find y m') by now apply find_m.
now rewrite Heq.
Qed.

(** ***  Preliminary results  **)

Lemma eq_pair_elt_weak_In : forall x y n m l,
  x == y -> InA eq_pair (x, n) l -> InA eq_elt (y, m) l.
Proof using .
intros x y n m l Heq Hin. induction l.
+ now inversion Hin.
+ inversion_clear Hin.
  - left. destruct a. compute in *. destruct H. now transitivity x; auto.
  - right. now apply IHl.
Qed.

Lemma NoDup_pair_In : forall x y n m l, NoDupA eq_elt l ->
  InA eq_pair (x, n) l -> InA eq_pair (y, m) l -> x == y -> n = m.
Proof using .
intros x y n m l Hl Hinx Hiny Heq. induction Hl as [| [z p] l]. inversion_clear Hiny.
inversion_clear Hinx; inversion_clear Hiny.
- compute in H0, H1. destruct H0 as [H0 ?], H1 as [H1 ?]. now subst p m.
- compute in H0. destruct H0 as [H0 ?]. subst p. elim H.
  apply eq_pair_elt_weak_In with y m. now transitivity x. assumption.
- compute in H1. destruct H1 as [H1 ?]. subst p. elim H.
  apply eq_pair_elt_weak_In with x n. now transitivity y; auto. assumption.
- now apply IHHl.
Qed.

Notation "s  [c=]  t" := (Subset s t) (at level 70, no associativity).

Lemma m_add_same : forall x n s, (m_add x n s)[x] = n + s[x].
Proof using MapSpec.
intros x n s. unfold m_add. simpl. destruct (Nat.eq_dec n 0). lia.
unfold m_multiplicity at 1. rewrite add_eq_o, Nat2Pos.id; lia || reflexivity.
Qed.

Lemma m_add_other : forall x y n s, x =/= y -> (m_add y n s)[x] = s[x].
Proof using MapSpec.
intros x y n s Hyx. unfold add. simpl. unfold m_add, m_multiplicity.
destruct (Nat.eq_dec n 0); trivial; []. rewrite add_neq_o; reflexivity || now symmetry.
Qed.

Lemma fold_add_out_list : forall (f : elt -> nat -> nat) x n l s,
  ~InA eq_key (x, n) l -> NoDupA eq_key l ->
  (fold_left (fun acc xn => m_add (fst xn) (f (fst xn) (Pos.to_nat (snd xn))) acc) l s)[x] = s[x].
Proof using MapSpec.
intros f x n l s Hin Hdup. revert s. induction l as [| [y m] l]; intro s; simpl.
+ reflexivity.
+ rewrite IHl.
  - rewrite m_add_other; trivial. intro. apply Hin. now left.
  - auto.
  - now inversion_clear Hdup.
Qed.

Lemma fold_add_out : forall (f : elt -> nat -> nat) x s s', ~FMapInterface.In x s ->
  (m_fold (fun y n acc => m_add y (f y n) acc) s s')[x] = s'[x].
Proof using MapSpec.
intros f x s s' Hin. unfold m_fold. rewrite FMapInterface.fold_1.
assert (Hs : forall n, ~(InA eq_key_elt (x, n) (FMapInterface.elements s))).
{ intros n Habs. apply Hin. exists n. now apply elements_2. }
revert s'. induction (FMapInterface.elements s) as [| [y m] l]; intro s'; simpl.
+ reflexivity.
+ assert ( Hxy : x =/= y). { intro Habs. apply (Hs m). left. now split. }
  rewrite IHl.
  - now rewrite m_add_other.
  - intros n Habs. apply (Hs n). now right.
Qed.

Notation compatb := (Proper (@equiv elt _ ==> Logic.eq ==> Logic.eq)) (only parsing).

Lemma fold_add : forall (f : elt -> nat -> nat) x n m m', compatb f -> find x m = Some n ->
  (m_fold (fun x n acc => m_add x (f x n) acc) m m')[x] = f x (Pos.to_nat n) + m'[x].
Proof using MapSpec.
intros f x n m m' Hf Hin. unfold m_fold. rewrite fold_1.
assert (Hm : InA eq_key_elt (x, Pos.of_nat (multiplicity x m)) (FMapInterface.elements m)).
{ apply elements_1. rewrite find_mapsto_iff. unfold multiplicity. simpl. unfold m_multiplicity.
  destruct (find x m); discriminate || now rewrite Pos2Nat.id. }
assert (Hdup := elements_3 m).
revert m'. induction (FMapInterface.elements m) as [| [y p] l]; intro m'; simpl; [now inversion Hm |].
destruct (equiv_dec x y) as [Hxy | Hxy].
+ assert (Heq : eq_key (x, Pos.of_nat m[x]) (y, p)) by auto.
  assert (p = n).
  { inversion_clear Hm.
    - destruct H as [_ H]. revert H. simpl. unfold m_multiplicity. now rewrite Hin, Pos2Nat.id.
    - exfalso. inversion_clear Hdup. now rewrite eq_key_elt_eq_key_subrelation, Heq in H. }
  subst p. inversion_clear Hdup. change m_multiplicity with multiplicity in *.
  rewrite (fold_add_out_list _  _ n); trivial; [|].
  - rewrite Hxy. apply m_add_same.
  - assert (Heq' : eq_key (x, n) (y, n)) by auto. now rewrite Heq'.
+ rewrite IHl.
  - f_equal. now apply m_add_other.
  - inversion_clear Hm; trivial. now destruct H as [? _].
  - now inversion_clear Hdup.
Qed.

Lemma In_MIn : forall x s, FMapInterface.In x s <-> s[x] > 0.
Proof using MapSpec.
intros x s. split; intro H.
- destruct H as [n Hn]. rewrite find_mapsto_iff in Hn. simpl.
  unfold m_multiplicity. rewrite Hn. now apply Pos2Nat.is_pos.
- exists (Pos.of_nat (m_multiplicity x s)). rewrite find_mapsto_iff. simpl in *. unfold multiplicity in *.
  unfold m_multiplicity in *. destruct (find x s). now rewrite Pos2Nat.id. now inversion H.
Qed.

Lemma Mequal_Mequivb_equiv : forall s s', Equal s s' <-> Equivb Pos.eqb s s'.
Proof using MapSpec.
intros s s'. split.
+ intro Heq. split.
  - intro x. split; intros [e Hin]; exists e.
      now rewrite find_mapsto_iff, <- Heq, <- find_mapsto_iff.
      now rewrite find_mapsto_iff, Heq, <- find_mapsto_iff.
  - intros x e e' He He'. rewrite find_mapsto_iff in He, He'.
    rewrite Heq in He. rewrite He in He'. inversion_clear He'. unfold Cmp. now apply Pos.eqb_refl.
+ intros [Heq1 Heq2] x.
  destruct (find x s) as [e |] eqn:Hfind, (find x s') as [e' |] eqn:Hfind'.
  - f_equal. apply Pos.eqb_eq. apply (Heq2 x); now rewrite find_mapsto_iff.
  - assert (Habs : FMapInterface.In x s'). { rewrite <- Heq1. exists e. now rewrite find_mapsto_iff. }
    destruct Habs as [e' Habs]. rewrite find_mapsto_iff, Hfind' in Habs. discriminate Habs.
  - assert (Habs : FMapInterface.In x s). { rewrite Heq1. exists e'. now rewrite find_mapsto_iff. }
    destruct Habs as [e Habs]. rewrite find_mapsto_iff, Hfind in Habs. discriminate Habs.
  - reflexivity.
Qed.

Lemma multiplicity_out : forall x m, m[x] = 0 <-> find x m = None.
Proof using .
simpl. unfold m_multiplicity. intros x m. split; intro Hm.
+ destruct (find x m) eqn:Hfind.
  - elim (lt_irrefl 0). rewrite <- Hm at 2. now apply Pos2Nat.is_pos.
  - reflexivity.
+ now rewrite Hm.
Qed.

(** **  Specifications of operations  **)

(** Specification of [multiplicity] *)
Global Instance multiplicity_spec : MultiplicitySpec elt _.
Proof using MapSpec.
split.
intros x y Hxy m m' Hm. rewrite Hm. simpl. unfold m_multiplicity.
assert (Heq : find x m' = find y m') by now apply find_m.
now rewrite Heq.
Qed.

(** Specification of [empty] *)
Global Instance empty_full_spec : EmptySpec elt _.
Proof using MapSpec.
split. intro x. simpl. unfold m_multiplicity, empty.
destruct (find x (FMapInterface.empty positive)) eqn:Hin.
- rewrite (empty_o positive x) in Hin. discriminate Hin.
- reflexivity.
Qed.

(** Specification of [singleton] *)
Global Instance singleton_spec : SingletonSpec elt _.
Proof using MapSpec. split.
+ intros x n. unfold singleton, add. simpl. destruct (Nat.eq_dec n 0).
  - subst n. unfold m_multiplicity. now rewrite empty_o.
  - unfold m_multiplicity. rewrite add_eq_o, Nat2Pos.id; trivial; reflexivity.
+ intros x y n Heq. unfold singleton, add. simpl. destruct (Nat.eq_dec n 0).
  - subst n. unfold m_multiplicity. now rewrite empty_o.
  - unfold m_multiplicity. rewrite add_neq_o, empty_o; reflexivity || now symmetry.
Qed.

(** Specification of [add] *)
Global Instance add_spec : AddSpec elt _.
Proof using MapSpec. split.
+ intros x n s. unfold add. simpl. unfold m_add. destruct (Nat.eq_dec n 0). lia.
  unfold m_multiplicity at 1. rewrite add_eq_o, Nat2Pos.id; reflexivity || lia.
+ intros x y n s Hyx. unfold add. simpl. unfold m_add. destruct (Nat.eq_dec n 0); trivial; [].
  unfold m_multiplicity at 1 3. rewrite add_neq_o; reflexivity || now symmetry.
Qed.

(** Specification of [remove] *)
Global Instance remove_spec : RemoveSpec elt _.
Proof using MapSpec. split.
+ intros x n s. unfold remove. simpl. destruct (Nat.eq_dec n 0). lia.
  destruct (le_lt_dec (m_multiplicity x s) n) as [Hle | Hlt]; unfold m_multiplicity at 1; simpl.
  - rewrite remove_eq_o; reflexivity || lia.
  - rewrite add_eq_o, Nat2Pos.id; reflexivity || lia.
+ intros x y n s Hyx. unfold remove. simpl. destruct (Nat.eq_dec n 0); trivial.
  destruct (le_lt_dec (m_multiplicity x s) n) as [Hle | Hlt]; unfold m_multiplicity at 1; simpl.
  - rewrite remove_neq_o; reflexivity || now symmetry.
  - rewrite add_neq_o; reflexivity || now symmetry.
Qed.

(** Specifications of [union], [inter], [diff], and [lub] *)
Global Instance binary_spec :  BinarySpec elt _.
Proof using MapSpec. split.
* intros x s s'. unfold union. simpl. destruct (find x s) eqn:Hin.
  - unfold m_multiplicity at 2. rewrite Hin. erewrite fold_add; eauto. now repeat intro.
  - unfold m_multiplicity at 2. rewrite Hin. erewrite fold_add_out; eauto.
    intros [n Habs]. now rewrite find_mapsto_iff, Hin in Habs.
* intros x s s'. unfold inter. simpl. destruct (find x s') eqn:Hin.
  + setoid_rewrite (fold_add (fun x n => min (m_multiplicity x s) n) x p s' (FMapInterface.empty _)); trivial; [|].
    - unfold multiplicity. simpl. unfold m_multiplicity. now rewrite empty_o, Hin, plus_0_r.
    - intros ? ? Heq ? ? ?. subst. now rewrite Heq.
  + rewrite fold_add_out.
    - unfold multiplicity. simpl. unfold m_multiplicity. now rewrite Hin, Min.min_0_r, empty_o.
    - intros [n Habs]. now rewrite find_mapsto_iff, Hin in Habs.
* intros x s s'. unfold diff. simpl. destruct (find x s) eqn:Hin.
  + setoid_rewrite (fold_add (fun x n => n - multiplicity x s') x p s (FMapInterface.empty _)); trivial.
    - unfold multiplicity. simpl. unfold m_multiplicity. now rewrite empty_o, Hin, plus_0_r.
    - intros ? ? Heq ? ? ?. subst. now rewrite Heq.
  + rewrite fold_add_out.
    - unfold multiplicity. simpl. unfold m_multiplicity. now rewrite Hin, empty_o.
    - intros [n Habs]. now rewrite find_mapsto_iff, Hin in Habs.
* intros x s s'. unfold lub. simpl.
  replace (max (m_multiplicity x s) (m_multiplicity x s'))
    with (m_multiplicity x s - m_multiplicity x s' + m_multiplicity x s') by (apply Max.max_case_strong; lia).
  destruct (find x s) eqn:Hin.
  + erewrite (fold_add); eauto.
    -unfold multiplicity. simpl. unfold m_multiplicity. now rewrite Hin.
    - intros ? ? Heq ? ? ?. subst. now rewrite Heq.
  + rewrite fold_add_out.
    - unfold multiplicity. simpl. unfold m_multiplicity. now rewrite Hin.
    - intros [n Habs]. now rewrite find_mapsto_iff, Hin in Habs.
Qed.

(** Specification of [fold] *)
Global Instance fold_full_spec : FoldSpec elt _.
Proof using MapSpec. split.
* intros A i f s. unfold fold, elements. simpl. unfold m_fold.
  now rewrite FMapInterface.fold_1, fold_left_map.
* intros A eqA HeqA f Hf Hfcomm s1 s2 Hs x y Hxy.
  unfold fold. simpl. unfold m_fold. do 2 rewrite FMapInterface.fold_1.
  rewrite fold_left_symmetry_PermutationA.
  + reflexivity.
  + apply eq_key_elt_Equivalence.
  + assumption.
  + intros ? ? Heq ? ? [? Heq']. now apply Hf; try rewrite Heq || rewrite Heq'.
  + intros. apply Hfcomm.
  + apply NoDupA_equivlistA_PermutationA.
    - autoclass.
    - eapply NoDupA_strengthen; apply eq_key_eq_key_elt_subrelation || apply elements_3.
    - eapply NoDupA_strengthen; apply eq_key_eq_key_elt_subrelation || apply elements_3.
    - clear -Hs MapSpec. intros [x n].
      setoid_rewrite <- @elements_mapsto_iff; trivial; []. setoid_rewrite @find_mapsto_iff; trivial; [].
      specialize (Hs x). cbn in Hs. unfold m_multiplicity in Hs.
      destruct (find x s1), (find x s2);
      solve [ apply Pos2Nat.inj in Hs; subst; reflexivity
            | elim (lt_irrefl 0); rewrite Hs at 2 || rewrite <- Hs at 2; apply Pos2Nat.is_pos
            | split; intro; discriminate ].
  + assumption.
Qed.

(** Specifications of [equal], [subset], and [is_empty] *)
Global Instance test_spec : TestSpec elt _.
Proof using MapSpec.
assert (His_empty_spec : forall s, is_empty s = true <-> s == empty).
{ intros s. unfold is_empty. simpl. split; intro H.
  + rewrite <- is_empty_iff in H. intros x. unfold m_multiplicity. rewrite empty_o.
    destruct (find x s) eqn:Hin; trivial. rewrite <- find_mapsto_iff in Hin. now apply H in Hin.
  + rewrite <- is_empty_iff. intros x n Habs.
    rewrite find_mapsto_iff in Habs. specialize (H x).
    unfold m_multiplicity in H. rewrite Habs, empty_o in H.
    apply (lt_irrefl 0). rewrite <- H at 2. apply Pos2Nat.is_pos. }
split; trivial.
* intros s s'. unfold equal. simpl.
  destruct (FMapInterface.equal Pos.eqb s s') eqn:Heq.
  + split; intro H; trivial || clear H. rewrite <- equal_iff, <- Mequal_Mequivb_equiv in Heq.
    unfold m_multiplicity. intro. now rewrite Heq.
  + split; intro Habs; try discriminate Habs. exfalso.
    assert (Hneq : ~FMapInterface.Equivb Pos.eqb s s').
    { intro Habs'. rewrite equal_iff, Heq in Habs'. discriminate Habs'. }
    rewrite <- Mequal_Mequivb_equiv in Hneq. apply Hneq. intro x.
    unfold m_multiplicity in Habs. specialize (Habs x). simpl in Habs.
    destruct (find x s) eqn:Hin1, (find x s') eqn:Hin2.
    - f_equal. now apply Pos2Nat.inj.
    - elim (lt_irrefl 0). rewrite <- Habs at 2. now apply Pos2Nat.is_pos.
    - elim (lt_irrefl 0). rewrite Habs at 2. now apply Pos2Nat.is_pos.
    - reflexivity.
* intros s s'. unfold subset. simpl.
  cbn in His_empty_spec. rewrite His_empty_spec. clear His_empty_spec.
  unfold m_multiplicity at 3. setoid_rewrite empty_o.
  split; intro Hle.
  + intro x. destruct (find x s) eqn:Hin.
    - cut (s[x] - s'[x] = 0). lia. rewrite <- diff_spec. simpl.
      erewrite fold_add; eauto; [|].
      ++ unfold multiplicity. simpl. unfold m_multiplicity at 2. rewrite empty_o, plus_0_r.
         specialize (Hle x). erewrite fold_add in Hle; eauto.
         -- unfold multiplicity in Hle. simpl in Hle. unfold m_multiplicity at 2 in Hle.
            now rewrite empty_o, plus_0_r in Hle.
         -- intros ? ? Heq ? ? ?. subst. now rewrite Heq.
      ++ intros ? ? Heq ? ? ?. subst. now rewrite Heq.
    - simpl. unfold m_multiplicity at 1. rewrite Hin. lia.
  + intro x. destruct (find x s) eqn:Hin.
    - erewrite fold_add; eauto.
      -- unfold multiplicity. simpl. unfold m_multiplicity at 2. rewrite empty_o, plus_0_r.
         specialize (Hle x). simpl in Hle. unfold m_multiplicity at 1 in Hle. rewrite Hin in Hle. lia.
      -- intros ? ? Heq ? ? ?. subst. now rewrite Heq.
    - erewrite fold_add_out; eauto.
      -- unfold multiplicity. simpl. unfold m_multiplicity. now rewrite empty_o.
      -- intros [n Habs]. now rewrite find_mapsto_iff, Hin in Habs.
Qed.

Corollary eq_dec : forall s s', {s == s'} + {s =/= s'}.
Proof using MapSpec.
intros s s'. destruct (equal s s') eqn:Heq.
- left. now rewrite <- equal_spec.
- right. intro H. revert H. rewrite <- equal_spec. rewrite Heq. discriminate.
Qed.

(** Specification of [elements] *)
Global Instance elements_full_spec : ElementsSpec elt _.
Proof using MapSpec. split.
* intros [x n] s. unfold elements. simpl. rewrite InA_map_iff; [split; intro H |..].
  + destruct H as [[y m] [[Heq1 Heq2] Hin]]. hnf in Heq1, Heq2. cbn in Heq1, Heq2. subst.
    rewrite <- elements_mapsto_iff, find_mapsto_iff in Hin.
    unfold m_multiplicity. rewrite <- Heq1, Hin. split; trivial. apply Pos2Nat.is_pos.
  + exists (x, Pos.of_nat n). destruct H as [H1 H2]. simpl in *. split.
    - split; hnf; simpl. reflexivity. apply Nat2Pos.id. lia.
    - rewrite <- elements_mapsto_iff, find_mapsto_iff. subst. unfold m_multiplicity in *.
      destruct (find x s). now rewrite Pos2Nat.id. lia.
  + autoclass.
  + autoclass.
  + clear. intros [] [] []. intros. split; simpl in *. assumption. now subst.
* intro s. unfold elements. simpl. rewrite NoDupA_inj_map;
  apply elements_3 || autoclass || (intros [] [] ?; assumption).
Qed.

(** Specification of [support] *)
Local Lemma support_elements_aux : forall x l1 l2, NoDupA eq_key (l1 ++ l2) ->
  ((InA equiv x (fold_left (fun acc xn => fst xn :: acc) l1 (List.map (@fst _ positive) l2)) <->
  exists n, InA eq_key_elt (x, n) (List.map (fun xn => (fst xn, snd xn)) (l1 ++ l2)))).
Proof using .
intros x l1. induction l1; simpl; intros l2 Hdup.
* split; intro H.
  + induction l2.
    - now inversion H.
    - destruct a as [y m]. inversion_clear H.
        exists m. left. now split.
        apply IHl2 in H0. destruct H0 as [n Hn]. exists n. simpl. now right. now inversion_clear Hdup.
  + destruct H as [n Hn]. induction l2; simpl.
    - now inversion Hn.
    - destruct a as [y m]. inversion_clear Hdup. inversion_clear Hn.
        left. now destruct H1.
        right. now apply IHl2.
* destruct a as [y m]. simpl. split; intro H.
  + destruct (equiv_dec x y). exists m. left. now split.
    change (y :: List.map (fst (B:=positive)) l2) with (List.map (fst (B:=positive)) ((y,m) :: l2)) in H.
    rewrite IHl1 in H.
    - destruct H as [p Hp]. exists p. rewrite map_app in *. rewrite InA_app_iff in Hp.
        simpl in Hp. destruct Hp.
          right. rewrite InA_app_iff. now left.
          inversion_clear H.
             now left.
             right. rewrite InA_app_iff. now right.
    - rewrite NoDupA_swap_iff. assumption. refine _.
  + change (y :: List.map (fst (B:=positive)) l2) with (List.map (fst (B:=positive)) ((y,m) :: l2)).
    rewrite IHl1. destruct H as [n Hn]. exists n. rewrite map_app, InA_app_iff. inversion_clear Hn.
    - right. now left.
    - rewrite map_app, InA_app_iff in H. destruct H. now left. now do 2 right.
    - rewrite NoDupA_swap_iff. assumption. autoclass.
Qed.

Lemma support_elements : forall x s, InA equiv x (support s) <-> InA eq_pair (x, multiplicity x s) (elements s).
Proof using MapSpec.
intros x s. unfold support, elements. simpl. rewrite fold_1.
change nil with (List.map (@fst elt positive) nil).
rewrite (support_elements_aux x (FMapInterface.elements s) nil); rewrite app_nil_r; [split; intro H |].
+ destruct H as [n Hn].
  rewrite (@InA_map_iff _ _ eq_key_elt) in Hn; try rewrite (@InA_map_iff _ _ eq_key_elt); autoclass;
  try (now intros [? ?] [? ?] Heq; simpl in *; hnf in Heq; destruct Heq; split; hnf; simpl in *; subst; auto); [].
  destruct Hn as [[y m] [[Heqx Heqn] Hin]]. exists (y, m). repeat split; eauto; try now hnf in *; cbn in *.
  subst. rewrite <- elements_mapsto_iff, find_mapsto_iff in Hin.
  hnf in *. simpl in *. subst. unfold m_multiplicity.
  rewrite find_m in Hin; eauto; try now intro; reflexivity. now rewrite Hin.
+ exists (Pos.of_nat (multiplicity x s)).
  rewrite (@InA_map_iff _ _ eq_key_elt) in H; try rewrite (@InA_map_iff _ _ eq_key_elt); autoclass;
  try (now intros [? ?] [? ?] Heq; simpl in *; hnf in Heq; destruct Heq; split; hnf; simpl in *; subst; auto); [].
  destruct H as [[y m] [[Heqx Heqn] Hin]]. exists (y, m). repeat split; eauto; try now hnf in *; cbn in *.
  subst. rewrite <- elements_mapsto_iff, find_mapsto_iff in Hin.
  hnf in *. simpl in *. subst. unfold m_multiplicity.
  rewrite find_m in Hin; eauto; try now intro; reflexivity. now rewrite Hin, Pos2Nat.id.
+ apply elements_3.
Qed.

Local Lemma support_NoDupA_aux : forall A B (l1 : list (A*B)) l2,
  fold_left (fun acc p => fst p :: acc) l1 l2 = rev (List.map (@fst _ _) l1) ++ l2.
Proof using .
intros A B l1. induction l1; intro l2; simpl.
- reflexivity.
- rewrite IHl1. now rewrite <- app_assoc.
Qed.

Global Instance support_spec : SupportSpec elt _.
Proof using MapSpec. split.
* intros x s. rewrite support_elements. rewrite elements_spec. intuition.
* intro s. unfold support. simpl. rewrite fold_1, support_NoDupA_aux, app_nil_r.
  apply NoDupA_rev; autoclass; [].
  rewrite NoDupA_inj_map; (now apply elements_3) || autoclass || (now intros ? ? ?).
Qed.

(** Specification of [choose] *)
Local Lemma choose_spec_aux : forall x s o, ~FMapInterface.In x s ->
  fold_left (fun (_ : option elt) (p : elt * positive) => Some (fst p)) (FMapInterface.elements s) o = Some x ->
  o = Some x.
Proof using MapSpec.
intros x s o Hs.
assert (Hs' : forall n, ~InA eq_key_elt (x, n) (FMapInterface.elements s)).
{ intros n Habs. apply Hs. exists n. now apply elements_2. } clear Hs.
revert o. induction (FMapInterface.elements s); simpl; intros o Hin.
+ assumption.
+ apply IHl in Hin.
  - elim (Hs' (snd a)). left. split; simpl. now inversion Hin. reflexivity.
  - intros n Habs. apply (Hs' n). now right.
Qed.

Global Instance choose_spec : ChooseSpec elt _.
Proof using MapSpec.
assert (Hchoose_Some : forall (x : elt) (s : multiset elt), choose s = Some x -> In x s).
{ intros x s Hin. destruct (In_dec s x).
  + unfold In. now rewrite <- In_MIn.
  + unfold choose in Hin. simpl in Hin. rewrite fold_1 in Hin.
    apply choose_spec_aux in Hin; trivial; discriminate. }
split; trivial.
* intros s. split; intro Hs.
  + intro x. unfold choose in Hs. simpl in Hs. rewrite fold_1 in Hs. rewrite empty_spec. rewrite multiplicity_out.
    destruct (find x s) eqn:Habs; trivial; [].
    rewrite <- find_mapsto_iff in Habs. apply elements_1 in Habs. destruct (FMapInterface.elements s).
    - now inversion Habs.
    - clear -Hs. simpl in Hs. revert p0 Hs. induction l. discriminate. intros. simpl in Hs. now apply (IHl _ Hs).
  + destruct (choose s) eqn:H; trivial; [].
    apply Hchoose_Some in H. rewrite Hs in H. unfold In in H. rewrite empty_spec in H. lia.
Qed.

(** Specification of [filter] *)
Local Lemma fold_nfilter_out_list : forall f x n l s, ~InA eq_key (x, n) l -> NoDupA eq_key l ->
  multiplicity x (fold_left (fun acc xn => if f (fst xn) (snd xn) : bool
                                           then add (fst xn) (Pos.to_nat (snd xn)) acc else acc) l s)
  = multiplicity x s.
Proof using MapSpec.
intros f x n l s Hin Hdup. revert s. induction l as [| [y m] l]; intro s; simpl.
+ reflexivity.
+ rewrite IHl.
  - destruct (f y m); auto. apply m_add_other. intro Habs. apply Hin. now left.
  - intro Habs. apply Hin. now right.
  - now inversion_clear Hdup.
Qed.

Local Lemma nfilter_spec_In : forall f s s' x, compatb f -> In x s ->
  multiplicity x
    (m_fold (fun y n acc => if f y n : bool then add y n acc else acc) s s')
  = if f x (multiplicity x s) then multiplicity x s + multiplicity x s' else multiplicity x s'.
Proof using MapSpec.
intros f s s' x Hf Hin. unfold m_fold. rewrite fold_1. revert s'. unfold In in Hin.
assert (Hs : InA eq_pair (x, multiplicity x s) (elements s)). { rewrite elements_spec. simpl. now split. }
assert (Hdup : NoDupA eq_elt (elements s)) by apply elements_NoDupA.
unfold elements in Hs, Hdup. simpl in Hs, Hdup.
induction (FMapInterface.elements s); simpl; intro s'; simpl in Hs.
* exfalso. rewrite <- InA_nil. apply Hs.
* destruct a as [y m].
  destruct (equiv_dec (x, Pos.of_nat (multiplicity x s)) (y, m)) as [Heq | Hneq].
  + destruct Heq as [H1 H2]. simpl in H1, H2 |- *. rewrite H1 in *. subst m.
    rewrite (fold_nfilter_out_list (fun x y => f x (Pos.to_nat y)) _ (Pos.of_nat (multiplicity y s))).
    - cbn in Hin. rewrite Nat2Pos.id; try lia; [].
      destruct (f y (m_multiplicity y s)) eqn:Htest; now rewrite ?m_add_same, H1.
    - inversion_clear Hdup. intro Habs. apply H. rewrite InA_map_iff; autoclass.
      -- exists (y, Pos.of_nat (m_multiplicity y s)). split; reflexivity || eassumption.
      -- clear. intros [] [] Hxy. now compute in *.
    - inversion_clear Hdup. rewrite NoDupA_inj_map in H0; solve [ eassumption | autoclass | now intros [] [] ].
  + inversion_clear Hs.
    - elim Hneq. destruct H as [H1 H2]. split; trivial; [].
      simpl in *. hnf in H2. cbn in H2. now rewrite H2, Pos2Nat.id.
    - inversion_clear Hdup.
      assert (Hxy : x =/= y) by (intro; eauto using eq_pair_elt_weak_In).
      rewrite IHl; try assumption. simpl.
      destruct (f x (multiplicity x s)), (f y (Pos.to_nat m));
      reflexivity || rewrite m_add_other; reflexivity || now auto.
Qed.

Local Lemma nfilter_spec_out : forall f s s' x, ~In x s ->
  multiplicity x (m_fold (fun y n acc => if f y n : bool then m_add y n acc else acc) s s')
  = multiplicity x s'.
Proof using MapSpec.
intros f s s' x Hin. unfold m_fold. rewrite fold_1.
assert (Hs : forall n, ~(InA eq_key_elt (x, n) (FMapInterface.elements s))).
{ intros n Habs. apply Hin. apply elements_2, find_mapsto_iff in Habs.
  unfold In. simpl. unfold m_multiplicity. rewrite Habs. apply Pos2Nat.is_pos. }
revert s'. induction (FMapInterface.elements s) as [| [y m] l]; intro s'; trivial; [].
assert ( Hxy : x =/= y). { intro Habs. apply (Hs m). left. now split. }
simpl. rewrite IHl.
- destruct (f y (Pos.to_nat m)); trivial; []. apply m_add_other. auto.
- intros n Habs. apply (Hs n). now right.
Qed.

Global Instance filter_spec : FilterSpec elt _.
Proof using MapSpec.
assert (Hnfilter : forall (f : elt -> nat -> bool) (x : elt) (s : multiset elt),
        Proper (equiv ==> eq ==> eq) f ->
        (nfilter f s)[x] = (if f x s[x] then s[x] else 0)).
* intros f x s Hf. unfold nfilter. simpl.
  destruct (m_multiplicity x s) eqn:Hin.
  + rewrite nfilter_spec_out.
    - unfold multiplicity. simpl. unfold m_multiplicity. rewrite empty_o. now destruct (f x 0).
    - unfold In. simpl. lia.
  + rewrite nfilter_spec_In.
    - unfold multiplicity. simpl. unfold m_multiplicity at 3 4. now rewrite empty_o, Hin, plus_0_r.
    - assumption.
    - unfold In. simpl. lia.
* split; trivial.
  intros f x s Hf. change (filter f s) with (nfilter (fun x _ => f x) s).
  apply Hnfilter. repeat intro. now apply Hf.
Qed.

(* Theorem filter_nfilter : forall f s, filter f s [=] nfilter (fun x _ => f x) s.
Proof. now unfold filter. Qed. *)

(** Specifications of [cardinal] and [size] *)
Global Instance size_spec : SizeSpec elt _.
Proof using MapSpec. split.
* intro. unfold cardinal. simpl. unfold m_fold. reflexivity.
* intro. unfold size, support. simpl. now rewrite fold_1, fold_left_length, fold_1, fold_left_cons_length.
Qed.

(** Specifications of [for_all] and [exists_] *)
Lemma fold_and_true_base_step : forall A f (l : list A) b,
  fold_left (fun a x => a && f x) l b = true -> b = true.
Proof using .
intros A f l. induction l; simpl; intros b Hl.
- assumption.
- apply IHl in Hl. destruct b. reflexivity. simpl in Hl. discriminate Hl.
Qed.

Lemma fold_and_true_inductive_step : forall A f (l : list A) a b,
  fold_left (fun a x => a && f x) (a :: l) b = true -> f a = true.
Proof using .
simpl. intros A f l a b Hl. apply fold_and_true_base_step in Hl.
destruct (f a). reflexivity. destruct b; simpl in Hl; discriminate Hl.
Qed.

Lemma Melements_multiplicity : forall s x n,
  InA eq_key_elt (x, n) (FMapInterface.elements s)
  <-> multiplicity x s = Pos.to_nat n /\ Pos.to_nat n > 0.
Proof using MapSpec.
intros s x n. split; intro H.
+ apply elements_2, find_mapsto_iff in H. unfold multiplicity. simpl. unfold m_multiplicity.
  rewrite H. split; trivial; []. apply Pos2Nat.is_pos.
+ destruct H as [H1 H2]. unfold multiplicity in H1. simpl in H1. unfold m_multiplicity in H1.
  destruct (find x s) eqn:Hin.
  - apply elements_1, find_mapsto_iff. rewrite Hin. f_equal. now apply Pos2Nat.inj.
  - rewrite  <- H1 in H2. inversion H2.
Qed.

Lemma for_all_spec_aux : forall (f : elt -> nat -> bool) s b, compatb f ->
  (m_fold (fun x n b => b && (f x n)) s b = true
   <-> b = true /\ For_all (fun x n => f x n = true) s).
Proof using MapSpec.
intros f s b Hf. unfold m_fold. rewrite fold_1. unfold For_all. split; intro H.
+ split. now apply fold_and_true_base_step in H.
  intros x Hin. unfold In in Hin. rewrite <- In_MIn in Hin. destruct Hin as [n Hin]. apply elements_1 in Hin.
  assert (Hn : multiplicity x s = Pos.to_nat n) by now rewrite Melements_multiplicity in Hin.
  revert b H x n Hn Hin. induction (FMapInterface.elements s); intros b H x n Hn Hin; inversion_clear Hin.
  - simpl in H. apply fold_and_true_base_step in H. rewrite andb_true_iff in H.
    destruct H as [_ H ], a, H0 as [H1 H2]. simpl in *. rewrite Hn, H1. now subst p.
  - simpl in H. apply (IHl _ H _ _ Hn H0).
+ destruct H as [Hb H]. subst b.
  assert (forall xn, InA eq_key_elt xn (FMapInterface.elements s) -> f (fst xn) (Pos.to_nat (snd xn)) = true).
  { intros [x n] Hx. simpl. rewrite Melements_multiplicity in Hx. destruct Hx as [Hm Hp].
    setoid_rewrite <- Pos2Nat.id. rewrite <- Hm, Nat2Pos.id. apply H. unfold In. simpl. now setoid_rewrite Hm. lia. }
  clear H. revert H0. induction (FMapInterface.elements s); simpl; intro Hin; trivial.
  rewrite Hin. apply IHl. intros x Hx. apply Hin. now right. now left.
Qed.

Lemma exists_spec_aux : forall (f : elt -> nat -> bool) s b, compatb f ->
  (m_fold (fun x n b => b || (f x n)) s b = true
  <-> b = true \/ Exists (fun x n => f x n = true) s).
Proof using MapSpec.
intros f s b Hf.
assert (Hequiv : Exists (fun x n => f x n = true) s <->
        exists x, exists n, InA eq_key_elt (x, n) (FMapInterface.elements s) /\ f x (Pos.to_nat n) = true).
{ split; intros [x Hx].
  + destruct Hx as [Hin Hfx]. exists x. exists (Pos.of_nat (m_multiplicity x s)). split.
    - rewrite Melements_multiplicity. unfold In in Hin. simpl in *. rewrite Nat2Pos.id. now split. lia.
    - rewrite Nat2Pos.id. assumption. unfold In in Hin. simpl in Hin. lia.
  + destruct Hx as [n [Hin Hfx]]. exists x. rewrite Melements_multiplicity in Hin. destruct Hin as [Hn Hp]. split.
    - simpl in *. unfold In. simpl. now rewrite Hn.
    - simpl in *. now rewrite Hn. }
rewrite Hequiv. clear Hequiv. unfold m_fold. rewrite fold_1. unfold For_all. split; intro H.
* revert b H. induction (FMapInterface.elements s); intros b H.
  + simpl in H. now left.
  + simpl in H. apply IHl in H. rewrite orb_true_iff in H. destruct H as [[H | H] | H]; (now left) || right.
    - destruct a as [x n]. exists x. exists n. split. now left. assumption.
    - destruct H as [x [n [Hin Hfx]]]. exists x. exists n. split. now right. assumption.
* revert b H. induction (FMapInterface.elements s); simpl; intros b H.
  + destruct H. assumption.
    destruct H as [? [? [Habs _]]]. now inversion Habs.
  + apply IHl. rewrite orb_true_iff. destruct H as [H | H].
    - now do 2 left.
    - destruct H as [x [n [Hin Hfx]]]. inversion_clear Hin.
      -- left. right. destruct H as [H1 H2]. simpl in H1, H2. now rewrite <- H1, <- H2.
      -- right. exists x. exists n. now split.
Qed.

Global Instance quantifiers_spec : QuantifierSpec elt _.
Proof using MapSpec. split.
* intros. unfold for_all. simpl. rewrite for_all_spec_aux; intuition.
* intros. unfold exists_. simpl. rewrite exists_spec_aux; intuition discriminate.
Qed.

(** Specification of [npartition] *)
Definition npartition_fun f := fun x n acc =>
         if f x (Pos.to_nat n) : bool
         then (add x (Pos.to_nat n) (fst acc), snd acc)
         else (fst acc, add x (Pos.to_nat n) (snd acc)).

Lemma fold_npartition_fst_out_list : forall f x n l s12,
  ~InA eq_key (x, n) l -> NoDupA eq_key l ->
  multiplicity x
  (fst
     (fold_left (fun acc xn => if f (fst xn) (Pos.to_nat (snd xn)) : bool
         then (add (fst xn) (Pos.to_nat (snd xn)) (fst acc), snd acc)
         else (fst acc, add (fst xn) (Pos.to_nat (snd xn)) (snd acc))) l s12))
  = multiplicity x (fst s12).
Proof using MapSpec.
intros f x n l s12 Hin Hdup. revert s12. induction l as [| [y m] l]; intros s12; trivial.
simpl. rewrite IHl.
- destruct (f y (Pos.to_nat m)); trivial; [].
  apply m_add_other. intro Habs. apply Hin. now left.
- intro Habs. apply Hin. now right.
- now inversion_clear Hdup.
Qed.

Lemma npartition_spec_fst_In : forall f s s12 x, compatb f -> In x s ->
  multiplicity x (fst (m_fold (fun x n acc =>
         if f x n : bool
         then (m_add x n (fst acc), snd acc)
         else (fst acc, m_add x n (snd acc))) s s12)) =
  (if f x (multiplicity x s) then multiplicity x s + multiplicity x (fst s12) else multiplicity x (fst s12)).
Proof using MapSpec.
intros f s s' x Hf Hin. unfold m_fold. rewrite fold_1. revert s'. unfold In in Hin. simpl in Hin.
assert (Hs : InA eq_pair (x, multiplicity x s) (elements s)). { rewrite elements_spec. simpl. now split. }
assert (Hdup : NoDupA eq_elt (elements s)) by apply elements_NoDupA.
unfold elements in Hs, Hdup. simpl in Hs, Hdup.
induction (FMapInterface.elements s); simpl; intros [s1 s2]; simpl in Hs.
* exfalso. rewrite <- InA_nil. apply Hs.
* destruct a as [y m]. simpl.
  destruct (equiv_dec (x, Pos.of_nat (multiplicity x s)) (y, m)) as [Heq | Hneq].
  + destruct Heq as [H1 H2]. simpl in H1, H2 |- *. rewrite H1 in *. subst m.
    rewrite (fold_npartition_fst_out_list f _ (Pos.of_nat (multiplicity y s))).
    - rewrite Nat2Pos.id; try lia; [].
      destruct (f y (m_multiplicity y s)) eqn:Htest; simpl; now rewrite ?m_add_same, H1.
    - inversion_clear Hdup. intro Habs. apply H. rewrite InA_map_iff.
      -- exists (y, Pos.of_nat (multiplicity y s)). split; eauto; reflexivity.
      -- autoclass.
      -- autoclass.
      -- clear. intros [] [] Hxy. now compute in *.
    - inversion_clear Hdup. rewrite NoDupA_inj_map in H0;
       solve [ eassumption | autoclass | now intros [] [] ].
  + inversion_clear Hs.
    - elim Hneq. destruct H as [H1 H2]. split. assumption. hnf in *. simpl in *. now rewrite H2, Pos2Nat.id.
    - inversion_clear Hdup.
      assert (Hxy : x =/= y) by (intro; eauto using eq_pair_elt_weak_In).
      rewrite IHl; try assumption. simpl. unfold npartition_fun.
      destruct (f x (multiplicity x s)), (f y (Pos.to_nat m));
      reflexivity || simpl; rewrite m_add_other; reflexivity || now auto.
Qed.

Lemma npartition_spec_fst_out : forall f s s12 x, ~In x s ->
  multiplicity x (fst (m_fold (fun x n acc =>
      if f x n : bool then (m_add x n (fst acc), snd acc) else (fst acc, m_add x n (snd acc))) s s12))
  = multiplicity x (fst s12).
Proof using MapSpec.
intros f s s' x Hin. unfold m_fold. rewrite fold_1.
assert (Hs : forall n, ~(InA eq_key_elt (x, n) (FMapInterface.elements s))).
{ intros n Habs. apply Hin. apply elements_2, find_mapsto_iff in Habs.
  unfold In. simpl. unfold m_multiplicity. rewrite Habs. apply Pos2Nat.is_pos. }
revert s'. induction (FMapInterface.elements s) as [| [y m] l]; intro s'; simpl; trivial; [].
assert ( Hxy : x =/= y). { intro Habs. apply (Hs m). left. now split. }
rewrite IHl.
+ unfold npartition_fun. destruct (f y (Pos.to_nat m)).
  - apply m_add_other. now auto.
  - reflexivity.
+ intros n Habs. apply (Hs n). now right.
Qed.

Lemma fold_npartition_snd_out_list : forall f x n l s12,
  ~InA eq_key (x, n) l -> NoDupA eq_key l ->
  multiplicity x
  (snd
     (fold_left
        (fun acc xn =>
         if f (fst xn) (Pos.to_nat (snd xn)) : bool
         then (add (fst xn) (Pos.to_nat (snd xn)) (fst acc), snd acc)
         else (fst acc, add (fst xn) (Pos.to_nat (snd xn)) (snd acc))) l s12))
  = multiplicity x (snd s12).
Proof using MapSpec.
intros f x n l s12 Hin Hdup. revert s12.
induction l as [| [y m] l]; intros s12; simpl.
+ reflexivity.
+ rewrite IHl.
  - destruct (f y (Pos.to_nat m)). reflexivity. simpl. apply m_add_other. intro Habs. apply Hin. now left.
  - intro Habs. apply Hin. now right.
  - now inversion_clear Hdup.
Qed.

Lemma npartition_spec_snd_In : forall f s s12 x, compatb f -> In x s ->
  multiplicity x
  (snd
     (m_fold
        (fun y n acc =>
         if f y n : bool then (m_add y n (fst acc), snd acc) else (fst acc, m_add y n (snd acc))) s s12))
  = if f x (multiplicity x s) then multiplicity x (snd s12) else multiplicity x s + multiplicity x (snd s12).
Proof using MapSpec.
intros f s s' x Hf Hin. unfold m_fold. rewrite fold_1. revert s'. unfold In in Hin. simpl in Hin.
assert (Hs : InA eq_pair (x, multiplicity x s) (elements s)). { rewrite elements_spec. simpl. now split. }
assert (Hdup : NoDupA eq_elt (elements s)) by apply elements_NoDupA.
unfold elements in Hs, Hdup. simpl in Hs, Hdup.
induction (FMapInterface.elements s); simpl; intros [s1 s2]; simpl in Hs.
* exfalso. rewrite <- InA_nil. apply Hs.
* destruct a as [y m].
  destruct (equiv_dec (x, Pos.of_nat (multiplicity x s)) (y, m)) as [Heq | Hneq].
  + destruct Heq as [H1 H2]. simpl in H1, H2 |- *. rewrite H1 in *. subst m.
    rewrite (fold_npartition_snd_out_list f _ (Pos.of_nat (multiplicity y s))).
    - rewrite Nat2Pos.id; try lia; [].
      destruct (f y (m_multiplicity y s)) eqn:Htest; simpl; now rewrite ?m_add_same, H1.
    - inversion_clear Hdup. intro Habs. apply H. rewrite InA_map_iff.
      -- exists (y, Pos.of_nat (multiplicity y s)). split; reflexivity || eassumption.
      -- autoclass.
      -- autoclass.
      -- clear. intros [] [] Hxy. now compute in *.
    - inversion_clear Hdup. rewrite NoDupA_inj_map in H0;
      solve [eassumption | autoclass | now intros [] [] ].
  + inversion_clear Hs.
    - elim Hneq. destruct H as [H1 H2]. split. assumption. hnf in *. simpl in *. now rewrite H2, Pos2Nat.id.
    - inversion_clear Hdup.
      assert (Hxy : x =/= y) by (intro; eauto using eq_pair_elt_weak_In).
      rewrite IHl; try assumption. simpl.
      destruct (f x (multiplicity x s)), (f y (Pos.to_nat m));
      reflexivity || simpl; rewrite m_add_other; reflexivity || now auto.
Qed.

Lemma npartition_spec_snd_out : forall f s s12 x, ~In x s ->
  multiplicity x
  (snd
     (m_fold
        (fun y n acc =>
         if f y n : bool then (m_add y n (fst acc), snd acc) else (fst acc, m_add y n (snd acc))) s s12))
  = multiplicity x (snd s12).
Proof using MapSpec.
intros f s s' x Hin. unfold m_fold. rewrite fold_1.
assert (Hs : forall n, ~(InA eq_key_elt (x, n) (FMapInterface.elements s))).
{ intros n Habs. apply Hin. apply elements_2, find_mapsto_iff in Habs.
  unfold In. simpl. unfold m_multiplicity. rewrite Habs. apply Pos2Nat.is_pos. }
revert s'. induction (FMapInterface.elements s) as [| [y m] l]; intro s'; trivial.
assert (Hxy : x =/= y). { intro Habs. apply (Hs m). left. now split. }
simpl. rewrite IHl.
- destruct (f y (Pos.to_nat m)); trivial; [].
  apply m_add_other. now auto.
- intros n Habs. apply (Hs n). now right.
Qed.

Global Instance npartition_spec : NpartitionSpec elt _.
Proof using MapSpec. split.
* intros f s Hf x. unfold npartition. rewrite nfilter_spec; trivial. simpl.
  destruct (m_multiplicity x s) eqn:Hin.
  + rewrite npartition_spec_fst_out.
    - simpl. unfold multiplicity. simpl. unfold m_multiplicity. rewrite empty_o. now destruct (f x 0).
    - unfold In. simpl. lia.
  + setoid_rewrite npartition_spec_fst_In.
    - simpl. unfold m_multiplicity at 3 4. now rewrite empty_o, Hin, plus_0_r.
    - assumption.
    - unfold In. simpl. lia.
* intros f s Hf x. rewrite nfilter_spec.
  + unfold npartition. simpl.
    destruct (m_multiplicity x s) eqn:Hin.
    - rewrite npartition_spec_snd_out.
      -- simpl. unfold m_multiplicity. rewrite empty_o. now destruct (f x 0).
      -- unfold In. simpl. lia.
    - rewrite npartition_spec_snd_In.
      -- simpl. unfold m_multiplicity at 2 4. rewrite empty_o, Hin, plus_0_r. now destruct (f x (S n)).
      -- assumption.
      -- unfold In. simpl. lia.
  + intros ? ? Heq ? ? ?. subst. now rewrite Heq.
Qed.

(** Specification of [partition] *)
Theorem partition_npartition_fst : forall f s, fst (partition f s) == fst (npartition (fun x _ => f x) s).
Proof using . now unfold partition. Qed.

Theorem partition_npartition_snd : forall f s, snd (partition f s) == snd (npartition (fun x _ => f x) s).
Proof using . now unfold partition. Qed.

Global Instance partition_spec : PartitionSpec elt _.
Proof using MapSpec. split.
* intros f s Hf. rewrite partition_npartition_fst, npartition_spec_fst.
  - reflexivity.
  - repeat intro. now apply Hf.
* intros f s Hf. rewrite partition_npartition_snd, npartition_spec_snd.
  - reflexivity.
  - repeat intro. now apply Hf.
Qed.

(** The full set of specifications. *)
Global Instance MakeFMultisetsFacts : FMultisetsOn elt _.
Proof using MapSpec. split; autoclass. Qed.

End WMapImplementation.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From LCAC Require Import Relations_ext.
Require FunInd.

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

(* Definition 2.1: Combinatory logic terms, or CL-terms *)

Inductive clterm : Set :=
  | clvar of nat
  | clapp of clterm & clterm
  | clatoms | clatomk | clatomi.

Lemma eq_clterm_dec (t1 t2 : clterm) : {t1 = t2}+{t1 <> t2}.
Proof. do ?decide equality. Qed.

Local Infix "@" := clapp (at level 20, left associativity).

Check ((clatoms @ (clatomk @ clatoms)) @ clatomk).
Check ((clatoms @ (clatomk @ clvar 0)) @ ((clatoms @ clatomk) @ clatomk)).

(* Definition 2.3: Length of CL-term *)

Fixpoint cl_length (t : clterm) : nat :=
  match t with
    | clapp t1 t2 => cl_length t1 + cl_length t2
    | _ => 1
  end.

(* Definition 2.4: Binary relation "occurs in" on CL-terms *)

Inductive cl_occurs : relation clterm :=
  | cl_occurs_refl t : cl_occurs t t
  | cl_occurs_left t1 t2 t3 : cl_occurs t1 t2 -> cl_occurs t1 (t2 @ t3)
  | cl_occurs_right t1 t2 t3 : cl_occurs t1 t3 -> cl_occurs t1 (t2 @ t3).

(* Definition 2.6, Exercise 2.8: Substitution *)

Fixpoint subst_lookup (l : seq (nat * clterm)) (v : nat) : option clterm :=
  match l with
    | nil => None
    | (v', t) :: l' => if eqn v v' then Some t else subst_lookup l' v
  end.

Fixpoint substitute (l : list (nat * clterm)) (t : clterm) : clterm :=
  match t with
    | clvar v =>
      match subst_lookup l v with
        | None => clvar v
        | Some t' => t'
      end
    | clapp tl tr => clapp (substitute l tl) (substitute l tr)
    | bc => bc
  end.

(* Example 2.7 *)

Eval compute in substitute
  [:: (1, clatoms @ clatomk)] (clvar 0 @ clvar 1 @ clvar 1).
Eval compute in substitute [:: (1, clatoms @ clatomk); (0, clatomk @ clatomi)]
  (clvar 0 @ clvar 1 @ clvar 1).

(* Definition 2.9: Weak reduction *)

Inductive cl_weakred : relation clterm :=
  | weakred_left t1 t2 t3 : cl_weakred t1 t2 -> cl_weakred (t1 @ t3) (t2 @ t3)
  | weakred_right t1 t2 t3 : cl_weakred t1 t2 -> cl_weakred (t3 @ t1) (t3 @ t2)
  | weakred_s t1 t2 t3 :
    cl_weakred (clatoms @ t1 @ t2 @ t3) (t1 @ t3 @ (t2 @ t3))
  | weakred_k t1 t2 : cl_weakred (clatomk @ t1 @ t2) t1
  | weakred_i t : cl_weakred (clatomi @ t) t.

Notation cl_weakred_rtc := (clos_refl_trans_1n clterm cl_weakred).

Infix "->1w" := cl_weakred (at level 50, no associativity).
Infix "->w" := cl_weakred_rtc (at level 50, no associativity).

Lemma weakred_rtc_left t1 t2 t3 : t1 ->w t2 -> t1 @ t3 ->w t2 @ t3.
Proof.
elim => // {t1 t2} t1 t2 t2' H H0 H1.
by apply rt1n_trans with (t2 @ t3) => //; constructor.
Qed.

Lemma weakred_rtc_right t1 t2 t3 : t1 ->w t2 -> t3 @ t1 ->w t3 @ t2.
Proof.
elim => // {t1 t2} t1 t1' t2 H H0 H1.
by apply rt1n_trans with (t3 @ t1') => //; constructor.
Qed.

Hint Resolve weakred_rtc_left weakred_rtc_right.

Lemma weakred_rtc_app t1 t1' t2 t2' :
  t1 ->w t1' -> t2 ->w t2' -> (t1 @ t2) ->w (t1' @ t2').
Proof. move => H H0; apply rtc_trans with (t1 @ t2'); auto. Qed.

Hint Resolve weakred_rtc_app.

(* Definition 2.10: Weak normal form *)

Definition cl_weaknf (t : clterm) : Prop := ~(exists t' : clterm, t ->1w t').
Definition cl_weaknf_of (t1 t2 : clterm) : Prop := t2 ->w t1 /\ cl_weaknf t1.

(* Example 2.11 *)

Definition cl_comb_b : clterm := clatoms @ (clatomk @ clatoms) @ clatomk.

Example example_2_11 t1 t2 t3 : cl_comb_b @ t1 @ t2 @ t3 ->w t1 @ (t2 @ t3).
Proof.
rewrite /cl_comb_b.
eapply rt1n_trans; first apply weakred_left, weakred_left, weakred_s.
eapply rt1n_trans;
  first apply weakred_left, weakred_left, weakred_left, weakred_k.
eapply rt1n_trans; first apply weakred_s.
apply rtc_step; apply weakred_left, weakred_k.
Qed.

(* Example 2.12 *)

Definition cl_comb_c : clterm :=
  clatoms @ (cl_comb_b @ cl_comb_b @ clatoms) @ (clatomk @ clatomk).

Example example_2_12 t1 t2 t3 : cl_comb_c @ t1 @ t2 @ t3 ->w t1 @ t3 @ t2.
Proof.
rewrite /cl_comb_c.
eapply rt1n_trans; first apply weakred_left, weakred_left, weakred_s.
eapply rtc_trans; first (do 3 apply weakred_rtc_left; apply example_2_11).
eapply rtc_trans; first apply weakred_rtc_left, example_2_11.
eapply rt1n_trans; first apply weakred_s.
apply weakred_rtc_right.
eapply rt1n_trans; first apply weakred_left, weakred_left, weakred_k.
apply rtc_step; apply weakred_k.
Qed.

(* Exercise 2.13 *)

(* Lemma 2.14: Substitution lemma for ->w *)

Lemma substlemma_a' t1 t2 v :
  t1 ->1w t2 -> cl_occurs (clvar v) t2 -> cl_occurs (clvar v) t1.
Proof.
move => H H0.
induction H.
inversion H0.
apply cl_occurs_left, IHcl_weakred, H3.
apply cl_occurs_right, H3.
inversion H0.
apply cl_occurs_left, H3.
apply cl_occurs_right, IHcl_weakred, H3.
inversion H0; inversion H2.
apply cl_occurs_left, cl_occurs_left, cl_occurs_right, H6.
apply cl_occurs_right, H6.
apply cl_occurs_left, cl_occurs_right, H6.
apply cl_occurs_right, H6.
apply cl_occurs_left, cl_occurs_right, H0.
apply cl_occurs_right, H0.
Qed.

Lemma substlemma_a t1 t2 v :
  t1 ->w t2 -> cl_occurs (clvar v) t2 -> cl_occurs (clvar v) t1.
Proof. elim => // x y z H H0 H1 H2; eapply substlemma_a'; eauto. Qed.

Lemma substlemma_b t1 t2 t3 v :
  t1 ->w t2 -> substitute [:: (v, t1)] t3 ->w substitute [:: (v, t2)] t3.
Proof.
move => H; elim: t3 => //=.
- by move => n; case: ifP.
- auto.
Qed.

Lemma substlemma_c t1 t2 l : t1 ->1w t2 -> substitute l t1 ->1w substitute l t2.
Proof. by elim => /=; constructor. Qed.

(* Theorem 2.15: Church-Rosser theorem for ->w *)

Inductive cl_parred : relation clterm :=
  | parred_app t1 t1' t2 t2' :
    cl_parred t1 t1' -> cl_parred t2 t2' -> cl_parred (t1 @ t2) (t1' @ t2')
  | parred_s t1 t1' t2 t2' t3 t3' t3'' :
    cl_parred t1 t1' -> cl_parred t2 t2' ->
    cl_parred t3 t3' -> cl_parred t3 t3'' ->
    cl_parred (clatoms @ t1 @ t2 @ t3) (t1' @ t3' @ (t2' @ t3''))
  | parred_k t1 t1' t2 : cl_parred t1 t1' -> cl_parred (clatomk @ t1 @ t2) t1'
  | parred_i t1 t1' : cl_parred t1 t1' -> cl_parred (clatomi @ t1) t1'
  | parred_var n : cl_parred (clvar n) (clvar n)
  | parred_atoms : cl_parred clatoms clatoms
  | parred_atomk : cl_parred clatomk clatomk
  | parred_atomi : cl_parred clatomi clatomi.

Infix "->p" := cl_parred (at level 50, no associativity).

Lemma cl_parred_refl t : t ->p t.
Proof. by elim: t; constructor. Qed.

Hint Resolve cl_parred_refl.

Lemma cl_weakred_in_parred : inclusion cl_weakred cl_parred.
Proof. by apply cl_weakred_ind; constructor. Qed.

Lemma cl_parred_in_weakred_rtc : inclusion cl_parred cl_weakred_rtc.
Proof.
apply cl_parred_ind => //=; auto.
- move => t1 t1' t2 t2' t3 t3' t3'' H H0 H1 H2 H3 H4 H5 H6.
  apply rt1n_trans with (t1 @ t3 @ (t2 @ t3)).
  + constructor.
  + auto.
- move => t1 t1' t2 H H0; apply rt1n_trans with t1 => //=; constructor.
- move => t1 t1' H H0; apply rt1n_trans with t1 => //=; constructor.
Qed.

Function cl_parred_all (t : clterm) : clterm :=
  match t with
    | clatoms @ t1 @ t2 @ t3 =>
      (cl_parred_all t1 @ cl_parred_all t3) @
      (cl_parred_all t2 @ cl_parred_all t3)
    | clatomk @ t1 @ t2 => cl_parred_all t1
    | clatomi @ t1 => cl_parred_all t1
    | t1 @ t2 => cl_parred_all t1 @ cl_parred_all t2
    | _ => t
  end.

Lemma cl_parred_all_lemma t1 t2 : t1 ->p t2 -> t2 ->p cl_parred_all t1.
Proof.
move => H; induction H; try by do ?constructor.
destruct t1; try by constructor.
- destruct t1_1; try by constructor.
  + destruct t1_1_1; try by constructor.
    inversion H; inversion H3; inversion H8 ;subst.
    inversion IHcl_parred1; subst; simpl in *.
    by inversion H6; apply parred_s.
  + inversion H; inversion H3; subst.
    by inversion IHcl_parred1; apply parred_k.
- inversion H; subst.
  by inversion IHcl_parred1; apply parred_i.
Qed.

Theorem cl_parred_confluent : confluent cl_parred.
Proof. by move => t1; exists (cl_parred_all t1); apply cl_parred_all_lemma. Qed.

Theorem cl_weakred_confluent : confluent cl_weakred_rtc.
Proof.
apply (rtc_confluent'
  cl_weakred_in_parred cl_parred_in_weakred_rtc cl_parred_confluent).
Qed.

(* Corollary 2.15.1: Uniqueness of nf *)

Corollary cl_weaknf_uniqueness t1 t2 t3 :
  cl_weaknf_of t2 t1 -> cl_weaknf_of t3 t1 -> t2 = t3.
Proof.
case => H H0; case => H1 H2.
case: (cl_weakred_confluent H H1) => [t4 H3 H4].
inversion H3.
- inversion H4.
  + auto.
  + apply False_ind, H2; eauto.
- apply False_ind, H0; eauto.
Qed.

(* Exercise 2.16 *)

Lemma exercise_2_16 t : clatoms @ clatomk @ clatomk @ t ->w t.
Proof.
eapply rt1n_trans.
- apply weakred_s.
- apply rtc_step, weakred_k.
Qed.

(* Exercise 2.17 *)


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops.
Require Import Coq_Cats.Type_Cat.Type_Cat.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.
Require Import Cat.Cat.
Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat
        NatTrans.NatIso.

Local Open Scope isomorphism_scope.
Local Open Scope morphism_scope.
Local Open Scope object_scope.

(** If two categories are isomorphic, then so are their duals. *)
Section Opposite_Cat_Iso.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  Program Definition Opposite_Cat_Iso :
    (C^op)%category ≃≃ (D^op)%category ::> Cat
    :=
      {|
        iso_morphism := ((iso_morphism I)^op)%functor;
        inverse_morphism := ((inverse_morphism I)^op)%functor
      |}.

  Next Obligation.
    change (I ⁻¹ ^op ∘ (iso_morphism I) ^op)%functor
    with (((inverse_morphism I) ∘ (iso_morphism I))^op)%functor.
    cbn_rewrite (left_inverse I).
    trivial.
  Qed.

  Next Obligation.
    change ((iso_morphism I) ^op ∘ I ⁻¹ ^op)%functor
    with (((iso_morphism I) ∘ (inverse_morphism I))^op)%functor.
    cbn_rewrite (right_inverse I).
    trivial.
  Qed.

End Opposite_Cat_Iso.

(** Conversion from a category to another isomorphic category. *)
Section Cat_IConv.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  (** Object conversion through an isomorphism and its inverse isomorphism
      gives back the same object. *)
  Definition Cat_Iso_Obj_conv (c : C) :
    c = (((inverse_morphism I) _o) (((iso_morphism I) _o) c))%object.
  Proof.
    change (I ⁻¹ _o ((iso_morphism I) _o c))
    with ((I ⁻¹ ∘ I)%morphism _o c)%object;
    rewrite (left_inverse I); trivial.
  Qed.

  (** Homomorphism types remain the smae after object conversion through an
      isomorphism and its inverse isomorphism. *)
  Definition Cat_Iso_Hom_conv (c c' : C) :
    ((((inverse_morphism I) _o) (((iso_morphism I) _o) c))
      –≻
      (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))%morphism
    = (c –≻ c').
  Proof.
    do 2 rewrite <- Cat_Iso_Obj_conv; trivial.
  Defined.

  (** Type conversion to the original hom type after conversion with
      an isomorphism and its inverse. *)
  Definition Cat_Iso_conv_inv {c c' : C}
             (h :
                (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
                  –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))
    : c –≻ c' :=
    match Cat_Iso_Hom_conv c c' in _ = Y return Y with
      eq_refl => h
    end.

  (** Heterogenous equality of type conversion to the original hom type after
      conversion with an isomorphism and its inverse. *)
  Theorem Cat_Iso_conv_inv_JMeq {c c' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))
    : Cat_Iso_conv_inv h ~= h.
  Proof.
    unfold Cat_Iso_conv_inv.
    destruct Cat_Iso_Hom_conv.
    trivial.
  Qed.

  (** Type conversion to the original hom type after conversion with the
      inverse of an isomorphism and that isomorphism. *)
  Definition Cat_Iso_conv {c c' : C} (h : c –≻ c') :
    (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
      –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
    :=
    match eq_sym (Cat_Iso_Hom_conv c c') in _ = Y return Y with
      eq_refl => h
    end.

  (** Heterogenous equality of type conversion to the original hom type after
      conversion with the inverse of an isomorphism and that isomorphism. *)
  Theorem Cat_Iso_conv_JMeq {c c' : C} (h : c –≻ c') : Cat_Iso_conv h ~= h.
  Proof.
    unfold Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv.
    trivial.
  Qed.

  (** Conversion once through an isomrphism and its inverse and once through
      its inverse and it gives back the same arrow as we strated with. *)
  Theorem Cat_Iso_conv_inv_Cat_Iso_conv {c c' : C} (h : c –≻ c')
    : Cat_Iso_conv_inv (Cat_Iso_conv h) = h.
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv; trivial.
  Qed.

  (** Conversion once through the inverse of an isomrphism and that isomorphism
      and once through that isomorphism and its inverse gives back the same
      arrow as we strated with. *)
  Theorem Cat_Iso_conv_Cat_Iso_conv_inv {c c' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))
    :
      Cat_Iso_conv (Cat_Iso_conv_inv h) = h.
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv; trivial.
  Qed.

  (** Conversion of an arrow through an isomorphism and its inverse (after
      correcting the homorphism type) is the same arrow as we started with. *)
  Theorem Cat_Iso_conv_inv_I_inv_I {c c' : C} (h : c –≻ c') :
    Cat_Iso_conv_inv (((inverse_morphism I) _a) (((iso_morphism I) _a) h)) = h.
  Proof.
    match goal with
      [|- ?A = ?B] =>
      let H := fresh "H" in
      cut (A ~= B); [intros H; rewrite H; trivial|]
    end.
    unfold Cat_Iso_conv_inv.
    destruct Cat_Iso_Hom_conv.
    change (I ⁻¹ _a ((iso_morphism I) _a h)) with ((I ⁻¹ ∘ I)%morphism _a h).
    apply (@JMeq_trans _ _ _ _ ((Functor_id _) _a h) _); trivial.
    cbn_rewrite <- (left_inverse I).
    trivial.
  Qed.

  (** Morphism composition commutes with conversion. *)
  Theorem Cat_Iso_conv_inv_compose {c c' c'' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
          )
          (h' :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c''))
          )
    :
      Cat_Iso_conv_inv (compose C h h')
      = compose C (Cat_Iso_conv_inv h) (Cat_Iso_conv_inv h').
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_Hom_conv.
    do 3 destruct Cat_Iso_Obj_conv; trivial.
  Qed.

End Cat_IConv.

Section Cat_Iso_inv.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  (** The main theorem of this module. Given an isomorphism I between
      categories C and D, for each morphism h: Hom (I _o c) (I _o c')
      in D, there is a morphism g in C such that the conversion of h
      through I (I _a g) gives back the smae arrow, i.e., h = (I _a h). *)
  Theorem Cat_Iso_inv
          {c c' : C} (h : ((iso_morphism I) _o c) –≻ ((iso_morphism I) _o c'))
    : {g : c –≻ c' | h = ((iso_morphism I) _a g)}.
  Proof.
    exists (Cat_Iso_conv_inv I ((inverse_morphism I) _a h)).
    match goal with
      [|- ?A = ?B] =>
        etransitivity;
        [apply (eq_sym (@Cat_Iso_conv_inv_I_inv_I D C (I⁻¹) _ _ A))|
         etransitivity; [|apply (@Cat_Iso_conv_inv_I_inv_I D C (I⁻¹) _ _ B)]]
    end.
    do 2 apply f_equal.
    match goal with
      [|- ?A = ?B] =>
        etransitivity;
        [apply (eq_sym (@Cat_Iso_conv_Cat_Iso_conv_inv C D I _ _ A))|
         etransitivity; [|apply (@Cat_Iso_conv_Cat_Iso_conv_inv C D I _ _ B)]]
    end.
    apply f_equal.
    rewrite Cat_Iso_conv_inv_I_inv_I; trivial.
  Qed.

End Cat_Iso_inv.

(**
Given I : C ≃ D for categories C and D and F : D -> E, F ∘ (I ∘ I⁻¹) and F are
naturally isomorphic.
*)
Section IsoCat_NatIso.
  Context {C D : Category} (I : (C ≃≃ D ::> Cat)%morphism)
          {E : Category} (F : (D –≻ E)%functor).

  Program Definition IsoCat_NatIso :
    ((F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism))%functor ≃ F)%natiso :=
    {|
      iso_morphism := IsoCat_NatTrans I F;
      inverse_morphism := IsoCat_NatTrans_back I F
    |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    FunExt.
    cbn.
    match goal with
      [|- ((match ?e with _ => _ end) ∘ (match ?e with _ => _ end))%morphism = _] =>
      destruct e
    end.
    auto.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    FunExt.
    cbn.
    match goal with
      [|- ((match ?e with _ => _ end) ∘ (match ?e with _ => _ end))%morphism = _] =>
      destruct e
    end.
    auto.
  Qed.

End IsoCat_NatIso.


From Hammer Require Import Hammer.

Require Import Ensembles.
From GroupTheory Require Import Laws.
From GroupTheory Require Import Group_definitions.
Section group_trivialities.
Variable U : Type.
Variable Gr : Group U.

Let G : Ensemble U := G_ U Gr.

Let star : U -> U -> U := star_ U Gr.

Let inv : U -> U := inv_ U Gr.

Let e : U := e_ U Gr.

Definition G0 : forall a b : U, In U G a -> In U G b -> In U G (star a b) :=
G0_ U Gr.

Definition G1 : forall a b c : U, star a (star b c) = star (star a b) c :=
G1_ U Gr.

Definition G2a : In U G e := G2a_ U Gr.

Definition G2b : forall a : U, star e a = a := G2b_ U Gr.

Definition G2c : forall a : U, star a e = a := G2c_ U Gr.

Definition G3a : forall a : U, In U G a -> In U G (inv a) := G3a_ U Gr.

Definition G3b : forall a : U, star a (inv a) = e := G3b_ U Gr.

Definition G3c : forall a : U, star (inv a) a = e := G3c_ U Gr.
Hint Resolve G1.
Hint Resolve G2a G2b G2c.
Hint Resolve G3a G3b G3c.
Hint Resolve G0.

Theorem triv1 : forall a b : U, star (inv a) (star a b) = b.
intros a b; try assumption.
rewrite (G1 (inv a) a b); auto.
rewrite G3c; auto.
Qed.

Theorem triv2 : forall a b : U, star (star b a) (inv a) = b.
intros a b; try assumption.
rewrite <- (G1 b a (inv a)); auto.
rewrite (G3b a); auto.
Qed.

Theorem resolve : forall a b : U, star b a = e -> b = inv a.
intros a b H'1.
cut (star (star b a) (inv a) = inv a).
rewrite <- (G1 b a (inv a)); auto.
rewrite (G3b a); auto.
rewrite (G2c b); auto.
rewrite H'1.
rewrite (G2b (inv a)); auto.
Qed.

Theorem self_inv : e = inv e.
apply resolve; auto.
Qed.

Theorem inv_star : forall a b : U, star (inv b) (inv a) = inv (star a b).
intros a b.
apply resolve.
rewrite <- (G1 (inv b) (inv a) (star a b)).
rewrite (G1 (inv a) a b).
rewrite (G3c a).
rewrite (G2b b); auto.
Qed.

Theorem cancellation : forall a b : U, star a b = a -> b = e.
intros a b H'.
cut (star (inv a) (star a b) = b).
rewrite H'.
rewrite (G3c a); auto.
rewrite (G1 (inv a) a b).
rewrite (G3c a); auto.
Qed.

Theorem inv_involution : forall a : U, a = inv (inv a).
intro a; apply resolve; auto.
Qed.
End group_trivialities.
Hint Resolve G1.
Hint Resolve G2a G2b G2c.
Hint Resolve G3a G3b G3c.
Hint Resolve G0.
Hint Resolve triv1 triv2 resolve self_inv inv_star inv_involution.