(*****************************************************************

 Enriched binary products

 In this file, we define binary products in the enriched setting.
 For ordinary categories, we can formulate the universal property
 of products via hom-sets. More specifically, the product `a × b`
 of `a` and `b` satisfies the following universal property: for
 every `z`, we have a natural isomorphism from `z --> a × b` to
 `(z --> a) × (z --> b)`. From this natural isomorphism, we can
 deduce that a cone for the product consists of an object `z`
 together with projections `z --> a` and `z --> b`, and that
 to give a map `z --> a × b`, it suffices to give `z --> a` and
 `z --> b`.

 To define enriched products, we formulate this universal property
 in monoidal categories. More specifically, we say that the hom
 object `z --> a × b` is the product of `z --> a` and `z --> b`.

 Content
 1. Cones of enriched products
 2. Binary products in an enriched category
 3. Being a binary product is a proposition
 4. Binary products in the underlying category
 5. Builders for binary products
 6. Products are closed under iso
 7. Products are isomorphic
 8. Enriched categories with products

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.limits.binproducts.

Import MonoidalNotations.
Local Open Scope cat.
Local Open Scope moncat.

Section EnrichedProducts.
  Context {V : monoidal_cat}
          {C : category}
          (E : enrichment C V)
          (x y : C).

  (**
   1. Cones of enriched binary products
   *)
  Definition enriched_binary_prod_cone
    : UU
    := ∑ (a : C),
       I_{V} --> E ⦃ a , x ⦄
       ×
       I_{V} --> E ⦃ a , y ⦄.

  Coercion ob_enriched_binary_prod_cone
           (a : enriched_binary_prod_cone)
    : C
    := pr1 a.

  Definition enriched_prod_cone_pr1
             (a : enriched_binary_prod_cone)
    : a --> x
    := enriched_to_arr E (pr12 a).

  Definition enriched_prod_cone_pr2
             (a : enriched_binary_prod_cone)
    : a --> y
    := enriched_to_arr E (pr22 a).

  Definition make_enriched_binary_prod_cone
             (a : C)
             (p₁ : I_{V} --> E ⦃ a , x ⦄)
             (p₂ : I_{V} --> E ⦃ a , y ⦄)
    : enriched_binary_prod_cone
    := a ,, p₁ ,, p₂.

  (**
   2. Binary products in an enriched category
   *)
  Definition is_binary_prod_enriched
             (a : enriched_binary_prod_cone)
    : UU
    := ∏ (w : C),
       isBinProduct
         V
         (E ⦃ w , x ⦄)
         (E ⦃ w , y ⦄)
         (E ⦃ w , a ⦄)
         (postcomp_arr E w (enriched_prod_cone_pr1 a))
         (postcomp_arr E w (enriched_prod_cone_pr2 a)).

  Definition is_binary_prod_enriched_to_BinProduct
             {a : enriched_binary_prod_cone}
             (Ha : is_binary_prod_enriched a)
             (w : C)
    : BinProduct
        V
        (E ⦃ w , x ⦄)
        (E ⦃ w , y ⦄).
  Proof.
    use make_BinProduct.
    - exact (E ⦃ w , a ⦄).
    - exact (postcomp_arr E w (enriched_prod_cone_pr1 a)).
    - exact (postcomp_arr E w (enriched_prod_cone_pr2 a)).
    - exact (Ha w).
  Defined.

  Definition binary_prod_enriched
    : UU
    := ∑ (a : enriched_binary_prod_cone),
       is_binary_prod_enriched a.

  Coercion cone_of_binary_prod_enriched
           (a : binary_prod_enriched)
    : enriched_binary_prod_cone
    := pr1 a.

  Coercion binary_prod_enriched_is_prod
           (a : binary_prod_enriched)
    : is_binary_prod_enriched a
    := pr2 a.

  (**
   3. Being a binary product is a proposition
   *)
  Proposition isaprop_is_binary_prod_enriched
              (a : enriched_binary_prod_cone)
    : isaprop (is_binary_prod_enriched a).
  Proof.
    use impred ; intro.
    apply isaprop_isBinProduct.
  Qed.

  (**
   4. Binary products in the underlying category
   *)
  Section InUnderlying.
    Context {a : enriched_binary_prod_cone}
            (Ha : is_binary_prod_enriched a).

    Definition is_binary_prod_enriched_arrow
               {w : C}
               (f : w --> x)
               (g : w --> y)
      : w --> a.
    Proof.
      refine (enriched_to_arr E _).
      use (BinProductArrow _ (is_binary_prod_enriched_to_BinProduct Ha w)).
      - exact (enriched_from_arr E f).
      - exact (enriched_from_arr E g).
    Defined.

    Proposition is_binary_prod_enriched_arrow_pr1
                {w : C}
                (f : w --> x)
                (g : w --> y)
      : is_binary_prod_enriched_arrow f g · enriched_prod_cone_pr1 a
        =
        f.
    Proof.
      unfold is_binary_prod_enriched_arrow, enriched_prod_cone_pr1.
      use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn.
      refine (_ @ BinProductPr1Commutes
                    _ _ _
                    (is_binary_prod_enriched_to_BinProduct Ha w)
                    _
                    (enriched_from_arr E f)
                    (enriched_from_arr E g)).
      cbn.
      unfold postcomp_arr, enriched_prod_cone_pr1.
      rewrite enriched_from_arr_comp.
      rewrite !assoc.
      apply maponpaths_2.
      rewrite tensor_linvunitor.
      rewrite !assoc'.
      apply maponpaths.
      rewrite <- tensor_split.
      rewrite !enriched_from_to_arr.
      apply idpath.
    Qed.

    Proposition is_binary_prod_enriched_arrow_pr2
                {w : C}
                (f : w --> x)
                (g : w --> y)
      : is_binary_prod_enriched_arrow f g · enriched_prod_cone_pr2 a
        =
        g.
    Proof.
      unfold is_binary_prod_enriched_arrow, enriched_prod_cone_pr2.
      use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn.
      refine (_ @ BinProductPr2Commutes
                    _ _ _
                    (is_binary_prod_enriched_to_BinProduct Ha w)
                    _
                    (enriched_from_arr E f)
                    (enriched_from_arr E g)).
      cbn.
      unfold postcomp_arr, enriched_prod_cone_pr2.
      rewrite enriched_from_arr_comp.
      rewrite !assoc.
      apply maponpaths_2.
      rewrite tensor_linvunitor.
      rewrite !assoc'.
      apply maponpaths.
      rewrite <- tensor_split.
      rewrite !enriched_from_to_arr.
      apply idpath.
    Qed.

    Proposition is_binary_prod_enriched_arrow_eq
                {w : C}
                {f g : w --> a}
                (q₁ : f · enriched_prod_cone_pr1 a = g · enriched_prod_cone_pr1 a)
                (q₂ : f · enriched_prod_cone_pr2 a = g · enriched_prod_cone_pr2 a)
      : f = g.
    Proof.
      refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _).
      apply maponpaths.
      use (BinProductArrowsEq
               _ _ _
               (is_binary_prod_enriched_to_BinProduct Ha w)).
      - cbn.
        unfold postcomp_arr.
        rewrite !assoc.
        rewrite !tensor_linvunitor.
        rewrite !assoc'.
        rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
        rewrite <- !tensor_split.
        use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn.
        rewrite !assoc.
        rewrite <- !(enriched_to_arr_comp E).
        exact q₁.
      - cbn.
        unfold postcomp_arr.
        rewrite !assoc.
        rewrite !tensor_linvunitor.
        rewrite !assoc'.
        rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
        rewrite <- !tensor_split.
        use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn.
        rewrite !assoc.
        rewrite <- !(enriched_to_arr_comp E).
        exact q₂.
    Qed.

    Definition underlying_BinProduct
      : BinProduct C x y.
    Proof.
      use make_BinProduct.
      - exact a.
      - exact (enriched_prod_cone_pr1 a).
      - exact (enriched_prod_cone_pr2 a).
      - intros w f g.
        use iscontraprop1.
        + abstract
            (use invproofirrelevance ;
             intros φ₁ φ₂ ;
             use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ;
             exact (is_binary_prod_enriched_arrow_eq
                      (pr12 φ₁ @ !(pr12 φ₂))
                      (pr22 φ₁ @ !(pr22 φ₂)))).
        + exact (is_binary_prod_enriched_arrow f g
                 ,,
                 is_binary_prod_enriched_arrow_pr1 f g
                 ,,
                 is_binary_prod_enriched_arrow_pr2 f g).
    Defined.
  End InUnderlying.

  (**
   5. Builders for binary products
   *)
  Definition make_is_binary_prod_enriched
             (a : enriched_binary_prod_cone)
             (pair : ∏ (w : C) (v : V)
                       (f : v --> E ⦃ w, x ⦄)
                       (g : v --> E ⦃ w, y ⦄),
                     v --> E ⦃ w , a ⦄)
             (pair_pr1 : ∏ (w : C) (v : V)
                           (f : v --> E ⦃ w, x ⦄)
                           (g : v --> E ⦃ w, y ⦄),
                         pair w v f g · postcomp_arr E w (enriched_prod_cone_pr1 a)
                         =
                         f)
             (pair_pr2 : ∏ (w : C) (v : V)
                           (f : v --> E ⦃ w, x ⦄)
                           (g : v --> E ⦃ w, y ⦄),
                         pair w v f g · postcomp_arr E w (enriched_prod_cone_pr2 a)
                         =
                         g)
             (pair_eq : ∏ (w : C) (v : V)
                          (φ₁ φ₂ : v --> E ⦃ w , a ⦄)
                          (q₁ : φ₁ · postcomp_arr E w (enriched_prod_cone_pr1 a)
                                =
                                φ₂ · postcomp_arr E w (enriched_prod_cone_pr1 a))
                          (q₂ : φ₁ · postcomp_arr E w (enriched_prod_cone_pr2 a)
                                =
                                φ₂ · postcomp_arr E w (enriched_prod_cone_pr2 a)),
                        φ₁ = φ₂)
    : is_binary_prod_enriched a.
  Proof.
    intro w.
    use make_isBinProduct.
    intros v f g.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         use subtypePath ; [ intro ; apply isapropdirprod ; apply homset_property | ] ;
         exact (pair_eq
                  w v
                  (pr1 φ₁) (pr1 φ₂)
                  (pr12 φ₁ @ !(pr12 φ₂)) (pr22 φ₁ @ !(pr22 φ₂)))).
    - simple refine (_ ,, _ ,, _).
      + exact (pair w v f g).
      + exact (pair_pr1 w v f g).
      + exact (pair_pr2 w v f g).
  Defined.

  Definition binary_prod_enriched_to_prod
             (BPV : BinProducts V)
             (a : enriched_binary_prod_cone)
             (w : C)
    : E ⦃ w, a ⦄ --> BPV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄).
  Proof.
    use BinProductArrow.
    - exact (postcomp_arr E w (enriched_prod_cone_pr1 a)).
    - exact (postcomp_arr E w (enriched_prod_cone_pr2 a)).
  Defined.

  Definition make_is_binary_prod_enriched_from_z_iso
             (BPV : BinProducts V)
             (a : enriched_binary_prod_cone)
             (Ha : ∏ (w : C),
                   is_z_isomorphism (binary_prod_enriched_to_prod BPV a w))
    : is_binary_prod_enriched a.
  Proof.
    intro w.
    use (isBinProduct_z_iso (pr2 (BPV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄))) (_ ,, Ha w) _).
    - abstract
        (unfold binary_prod_enriched_to_prod ; cbn ;
         refine (!_) ;
         apply BinProductPr1Commutes).
    - abstract
        (unfold binary_prod_enriched_to_prod ; cbn ;
         refine (!_) ;
         apply BinProductPr2Commutes).
  Defined.

  Section BinaryProductFromUnderlying.
    Context (BPV : BinProducts V)
            (a : enriched_binary_prod_cone)
            (prod : isBinProduct
                      C
                      x y
                      a
                      (enriched_prod_cone_pr1 a)
                      (enriched_prod_cone_pr2 a))
            (w : C).

    Definition prod_from_underlying_arr_map
               (f : I_{V} --> BPV (E ⦃ w , x ⦄) (E ⦃ w, y ⦄))
      : I_{V} --> E ⦃ w, a ⦄.
    Proof.
      apply enriched_from_arr.
      use (BinProductArrow _ (make_BinProduct _ _ _ _ _ _ prod)).
      - exact (enriched_to_arr E (f · BinProductPr1 _ _)).
      - exact (enriched_to_arr E (f · BinProductPr2 _ _)).
    Defined.

    Proposition prod_from_underlying_arr_map_eq₁
                (f : I_{V} --> E ⦃ w, a ⦄)
      : prod_from_underlying_arr_map (f · binary_prod_enriched_to_prod BPV a w)
        =
        f.
    Proof.
      unfold prod_from_underlying_arr_map.
      refine (_ @ enriched_from_to_arr E f).
      apply maponpaths.
      use (BinProductArrowsEq
             _ _ _
             (make_BinProduct C x y a _ _ prod)).
      - unfold binary_prod_enriched_to_prod.
        rewrite !assoc'.
        rewrite !BinProductPr1Commutes ; cbn.
        rewrite (enriched_to_arr_comp E).
        apply maponpaths.
        rewrite tensor_split.
        rewrite !assoc.
        rewrite <- tensor_linvunitor.
        rewrite !assoc'.
        rewrite enriched_from_to_arr.
        apply maponpaths.
        rewrite !assoc.
        apply idpath.
      - unfold binary_prod_enriched_to_prod.
        rewrite !assoc'.
        rewrite !BinProductPr2Commutes ; cbn.
        rewrite (enriched_to_arr_comp E).
        apply maponpaths.
        rewrite tensor_split.
        rewrite !assoc.
        rewrite <- tensor_linvunitor.
        rewrite !assoc'.
        rewrite enriched_from_to_arr.
        apply maponpaths.
        rewrite !assoc.
        apply idpath.
    Qed.

    Proposition prod_from_underlying_arr_map_eq₂
                (f : I_{V} --> BPV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄))
      : prod_from_underlying_arr_map f · binary_prod_enriched_to_prod BPV a w = f.
    Proof.
      unfold prod_from_underlying_arr_map.
      use (BinProductArrowsEq
             _ _ _
             (BPV (E ⦃ w, x ⦄) (E ⦃ w, y ⦄))).
      - unfold binary_prod_enriched_to_prod.
        rewrite !assoc'.
        rewrite !BinProductPr1Commutes.
        rewrite enriched_from_arr_postcomp.
        refine (_ @ enriched_from_to_arr E _).
        apply maponpaths.
        apply (BinProductPr1Commutes _ _ _ (make_BinProduct C x y a _ _ prod)).
      - unfold binary_prod_enriched_to_prod.
        rewrite !assoc'.
        rewrite !BinProductPr2Commutes.
        rewrite enriched_from_arr_postcomp.
        refine (_ @ enriched_from_to_arr E _).
        apply maponpaths.
        apply (BinProductPr2Commutes _ _ _ (make_BinProduct C x y a _ _ prod)).
    Qed.
  End BinaryProductFromUnderlying.

  Definition make_is_binary_prod_enriched_from_underlying
             (BPV : BinProducts V)
             (a : enriched_binary_prod_cone)
             (prod : isBinProduct
                       C
                       x y
                       a
                       (enriched_prod_cone_pr1 a)
                       (enriched_prod_cone_pr2 a))
             (HV : conservative_moncat V)
    : is_binary_prod_enriched a.
  Proof.
    use (make_is_binary_prod_enriched_from_z_iso BPV).
    intros w.
    use HV.
    use isweq_iso.
    - exact (prod_from_underlying_arr_map BPV a prod w).
    - exact (prod_from_underlying_arr_map_eq₁ BPV a prod w).
    - exact (prod_from_underlying_arr_map_eq₂ BPV a prod w).
  Defined.

  (**
   6. Products are closed under iso
   *)
  Section ProdIso.
    Context (a : enriched_binary_prod_cone)
            (Ha : is_binary_prod_enriched a)
            (b : C)
            (f : z_iso b a).

    Definition enriched_binary_prod_cone_from_iso
      : enriched_binary_prod_cone
      := make_enriched_binary_prod_cone
           b
           (enriched_from_arr E (f · enriched_prod_cone_pr1 a))
           (enriched_from_arr E (f · enriched_prod_cone_pr2 a)).

    Definition is_binary_prod_enriched_from_iso
      : is_binary_prod_enriched enriched_binary_prod_cone_from_iso.
    Proof.
      intros w.
      use (isBinProduct_z_iso (Ha w)).
      - exact (postcomp_arr_z_iso E w f).
      - abstract
          (cbn ;
           rewrite <- postcomp_arr_comp ;
           apply maponpaths ;
           unfold enriched_binary_prod_cone_from_iso ; cbn ;
           unfold  enriched_prod_cone_pr1 ; cbn ;
           rewrite enriched_to_from_arr ;
           apply idpath).
      - abstract
          (cbn ;
           rewrite <- postcomp_arr_comp ;
           apply maponpaths ;
           unfold enriched_binary_prod_cone_from_iso ; cbn ;
           unfold  enriched_prod_cone_pr2 ; cbn ;
           rewrite enriched_to_from_arr ;
           apply idpath).
    Defined.
  End ProdIso.

  (**
   7. Products are isomorphic
   *)
  Definition map_between_product_enriched
             {a b : enriched_binary_prod_cone}
             (Ha : is_binary_prod_enriched a)
             (Hb : is_binary_prod_enriched b)
    : a --> b
    := is_binary_prod_enriched_arrow
         Hb
         (enriched_prod_cone_pr1 a)
         (enriched_prod_cone_pr2 a).

  Lemma iso_between_product_enriched_inv
        {a b : enriched_binary_prod_cone}
        (Ha : is_binary_prod_enriched a)
        (Hb : is_binary_prod_enriched b)
    : map_between_product_enriched Ha Hb · map_between_product_enriched Hb Ha
      =
      identity _.
  Proof.
    unfold map_between_product_enriched.
    use (is_binary_prod_enriched_arrow_eq Ha).
    - rewrite !assoc'.
      rewrite !is_binary_prod_enriched_arrow_pr1.
      rewrite id_left.
      apply idpath.
    - rewrite !assoc'.
      rewrite !is_binary_prod_enriched_arrow_pr2.
      rewrite id_left.
      apply idpath.
  Qed.

  Definition iso_between_product_enriched
             {a b : enriched_binary_prod_cone}
             (Ha : is_binary_prod_enriched a)
             (Hb : is_binary_prod_enriched b)
    : z_iso a b.
  Proof.
    use make_z_iso.
    - exact (map_between_product_enriched Ha Hb).
    - exact (map_between_product_enriched Hb Ha).
    - split.
      + apply iso_between_product_enriched_inv.
      + apply iso_between_product_enriched_inv.
  Defined.
End EnrichedProducts.

(**
 8. Enriched categories with products
 *)
Definition enrichment_binary_prod
           {V : monoidal_cat}
           {C : category}
           (E : enrichment C V)
  : UU
  := ∏ (x y : C),
     ∑ (a : enriched_binary_prod_cone E x y),
     is_binary_prod_enriched E x y a.

Proposition isaprop_enrichment_binary_prod
            {V : monoidal_cat}
            {C : category}
            (HC : is_univalent C)
            (E : enrichment C V)
  : isaprop (enrichment_binary_prod E).
Proof.
  use invproofirrelevance.
  intros φ₁ φ₂.
  use funextsec ; intro x.
  use funextsec ; intro y.
  use subtypePath.
  {
    intro.
    apply isaprop_is_binary_prod_enriched.
  }
  use total2_paths_f.
  - use (isotoid _ HC).
    use iso_between_product_enriched.
    + exact (pr2 (φ₁ x y)).
    + exact (pr2 (φ₂ x y)).
  - rewrite transportf_dirprod.
    use pathsdirprod.
    + rewrite transportf_enriched_arr_l.
      rewrite idtoiso_inv.
      rewrite idtoiso_isotoid.
      cbn.
      refine (_ @ enriched_from_to_arr E _).
      apply maponpaths.
      unfold map_between_product_enriched ; cbn.
      apply is_binary_prod_enriched_arrow_pr1.
    + rewrite transportf_enriched_arr_l.
      rewrite idtoiso_inv.
      rewrite idtoiso_isotoid.
      cbn.
      refine (_ @ enriched_from_to_arr E _).
      apply maponpaths.
      unfold map_between_product_enriched ; cbn.
      apply is_binary_prod_enriched_arrow_pr2.
Qed.

Definition cat_with_enrichment_binary_prod
           (V : monoidal_cat)
  : UU
  := ∑ (C : cat_with_enrichment V), enrichment_binary_prod C.

Coercion cat_with_enrichment_binary_prod_to_cat_with_enrichment
         {V : monoidal_cat}
         (C : cat_with_enrichment_binary_prod V)
  : cat_with_enrichment V
  := pr1 C.

Definition binary_prod_of_cat_with_enrichment
           {V : monoidal_cat}
           (C : cat_with_enrichment_binary_prod V)
  : enrichment_binary_prod C
  := pr2 C.


Require Import Wellfounded.
Require Import Setoid.
Require Import CAD_types.
Require Import Utils.
Require Import NArith.
Require Import NArithRing.
Require Import Zwf.
Require Import QArith.
Require Import Recdef.
Require Import Qnorm.
Require Import Pol_ring2.

Definition cdiv : Coef -> Coef -> Coef :=
   Qdiv.

Infix "/" := cdiv.

Theorem cmul_div_r :
  forall p q, ~q==c0 -> cmul q (cdiv p q) == p.
exact Qmult_div_r.
Qed.

Theorem cdiv_mul_l :
  forall p q, ~q==c0 -> cdiv (cmul p q) q == p.
exact Qdiv_mult_l.
Qed.

Definition cle : Coef -> Coef -> Prop := Qle.

Infix "<=" := cle.

Notation "x <= y <= z" := (cle x y /\ cle y z).

Theorem cle_trans : forall x y z, cle x y -> cle y z -> cle x z.
exact Qle_trans.
Qed.

Theorem cle_refl : forall x, cle x x.
exact Qle_refl.
Qed.

Theorem cle_antisym : forall x y, x <= y -> y <= x -> x==y.
exact Qle_antisym.
Qed.

Theorem cle_Qle : forall x y, cle x y -> Qle x y.
auto.
Qed.

Theorem Qle_cle : forall x y, Qle x y -> cle x y.
auto.
Qed.

Theorem cle_morph_aux : forall x1 x2 : Coef,
   x1 == x2 -> forall x3 x4 : Coef, x3 == x4 -> cle x1 x3 -> cle x2 x4.
unfold Coef_record.Ceq, ceq_compat, cle, Qle, Qeq.
intros x1 x2 H1 x3 x4 H2 H.

apply Zmult_le_reg_r with (Zpos (Qden x1)).
unfold Zgt;auto.
replace (Qnum x2 * ' Qden x4 * ' Qden x1)%Z with
        (Qnum x2 * ' Qden x1 * ' Qden x4)%Z;[idtac | ring].
rewrite <- H1.
apply Zmult_le_reg_r with (Zpos (Qden x3)).
compute; auto.
replace (Qnum x4 * ' Qden x2 * ' Qden x1 * ' Qden x3)%Z with
   (Qnum x4 * ' Qden x3 * ' Qden x2 * ' Qden x1)%Z;[idtac|ring].
rewrite <- H2.
replace (Qnum x1 * ' Qden x2 * ' Qden x4 * ' Qden x3)%Z with
     (Qnum x1 * ' Qden x3 * ' Qden x4 * ' Qden x2)%Z;[idtac | ring].
replace (Qnum x3 * ' Qden x4 * ' Qden x2 * ' Qden x1)%Z with
     (Qnum x3 * ' Qden x1 * ' Qden x4 * ' Qden x2)%Z;[idtac | ring].
apply Zmult_le_compat_r.
apply Zmult_le_compat_r.
assumption.
compute; intros; discriminate.
compute; intros; discriminate.
Qed.
Add Morphism cle with signature ceq ==> ceq ==> iff as Qle_morphism.
intros x1 x2 H1 x3 x4 H2; split; intros H.
apply cle_morph_aux with x1 x3; auto.
apply cle_morph_aux with x2 x4; auto.
apply ceq_sym; assumption.
apply ceq_sym; assumption.
Qed.

Definition clt : Coef -> Coef -> Prop := Qlt.

Infix "<" := clt.

Lemma clt_le_dec : forall x y:Coef, {clt x y}+{cle y x}.
exact Qlt_le_dec.
Qed.

Lemma clt_trans : forall x y z, clt x y -> clt y z -> clt x z.
exact Qlt_trans.
Qed.

Lemma clt_decompose : forall x y, ~ceq x y -> cle x y -> clt x y.
unfold Coef_record.Ceq, ceq_compat, cle, Qle, clt, Qlt, Qeq.
intros; auto with zarith.
Qed.

Lemma clt_cle_weak : forall x y, x < y -> x <= y.
unfold Coef_record.Ceq, ceq_compat, cle, Qle, clt, Qlt, Qeq.
intros; auto with zarith.
Qed.

Theorem clt_morph_aux : forall x1 x2 : Coef,
   x1 == x2 -> forall x3 x4 : Coef, x3 == x4 -> clt x1 x3 -> clt x2 x4.
unfold Coef_record.Ceq, ceq_compat, cle, Qle, clt, Qlt, Qeq.
intros x1 x2 H1 x3 x4 H2 H.

apply Zmult_lt_reg_r with (Zpos (Qden x1)).
unfold Zlt;auto.
replace (Qnum x2 * ' Qden x4 * ' Qden x1)%Z with
        (Qnum x2 * ' Qden x1 * ' Qden x4)%Z;[idtac | ring].
rewrite <- H1.
apply Zmult_lt_reg_r with (Zpos (Qden x3)).
compute; auto.
replace (Qnum x4 * ' Qden x2 * ' Qden x1 * ' Qden x3)%Z with
   (Qnum x4 * ' Qden x3 * ' Qden x2 * ' Qden x1)%Z;[idtac|ring].
rewrite <- H2.
replace (Qnum x1 * ' Qden x2 * ' Qden x4 * ' Qden x3)%Z with
     (Qnum x1 * ' Qden x3 * ' Qden x4 * ' Qden x2)%Z;[idtac | ring].
replace (Qnum x3 * ' Qden x4 * ' Qden x2 * ' Qden x1)%Z with
     (Qnum x3 * ' Qden x1 * ' Qden x4 * ' Qden x2)%Z;[idtac | ring].
apply Zmult_lt_compat_r.
compute; auto.
apply Zmult_lt_compat_r.
compute; auto.
assumption.
Qed.

Add Morphism clt with signature ceq ==> ceq ==> iff as Qlt_morphism.
intros x1 x2 H1 x3 x4 H2; split; intros H.
apply clt_morph_aux with x1 x3; auto.
apply clt_morph_aux with x2 x4; auto.
apply ceq_sym; assumption.
apply ceq_sym; assumption.
Qed.

Lemma cmul_le_compat_r :
   forall x y z:Coef, cle x y -> cle c0 z -> cle (x**z) (y**z).
exact Qmult_le_compat_r.
Qed.

Lemma cmul_le_0 : forall x y, cle c0 x -> cle c0 y -> cle c0 (x**y).
intros; setoid_replace c0 with (c0 ** y).
apply cmul_le_compat_r; auto.
setoid ring.
Qed.

Lemma cmul_lt_0_le_reg_r :
  forall x y z, clt c0 z -> cle (x**z) (y**z) -> cle x y.
exact Qmult_lt_0_le_reg_r.
Qed.

Lemma cle_0_mult :
   forall x y, cle c0 x -> cle c0 y -> cle c0 (x ** y).
intros x y Hx Hy; assert (ceq c0 (c0**y)).
setoid ring.
setoid_rewrite H.
apply cmul_le_compat_r; auto.
Qed.

Lemma cplus_le_compat :
    forall x y z t, cle x y -> cle z t -> cle (x++z) (y++t).
exact Qplus_le_compat.
Qed.

Lemma cle_0_plus :
  forall x y, cle c0 x -> cle c0 y -> cle c0 (x ++ y).
intros x y Hx Hy.
assert (ceq c0 (c0++c0)).
setoid ring.
setoid_rewrite H.
apply cplus_le_compat; auto.
Qed.

Lemma Q0_le_1 : (0 <= 1)%Q.
unfold Qle, Qnum, Qden; omega.
Qed.

Lemma c0_cle_c1: cle c0 c1.
exact Q0_le_1.
Qed.

Lemma copp_le_compat :
  forall p q, cle p q -> cle (copp q) (copp p).
exact Qopp_le_compat.
Qed.

Lemma copp_le_0_compat :
  forall p, cle c0 p -> cle (copp p) c0.
intros; setoid_replace c0 with (copp c0).
apply copp_le_compat; auto.
setoid ring.
Qed.

Lemma cle_0_copp : forall x, x <= c0 -> c0 <= copp x.
intros; setoid_replace c0 with (copp c0).
apply copp_le_compat; auto.
setoid ring.
Qed.

Lemma copp_le_0_compat_copp:
  forall p, cle p c0 -> cle c0 (copp p).
intros; setoid_replace c0 with (copp c0).
apply copp_le_compat; auto.
setoid ring.
Qed.

Lemma mul_copp : forall p q, copp p ** q == copp (p ** q).
intros; setoid ring.
Qed.

Lemma copp_copp : forall p, copp (copp p) == p.
intros; setoid ring.
Qed.

Theorem  clt_neq : forall x y, x < y -> ~x==y.
unfold clt, Qlt, Coef_record.Ceq, ceq_compat, Qeq.
auto with zarith.
Qed.

Theorem cmul_lt_0 : forall x y, c0 < x -> c0 < y -> c0 < x ** y.
intros x y Hx Hy.
apply clt_decompose.
unfold Coef_record.Ceq, ceq_compat; intros H; elim (Qmult_integral x y);
intros.
elim (clt_neq _ _ Hx); apply Qeq_sym; auto.
elim (clt_neq _ _ Hy); apply Qeq_sym; auto.
apply Qeq_sym; auto.
apply cmul_le_0; apply clt_cle_weak; auto.
Qed.

Theorem cplus_lt_0_le_lt : forall x y, c0 < x -> c0 <= y -> 0 < x ++ y.
unfold clt, cle, Qlt, Qle, Coef_record.C0, ceq_compat, cops,
  Coef_record.Cadd, Qplus.
intros [x1 x2] [y1 y2]; unfold Qden, Qnum.
repeat rewrite Zmult_0_l.
repeat rewrite Zmult_1_r.
intros; apply Zlt_le_trans with (x1 * Zpos y2)%Z.
apply Zmult_lt_0_compat.
assumption.
compute; auto.
assert (0 <= y1*Zpos x2)%Z.
apply Zmult_le_0_compat.
assumption.
intros; discriminate.
omega.
Qed.

Theorem cdiv_le_0_compat_l :
  forall p q, c0 < q -> c0 <= p -> c0 <= p/q.
intros p q Hlt Hle.
apply cmul_lt_0_le_reg_r with q.
assumption.
setoid_rewrite cmul_0_l.
setoid_rewrite cmul_sym; setoid_rewrite cmul_div_r.
assert (Habs:~c0==q) by (apply clt_neq; auto).
intros Habs2; elim Habs; apply ceq_sym;auto.
assumption.
Qed.

Theorem cdiv_lt_0_compat_l :
  forall p q, c0 < q -> c0 < p -> c0 < p/q.
intros p q Hlq Hlp.
assert (Hqn0: ~ q == 0).
intros H; elim (clt_neq _ _ Hlq); apply ceq_sym; exact H.
unfold cdiv.
unfold Qdiv.
setoid_replace c0 with (0 * /q)%Q.
apply Qmult_lt_compat_r.
apply clt_decompose.
intros H; elim (clt_neq _ _ Hlq).
setoid_rewrite <- (cmul_1_l q).
setoid_replace c1 with (q**/q).
replace 0 with c0 in H.
setoid_rewrite <- H; setoid ring.
reflexivity.
unfold Coef_record.Ceq, Coef_record.Cmul, ceq_compat, Coef_record.C1, cops.
apply Qeq_sym; apply Qmult_inv_r.
assumption.
apply cmul_lt_0_le_reg_r with q.
assumption.
setoid_rewrite (cmul_sym (/q) q).
setoid_replace (q**/q) with c1.
setoid_replace (0**q) with c0.
exact c0_cle_c1.
change (c0**q==c0); apply cmul_0_l.
unfold Coef_record.Ceq, Coef_record.Cmul, ceq_compat, Coef_record.C1, cops.
apply Qmult_inv_r.
exact Hqn0.
exact Hlp.
change (c0 == c0 ** /q).
setoid ring.
Qed.

Theorem c0_clt_2 : c0 < c1++c1.
apply cplus_lt_0_le_lt.
apply clt_decompose; [apply c0_diff_c1 | apply c0_cle_c1].
apply c0_cle_c1.
Qed.

Lemma cut_half : forall x, x == x/(c1++c1) ++ x/(c1++c1).
intros x0; setoid_replace (x0/(c1++c1)++x0/(c1++c1)) with
   ((c1++c1) ** (x0/(c1++c1))).
setoid_rewrite cmul_div_r.
intros Habs.
elim (clt_neq _ _ c0_clt_2).
apply ceq_sym; assumption.
apply ceq_refl.
setoid ring.
Qed.

Lemma cplus_pos_simplify : forall x y, c0 <= x -> y <= x ++ y.
intros x y H;
pose (u:=x++y); fold u.
setoid_replace y with (c0 ++ y);[unfold u|setoid ring].
apply cplus_le_compat;[assumption |apply cle_refl].
Qed.

Lemma mul_copp_copp : forall x y, copp x ** copp y == x ** y.
intros; setoid ring.
Qed.

Lemma csub_diag : forall x, x -- x == c0.
intros; setoid ring.
Qed.

Lemma cle_csub_cadd : forall a b c, a -- b <= c -> a <= b ++ c.
intros; setoid_replace a with (b ++ (a--b));[idtac|setoid ring].
apply cplus_le_compat;[apply cle_refl|assumption].
Qed.

Lemma cdiv_decompose :  forall x y, ~y==c0 -> x/y == c1/y**x.
intros x y Hy; setoid_replace (x/y) with ((c1/y**y)**(x/y)).
setoid_rewrite <- cmul_assoc.
setoid_rewrite cmul_div_r.
exact Hy.
apply ceq_refl.
setoid_rewrite (cmul_sym (c1/y) y).
setoid_rewrite cmul_div_r.
exact Hy.
setoid ring.
Qed.

Lemma cdiv_assoc : forall x y z, ~y**z == c0 -> (x/y)/z == x/(y**z).
intros x y z Hnz.
assert (Hy:~y==c0).
intros Ha; elim Hnz;setoid_rewrite Ha;setoid ring.
assert (Hz:~z==c0).
intros Ha; elim Hnz;setoid_rewrite Ha;setoid ring.
setoid_replace ((x/y)/z) with ((y**z)**(c1/(y**z))**((x/y)/z)).
setoid_rewrite (cmul_sym (y**z)).
repeat setoid_rewrite <- cmul_assoc.
setoid_rewrite cmul_div_r.
assumption.
setoid_rewrite cmul_div_r.
assumption.
setoid_rewrite (cdiv_decompose x (y**z)).
assumption.
apply ceq_refl.
setoid_rewrite cmul_div_r.
assumption.
setoid ring.
Qed.

Lemma pos_non_c0 : forall x, c0 < x -> ~x==c0.
intros x Hx Ha; elim (clt_neq _ _ Hx);setoid_rewrite Ha; apply ceq_refl.
Qed.

Lemma c0_clt_c1 : c0 < c1.
apply clt_decompose.
apply c0_diff_c1.
apply c0_cle_c1.
Qed.

Definition ceq_dec : forall x y : Coef, {ceq x y} + {~ ceq x y}
:= Qeq_dec.

Lemma cadd_copp : forall x y : Coef, -- x ++ -- y == -- (x++y).
intros; setoid ring.
Qed.

Lemma copp_csub : forall x y : Coef, --(x -- y) == y -- x.
intros; setoid ring.
Qed.

Lemma copp_div_l :
  forall x y, ~y==0 -> copp x / y == copp (x / y).
intros; setoid_rewrite (cdiv_decompose x y).
assumption.
setoid_rewrite (cdiv_decompose (--x)).
assumption.
setoid_rewrite <- copp_mul_r.
apply ceq_refl.
Qed.

Theorem cplus_le_lt_compat :
  forall x y z t, x <= y -> z < t -> x++z < y++t.
unfold clt, cle, Coef, Qlt, Qle.
intros [xn xd] [yn yd] [zn zd] [tn td]; lazy zeta.
unfold Coef_record.Cadd, cops, Qplus, Qden, Qnum.
intros.
replace ('(yd*td)) with ('yd *'td)%Z; [idtac | apply refl_equal].
replace ('(xd*zd)) with ('xd *'zd)%Z; [idtac | apply refl_equal].
replace ((xn*'zd +zn*'xd)*('yd*'td))%Z with
  (xn*'yd*'zd*'td +zn*'td*'yd*'xd)%Z;[idtac | ring].
replace ((yn*'td+tn*'yd)*('xd *'zd))%Z with
  (yn*'xd*'zd*'td +tn*'zd*'yd*'xd)%Z;[idtac | ring].
apply Zplus_le_lt_compat.
repeat apply Zmult_le_compat_r.
assumption.
intro; discriminate.
intro; discriminate.
repeat apply Zmult_lt_compat_r.
exact (refl_equal Lt).
exact (refl_equal Lt).
assumption.
Qed.

Lemma clt_0_le_lt_plus_compat :
 forall x y, c0 <= x -> c0 < y -> c0 < x ++ y.
intros; setoid_replace c0 with (c0 ++ c0).
apply cplus_le_lt_compat; assumption.
setoid ring.
Qed.

Lemma clt_0_plus_compat :
  forall x y, c0 < x -> c0 < y -> c0 < x ++ y.
intros; apply clt_0_le_lt_plus_compat.
apply clt_cle_weak; assumption.
assumption.
Qed.

Lemma clt_0_copp : forall x, x < c0 -> c0 < --x.
intros.
setoid_replace c0 with (--x ++ x).
set (u:= -- x ++ x); setoid_replace (--x) with (--x ++ c0); unfold u.
apply cplus_le_lt_compat.
apply cle_refl.
assumption.
setoid ring.
setoid ring.
Qed.

Theorem cmul_lt_compat_r :
  forall x y z, c0 < z -> x < y -> x**z < y**z.
exact Qmult_lt_compat_r.
Qed.

Theorem clt_le_trans : forall x y z, x < y -> y <= z -> x < z.
intros x y z Hy Hz.
case (ceq_dec y z).
intros Heq; setoid_rewrite <- Heq; assumption.
intros; apply clt_trans with y.
assumption.
apply clt_decompose; assumption.
Qed.

Theorem cle_lt_trans : forall x y z, x <= y -> y < z -> x < z.
intros x y z Hy Hz.
case (ceq_dec x y).
intros Heq; setoid_rewrite Heq; assumption.
intros; apply clt_trans with y.
apply clt_decompose; assumption.
assumption.
Qed.

Theorem clt_0 : forall x, c0 < copp x -> x < c0.
intros; setoid_replace x with (x++c0).
set (u:= x++c0); setoid_replace c0 with (x++--x); unfold u.
apply cplus_le_lt_compat.
apply cle_refl.
assumption.
setoid ring.
setoid ring.
Qed.

Theorem cplus_lt_compat_r :
  forall x y z, x < y -> x++z < y++z.
intros; repeat setoid_rewrite <- (cadd_sym z).
apply cplus_le_lt_compat.
apply cle_refl.
assumption.
Qed.

Lemma cmul_lt_0_lt_reg_r:
   forall x y z : Coef, c0 < z -> x ** z < y ** z -> x < y.
intros; apply clt_decompose.
intros Habs; elim (clt_neq _ _ H0); setoid_rewrite Habs.
apply ceq_refl.
apply cmul_lt_0_le_reg_r with z.
assumption.
apply clt_cle_weak; assumption.
Qed.

Lemma inv_clt : forall x y, c0 < x -> x < y -> c1/y < c1/x .
intros x y Hx Hy.
apply cmul_lt_0_lt_reg_r with (x**y).
apply cmul_lt_0.
assumption.
apply clt_trans with x; assumption.
setoid_replace (c1/y**(x**y)) with (x ** (y**(c1/y))).
setoid_rewrite cmul_div_r.
apply pos_non_c0; apply clt_trans with x; assumption.
setoid_rewrite cmul_1_r.
setoid_replace (c1/x**(x**y)) with (y**(x**(c1/x))).
setoid_rewrite cmul_div_r.
apply pos_non_c0; assumption.
setoid_rewrite cmul_1_r.
assumption.
setoid ring.
setoid ring.
Qed.

Lemma inv_cle : forall x y, c0 < x -> x <= y -> c1/y <= c1/x.
intros x y Hx Hy; elim (ceq_dec x y).
intros Heq; apply cmul_lt_0_le_reg_r with (x**y).
apply cmul_lt_0.
assumption.
apply clt_le_trans with x; assumption.
setoid_replace (c1/y**(x**y)) with (x ** (y**(c1/y))).
setoid_rewrite cmul_div_r.
apply pos_non_c0; apply clt_le_trans with x; assumption.
setoid_rewrite cmul_1_r.
setoid_replace (c1/x**(x**y)) with (y**(x**(c1/x))).
setoid_rewrite cmul_div_r.
apply pos_non_c0; assumption.
setoid_rewrite cmul_1_r.
setoid_rewrite Heq; apply cle_refl.
setoid ring.
setoid ring.
intros Hn.
apply clt_cle_weak.
apply inv_clt.
assumption.
apply clt_decompose; assumption.
Qed.

Lemma cle_opp_div_r : forall a b c, c0 <= a -> c0 < b -> b <= c ->
  --(a/b) <= --(a/c).
intros a b c Ha Hb Hc; apply copp_le_compat.
repeat setoid_rewrite (cdiv_decompose a).
apply pos_non_c0; apply clt_le_trans with b; assumption.
apply pos_non_c0; assumption.
apply cmul_le_compat_r.
apply inv_cle; assumption.
assumption.
Qed.

Lemma cle_div_r : forall a b c, c0 <= a -> c0 < c -> c <= b ->
  a/b <= a/c.
intros a b c Ha Hb Hc.
repeat setoid_rewrite (cdiv_decompose a).
apply pos_non_c0; apply clt_le_trans with c; assumption.
apply pos_non_c0; assumption.
apply cmul_le_compat_r.
apply inv_cle; assumption.
assumption.
Qed.

Theorem cmul_lt_compat : forall x y z t,
   c0 < x -> x < y -> c0 < z -> z < t ->  x ** z < y ** t.
intros x y z t Hx Hy Hz Ht.
apply clt_trans with (y**z).
apply cmul_lt_compat_r; assumption.
repeat setoid_rewrite (cmul_sym y).
apply cmul_lt_compat_r.
apply clt_trans with x; assumption.
assumption.
Qed.

Lemma cmul_lt_neg_r :
  forall x y, c0 < x -> y < c0 -> x**y < c0.
intros; setoid_rewrite (cmul_sym x).
setoid_replace c0 with (c0 ** x).
apply cmul_lt_compat_r;assumption.
setoid ring.
Qed.

Theorem cplus_lt_reg_r :
  forall x y z, x ++ z < y ++ z -> x < y.
intros.
setoid_replace x with ((x++z)++(--z));[idtac|setoid ring].
setoid_replace y with ((y++z)++(--z));[idtac|setoid ring].
apply cplus_lt_compat_r; assumption.
Qed.

Lemma csub_le_0 :
   forall a b, a <= b -> c0 <= b--a.
intros; setoid_replace (b--a) with (b++--a).
setoid_replace c0 with (a++--a).
apply cplus_le_compat.
assumption.
apply cle_refl.
setoid ring.
setoid ring.
Qed.

Lemma csub_lt_0 :
   forall a b, a < b -> c0 < b--a.
intros; setoid_replace (b--a) with (b++--a).
setoid_replace c0 with (a++--a).
apply cplus_lt_compat_r.
assumption.
setoid ring.
setoid ring.
Qed.

Theorem clt_div_mul :
   forall x y z, c0 < y ->  x/y < z -> x < z**y.
intros; apply cmul_lt_0_lt_reg_r with (c1/y).
apply cdiv_lt_0_compat_l.
assumption.
apply c0_clt_c1.
setoid_rewrite (cmul_sym x).
setoid_rewrite <- cdiv_decompose.
apply pos_non_c0; assumption.
setoid_rewrite <- cmul_assoc.
setoid_rewrite cmul_div_r.
apply pos_non_c0; assumption.
setoid_rewrite cmul_1_r; assumption.
Qed.

Theorem clt_copp_prem :
  forall x y, -- x < -- y -> y < x.
intros; apply cplus_lt_reg_r with (--x).
apply cplus_lt_reg_r with (--y).
setoid_replace (x++ --x ++ --y) with (--y);[idtac|setoid ring].
setoid_replace (y++ --x ++ --y) with (--x);[idtac|setoid ring].
assumption.
Qed.

Theorem cmul_lt_le_compat :
  forall x y z t, c0 < x -> c0 < z -> x < y -> z <= t -> x ** z < y ** t.
intros; case (ceq_dec z t).
intros heq; setoid_rewrite <- heq; apply cmul_lt_compat_r; assumption.
intros; apply cmul_lt_compat; try assumption.
apply clt_decompose; assumption.
Qed.

Theorem cmul_copp_r : forall a b, a ** -- b == -- (a ** b).
intros; setoid ring.
Qed.

Theorem cle_copp_prem :
   forall x y, copp x <= copp y -> y <= x.
intros; setoid_rewrite <- (copp_copp x); setoid_rewrite <- (copp_copp y).
apply copp_le_compat.
assumption.
Qed.

Theorem cplus_lt_r :
   forall x y, c0 < y -> x < x++y.
intros; apply clt_decompose.
intros Ha; elim (pos_non_c0 _ H).
setoid_replace c0 with ((x++y)--x).
setoid ring.
setoid_rewrite <- Ha; setoid ring.
setoid_rewrite cadd_sym.
apply cplus_pos_simplify.
apply clt_cle_weak; auto.
Qed.


Require Import Setoid.
Require Import Morphisms.

Require Import maps.
Require Import sets.

Set Implicit Arguments.

Inductive InSet (Elt : Type) (v : Elt) : MultiSet Elt -> Prop :=
| in_item : InSet v (setItem v)
| in_join_l : forall l r, InSet v l -> InSet v (setJoin l r)
| in_join_r : forall l r, InSet v r -> InSet v (setJoin l r)
.

Lemma in_equiv {Elt} (v : Elt) s1 s2 :
  SetEquiv s1 s2 -> (InSet v s1 <-> InSet v s2).
induction 1;split;try solve[auto using InSet | firstorder];intro;
repeat match goal with
| [H : InSet _ (setJoin _ _) |- _] =>
  inversion H;clear H;subst
| [H : InSet _ setEmpty |- _] =>
  solve[inversion H]
end;
firstorder;eauto using InSet.
Qed.

Lemma in_split (Elt : Type) (v : Elt) (m1 m2 : MultiSet Elt) :
  InSet v (setJoin m1 m2) <-> (InSet v m1 \/ InSet v m2).
split;inversion 1;subst;auto using InSet.
Qed.

Fixpoint disjointFrom {Elt} (s : MultiSet Elt) (used : MultiSet Elt) : Prop :=
match s with
| setEmpty => True
| setItem v => ~InSet v used
| setJoin l r => disjointFrom l (setJoin r used) /\ disjointFrom r (setJoin l used)
end.

Lemma disjointSplit {Elt} (s : MultiSet Elt) :
  forall (u1 u2 : MultiSet Elt),
  disjointFrom s (setJoin u1 u2) <->
  (disjointFrom s u1 /\ disjointFrom s u2).
induction s.
* tauto.
* simpl.
  split.
  intro H;split;contradict H;auto using InSet.
  destruct 1. inversion 1;subst;tauto.
* simpl. intros. rewrite !IHs1, !IHs2. tauto.
Qed.

Lemma disjointItem {Elt} (s : MultiSet Elt) :
  forall (v : Elt),
  (disjointFrom s (setItem v) <-> ((~ InSet v s) /\ disjointFrom s setEmpty)).
induction s.
simpl. firstorder. inversion 1.
simpl. firstorder;contradict H;inversion H;congruence.
simpl. intro.
 rewrite !disjointSplit.
    rewrite IHs1. rewrite IHs2. clear IHs1 IHs2.
   intuition (eauto using InSet). inversion H3;subst;tauto.
Qed.

Lemma disjointUsedEquiv {Elt} (s : MultiSet Elt) :
  Proper (SetEquiv ==> iff) (disjointFrom s).
unfold Proper, respectful;simpl.
induction s;simpl.
reflexivity.
intros. rewrite (in_equiv e H). reflexivity.
intros.
rewrite IHs1;[
  rewrite IHs2;[
  | rewrite H]
|rewrite H];reflexivity.
Qed.

Lemma andL : forall P, P /\ True <-> P.
firstorder.
Qed.
Lemma andComm : forall P Q, P /\ Q <-> Q /\ P.
firstorder.
Qed.

Add Parametric Morphism E : (@InSet E) with
  signature eq ==> SetEquiv ==> iff as in_set_mor.
Proof. apply in_equiv. Qed.

Add Parametric Morphism E : (@disjointFrom E) with
  signature SetEquiv ==> SetEquiv ==> iff as disjoint_from_mor.
Proof.
induction 1;simpl;intros.
* rewrite andL. apply disjointUsedEquiv.
  rewrite equivComm. rewrite equivUnit. assumption.
* do 2 match goal with
  | [|- context [disjointFrom ?s (setJoin ?t x0)]] =>
    setoid_replace (disjointFrom s (setJoin t x0))
    with (disjointFrom s (setJoin t y0))
    ;[|apply disjointUsedEquiv;rewrite H0;reflexivity]
  end. tauto.
* setoid_replace (disjointFrom s1 (setJoin s2 (setJoin s3 x0)))
            with (disjointFrom s1 (setJoin (setJoin s2 s3) y0));
   [|apply disjointUsedEquiv;rewrite H0;rewrite equivAssoc;reflexivity].
  setoid_replace (disjointFrom s2 (setJoin s1 (setJoin s3 x0)))
            with (disjointFrom s2 (setJoin s3 (setJoin s1 y0)));
   [|apply disjointUsedEquiv;rewrite H0;
            rewrite <- equivAssoc;rewrite (equivComm s1);apply equivAssoc].
  setoid_replace (disjointFrom s3 (setJoin (setJoin s1 s2) x0))
            with (disjointFrom s3 (setJoin s2 (setJoin s1 y0)));
   [|apply disjointUsedEquiv;rewrite H0;rewrite (equivComm s1);apply equivAssoc].
  tauto.
* rewrite IHSetEquiv1.
  rewrite IHSetEquiv2. reflexivity.
  apply set_join_mor;assumption.
  apply set_join_mor;assumption.
* rewrite IHSetEquiv1. apply IHSetEquiv2.
  eassumption. reflexivity.
* rewrite IHSetEquiv. reflexivity. symmetry. assumption.
* apply disjointUsedEquiv. assumption.
Qed.

Definition wfMap {Key Elt : Type} (m : Map Key Elt) : Prop :=
  disjointFrom (keys m) setEmpty.

Lemma disjointGrow {Elt : Type} (m s1 s2 : MultiSet Elt) :
  disjointFrom m (setJoin s1 s2) -> disjointFrom m s2.
revert s1 s2.
induction m;simpl;try tauto.
intros. contradict H. constructor(assumption).

destruct 1.
rewrite equivCommAssoc in H, H0.
firstorder.
Qed.

Lemma disjointEmpty {Elt : Type} (m s : MultiSet Elt) :
  disjointFrom m s -> disjointFrom m setEmpty.
rewrite <- (equivUnit s).
apply disjointGrow.
Qed.


Require Import HoTT.
From GR Require Export path_over.

(** A globe represents an equality between two paths. *)
Inductive globe
          {A : Type}
  : forall {a₁ a₂ : A} (p q : a₁ = a₂), Type
  :=
  | globe_id : forall {a : A}, @globe A a a idpath idpath.

(** A globe is thus the same as a path between two paths. *)
Definition path_to_globe
           {A : Type}
           {a₁ a₂ : A}
           {p q : a₁ = a₂}
           (h : p = q)
  : globe p q
  := match h with
     | idpath =>
       match p with
       | idpath => globe_id
       end
     end.

Definition globe_to_path
           {A : Type}
           {a₁ a₂ : A}
           {p q : a₁ = a₂}
           (h : globe p q)
  : p = q
  := match h with
     | globe_id _ => idpath
     end.

Global Instance path_to_globe_isequiv
       {A : Type}
       {a₁ a₂ : A}
       {p q : a₁ = a₂}
  : IsEquiv (@path_to_globe A a₁ a₂ p q).
Proof.
  simple refine (isequiv_adjointify _ globe_to_path _ _).
  - intros x.
    induction x ; reflexivity.
  - intros x.
    induction x, p ; reflexivity.
Defined.

Arguments globe_id {_} {_}.

(** We can also define `globe_over`, which represents an equality between two `path_over`. *)
Inductive globe_over
          {A : Type}
          (Y : A -> Type)
  : forall {a₁ a₂ : A}
           {c₁ : Y a₁} {c₂ : Y a₂}
           {p₁ p₂ : a₁ = a₂}
           (h : globe p₁ p₂)
           (q₁ : path_over Y p₁ c₁ c₂)
           (q₂ : path_over Y p₂ c₁ c₂),
    Type
  :=
  | globe_over_id : forall {a : A} {c₁ c₂ : Y a} (q : path_over Y idpath c₁ c₂),
      globe_over Y globe_id q q.

(** In a constant fibration, this is the same as proving two paths are equal. *)
Definition const_globe_over
           {A B : Type}
           {a₁ a₂ : A}
           {b₁ b₂ : B}
           {p₁ p₂ : a₁ = a₂}
           (h₁ : globe p₁ p₂)
           (q₁ q₂ : b₁ = b₂)
           (h₂ : globe q₁ q₂)
  : globe_over (fun _ => B) h₁ (const_path_over q₁) (const_path_over q₂).
Proof.
  induction h₁, h₂.
  apply globe_over_id.
Defined.

(** This changes the sides of a `globe_over`. *)
Definition globe_over_whisker
           {A : Type}
           (Y : A -> Type)
           {a₁ a₂ : A}
           {c₁ : Y a₁} {c₂ : Y a₂}
           {p₁ p₂ : a₁ = a₂}
           (h : globe p₁ p₂)
           {q₁ q₃ : path_over Y p₁ c₁ c₂}
           {q₂ q₄ : path_over Y p₂ c₁ c₂}
           (s₁ : q₁ = q₃) (s₂ : q₂ = q₄)
  : globe_over Y h q₁ q₂ -> globe_over Y h q₃ q₄
  := match s₁, s₂ with
     | idpath, idpath => idmap
     end.

(** One way to provide a `globe_over`, is by giving a path between two paths. *)
Definition path_to_globe_over
           {A : Type}
           (Y : A -> Type)
           {a₁ a₂ : A}
           {c₁ : Y a₁} {c₂ : Y a₂}
           {p₁ p₂ : a₁ = a₂}
           (h : globe p₁ p₂)
           (q₁ : path_over Y p₁ c₁ c₂)
           (q₂ : path_over Y p₂ c₁ c₂)
           (s : path_over_to_path (transport (fun r => path_over Y r c₁ c₂)
                                             (globe_to_path h)
                                             q₁)
                = path_over_to_path q₂)
  : globe_over Y h q₁ q₂.
Proof.
  pose (ap path_over_to_path^-1 s) as p.
  rewrite !eissect in p.
  induction p, h ; clear s.
  exact (globe_over_id Y q₁).
Defined.

(** `globe_over` in a family of sets. *)
Definition path_globe_over_hset
           {A : Type}
           (Y : A -> Type)
           `{forall (a : A), IsHSet (Y a)}
           {a₁ a₂ : A}
           {c₁ : Y a₁} {c₂ : Y a₂}
           {p₁ p₂ : a₁ = a₂}
           (h : globe p₁ p₂)
           (q₁ : path_over Y p₁ c₁ c₂)
           (q₂ : path_over Y p₂ c₁ c₂)
  : globe_over Y h q₁ q₂.
Proof.
  apply path_to_globe_over.
  apply path_ishprop.
Defined.


Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Psatz.
Require Import Crypto.Util.ZUtil.Tactics.SplitMinMax.
Require Import Crypto.Util.ZUtil.Stabilization.
Require Import Crypto.Util.ZUtil.MulSplit.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Bool.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZRange.Operations.
Require Import Crypto.Util.ZRange.BasicLemmas.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.SpecializeBy.

Local Open Scope Z_scope.

Module ZRange.
  Import Operations.ZRange.
  Local Arguments is_bounded_by' !_ _ _ / .

  Lemma monotone_two_corners_genb
        (f : Z -> Z)
        (R := fun b : bool => if b then Z.le else Basics.flip Z.le)
        (Hmonotone : exists b, Proper (R b ==> Z.le) f)
        x_bs x
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
    : ZRange.is_bounded_by' None (two_corners f x_bs) (f x).
  Proof.
    split; trivial.
    destruct x_bs as [lx ux]; simpl in *.
    destruct Hboundedx as [Hboundedx _].
    destruct_head'_ex.
    repeat match goal with
           | [ H : Proper (R ?b ==> Z.le) f |- _ ]
             => unique assert (R b (if b then lx else x) (if b then x else lx)
                               /\ R b (if b then x else ux) (if b then ux else x))
               by (unfold R, Basics.flip; destruct b; omega)
           end.
    destruct_head' and.
    repeat match goal with
           | [ H : Proper (R ?b ==> Z.le) _, H' : R ?b _ _ |- _ ]
             => unique pose proof (H _ _ H')
           end.
    destruct_head bool; split_min_max; omega.
  Qed.

  Lemma monotone_two_corners_gen
        (f : Z -> Z)
        (Hmonotone : Proper (Z.le ==> Z.le) f \/ Proper (Basics.flip Z.le ==> Z.le) f)
        x_bs x
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
    : ZRange.is_bounded_by' None (ZRange.two_corners f x_bs) (f x).
  Proof.
    eapply monotone_two_corners_genb; auto.
    destruct Hmonotone; [ exists true | exists false ]; assumption.
  Qed.
  Lemma monotone_two_corners
        (b : bool)
        (f : Z -> Z)
        (R := if b then Z.le else Basics.flip Z.le)
        (Hmonotone : Proper (R ==> Z.le) f)
        x_bs x
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
    : ZRange.is_bounded_by' None (ZRange.two_corners f x_bs) (f x).
  Proof.
    apply monotone_two_corners_genb; auto; subst R;
      exists b.
    intros ???; apply Hmonotone; auto.
  Qed.

  Lemma monotone_four_corners_genb
        (f : Z -> Z -> Z)
        (R := fun b : bool => if b then Z.le else Basics.flip Z.le)
        (Hmonotone1 : forall x, exists b, Proper (R b ==> Z.le) (f x))
        (Hmonotone2 : forall y, exists b, Proper (R b ==> Z.le) (fun x => f x y))
        x_bs y_bs x y
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
        (Hboundedy : ZRange.is_bounded_by' None y_bs y)
    : ZRange.is_bounded_by' None (ZRange.four_corners f x_bs y_bs) (f x y).
  Proof.
    destruct x_bs as [lx ux].
    cbn [ZRange.four_corners lower upper].
    pose proof (monotone_two_corners_genb (f lx) (Hmonotone1 _) _ _ Hboundedy) as Hmono_fl.
    pose proof (monotone_two_corners_genb (f ux) (Hmonotone1 _) _ _ Hboundedy) as Hmono_fu.
    repeat match goal with
           | [ |- context[ZRange.two_corners ?x ?y] ]
             => let l := fresh "lf" in
                let u := fresh "uf" in
                generalize dependent (ZRange.two_corners x y); intros [l u]; intros
           end.
    unfold ZRange.is_bounded_by', union in *; simpl in *; split; trivial.
    destruct_head'_and; destruct_head' True.
    pose proof (Hmonotone2 y).
    destruct_head'_ex.
    repeat match goal with
           | [ H : Proper (R ?b ==> Z.le) (f _) |- _ ]
             => unique assert (R b (if b then ly else y) (if b then y else ly)
                               /\ R b (if b then y else uy) (if b then uy else y))
               by (unfold R, Basics.flip; destruct b; omega)
           | [ H : Proper (R ?b ==> Z.le) (fun x => f x _) |- _ ]
             => unique assert (R b (if b then lx else x) (if b then x else lx)
                               /\ R b (if b then x else ux) (if b then ux else x))
               by (unfold R, Basics.flip; destruct b; omega)
           end.
    destruct_head' and.
    repeat match goal with
           | [ H : Proper (R ?b ==> Z.le) _, H' : R ?b _ _ |- _ ]
             => unique pose proof (H _ _ H')
           end; cbv beta in *.
    destruct_head bool; split_min_max; omega.
  Qed.

  Lemma monotone_four_corners_gen
        (f : Z -> Z -> Z)
        (Hmonotone1 : forall x, Proper (Z.le ==> Z.le) (f x) \/ Proper (Basics.flip Z.le ==> Z.le) (f x))
        (Hmonotone2 : forall y, Proper (Z.le ==> Z.le) (fun x => f x y) \/ Proper (Basics.flip Z.le ==> Z.le) (fun x => f x y))
        x_bs y_bs x y
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
        (Hboundedy : ZRange.is_bounded_by' None y_bs y)
    : ZRange.is_bounded_by' None (ZRange.four_corners f x_bs y_bs) (f x y).
  Proof.
    eapply monotone_four_corners_genb; auto.
    { intro x'; destruct (Hmonotone1 x'); [ exists true | exists false ]; assumption. }
    { intro x'; destruct (Hmonotone2 x'); [ exists true | exists false ]; assumption. }
  Qed.
  Lemma monotone_four_corners
        (b1 b2 : bool)
        (f : Z -> Z -> Z)
        (R1 := if b1 then Z.le else Basics.flip Z.le) (R2 := if b2 then Z.le else Basics.flip Z.le)
        (Hmonotone : Proper (R1 ==> R2 ==> Z.le) f)
        x_bs y_bs x y
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
        (Hboundedy : ZRange.is_bounded_by' None y_bs y)
    : ZRange.is_bounded_by' None (ZRange.four_corners f x_bs y_bs) (f x y).
  Proof.
    apply monotone_four_corners_genb; auto; intro x'; subst R1 R2;
      [ exists b2 | exists b1 ];
      [ eapply (Hmonotone x' x'); destruct b1; reflexivity
      | intros ???; apply Hmonotone; auto; destruct b2; reflexivity ].
  Qed.

  Lemma monotone_eight_corners_genb
        (f : Z -> Z -> Z -> Z)
        (R := fun b : bool => if b then Z.le else Basics.flip Z.le)
        (Hmonotone1 : forall x y, exists b, Proper (R b ==> Z.le) (f x y))
        (Hmonotone2 : forall x z, exists b, Proper (R b ==> Z.le) (fun y => f x y z))
        (Hmonotone3 : forall y z, exists b, Proper (R b ==> Z.le) (fun x => f x y z))
        x_bs y_bs z_bs x y z
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
        (Hboundedy : ZRange.is_bounded_by' None y_bs y)
        (Hboundedz : ZRange.is_bounded_by' None z_bs z)
    : ZRange.is_bounded_by' None (ZRange.eight_corners f x_bs y_bs z_bs) (f x y z).
  Proof.
    destruct x_bs as [lx ux].
    unfold ZRange.eight_corners; cbn [lower upper].
    pose proof (monotone_four_corners_genb (f lx) (Hmonotone1 _) (Hmonotone2 _) _ _ _ _ Hboundedy Hboundedz) as Hmono_fl.
    pose proof (monotone_four_corners_genb (f ux) (Hmonotone1 _) (Hmonotone2 _) _ _ _ _ Hboundedy Hboundedz) as Hmono_fu.
    repeat match goal with
           | [ |- context[ZRange.four_corners ?x ?y ?z] ]
             => let l := fresh "lf" in
                let u := fresh "uf" in
                generalize dependent (ZRange.four_corners x y z); intros [l u]; intros
           end.
    unfold ZRange.is_bounded_by' in *; simpl in *; split; trivial.
    destruct_head'_and; destruct_head' True.
    pose proof (Hmonotone3 y z).
    destruct_head'_ex.
    repeat match goal with
           | [ H : Proper (R ?b ==> Z.le) (f _ _) |- _ ]
             => unique assert (R b (if b then lz else z) (if b then z else lz)
                               /\ R b (if b then z else uz) (if b then uz else z))
               by (unfold R, Basics.flip; destruct b; omega)
           | [ H : Proper (R ?b ==> Z.le) (fun y' => f _ y' _) |- _ ]
             => unique assert (R b (if b then ly else y) (if b then y else ly)
                               /\ R b (if b then y else uy) (if b then uy else y))
               by (unfold R, Basics.flip; destruct b; omega)
           | [ H : Proper (R ?b ==> Z.le) (fun x' => f x' _ _) |- _ ]
             => unique assert (R b (if b then lx else x) (if b then x else lx)
                               /\ R b (if b then x else ux) (if b then ux else x))
               by (unfold R, Basics.flip; destruct b; omega)
           end.
    destruct_head' and.
    repeat match goal with
           | [ H : Proper (R ?b ==> Z.le) _, H' : R ?b _ _ |- _ ]
             => unique pose proof (H _ _ H')
           end.
    destruct_head bool; split_min_max; omega.
  Qed.

  Lemma monotone_eight_corners_gen
        (f : Z -> Z -> Z -> Z)
        (Hmonotone1 : forall x y, Proper (Z.le ==> Z.le) (f x y) \/ Proper (Basics.flip Z.le ==> Z.le) (f x y))
        (Hmonotone2 : forall x z, Proper (Z.le ==> Z.le) (fun y => f x y z) \/ Proper (Basics.flip Z.le ==> Z.le) (fun y => f x y z))
        (Hmonotone3 : forall y z, Proper (Z.le ==> Z.le) (fun x => f x y z) \/ Proper (Basics.flip Z.le ==> Z.le) (fun x => f x y z))
        x_bs y_bs z_bs x y z
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
        (Hboundedy : ZRange.is_bounded_by' None y_bs y)
        (Hboundedz : ZRange.is_bounded_by' None z_bs z)
    : ZRange.is_bounded_by' None (ZRange.eight_corners f x_bs y_bs z_bs) (f x y z).
  Proof.
    eapply monotone_eight_corners_genb; auto.
    { intros x' y'; destruct (Hmonotone1 x' y'); [ exists true | exists false ]; assumption. }
    { intros x' y'; destruct (Hmonotone2 x' y'); [ exists true | exists false ]; assumption. }
    { intros x' y'; destruct (Hmonotone3 x' y'); [ exists true | exists false ]; assumption. }
  Qed.
  Lemma monotone_eight_corners
        (b1 b2 b3 : bool)
        (f : Z -> Z -> Z -> Z)
        (R1 := if b1 then Z.le else Basics.flip Z.le)
        (R2 := if b2 then Z.le else Basics.flip Z.le)
        (R3 := if b3 then Z.le else Basics.flip Z.le)
        (Hmonotone : Proper (R1 ==> R2 ==> R3 ==> Z.le) f)
        x_bs y_bs z_bs x y z
        (Hboundedx : ZRange.is_bounded_by' None x_bs x)
        (Hboundedy : ZRange.is_bounded_by' None y_bs y)
        (Hboundedz : ZRange.is_bounded_by' None z_bs z)
    : ZRange.is_bounded_by' None (ZRange.eight_corners f x_bs y_bs z_bs) (f x y z).
  Proof.
    apply monotone_eight_corners_genb; auto; intro x'; subst R1 R2 R3;
      [ exists b3 | exists b2 | exists b1 ];
      intros ???; apply Hmonotone; break_innermost_match; try reflexivity; trivial.
  Qed.

  Lemma monotonify2 (f : Z -> Z -> Z) (upper : Z -> Z -> Z)
        (Hbounded : forall a b, Z.abs (f a b) <= upper (Z.abs a) (Z.abs b))
        (Hupper_monotone : Proper (Z.le ==> Z.le ==> Z.le) upper)
        {xb yb x y}
        (Hboundedx : ZRange.is_bounded_by' None xb x)
        (Hboundedy : ZRange.is_bounded_by' None yb y)
        (abs_x := ZRange.upper (ZRange.abs xb))
        (abs_y := ZRange.upper (ZRange.abs yb))
    : ZRange.is_bounded_by'
        None
        {| ZRange.lower := -upper abs_x abs_y;
           ZRange.upper := upper abs_x abs_y |}
        (f x y).
  Proof.
    split; [ | exact I ]; subst abs_x abs_y; simpl.
    apply Z.abs_le.
    destruct Hboundedx as [Hx _], Hboundedy as [Hy _].
    etransitivity; [ apply Hbounded | ].
    apply Hupper_monotone;
      unfold ZRange.abs;
      repeat (apply Z.max_case_strong || apply Zabs_ind); omega.
  Qed.
End ZRange.


Theorem my_first_proof : (forall A : Prop, A -> A).
Proof.
  intros A.
  intros proof_of_A.
  exact proof_of_A.
Qed.


Lemma mul_0_r : forall n : nat, n * 0 = 0.
induction n; simpl.
trivial.
apply IHn.
Optimize Proof.
Defined.

Print mul_0_r.
(*
fun n : nat =>
nat_ind (fun n0 : nat => n0 * 0 = 0) eq_refl (fun (n0 : nat) (IHn : n0 * 0 = 0) => IHn) n
*)

Lemma mul_1_l : forall n : nat, 1 * n = n.
simpl.
induction n; simpl.
trivial.
rewrite IHn.
trivial.
Optimize Proof.
Defined.

Print mul_1_l.

(*
nat_ind (fun n0 : nat => n0 + 0 = n0) eq_refl
  (fun (n0 : nat) (IHn : n0 + 0 = n0) => eq_ind_r (fun n1 : nat => S n1 = S n0) eq_refl IHn) n
*)

Theorem m0r_m1l_subst_eq : (mul_0_r 1) = (mul_1_l 0).
simpl.
trivial.
Optimize Proof.
Defined.

Print m0r_m1l_subst_eq.

(*eq_refl*)


(** * Maps: Total and Partial Maps *)

(** _Maps_ (or _dictionaries_) are ubiquitous data structures both
    generally and in the theory of programming languages in
    particular; we're going to need them in many places in the coming
    chapters.  They also make a nice case study using ideas we've seen
    in previous chapters, including building data structures out of
    higher-order functions (from [Basics] and [Poly]) and the use of
    reflection to streamline proofs (from [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we begin...

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

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

(** Documentation for the standard library can be found at
    https://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems involving
    objects of specific types.  Take a minute now to experiment with it. *)

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  In [Lists.v] we introduced a fresh type [id] for a similar
    purpose; here and for the rest of _Software Foundations_ we will
    use the [string] type from Coq's standard library. *)

(** To compare strings, we define the function [eqb_string], which
    internally uses the function [string_dec] from Coq's string
    library. *)

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

(** (The function [string_dec] comes from Coq's string library.
    If you check the result type of [string_dec], you'll see that it
    does not actually return a [bool], but rather a type that looks
    like [{x = y} + {x <> y}], called a [sumbool], which can be
    thought of as an "evidence-carrying boolean."  Formally, an
    element of [{x = y} + {x <> y}] is either a proof that [x] and [y] are equal
    or a proof that they are unequal, together with a tag indicating
    which.  But for present purposes you can think of it as just a
    fancy [bool].) *)

(** Now we need a few basic properties of string equality... *)
Theorem eqb_string_refl : forall s : string, true = eqb_string s s.
Proof.
  intros s. unfold eqb_string.
  destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
  - reflexivity.
  - destruct Hs_not_eq. reflexivity.
Qed.

(** Two strings are equal according to [eqb_string] iff they
    are equal according to [=].  So [=] is reflected in [eqb_string],
    in the sense of "reflection" as discussed in [IndProp]. *)

Theorem eqb_string_true_iff : forall x y : string,
    eqb_string x y = true <-> x = y.
Proof.
   intros x y.
   unfold eqb_string.
   destruct (string_dec x y) as [Hs_eq | Hs_not_eq].
   - rewrite Hs_eq. split. reflexivity. reflexivity.
   - split.
     + intros contra. discriminate contra.
     + intros H. rewrite H in Hs_not_eq. destruct Hs_not_eq. reflexivity.
Qed.

(** Similarly: *)

Theorem eqb_string_false_iff : forall x y : string,
    eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This corollary follows just by rewriting: *)

Theorem false_eqb_string : forall x y : string,
   x <> y -> eqb_string x y = false.
Proof.
  intros x y. rewrite eqb_string_false_iff.
  intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about its behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the very same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps. *)

(** We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A : Type) := string -> A.

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [string]s, yielding [A]s. *)

(** The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any string. *)

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A) :=
  fun x' => if eqb_string x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map. *)

(** For example, we can build a map taking [string]s to [bool]s, where
    ["foo"] and ["bar"] are mapped to [true] and every other key is
    mapped to [false], like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) "foo" true)
           "bar" true.

(** Next, let's introduce some new notations to facilitate working
    with maps. *)

(** First, we will use the following notation to create an empty
    total map with a default value. *)
Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Example example_empty := (_ !-> false).

(** We then introduce a convenient notation for extending an existing
    map with some bindings. *)
Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

(** The [examplemap] above can now be defined as follows: *)

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _     !-> false
  ).

(** This completes the definition of total maps.  Note that we
    don't need to define a [find] operation because it is just
    function application! *)

Example update_example1 : examplemap' "baz" = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap' "foo" = true.
Proof. reflexivity. Qed.

Example update_example3 : examplemap' "quux" = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap' "bar" = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave. *)

(** Even if you don't work the following exercises, make sure
    you thoroughly understand the statements of the lemmas! *)

(** (Some of the proofs require the functional extensionality axiom,
    which is discussed in the [Logic] chapter.) *)

(** **** Exercise: 1 star, standard, optional (t_apply_empty)

    First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_eq)

    Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
    (x !-> v ; m) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_neq)

    On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v ; m) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (t_update_shadow)

    If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on strings with the boolean function [eqb_string]. *)

(** **** Exercise: 2 stars, standard, optional (eqb_stringP)

    Use the proof of [eqbP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma eqb_stringP : forall x y : string,
    reflect (x = y) (eqb_string x y).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Now, given [string]s [x1] and [x2], we can use the tactic
    [destruct (eqb_stringP x1 x2)] to simultaneously perform case
    analysis on the result of [eqb_string x1 x2] and generate
    hypotheses about the equality (in the sense of [=]) of [x1]
    and [x2]. *)

(** **** Exercise: 2 stars, standard (t_update_same)

    With the example in chapter [IndProp] as a template, use
    [eqb_stringP] to prove the following theorem, which states that
    if we update a map to assign key [x] the same value as it already
    has in [m], then the result is equal to [m]: *)

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x ; m) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, standard, recommended (t_update_permute)

    Use [eqb_stringP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (A : Type) (m : total_map A)
                                  v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1 ; x2 !-> v2 ; m)
    =
    (x2 !-> v2 ; x1 !-> v1 ; m).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

(** We introduce a similar notation for partial maps: *)
Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

(** We can also hide the last case when it is empty. *)
Notation "x '|->' v" := (update empty x v)
  (at level 100).

Example examplepmap :=
  ("Church" |-> true ; "Turing" |-> false).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1 ->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A)
                                x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

(* Thu Sep 19 16:47:01 EDT 2019 *)