From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import micromega.Lia.
From Coq Require Import micromega.Zify.
From Coq Require Import Lists.List.
From Coq Require Import Bool.Bool.
From Coq Require Import Reals.Reals. Import Rdefinitions. Import RIneq.
From Coq Require Import ZArith.Zdiv.
From Coq Require Import ZArith.Int.
From Coq Require Import ZArith.Znat.
From Coq Require Import Setoids.Setoid.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Classes.Morphisms.

From ATL Require Import Tactics.

Open Scope Z_scope.

Definition div_ceil (n d : Z) : Z := (n + d - 1) / d.

Notation "a // b" := (div_ceil a b) (at level 10, left associativity).

Theorem zero_div : forall n, 0 < n -> 0 // n = 0.
Proof.
  intros.
  apply Zdiv_small.
  lia.
Qed.

Theorem div_zero : forall n, n // 0 = 0.
Proof.  intros. unfold div_ceil. apply Zdiv_0_r. Qed.

Definition div_ceil_n (n d : nat) : nat := ((n + d - 1) / d)%nat.

Notation "a //n b" := (div_ceil_n a b) (at level 10, left associativity).
Arguments div_ceil_n : simpl never.

Theorem of_nat_div_distr : forall n c,
    (Z.of_nat n) // (Z.of_nat c) = Z.of_nat ( n //n c).
Proof.
  intros.
  destruct c.
  - rewrite div_zero. reflexivity.
  - unfold div_ceil, div_ceil_n.
    rewrite <- Nat2Z.inj_add.
    replace 1 with (Z.of_nat (S O)) by reflexivity.
    rewrite <- Nat2Z.inj_sub by lia.
    rewrite <- div_Zdiv by lia.
    reflexivity.
Qed.

Theorem znat_id_distr : forall n c,
    (Z.to_nat (Z.of_nat n // (Z.of_nat c))) =
    (Z.to_nat (Z.of_nat n)) //n (Z.to_nat (Z.of_nat c)).
Proof.
  intros.
  rewrite of_nat_div_distr.
  repeat rewrite Nat2Z.id.
  reflexivity.
Qed.

Theorem mul_add_lt : forall i j n m,
    0 <= i ->
    i < n ->
    0 <= j ->
    j < m ->
    i * m + j < n * m.
Proof.
  intros.
  assert (i*m <= (n-1) * m).
  {
    apply Z.mul_le_mono_nonneg_r. lia. lia.
  }
  assert ((n-1)*m + j < (n-1)*m + m).
  {
    apply Zplus_lt_compat_l. auto.
  }
  assert (i*m + j <= (n-1)*m + j).
  {
    apply Zplus_le_compat_r. auto.
  }
  eapply Z.le_lt_trans.
  apply H5.
  rewrite Zmult_succ_l_reverse in H4.
  assert (Z.succ (n-1) = n). lia.
  rewrite H6 in H4. auto.
Qed.

Close Scope Z_scope.

Theorem nat_mul_div_id : forall n m,
    0 < m ->
    (n * m) //n m = n.
Proof.
  intros.
  unfold div_ceil_n.
  rewrite <- add_sub_assoc by lia.
  rewrite div_add_l by lia.
  rewrite div_small. lia. lia.
Qed.

Theorem ndiv_pos : forall n m,
    0 < n ->
    0 < m ->
    0 < n //n m .
Proof.
  intros.
  unfold "_ //n _".
  destruct n. lia.
  simpl.
  rewrite sub_0_r.
  apply div_str_pos.
  lia.
Qed.
Hint Extern 1 (0 < _ //n _) => apply ndiv_pos : crunch.

Theorem div_pos : forall n m,
    (0 < n)%Z ->
    (0 < m)%Z ->
    (0 < n // m)%Z.
Proof.
  intros. unfold div_ceil.
  apply Z.div_str_pos. lia.
Qed.
Hint Extern 1 ((0 < _ // _)%Z) => apply div_pos : crunch.

Theorem div_nonneg : forall n m,
    (0 <= n)%Z ->
    (0 < m)%Z ->
    (0 <= n // m)%Z.
Proof.
  intros. unfold div_ceil.
  apply Z.div_pos; lia.
Qed.
Hint Extern 1 ((0 <= _ // _)%Z) => apply div_nonneg : crunch.

Lemma of_nat_nonneg : forall x,
    (0 <= Z.of_nat x)%Z.
Proof.
  intros. zify. lia.
Qed.
Hint Extern 1 ((0 <= _)%Z) => apply of_nat_nonneg : crunch.

Lemma znat_lt : forall x n,
    (0 <= x)%Z ->
    (x < Z.of_nat n)%Z ->
    Z.to_nat x < n.
Proof.
  intros.
  zify. lia.
Qed.

Hint Extern 5 (Z.to_nat _ < _) => apply znat_lt : crunch.

Lemma pos_nat_succ : forall p, exists n, Pos.to_nat p = S n.
Proof.
  intros p.
  specialize (Pos2Nat.is_pos p); intros.
  destruct (Pos.to_nat p); try lia; eauto.
Qed.

Ltac posnat :=
  match goal with
  | [ |- context[Pos.to_nat ?p] ] => specialize (pos_nat_succ p);
                                     intros [pn Hpos]; rewrite Hpos
  end.

Lemma znat_0lt : forall x, (0 < x)%Z -> 0 < (Z.to_nat x).
Proof.
  intros. zify. lia.
Qed.

Hint Resolve znat_0lt : crunch.

Lemma natz_0lt : forall x, 0 < x -> (0 < (Z.of_nat x))%Z.
Proof.
  intros. zify. lia.
Qed.

Hint Resolve natz_0lt : crunch.

Lemma weaker_Z2Nat_injlt : forall i j,
    Z.to_nat i < Z.to_nat j ->
    (0 <= i)%Z ->
    (i < j)%Z.
Proof.
  intros. destruct j eqn:e.
  - simpl in *. lia.
  - rewrite <- e in *.
    apply Z2Nat.inj_lt in H; auto.
    subst.
    apply Zle_0_pos.
  - simpl in *. lia.
Qed.

Lemma factor_unique : forall i i0 i1 i2 m,
    (0 <= i0 < m)%Z ->
    (0 <= i2 < m)%Z ->
    ((i * m + i0 =? i1 * m + i2)%Z =
     (i=?i1)%Z && (i0=?i2)%Z).
Proof.
  intros.
  unbool.
  split; intros.
  - eapply Z.div_mod_unique.
    left.
    eauto.
    left.
    lia.
    rewrite Z.mul_comm. rewrite H1. rewrite Z.mul_comm. reflexivity.
  - destruct H1. subst. reflexivity.
Qed.

Lemma div_eucl_div : forall a b,
    (b > 0)%Z ->
    let (q,_) := Z.div_eucl a b in
    q = (a / b)%Z.
Proof.
  intros.
  pose (Z_div_mod a b). peel_hyp.
  destruct (Z.div_eucl a b) eqn:e. destruct y.
  subst.
  rewrite Z.add_comm.
  rewrite Z.mul_comm.
  rewrite Z_div_plus by auto.
  rewrite Zdiv_small; auto.
Qed.

Lemma mul_lt : forall z k x,
  (0 <= z < k)%Z ->
  ((z < k * x)%Z <-> (0 < x)%Z).
Proof.
  intros.
  split; intros.
  - destruct x. lia. zlia.
    assert (0 < k * Z.neg p)%Z by lia.
    assert (0 < k)%Z by lia.
    apply Z.lt_0_mul in H1.
    lia.
  - destruct x; zify; try lia.
    assert (1 <= Z.pos p )%Z by (zify; lia).
    replace z with (z * 1)%Z by lia.
    destruct (1 =? Z.pos p)%Z eqn:ee; unbool.
    * rewrite <- ee.
      lia.
    * assert (1 < Z.pos p)%Z by lia.
      apply Z.mul_lt_mono_nonneg; try lia.
Qed.

Lemma mul_le : forall z k x,
    (0 <= z < k)%Z ->
    (k * x <= z <-> x <= 0)%Z.
Proof.
  intros.
  split; intros.
  - destruct x; zify; try lia.
    assert (k < k * Z.pos p)%Z.
    assert (1 <= Z.pos p )%Z by (zify; lia).
    destruct (1 =? Z.pos p)%Z eqn:ee; unbool.
    + rewrite <- ee in *. rewrite Z.mul_1_r in *. lia.
    + assert (1 < Z.pos p)%Z by lia.
      replace k with (k * 1)%Z at 1 by lia.
      apply Zmult_lt_compat_l; lia.
    + lia.
  - destruct (x =? 0)%Z eqn:ee; unbool.
    + subst. rewrite Z.mul_0_r. lia.
    + assert (x < 0)%Z by lia.
      assert (k * x < 0)%Z.
      apply Z.mul_pos_neg; lia.
      lia.
Qed.

Lemma floor_lt_ceil : forall x y,
    (0 <= x)%Z ->
    (0 < y)%Z ->
    (x / y <= x // y)%Z.
Proof.
  intros.
  unfold div_ceil.
  apply Z_div_le. lia. lia.
Qed.

Lemma div_eq_num_diff : forall a b c,
    (0 <= a)%Z ->
    (0 <= b)%Z ->
    (0 < c)%Z ->
    (a / c = b / c)%Z ->
    (a < b)%Z ->
    (b - a < c)%Z.
Proof.
  intros.
  pose (Z_div_mod a c). peel_hyp.
  pose (Z_div_mod b c). peel_hyp.
  destruct (Z.div_eucl a c).
  destruct (Z.div_eucl b c).
  destruct y. destruct y0. subst.
  rewrite Z.sub_add_distr.
  repeat rewrite (Z.mul_comm c) in H2.
  repeat rewrite Z.div_add_l in H2 by lia.
  repeat rewrite Z.div_small in H2 by lia.
  repeat rewrite Z.add_0_r in H2.
  subst. lia.
Qed.

Lemma floor_lt_ceil_mono_l : forall i k n,
    (0 <= i)%Z ->
    (i < n)%Z ->
    (0 < k)%Z ->
    (0 < n)%Z ->
    (i / k < n // k)%Z.
Proof.
  intros. unfold div_ceil.
  pose proof (Z.div_le_mono i (n+k-1)%Z k). peel_hyp; try lia.
  destruct (i / k =? (n + k - 1) / k)%Z eqn:e; unbool.
  - rewrite <- e in *. clear H3.
    apply div_eq_num_diff in e; try lia.
  - lia.
Qed.
Hint Resolve floor_lt_ceil_mono_l : crunch.

Lemma floor_lt_nat_ceil_mono_l : forall i k n,
    (0 <= i)%Z ->
    (i < Z.of_nat n)%Z ->
    0 < k ->
    0 < n ->
    (i / Z.of_nat k < Z.of_nat (n //n k))%Z.
Proof.
  intros.
  rewrite <- of_nat_div_distr.
  apply floor_lt_ceil_mono_l; auto with crunch.
Qed.
Hint Resolve floor_lt_nat_ceil_mono_l : crunch.

Theorem pos_zofnat : forall n,
    0 < n ->
    (0 < Z.of_nat n)%Z.
Proof. intros. lia. Qed.
Hint Resolve pos_zofnat : crunch.
Hint Resolve Z.div_pos : crunch.

Lemma expand_Zmod : forall i m,
    (0 < m)%Z ->
    (i - i / m * m = Zmod i m)%Z.
Proof.
  intros. unfold Zmod.
  pose proof (Z_div_mod i m).
  assert (m > 0)%Z by lia.
  apply H0 in H1.
  destruct (Z.div_eucl i m) eqn:e.
  destruct H1.
  rewrite H1.
  rewrite Z.mul_comm.
  rewrite Z_div_plus_full_l by lia.
  rewrite Zdiv_small by lia.
  rewrite Z.add_0_r. lia.
Qed.

Lemma Zplus_assoc : forall p m n, (n + (m + p))%Z = (n + m + p)%Z.
Proof. intros. lia. Qed.

Lemma div_ceil_n_lower_bound : forall n k,
    0 < k ->
    n <= n //n k * k.
Proof.
  intros n k Hk_pos.
  unfold div_ceil_n.
  assert (k <> 0) as Hk_nzero by lia.
  pose proof (div_mod (n + k - 1) k Hk_nzero).
  assert ((n + k - 1) mod k < k) by (apply mod_upper_bound; apply Hk_nzero).
  assert (n <= k * ((n + k - 1) / k)) by lia.
  rewrite mul_comm. assumption.
Qed.

Hint Resolve div_ceil_n_lower_bound : crunch.

Lemma mod_upper_bound : forall k i,
    (0 < k)%Z ->
    (i mod k < k)%Z.
Proof.
  intros.
  pose proof (Z.mod_pos_bound i k).
  peel_hyp. lia.
Qed.

Lemma mod_nonneg : forall k i,
    (0 < k)%Z ->
    (0 <= i mod k)%Z.
Proof.
  intros.
  pose proof (Z.mod_pos_bound i k).
  peel_hyp. lia.
Qed.

Hint Resolve mod_upper_bound mod_nonneg : crunch.

Theorem div_mod_eq : forall i k,
    (0 < k)%Z ->
    (i / k * k + i mod k = i)%Z.
Proof.
  intros.
  rewrite <- expand_Zmod by lia.
  rewrite Zplus_minus.
  reflexivity.
Qed.

Lemma gt_add_r : forall k a b,
    (0 <= a)%Z ->
    (k <= b)%Z ->
    (k <= a + b)%Z.
Proof. intros. lia. Qed.

Hint Resolve Z.max_lub Z.min_glb Z.le_max_l Z.le_min_r Z.le_min_l : crunch.

Lemma ceil_div_pos : forall (m k : Z),
    (0 < m)%Z ->
    (0 < k)%Z ->
    (0 < m // k)%Z.
Proof.
  intros.
  unfold div_ceil.
  assert (m + k - 1 >= k)%Z by lia.
  apply Z.div_str_pos.
  split; lia.
Qed.

Lemma ceil_div_nonneg : forall (m k : Z),
    (0 <= m)%Z ->
    (0 < k)%Z ->
    (0 <= m // k)%Z.
Proof.
  intros.
  assert (m = 0 \/ 0 < m)%Z as [ Hm_zero | Hm_pos ] by lia.
  {
    rewrite Hm_zero in *.
    rewrite zero_div by assumption.
    lia.
  }
  {
    pose proof (ceil_div_pos m k Hm_pos H0).
    lia.
  }
Qed.

Lemma ceil_div_mod_pos : forall (m k : Z),
    (0 < m)%Z ->
    (0 < k)%Z ->
    (0 < (m mod k) // k)%Z \/ (0 < m /k)%Z.
Proof.
  intros m k H H0.
  assert (0 <= m)%Z as H' by lia.
  pose proof (Z.mod_bound_pos m k H' H0) as [Hlb Hub].
  assert ((m mod k = 0)%Z \/ (0 < m mod k)%Z) as [Heq | Hgt]by lia.
  {
    assert (k <> 0)%Z as Hk_nzero by lia.
    pose proof (Znumtheory.Zmod_divide m k Hk_nzero Heq).
    right.
    assert (k = 1 \/ 1 < k)%Z as [Hk_eq1 | Hk_gt1] by lia.
    {
      rewrite Hk_eq1 in *.
      rewrite Z.div_1_r.
      assumption.
    }
    {
      pose proof (Znumtheory.Zdivide_Zdiv_lt_pos k m Hk_gt1 H H1) as [H_goal _].
      apply H_goal.
    }
  }
  {
    left.
    apply ceil_div_pos; assumption.
  }
Qed.

Lemma split_floor_rest_nonneg : forall m k,
    (0 < m)%Z ->
    (0 < k)%Z ->
    (0 < m / k + (m mod k) // k)%Z.
Proof.
  intros.
  assert (0 <= m / k)%Z as Hdiv_nneg.
  {
    apply Z.div_pos; lia.
  }
  assert (0 <= (m mod k) // k)%Z as Hdiv_mod_nneg.
  {
    apply ceil_div_nonneg.
    { apply mod_nonneg; assumption. }
    { assumption. }
  }
  pose proof (ceil_div_mod_pos m k H H0) as [ Hdiv_mod_pos | H_div_pos ];
  lia.
Qed.

Lemma floor_div_mono_helper : forall (n k : Z),
  (0 < k)%Z -> (n < k * (n / k) + k)%Z.
Proof.
  intros n k Hk_pos.
  assert (k <> 0)%Z as Hk_nzero by lia.
  pose proof (Z.div_mod n k Hk_nzero).
  pose proof (mod_upper_bound k n Hk_pos).
  lia.
Qed.

Lemma floor_div_mono_strict : forall (n m k : Z),
    (0 < k)%Z ->
    (n / k < m / k)%Z ->
    (n < m)%Z.
Proof.
  intros.
  assert (k * (n / k) < k * (m / k))%Z as H_mul_lt.
  { apply Z.mul_lt_mono_pos_l; assumption. }
  pose proof (floor_div_mono_helper n k H).
  pose proof (Z.mul_div_le m k H).
  assert ((n / k) + 1 <= (m / k))%Z by lia.
  assert (k * ((n / k) + 1) <= k * ((m / k)))%Z.
  { apply Z.mul_le_mono_nonneg_l; lia. }
  assert (k * (n / k) + k <= m)%Z.
  { rewrite Z.mul_add_distr_l in H4. lia. }
  lia.
Qed.

Lemma floor_div_mono_upper : forall (n m k : Z),
  (0 < k)%Z ->
  (m < n / k)%Z ->
  (m * k <= n - k)%Z.
Proof.
  intros.
  assert (m * k / k <= (n - k) / k)%Z as H_div_bound.
  {
    rewrite Z.div_mul by lia.
    replace (n - k)%Z with (n + -1 * k)%Z by lia.
    rewrite Z.div_add; lia.
  }
  assert (m * k / k = (n - k) / k \/ m * k / k < (n - k) / k)%Z as [ H_div_eq | H_div_lt ] by lia.
  {
    rewrite Z.div_mul in H_div_eq by lia.
    rewrite H_div_eq in *.
    rewrite Z.mul_comm.
    apply Z.mul_div_le.
    assumption.
  }
  {
    pose proof (floor_div_mono_strict (m * k) (n - k) k H H_div_lt).
    lia.
  }
Qed.

Lemma floor_div_mul_lt : forall n k i0 i1,
    (0 < k)%Z ->
    (0 <= i0)%Z ->
    (i0 < n / k)%Z ->
    (0 <= i1)%Z ->
    (i1 < k)%Z ->
    (i0 * k + i1 < n)%Z.
Proof.
  intros.
  assert (i0 * k <= n - k)%Z.
  { apply floor_div_mono_upper; assumption. }
  { lia. }
Qed.

Hint Resolve floor_div_mul_lt split_floor_rest_nonneg Z.div_pos  : crunch.

Lemma Z_div_mod_eq : forall (n k : Z),
    (k <> 0)%Z ->
    (k * (n / k) = n - (n mod k))%Z.
Proof.
  intros n k Hk_nzero.
  pose proof (Z.div_mod n k Hk_nzero).
  lia.
Qed.

Lemma ceil_floor_mod : forall n k,
    (0 <= n)%Z ->
    (0 < k)%Z ->
    (n//k = n/k + ((n mod k) // k))%Z.
Proof.
  intros n k Hn_nneg Hk_pos.
  unfold div_ceil.
  apply Z.mul_cancel_l with (p := k).
  { lia. }
  rewrite Z.mul_add_distr_l.
  assert (k <> 0)%Z as Hk_nzero by lia.
  repeat rewrite Z_div_mod_eq by assumption.
  replace (n - n mod k + (n mod k + k - 1 - (n mod k + k - 1) mod k))%Z
    with (n + k - 1 - (n mod k + k - 1) mod k)%Z by lia.
  assert ((n + k - 1) mod k = (n mod k + k - 1) mod k)%Z.
  2: lia.
  replace (n + k - 1)%Z with (n + (k - 1))%Z by lia.
  replace (n mod k + k - 1)%Z with (n mod k + (k - 1))%Z by lia.
  rewrite Z.add_mod by assumption.
  symmetry.
  rewrite Z.add_mod by assumption.
  rewrite Z.mod_mod by assumption.
  lia.
Qed.


Require Export section_07_equivalences.

(** Section 8.1 Contractible types *)

(** Definition 8.1.1 *)

Definition is_contr (A : Type) : Type :=
  Sigma A (fun a => forall x, a == x).

Definition center {A : Type} : is_contr A -> A := pr1.

Definition contraction' {A : Type} (c : is_contr A) (x y : A) : x == y :=
  concat (inv (pr2 c x)) (pr2 c y).

Definition contraction {A : Type} (c : is_contr A) :
  forall x, (center c) == x :=
  contraction' c (center c).

Definition coh_contraction {A : Type} (c : is_contr A) :
  contraction c (center c) == refl := left_inv.

(** Remark 8.1.3 *)

Definition contraction_unit : forall x, star == x.
Proof.
  intro x. now destruct x.
Defined.

Theorem is_contr_unit : is_contr unit.
Proof.
  exact (pair star contraction_unit).
Defined.

(** Definition 8.1.4 *)

Definition ev_pt {A} {B : A -> Type} (a : A) :
  (forall x, B x) -> B a :=
  fun h => h a.

Definition Ind_sing {A} (a : A) : Type :=
  forall (B : A -> Type), sec (@ev_pt A B a).

(** Remark 8.1.5 *)

Definition ind_sing_unit (B : unit -> Type) (b : B star) (x : unit) : B x.
Proof.
  now destruct x.
Defined.

Definition comp_sing_unit (B : unit -> Type) (b : B star) :
  ev_pt star (ind_sing_unit B b) == b.
Proof.
  reflexivity.
Defined.

Definition Ind_sing_unit : Ind_sing star.
Proof.
  intro B.
  apply (pair (ind_sing_unit B)).
  exact (comp_sing_unit B).
Defined.

(** Theorem 8.1.6 *)

Definition ind_sing_is_contr {A} {a : A} (c : is_contr A) {B : A -> Type}
           (b : B a) : forall x, B x :=
  fun x => tr B (contraction' c a x) b.

Definition comp_sing_is_contr {A} {a : A} (c : is_contr A) {B : A -> Type}
           (b : B a) :
  ev_pt a (ind_sing_is_contr c b) == b :=
  ap (fun p => tr B p b) left_inv.

Theorem Ind_sing_is_contr {A} (c : is_contr A) (a : A) : Ind_sing a.
Proof.
  intro B.
  exact (pair (ind_sing_is_contr c) (comp_sing_is_contr c)).
Defined.

Theorem is_contr_Ind_sing {A} (a : A) (H : Ind_sing a) : is_contr A.
Proof.
  apply (pair a).
  now apply (map_sec (H (fun x => a == x))).
Defined.

(** Theorem 8.1.7 *)

Definition total_path {A} (a : A) : Type :=
  Sigma A (fun x => a == x).

Definition pt_total_path {A} (a : A) : total_path a :=
  pair a refl.

Definition ev_refl {A} (a : A) {B : forall x, a == x -> Type} :
  (forall x p, B x p) -> B a refl :=
  fun h => h a refl.

Definition ind_sing_total_path {A} (a : A) {B : total_path a -> Type}
           (b : B (pt_total_path a)) :
  forall x, B x.
Proof.
  intro x.
  destruct x as [x p].
  now destruct p.
Defined.

Definition comp_sing_total_path {A} (a : A) {B : total_path a -> Type}
           (b : B (pt_total_path a)) :
  ev_pt (pt_total_path a) (ind_sing_total_path a b) == b := refl.

Definition Ind_sing_total_path {A} (a : A) :
  @Ind_sing (Sigma A (fun x => a == x)) (pair a refl).
Proof.
  intro B.
  apply (pair (ind_sing_total_path a)).
  exact (comp_sing_total_path a).
Defined.

Theorem is_contr_total_path {A} (a : A) : is_contr (total_path a).
Proof.
  apply (is_contr_Ind_sing (pt_total_path a)).
  exact (Ind_sing_total_path a).
Defined.

(** Section 8.2 Contractible maps *)

(** Definition 8.2.1 *)

Definition fib {A B} (f : A -> B) (b : B) : Type :=
  Sigma A (fun x => f x == b).

(** Definition 8.2.2 *)

Definition Eq_fib {A B} (f : A -> B) {b : B} (s t : fib f b) : Type :=
  Sigma (pr1 s == pr1 t) (fun p => pr2 s == concat (ap f p) (pr2 t)).

Definition refl_Eq_fib {A B} (f : A -> B) {b : B} (s : fib f b) :
  Eq_fib f s s := pair refl refl.

(** Lemma 8.2.3 *)

Definition Eq_fib_eq {A B} (f : A -> B) {b : B} {s t : fib f b} :
  s == t -> Eq_fib f s t.
Proof.
  intro p; destruct p.
  apply refl_Eq_fib.
Defined.

Definition eq_Eq_fib {A B} (f : A -> B) {b : B} {s t : fib f b} :
  Eq_fib f s t -> s == t.
Proof.
  induction s as [x p]; induction t as [y q].
  intro e; destruct e as [u v].
  cbn in u; induction u.
  cbn in v; now induction v.
Defined.

Definition is_sec_eq_Eq_fib {A B} (f : A -> B) {b : B} {s t : fib f b} :
  comp (@Eq_fib_eq _ _ f b s t) (eq_Eq_fib f) ~ idmap.
Proof.
  induction s as [x p]; induction t as [y q].
  intro e; destruct e as [u v].
  cbn in u; induction u.
  cbn in v; now induction v.
Defined.

Definition is_retr_eq_Eq_fib {A B} (f : A -> B) {b : B} {s t : fib f b} :
  comp (eq_Eq_fib f) (@Eq_fib_eq _ _ f b s t) ~ idmap.
Proof.
  intro p; destruct p; now destruct s.
Defined.

Theorem is_equiv_Eq_fib_eq {A B} (f : A -> B) {b : B} {s t : fib f b} :
  is_equiv (@Eq_fib_eq _ _ f b s t).
Proof.
  apply (is_equiv_has_inverse (eq_Eq_fib f)).
  - exact (is_sec_eq_Eq_fib f).
  - exact (is_retr_eq_Eq_fib f).
Defined.

Theorem is_equiv_eq_Eq_fib {A B} (f : A -> B) {b : B} {s t : fib f b} :
  is_equiv (@eq_Eq_fib _ _ f b s t).
Proof.
  apply (is_equiv_has_inverse (Eq_fib_eq f)).
  - exact (is_retr_eq_Eq_fib f).
  - exact (is_sec_eq_Eq_fib f).
Defined.

(** Definition 8.2.4 *)

Definition is_contr_map {A B} (f : A -> B) : Type :=
  forall b, is_contr (fib f b).

(** Theorem 8.2.5 *)

Definition inv_is_contr_map {A B} {f : A -> B} (c : is_contr_map f) :
  B -> A.
Proof.
  intro b.
  exact (pr1 (center (c b))).
Defined.

Definition is_sec_inv_is_contr_map {A B} {f : A -> B} (c : is_contr_map f) :
  comp f (inv_is_contr_map c) ~ idmap.
Proof.
  intro b.
  exact (pr2 (center (c b))).
Defined.

(** Sometimes Coq pretends it cannot apply a tactic, while it should certainly
    accept my steps. This is one of those cases, where it is easier to just
    write out the proof term than to convince Coq of some sequence of tactics. *)

Definition is_retr_inv_is_contr_map {A B} {f : A -> B} (c : is_contr_map f) :
  comp (inv_is_contr_map c) f ~ idmap.
Proof.
  intro a.
  set (g := inv_is_contr_map c).
  assert (p : f (g (f a)) == f a) by apply is_sec_inv_is_contr_map.
  assert (q : pair (g (f a)) p == pair a refl) by apply (contraction' (c (f a))).
  exact (ap pr1 q).
Defined.

Theorem is_equiv_is_contr_map {A B} {f : A -> B} :
  is_contr_map f -> is_equiv f.
Proof.
  intro is_contr_f.
  apply (is_equiv_has_inverse (inv_is_contr_map is_contr_f)).
  - apply is_sec_inv_is_contr_map.
  - apply is_retr_inv_is_contr_map.
Defined.

(** Section 8.3 Equivalences are contractible maps *)

(** Definition 8.3.1 *)

Definition is_coh_invertible {A B} (f : A -> B) : Type :=
  Sigma
    (B -> A)
    (fun g => Sigma
                (comp f g ~ idmap)
                (fun G => Sigma
                            (comp g f ~ idmap)
                            (fun H =>
                               right_whisker_htpy G f ~
                                                  left_whisker_htpy f H))).

Definition inv_is_coh_invertible {A B} {f : A -> B} :
  is_coh_invertible f -> B -> A := pr1.

Definition is_sec_inv_is_coh_invertible {A B} {f : A -> B}
           (I : is_coh_invertible f) :
  comp f (inv_is_coh_invertible I) ~ idmap := pr1 (pr2 I).

Definition is_retr_inv_is_coh_invertible {A B} {f : A -> B}
           (I : is_coh_invertible f) :
  comp (inv_is_coh_invertible I) f ~ idmap := pr1 (pr2 (pr2 I)).

Definition coh_inv_is_coh_invertible {A B} {f : A -> B}
           (I : is_coh_invertible f) :
  right_whisker_htpy (is_sec_inv_is_coh_invertible I) f ~
                     left_whisker_htpy f (is_retr_inv_is_coh_invertible I) :=
  pr2 (pr2 (pr2 I)).

(** Lemma 8.3.2 *)

Definition center_fib_is_coh_invertible {A B} {f : A -> B}
           (I : is_coh_invertible f) (b : B) : fib f b :=
  pair (inv_is_coh_invertible I b) (is_sec_inv_is_coh_invertible I b).

Definition contraction_fib_is_coh_invertible {A B} {f : A -> B}
           (I : is_coh_invertible f) (b : B) (x : fib f b) :
  center_fib_is_coh_invertible I b == x.
Proof.
  apply (eq_Eq_fib f).
  destruct x as [x p]; destruct p.
  apply (pair (is_retr_inv_is_coh_invertible I x)).
  transitivity (ap f (is_retr_inv_is_coh_invertible I x)).
  - apply (coh_inv_is_coh_invertible I).
  - apply inv; apply right_unit.
Defined.

Theorem is_contr_map_is_coh_invertible {A B} {f : A -> B} :
  is_coh_invertible f -> is_contr_map f.
Proof.
  intros I b.
  apply (pair (center_fib_is_coh_invertible I b)).
  exact (contraction_fib_is_coh_invertible I b).
Defined.

(** Definition 8.3.3 *)

Definition nat_htpy {A B} {f g : A -> B} (H : f ~ g) {x y : A} (p : x == y) :
  concat (ap f p) (H y) == concat (H x) (ap g p).
Proof.
  destruct p.
  apply inv; apply right_unit.
Defined.

(** Definition 8.3.4 *)

Definition left_unwhisk {A} {x y z : A} (p : x == y) {q r : y == z} :
  concat p q == concat p r -> q == r.
Proof.
  now destruct p.
Defined.

Definition right_unwhisk {A} {x y z : A} {p q : x == y} (r : y == z) :
  concat p r == concat q r -> p == q.
Proof.
  destruct r.
  intro s.
  exact (concat (inv right_unit) (concat s right_unit)).
Defined.

Definition reduce_htpy {A} {f : A -> A} {H : f ~ idmap} {x : A} :
  ap f (H x) == H (f x).
Proof.
  apply (right_unwhisk (H x)).
  transitivity (concat (H (f x)) (ap idmap (H x))).
  apply nat_htpy.
  apply (ap (concat (H (f x)))).
  apply inv. apply ap_id.
Defined.

(** Lemma 8.3.5 *)

Definition mod_is_sec_inv_has_inverse {A B} {f : A -> B} (I : has_inverse f) :
  comp f (inv_has_inverse I) ~ idmap.
Proof.
  intro y.
  transitivity (f (inv_has_inverse I (f (inv_has_inverse I y)))).
  - apply inv.
    exact (is_sec_inv_has_inverse I (f (inv_has_inverse I y))).
  - transitivity (f (inv_has_inverse I y)).
    * exact (ap f (is_retr_inv_has_inverse I (inv_has_inverse I y))).
    * exact (is_sec_inv_has_inverse I y).
Defined.

Definition coh_inv_has_inverse {A B} {f : A -> B} (I : has_inverse f) :
  right_whisker_htpy (mod_is_sec_inv_has_inverse I) f ~
                     left_whisker_htpy f (is_retr_inv_has_inverse I).
Proof.
  intro x.
  apply inv; apply inv_con; apply inv.
  transitivity (concat (ap (comp f (comp (inv_has_inverse I) f)) (is_retr_inv_has_inverse I x)) (is_sec_inv_has_inverse I (f x))).
  - apply (ap (concat' (is_sec_inv_has_inverse I (f x)))).
    transitivity (ap f (ap (comp (inv_has_inverse I) f) (is_retr_inv_has_inverse I x))).
    * apply (ap (ap f)).
      apply inv. exact reduce_htpy.
    * apply ap_comp.
  - apply (nat_htpy (right_whisker_htpy (is_sec_inv_has_inverse I) f)).
Defined.

Lemma is_coh_invertible_has_inverse {A B} {f : A -> B} :
  has_inverse f -> is_coh_invertible f.
Proof.
  intro I.
  apply (pair (inv_has_inverse I)).
  apply (pair (mod_is_sec_inv_has_inverse I)).
  apply (pair (is_retr_inv_has_inverse I)).
  exact (coh_inv_has_inverse I).
Defined.

(** Theorem 8.3.6 *)

Lemma is_contr_map_has_inverse {A B} {f : A -> B} :
  has_inverse f -> is_contr_map f.
Proof.
  intro I.
  apply is_contr_map_is_coh_invertible.
  now apply is_coh_invertible_has_inverse.
Defined.

Theorem is_contr_map_is_equiv {A B} {f : A -> B} : is_equiv f -> is_contr_map f.
Proof.
  intro is_equiv_f.
  apply is_contr_map_has_inverse.
  now apply has_inverse_is_equiv.
Defined.

(** Corollary 8.3.7 *)

Definition total_path' {A} (a : A) : Type :=
  Sigma A (fun x => x == a).

Lemma is_contr_map_idmap {A} : is_contr_map (@idmap A).
Proof.
  apply is_contr_map_is_equiv.
  exact is_equiv_idmap.
Defined.

Definition is_contr_total_path' {A} (a : A) : is_contr (total_path' a) :=
  is_contr_map_idmap a.

(** Exercises *)

(** Exercise 8.1 *)

Definition is_prop_is_contr {A} (c : is_contr A) {x y : A} : is_contr (x == y).
Proof.
  apply (pair (contraction' c x y)).
  intro p; destruct p.
  apply left_inv.
Defined.

(** Exercise 8.2 *)

Definition is_contr_retract {A B} (R : sr_pair A B) :
  is_contr B -> is_contr A.
Proof.
  destruct R as [i [r H]].
  intro is_contr_B; destruct is_contr_B as [b c].
  apply (pair (r b)).
  intro x.
  transitivity (r (i x)).
  - now apply (ap r).
  - now apply H.
Defined.

(** Exercise 8.3 *)

(** Exercise 8.3.a *)

Definition sr_pair_is_equiv {A B} {f : A -> B} :
  is_equiv f -> sr_pair A B.
Proof.
  intro H.
  exact (pair f (retr_is_equiv H)).
Defined.

Definition is_contr_is_equiv_const_star {A} :
  is_equiv (@const A unit star) -> is_contr A.
Proof.
  intro H.
  apply (is_contr_retract (sr_pair_is_equiv H)).
  exact is_contr_unit.
Defined.

Definition is_equiv_const_star_is_contr {A} :
  is_contr A -> is_equiv (@const A unit star).
Proof.
  intro c.
  apply (is_equiv_has_inverse (const (center c))).
  exact (contraction is_contr_unit).
  exact (contraction c).
Defined.

(** Exercise 8.3.b *)

Definition is_contr_is_equiv {A B} {f : A -> B} :
  is_equiv f -> is_contr B -> is_contr A.
Proof.
  intro H.
  apply is_contr_retract.
  apply (sr_pair_is_equiv H).
Defined.

Definition is_contr_equiv {A B} (e : A <~> B) :
  is_contr B -> is_contr A :=
  is_contr_is_equiv (is_equiv_map_equiv e).

Definition is_contr_is_equiv' {A B} {f : A -> B} :
  is_equiv f -> is_contr A -> is_contr B.
Proof.
  intro H.
  exact (is_contr_is_equiv (is_equiv_inv_is_equiv H)).
Defined.

Definition is_contr_equiv' {A B} (e : A <~> B) :
  is_contr A -> is_contr B :=
  is_contr_is_equiv' (is_equiv_map_equiv e).

Definition is_equiv_is_contr {A B} (f : A -> B) :
  is_contr A -> is_contr B -> is_equiv f.
Proof.
  intros CA CB.
  apply (@is_equiv_right_factor A B unit
                                (@const A unit star)
                                (@const B unit star)
                                (pair f (@refl_htpy _ _ (@const A unit star)))).
  - now apply is_equiv_const_star_is_contr.
  - now apply is_equiv_const_star_is_contr.
Defined.


Require Import Arith MoreInversion Coq.Lists.List Setoid Coq.Lists.SetoidList Omega.
Require Import Len.
(*Require Import EqDec AutoIndTac.*)

Set Implicit Arguments.

Inductive length_eq X Y : list X -> list Y -> Type :=
  | LenEq_nil : length_eq nil nil
  | LenEq_cons x XL y YL : length_eq XL YL -> length_eq (x::XL) (y::YL).

Smpl Add 100
     match goal with
     | [ H : @length_eq _ _ ?L ?L' |- _ ]
       => inv_if_one_ctor H L L'
     end : inv_trivial.

Lemma length_eq_refl X (XL:list X)
  : length_eq XL XL.
Proof.
  induction XL; eauto using length_eq.
Qed.

Lemma length_eq_sym X Y (XL:list X) (YL:list Y)
  : length_eq XL YL -> length_eq YL XL.
Proof.
  intros A. induction A;eauto using length_eq.
Qed.

Lemma length_eq_trans X Y Z (XL:list X) (YL:list Y) (ZL:list Z)
  : length_eq XL YL -> length_eq YL ZL -> length_eq XL ZL.
Proof.
  intros A. revert ZL.
  induction A; inversion 1; eauto using length_eq.
Qed.

Lemma length_length_eq X Y (L:list X) (L':list Y)
  : length L = length L' -> length_eq L L'.
Proof.
  revert L'.
  induction L; destruct L'; inversion 1; eauto using length_eq.
Qed.

Lemma length_eq_length X Y (L:list X) (L':list Y)
  : length_eq L L' -> length L = length L'.
Proof.
  revert L'.
  induction L; destruct L'; inversion 1; simpl; eauto.
Qed.

Ltac length_equify :=
  repeat (match goal with
            | [ H : length ?A = length ?B |- _ ] =>
              eapply length_length_eq in H
          end).

Hint Immediate length_eq_length : len.
Hint Resolve length_length_eq : len.


(* List_Type_ Library *)

(** * Copy of some List library with parameters with Type output *)

Require Export List.

Set Implicit Arguments.

Section In.

Variable A:Type.

Fixpoint In_Type (a:A) (l:list A) : Type :=
    match l with
      | nil => False
      | b :: m => sum (b = a) (In_Type a m)
    end.

  (** Characterization of [In] *)

  Theorem in_Type_eq : forall (a:A) (l:list A), In_Type a (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Theorem in_Type_cons : forall (a b:A) (l:list A), In_Type b l -> In_Type b (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Theorem not_in_Type_cons (x a : A) (l : list A):
    (In_Type x (a::l) -> False) -> (x<>a) * (In_Type x l -> False).
  Proof.
    simpl. intuition.
  Qed.

  Theorem cons_not_in_Type (x a : A) (l : list A):
    x<>a -> (In_Type x l -> False) -> In_Type x (a::l) -> False.
  Proof.
    simpl. intuition.
  Qed.

  Theorem in_Type_nil : forall a:A, In_Type a nil -> False.
  Proof.
    unfold not; intros a H; inversion_clear H.
  Qed.

  Theorem in_Type_split : forall x (l:list A), In_Type x l ->
    { l' | l = (fst l')++(x::snd l') }.
  Proof.
  induction l; simpl; destruct 1.
  subst a; auto.
  exists (nil, l) ; auto.
  destruct (IHl i) as ((l1,l2),H0).
  exists (a::l1, l2); simpl. apply f_equal. auto.
  Qed.

  (** Inversion *)
  Lemma in_Type_inv : forall (a b:A) (l:list A), In_Type b (a :: l) ->
    sum (a = b) (In_Type b l).
  Proof.
    intros a b l H; inversion_clear H; auto.
  Qed.

  (** Decidability of [In] *)
  Theorem in_Type_dec :
    (forall x y:A, {x = y} + {x <> y}) ->
    forall (a:A) (l:list A), (In_Type a l) + (In_Type a l -> False).
  Proof.
    intro H; induction l as [| a0 l IHl].
    right; apply in_Type_nil.
    destruct (H a0 a); simpl; auto.
    destruct IHl; simpl; auto.
    right; unfold not; intros [Hc1| Hc2]; auto.
  Defined.

  (** Compatibility with other operations *)
  Lemma in_Type_app_or : forall (l m:list A) (a:A), In_Type a (l ++ m) ->
    In_Type a l + In_Type a m.
  Proof.
    intros l m a.
    elim l; simpl; auto.
    intros a0 y H H0.
    now_show (sum (sum (a0 = a) (In_Type a y)) (In_Type a m)).
    elim H0; auto.
    intro H1.
    now_show (sum (sum (a0 = a) (In_Type a y)) (In_Type a m)).
    elim (H H1); auto.
  Qed.

  Lemma in_Type_or_app : forall (l m:list A) (a:A),
    sum (In_Type a l) (In_Type a m) -> In_Type a (l ++ m).
  Proof.
    intros l m a.
    elim l; simpl; intro H.
    now_show (In_Type a m).
    elim H; auto; intro H0.
    now_show (In_Type a m).
    elim H0. (* subProof completed *)
    intros y H0 H1.
    destruct H1 ; intuition.
  Qed.

End In.

Hint Resolve in_Type_eq in_Type_cons in_Type_inv in_Type_nil in_Type_app_or
  in_Type_or_app: datatypes.

  (**************************)
  (** Facts about [app] *)
  (**************************)

Section App.

  Variable A : Type.

  (** Facts deduced from the result of a concatenation *)

  Theorem app_eq_nil_Type : forall l l':list A, l ++ l' = nil -> (l = nil) * (l' = nil).
  Proof.
    destruct l as [| x l]; destruct l' as [| y l']; simpl; auto.
    intro; discriminate.
    intros H; discriminate H.
  Qed.

  Theorem app_eq_unit_Type :
    forall (x y:list A) (a:A),
      x ++ y = a::nil -> ((x = nil) * (y = a::nil)) + ((x = a::nil) * (y = nil)).
  Proof.
    destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ];
      simpl.
    intros a H; discriminate H.
    left; split; auto.
    right; split; auto.
    generalize H.
    generalize (app_nil_r l); intros E.
    rewrite -> E; auto.
    intros.
    injection H as H H0.
    assert (nil = l ++ a0 :: l0) by auto.
    apply app_cons_not_nil in H1 as [].
  Qed.

End App.

(*********************************************)
(** Reverse Induction Principle on Lists  *)
(*********************************************)

  Section Reverse_Induction.

  Variable A : Type.

    Lemma rev_list_ind_Type :
      forall P:list A-> Type,
	P nil ->
	(forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
	forall l:list A, P (rev l).
    Proof.
      induction l; auto.
    Qed.

    Theorem rev_ind_Type :
      forall P:list A -> Type,
	P nil ->
	(forall (x:A) (l:list A), P l -> P (l ++ x :: nil)) -> forall l:list A, P l.
    Proof.
      intros.
      generalize (rev_involutive l).
      intros E; rewrite <- E.
      apply (rev_list_ind_Type P).
      - auto.
      - simpl.
        intros.
        apply (X0 a (rev l0)).
        auto.
    Qed.

  End Reverse_Induction.

(***************************************************)
(** * Applying functions to the elements of a list *)
(***************************************************)

(************)
(** ** Map  *)
(************)

Section Map.
  Variables (A : Type) (B : Type).
  Variable f : A -> B.

  Lemma in_Type_map :
    forall (l:list A) (x:A), In_Type x l -> In_Type (f x) (map f l).
  Proof.
    induction l; firstorder (subst; auto).
  Qed.

  Lemma in_Type_map_inv : forall l y, In_Type y (map f l) ->
    { x : _ & prod (f x = y) (In_Type x l) }.
  Proof.
    induction l; firstorder (subst; auto).
  Qed.

  Lemma in_Type_flat_map : forall (f:A->list B)(l:list A)(y:B),
    In_Type y (flat_map f l) -> { x : _ & prod (In_Type x l) (In_Type y (f x)) }.
  Proof using A B.
    induction l; simpl; intros.
    contradiction.
    destruct (in_Type_app_or _ _ _ X).
    - exists a; auto.
    - destruct (IHl y i) as (x,(H1,H2)).
      exists x; auto.
  Qed.

  Lemma flat_map_in_Type : forall (f:A->list B)(l:list A)(y:B),
    { x : _ & prod (In_Type x l) (In_Type y (f x)) } -> In_Type y (flat_map f l).
  Proof using A B.
    induction l; simpl; intros.
    destruct X as (x,(X,_)); contradiction.
    apply in_Type_or_app.
    destruct X as (x,(H0,H1)); destruct H0.
    - subst; auto.
    - right ; apply (IHl y (existT _ x (i,H1))).
  Qed.

End Map.

Lemma map_ext_in_Type :
  forall (A B : Type)(f g:A->B) l, (forall a, In_Type a l -> f a = g a) -> map f l = map g l.
Proof.
  induction l; simpl; auto.
  intros; rewrite H by intuition; rewrite IHl; auto.
Qed.

Lemma ext_in_Type_map :
  forall (A B : Type)(f g:A->B) l, map f l = map g l -> forall a, In_Type a l -> f a = g a.
Proof. induction l; intros [=] ? []; subst; auto. Qed.

Arguments ext_in_Type_map [A B f g l].

(******************************)
(** ** Set inclusion on list  *)
(******************************)

Section SetIncl.

  Variable A : Type.

  Definition incl_Type (l m:list A) := forall a:A, In_Type a l -> In_Type a m.
  Hint Unfold incl_Type.

  Lemma incl_Type_refl : forall l:list A, incl_Type l l.
  Proof.
    auto.
  Qed.
  Hint Resolve incl_Type_refl.

  Lemma incl_Type_tl : forall (a:A) (l m:list A), incl_Type l m -> incl_Type l (a :: m).
  Proof.
    unfold incl_Type ; intros.
    simpl ; intuition.
  Qed.
  Hint Immediate incl_Type_tl.

  Lemma incl_Type_tran : forall l m n:list A, incl_Type l m -> incl_Type m n -> incl_Type l n.
  Proof.
    auto.
  Qed.

  Lemma incl_Type_appl : forall l m n:list A, incl_Type l n -> incl_Type l (n ++ m).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_Type_appl.

  Lemma incl_Type_appr : forall l m n:list A, incl_Type l n -> incl_Type l (m ++ n).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_Type_appr.

  Lemma incl_Type_cons :
    forall (a:A) (l m:list A), In_Type a m -> incl_Type l m -> incl_Type (a :: l) m.
  Proof.
    unfold incl_Type; simpl; intros a l m H H0 a0 H1.
    now_show (In_Type a0 m).
    elim H1.
    now_show (a = a0 -> In_Type a0 m).
    elim H1; auto; intro H2.
    now_show (a = a0 -> In_Type a0 m).
    elim H2; auto. (* solves subgoal *)
    now_show (In_Type a0 l -> In_Type a0 m).
    auto.
  Qed.
  Hint Resolve incl_Type_cons.

  Lemma incl_Type_app : forall l m n:list A, incl_Type l n -> incl_Type m n ->
    incl_Type (l ++ m) n.
  Proof.
    unfold incl_Type; simpl; intros l m n H H0 a H1.
    now_show (In_Type a n).
    elim (in_Type_app_or _ _ _ H1); auto.
  Qed.
  Hint Resolve incl_Type_app.

End SetIncl.

Hint Resolve incl_Type_refl incl_Type_tl incl_Type_tran incl_Type_appl incl_Type_appr
  incl_Type_cons incl_Type_app: datatypes.

Section Exists_Forall.

  (** * Existential and universal predicates over lists *)

  Variable A:Type.

  Section One_predicate.

    Variable P:A->Type.

    Inductive Exists_Type : list A -> Type :=
      | Exists_Type_cons_hd : forall x l, P x -> Exists_Type (x::l)
      | Exists_Type_cons_tl : forall x l, Exists_Type l -> Exists_Type (x::l).

    Hint Constructors Exists_Type.

    Lemma Exists_Type_nil : Exists_Type nil -> False.
    Proof. inversion 1. Qed.

    Lemma Exists_Type_cons x l:
      Exists_Type (x::l) -> P x + Exists_Type l.
    Proof. inversion 1; auto. Qed.

    Lemma Exists_Type_dec l:
      (forall x:A, P x + (P x -> False)) ->
      Exists_Type l + (Exists_Type l -> False).
    Proof.
      intro Pdec. induction l as [|a l' Hrec].
      - right. now apply Exists_Type_nil.
      - destruct Hrec as [Hl'|Hl'].
        * left. now apply Exists_Type_cons_tl.
        * destruct (Pdec a) as [Ha|Ha].
          + left. now apply Exists_Type_cons_hd.
          + right. now inversion_clear 1.
    Qed.

    Inductive Forall_Type : list A -> Type :=
      | Forall_Type_nil : Forall_Type nil
      | Forall_Type_cons : forall x l, P x -> Forall_Type l -> Forall_Type (x::l).

    Hint Constructors Forall_Type.

    Lemma Forall_Type_forall (l:list A):
      Forall_Type l -> forall x, In_Type x l -> P x.
    Proof.
      induction 1; firstorder; subst; auto.
    Qed.

    Lemma forall_Forall_Type (l:list A):
      (forall x, In_Type x l -> P x) -> Forall_Type l.
    Proof.
      induction l; firstorder.
    Qed.

    Lemma Forall_Type_inv : forall (a:A) l, Forall_Type (a :: l) -> P a.
    Proof.
      intros ? ? H ; inversion H ; trivial.
    Qed.

    Lemma Forall_Type_dec :
      (forall x:A, P x + (P x -> False)) ->
      forall l:list A, Forall_Type l + (Forall_Type l -> False).
    Proof.
      intro Pdec. induction l as [|a l' Hrec].
      - left. apply Forall_Type_nil.
      - destruct Hrec as [Hl'|Hl'].
        + destruct (Pdec a) as [Ha|Ha].
          * left. now apply Forall_Type_cons.
          * right. abstract now inversion 1.
        + right. abstract now inversion 1.
    Defined.

  End One_predicate.

  Lemma Forall_Exists_neg_Type (P:A->Type)(l:list A) :
   Forall_Type (fun x => P x -> False) l -> Exists_Type P l -> False.
  Proof.
   induction l ; intros HF HE ; inversion HE ; inversion HF ; subst ; auto.
  Qed.

  Lemma Exists_neg_Forall_Type (P:A->Type)(l:list A) :
   (Exists_Type P l -> False) -> Forall_Type (fun x => P x -> False) l.
  Proof.
   induction l ; intros HE ; constructor.
   - intros Ha ; apply HE.
     now constructor.
   - apply IHl ; intros HF ; apply HE.
     now constructor.
  Qed.

  Lemma Exists_Forall_neg_Type (P:A->Type)(l:list A) :
    Exists_Type (fun x => P x -> False) l -> Forall_Type P l -> False.
  Proof.
   induction l ; intros HE HF ; inversion HE ; inversion HF ; subst ; auto.
  Qed.

  Lemma Forall_neg_Exists_Type (P:A->Type)(l:list A) :
    (forall x, P x + (P x -> False)) ->
    (Forall_Type P l -> False) -> Exists_Type (fun x => P x -> False) l.
  Proof.
   intro Dec.
   induction l ; intros HF.
   - contradiction HF. constructor.
   - destruct (Dec a) as [ Ha | Hna ].
     + apply Exists_Type_cons_tl.
       apply IHl.
       intros HFl.
       apply HF ; now constructor.
     + now apply Exists_Type_cons_hd.
  Qed.

  Lemma neg_Forall_Exists_neg_Type (P:A->Type) (l:list A) :
    (forall x:A, P x + (P x -> False)) ->
    (Forall_Type P l -> False) ->
    Exists_Type (fun x => (P x -> False)) l.
  Proof.
    intro Dec.
    apply Forall_neg_Exists_Type; intros.
    destruct (Dec x); auto.
  Qed.

  Lemma Forall_Exists_Type_dec (P:A->Type) :
    (forall x:A, P x + (P x -> False)) ->
    forall l:list A,
    Forall_Type P l + Exists_Type (fun x => P x -> False) l.
  Proof.
    intros Pdec l.
    destruct (Forall_Type_dec P Pdec l); [left|right]; trivial.
    now apply neg_Forall_Exists_neg_Type.
  Defined.

  Lemma Forall_Type_arrow : forall (P Q : A -> Type), (forall a, P a -> Q a) ->
    forall l, Forall_Type P l -> Forall_Type Q l.
  Proof.
    induction l ; intros H ; inversion H ; constructor ; auto.
  Qed.

End Exists_Forall.

Hint Constructors Exists_Type.
Hint Constructors Forall_Type.

Section Forall2.

  (** [Forall2]: stating that elements of two lists are pairwise related. *)

  Variables A B : Type.
  Variable R : A -> B -> Type.

  Inductive Forall2_Type : list A -> list B -> Type :=
    | Forall2_Type_nil : Forall2_Type nil nil
    | Forall2_Type_cons : forall x y l l',
      R x y -> Forall2_Type l l' -> Forall2_Type (x::l) (y::l').

  Hint Constructors Forall2_Type.

  Theorem Forall2_Type_refl : Forall2_Type nil nil.
  Proof. intros; apply Forall2_Type_nil. Qed.

  Theorem Forall2_Type_app_inv_l : forall l1 l2 l0,
    Forall2_Type (l1 ++ l2) l0 ->
    { l'' : { l' : _ & Forall2_Type l1 (fst l') & Forall2_Type l2 (snd l') }
          | l0 = fst (projT1 (sigT_of_sigT2 l'')) ++ snd (projT1 (sigT_of_sigT2 l'')) }.
  Proof.
    induction l1; intros.
    - assert (Forall2_Type nil nil) as H1 by auto.
      assert (Forall2_Type l2 l0) as H2 by auto.
      exists (existT2 _ _ (nil,l0) H1 H2).
      reflexivity.
    - simpl in X; inversion X; subst; clear X.
      apply IHl1 in X1 as (l0' & Hl).
      destruct l0' as [ l'' H1 H2 ].
      simpl in Hl.
      assert (Forall2_Type (a :: l1) (y :: fst l'')) as H3 by auto.
      exists (existT2 _ _ (y :: fst l'', snd l'') H3 H2).
      simpl ; rewrite Hl ; auto.
  Qed.

  Theorem Forall2_Type_app_inv_r : forall l1 l2 l0,
    Forall2_Type l0 (l1 ++ l2) ->
    { l'' : { l' : _ & Forall2_Type (fst l') l1 & Forall2_Type (snd l') l2 }
          | l0 = fst (projT1 (sigT_of_sigT2 l'')) ++ snd (projT1 (sigT_of_sigT2 l'')) }.
  Proof.
    induction l1; intros.
    - assert (Forall2_Type nil nil) as H1 by auto.
      assert (Forall2_Type l0 l2) as H2 by auto.
      exists (existT2 _ _ (nil,l0) H1 H2).
      reflexivity.
    - simpl in X; inversion X; subst; clear X.
      apply IHl1 in X1 as (l0' & Hl).
      destruct l0' as [ l'' H1 H2 ].
      simpl in Hl.
      assert (Forall2_Type (x :: fst l'') (a :: l1)) as H3 by auto.
      exists (existT2 _ _ (x :: fst l'', snd l'') H3 H2).
      simpl ; rewrite Hl ; auto.
  Qed.

  Theorem Forall2_Type_app : forall l1 l2 l1' l2',
    Forall2_Type l1 l1' -> Forall2_Type l2 l2' -> Forall2_Type (l1 ++ l2) (l1' ++ l2').
  Proof.
    intros. induction l1 in l1', X, X0 |- *; inversion X; subst; simpl; auto.
  Qed.
End Forall2.

Hint Constructors Forall2.


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

(*
  Reduction from:
    Finite Multiset Constraint Solvability (FMsetC_SAT)
  to:
    Linear Polynomial (over N) Constraint Solvability (LPolyNC_SAT)
*)

Require Import List PeanoNat Lia.
Import ListNotations.

Require Import Undecidability.SetConstraints.FMsetC.
Require Import Undecidability.PolynomialConstraints.LPolyNC.

Require Import Undecidability.Synthetic.Definitions.

From Undecidability.PolynomialConstraints.Util Require Import PolyFacts.
Require Undecidability.SetConstraints.Util.mset_eq_utils.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Module Argument.
Local Arguments poly_add !p !q.

Local Notation "p ≃ q" := (poly_eq p q) (at level 65).
Local Notation "A ≡ B" := (mset_eq A B) (at level 65).

Definition encode_msetc (c : msetc) : polyc :=
  match c with
  | msetc_zero x => polyc_one x
  | msetc_sum x y z => polyc_sum x y z
  | msetc_h x y => polyc_prod x y
  end.

(* count the number of occurrences of each element *)
Fixpoint mset_to_poly (A: list nat) :=
  match A with
  | [] => []
  | a :: A => poly_add (repeat 0 a ++ [1]) (mset_to_poly A)
  end.

Lemma mset_to_poly_shift {a A B} : mset_to_poly (A ++ a :: B) ≃ mset_to_poly (a :: A ++ B).
Proof.
  elim: A; first done.
  move=> c A + i => /(_ i) /=. rewrite ?poly_add_nthP. by lia.
Qed.

Lemma mset_to_poly_appP {A B} : mset_to_poly (A ++ B) ≃ poly_add (mset_to_poly A) (mset_to_poly B).
Proof.
  elim: A; first done.
  move=> a A + i => /(_ i) /=. rewrite ?poly_add_nthP. by lia.
Qed.

Lemma mset_to_poly_mapP {A} : mset_to_poly (map S A) ≃ 0 :: mset_to_poly A.
Proof.
  elim: A; first by (case; [done | by case]).
  move=> a A + i => /(_ i). case: i.
  - by rewrite /map -/(map _ _) ?poly_add_nthP.
  - move=> i. rewrite /map -/(map _ _) /mset_to_poly -/(mset_to_poly).
    rewrite /= ?poly_add_nthP /=. by lia.
Qed.

Lemma poly_add_0I {p q r} : r ≃ [] -> p ≃ q -> p ≃ poly_add q r.
Proof.
  move=> + + i => /(_ i) + /(_ i). rewrite poly_add_nthP.
  case: i=> /=; by lia.
Qed.

Lemma poly_shiftI {p} : (0 :: p) ≃ poly_mult [0; 1] p.
Proof.
  rewrite /poly_mult.
  have ->: map (fun x => 0 * x) p = repeat 0 (length p).
  { elim: p; [done | by move=> > /= ->]. }
  rewrite [poly_add (repeat _ _) _] poly_add_comm.
  apply: poly_add_0I; first by apply: repeat_0P.
  under map_ext => a do have -> : 1 * a = a by lia.
  rewrite -/(poly_eq _ _) map_id. apply: poly_eq_consI; first done.
  apply: poly_add_0I; last done.
  by apply: (repeat_0P (n := 1)).
Qed.

Lemma mset_to_poly_eqI {A B} : A ≡ B -> mset_to_poly A ≃ mset_to_poly B.
Proof.
  elim: A B.
  - by move=> B /mset_eq_utils.eq_nilE ->.
  - move=> a A IH B /mset_eq_utils.eq_consE [B1 [B2 [-> /IH {}IH]]].
    apply: poly_eq_sym.
    apply: (poly_eq_trans mset_to_poly_shift) => /=.
    move=> i. move: (IH i). rewrite ?poly_add_nthP. by lia.
Qed.

Lemma completeness {l} : FMsetC_SAT l -> LPolyNC_SAT (map encode_msetc l).
Proof.
  move=> [φ]. rewrite -Forall_forall => Hφ.
  exists (fun x => mset_to_poly (φ x)). rewrite -Forall_forall Forall_map.
  apply: Forall_impl; last by eassumption. case.
  - by move=> x /= /mset_eq_utils.eq_symm /mset_eq_utils.eq_singletonE ->.
  - move=> x y z /= /mset_to_poly_eqI. move /poly_eq_trans. apply.
    by apply mset_to_poly_appP.
  - move=> x y /= /mset_to_poly_eqI. move /poly_eq_trans. apply.
    apply: (poly_eq_trans _ poly_shiftI).
    by apply: mset_to_poly_mapP.
Qed.

Fixpoint poly_to_mset (p: list nat) :=
  match p with
  | [] => []
  | a :: p => (repeat 0 a) ++ map S (poly_to_mset p)
  end.

Lemma count_occ_poly_to_msetP {a p}: count_occ Nat.eq_dec (poly_to_mset p) a = nth a p 0.
Proof.
  elim: a p.
  - case; first done.
    move=> + p /=. elim; first by elim: (poly_to_mset p).
    by move=> ? /= ->.
  - move=> i IH. case; first done.
    move=> a p /=. rewrite count_occ_app.
    rewrite -(count_occ_map S Nat.eq_dec) ?IH; first by lia.
    by elim a.
Qed.

Lemma poly_to_mset_eqI {p q} : p ≃ q -> poly_to_mset p ≡ poly_to_mset q.
Proof. move=> + a. by rewrite ?count_occ_poly_to_msetP. Qed.

Lemma poly_to_mset_addP {p q} : poly_to_mset (poly_add p q) ≡ poly_to_mset p ++ poly_to_mset q.
Proof. move=> a. by rewrite count_occ_app ? count_occ_poly_to_msetP poly_add_nthP. Qed.

Lemma poly_to_mset_consP {p} : poly_to_mset (0 :: p) = map S (poly_to_mset p).
Proof. done. Qed.

Lemma soundness {l} : LPolyNC_SAT (map encode_msetc l) -> FMsetC_SAT l.
Proof.
  move=> [ψ]. rewrite -Forall_forall Forall_map => Hψ.
  exists (fun x => poly_to_mset (ψ x)). rewrite -Forall_forall.
  apply: Forall_impl; last by eassumption. case.
  - by move=> x /= /poly_to_mset_eqI.
  - move=> x y z /= /poly_to_mset_eqI. move /mset_eq_utils.eq_trans. apply.
    by apply: poly_to_mset_addP.
  - move=> x y /= /poly_to_mset_eqI. move /mset_eq_utils.eq_trans. apply.
    move: (ψ y) => p. rewrite -poly_to_mset_consP. apply: poly_to_mset_eqI.
    apply: poly_eq_sym.
    by apply: (poly_eq_trans _ poly_shiftI).
Qed.

End Argument.

(* many-one reduction from FMsetC_SAT to LPolyNC_SAT *)
Theorem reduction : FMsetC_SAT ⪯ LPolyNC_SAT.
Proof.
  exists (map Argument.encode_msetc) => l. constructor.
  - exact Argument.completeness.
  - exact Argument.soundness.
Qed.


Require Import Arith.
Require Import Reals.
Require Import Psatz.
Require Import Coq.Init.Nat.
Require Import QArith.
Require Import QArith.QArith_base.
Require Import Coq.Arith.PeanoNat.
Require Import ZArith.
Require Import BinNat Bool Equalities GenericMinMax
 OrdersFacts ZAxioms ZProperties.
Require Import BinIntDef BinInt Zorder Zcompare Znat Zmin Zmax Zminmax
 Zabs Zeven auxiliary ZArith_dec Zbool Zmisc Wf_Z
 Zcomplements Zsqrt_compat Zpow_def Zpow_alt Zpower Zdiv Zwf  Int Zpow_facts Zdigits.
Require BinIntDef.
Require Lra.
Require Import Ring.
Axiom Q_equality : forall (q1 q2 : Q), q1 == q2 -> q1 = q2.

Lemma Qlt_dec: forall (q1 q2:Q), {q1<q2} + {~ q1 < q2}.
Proof.
intros.
case (Qlt_le_dec q1 q2).
-intro. auto.
-intro. apply Qle_not_lt in q. auto.
Defined.

Lemma Q_mult_dist: forall (a b c : Q) , a * (b - c) == a * b - a * c.
Proof. intros. lra. Qed.

Lemma Q_mult: forall (a b c d : Q), (a - b) * (c - d) == a*c - a*d - b*c + b*d.
Proof. intros.
 lra. Qed.
Lemma Qle_neq_lt : forall (r1 r2 : Q),
  r1 <= r2 -> r1 <> r2 -> r1 < r2.
Proof.
intros r1 r2 H1 H2. apply Qle_lteq in H1. destruct H1.
tauto. apply Q_equality in H. tauto.
Qed.

Lemma Q_gt_0_plus : forall (r1 r2 : Q),
  r1 > 0 -> r2 > 0 -> r1 + r2 > 0.
Proof.
intros r1 r2 H1 H2. lra.
Qed.
Lemma Q_gt_0_mult : forall (r1 r2 : Q),
  r1 > 0 -> r2 > 0 -> r1 * r2 > 0.
Proof.
intros. assert (H1:= Qmult_lt_compat_r 0 r1 r2) .
apply H1 in H0. - lra. - tauto.
Qed.

Lemma Q_gt_0_div : forall (r1 r2 : Q),
  r1 > 0 -> r2 > 0 -> r1 * / r2 > 0.
Proof.
intros r1 r2 H1 H2.
apply Q_gt_0_mult.
 assumption. apply Qinv_lt_0_compat . tauto.
Qed.
Lemma Q_lt_0_plus : forall (r1 r2 : Q),
  r1 < 0 -> r2 < 0 -> r1 + r2 < 0.
Proof.
intros r1 r2 H1 H2. lra.
Qed.
Lemma Z_neg_mult: forall (a b:Z) , (a < 0)%Z -> (b<0)%Z -> (a*b >0)%Z.
Proof.
intros.
assert(H2:=Z.mul_neg_neg a b). apply Zgt_iff_lt. tauto.
Qed.

Lemma Q_lt_0_mult : forall (r1 r2 : Q),
  r1 < 0 -> r2 < 0 -> r1 * r2 > 0.
Proof.
intros.
 unfold Qgt in *. simpl in *. rewrite Z.mul_comm in H.
 rewrite Z.mul_1_l in H.  rewrite Z.mul_comm in H0.
 rewrite Z.mul_1_l in H0. rewrite <- Z.gt_lt_iff in H. rewrite <- Z.gt_lt_iff in H0.
rewrite <- Z.gt_lt_iff . rewrite Z.mul_comm. rewrite Z.mul_1_l.
apply Zgt_iff_lt. apply (Z.mul_neg_neg (Qnum r1) (Qnum r2)).
apply Zgt_iff_lt in H. tauto. apply Zgt_iff_lt in H0. tauto.
Qed.
Lemma Q_lt_0_neg: forall(a:Q) , a<0 -> -a > 0.
Proof. intros.
apply Qlt_minus_iff in H.
assert (H1:= (Qplus_0_l (-a)) ). rewrite H1 in H. tauto.
Qed.
Lemma Q_gt_0_neg: forall(a:Q) , a>0 -> -a < 0.
Proof. intros. lra.
Qed.
Lemma Q_mult_negpos: forall (a b:Q) , a<0 -> b>0 -> a * b < 0.
Proof.
intros.
 apply Q_lt_0_neg in H.   assert (H2:-a * b > 0).
 apply (Q_gt_0_mult ). tauto. tauto.
lra.
Qed.
Lemma Q_lt_0_div : forall (r1 r2 : Q),
  r1 < 0 -> r2 < 0 -> 0 <r1  */ r2 .
Proof.
intros.
apply Q_lt_0_mult. tauto. apply Q_lt_0_neg in H0.
apply Qinv_lt_0_compat in H0. apply Q_gt_0_neg in H0.
induction r2. simpl in *. unfold Qinv in *. simpl.
induction Qnum. simpl in *. lra. tauto. tauto.
Qed.
Lemma Q_mult_div : forall (r1 r2 r3 : Q),
  r1 = r2 * r3 -> r2 > 0 -> r1 * / r2 = r3.
Proof.
intros r1 r2 r3 H1 H2.
subst r1. assert (H:=Qmult_comm r2 r3). apply Q_equality in H.
rewrite H. assert (H1:= Qdiv_mult_l r3 r2). apply Q_equality. apply H1.
lra.
Qed.

Lemma Q_mult_dist_eq: forall(r1 r2 r3 r4 :Q),
(r1-r2)*(r3-r4)=r1*r3-r1*r4-r2*r3+r2*r4.
Proof.
intros. assert (H: (r1 - r2) * (r3 - r4) == r1 * r3 - r1 * r4 - r2 * r3 + r2 * r4).
apply Q_mult.
apply Q_equality. tauto.
Qed.

Lemma Q_mult_par: forall (a b c :Q), a* (b * c) == a* b * c.
Proof. intros. lra.
Qed.

Lemma Qmult_minus_dist : forall (a b c :Q) , a * (b  -  c) == a* b - a*c.
Proof.
intros. lra.
Qed.
Lemma Q_mult_sign_ch:forall (a b :Q) , a * (-b) == (-a) * b.
Proof.
intros. lra.
Qed.

Lemma Q_inv_sign_ch:forall (a b :Q) , a */ (-b) == (-a) */ b.
Proof. intros. induction b. induction a.

 unfold Qinv in *. simpl.
induction (Qnum ). simpl in *. lra. simpl. unfold Qeq. simpl. lia.
simpl. unfold Qeq. simpl. lia.
Qed.
Lemma Q_div_sign_ch: forall (a b :Q) ,  a / -b == -a / b.
Proof. intros.
 unfold Qdiv. rewrite Q_inv_sign_ch. lra.
Qed.
Lemma Q_div_plus_denum: forall(a b c:Q) , a/b + c/b == (a+c)/b.
Proof. intros. unfold Qdiv. lra.
Qed.
Lemma Q_div_minus_denum: forall(a b c:Q) , a/b - c/b == (a-c)/b.
Proof. intros. unfold Qdiv. lra.
Qed.
Lemma Q_mult_div_nom: forall (a b c:Q) , a * (b/c) == (a *b) / c.
Proof. intros.
unfold Qdiv. lra.
Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2017 - Pset 8 *)

Require Import Frap.

(* Authors:
 * Peng Wang (wangpeng@csail.mit.edu)
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** * Subtyping *)

(* We can't resist fitting in another crucial aspect of type systems:
 * *subtyping*, which formalizes when any value of one type should also be
 * permitted as a value of some other type.  Languages like Java include
 * *nominal* subtyping, based on declared type hierarchies.  Instead, here we
 * will prove soundness of *structural* subtyping, whose rules we'll get to
 * shortly.  The simply typed lambda calculus will be our starting point. *)

(* Expression syntax *)
Inductive exp  :=
(* Our old friends from simply typed lambda calculus *)
| Var (x : var)
| Abs (x : var) (e1 : exp)
| App (e1 e2 : exp)

(* New features, surrounding *tuple* types, which build composite types out of
 * constituents *)
| TupleNil
(* Empty tuple (no fields *)
| TupleCons (e1 e2 : exp)
(* Nonempty tuple, where [e1] is the first field of the tuple, and [e2] is a
 * nested tuple with all the remaining fields *)
| Proj (e : exp) (n : nat)
(* Grab the [n]th field of tuple [e]. *)
.

(* Values (final results of evaluation) *)
Inductive value : exp -> Prop :=
| VAbs : forall x e1, value (Abs x e1)
| VTupleNil : value TupleNil
| VTupleCons : forall e1 e2, value e1 -> value e2 -> value (TupleCons e1 e2)
.

(* The next few definitions are quite routine and should be safe to skim through
 * quickly; but start paying more attention when we get to defining the
 * subtyping relation! *)

(* Substitution (not capture-avoiding, for the usual reason) *)
Fixpoint subst (e1 : exp) (x : var) (e2 : exp) : exp :=
  match e2 with
  | Var y => if y ==v x then e1 else Var y
  | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
  | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
  | TupleNil => TupleNil
  | TupleCons e2' e2'' => TupleCons (subst e1 x e2') (subst e1 x e2'')
  | Proj e2' n => Proj (subst e1 x e2') n
  end.

(* Evaluation contexts *)
Inductive context :=
| Hole
| App1 (C : context) (e2 : exp)
| App2 (v1 : exp) (C : context)
| TupleCons1 (C : context) (e2 : exp)
| TupleCons2 (v1 : exp) (C : context)
| Proj1 (C : context) (n : nat)
.

(* Plugging an expression into a context *)
Inductive plug : context -> exp -> exp -> Prop :=
| PlugHole : forall e, plug Hole e e
| PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
| PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')
| PlugTupleCons1 : forall C e e' e2,
    plug C e e'
    -> plug (TupleCons1 C e2) e (TupleCons e' e2)
| PlugTupleCons2 : forall v1 C e e',
    value v1
    -> plug C e e'
    -> plug (TupleCons2 v1 C) e (TupleCons v1 e')
| PlugProj : forall C e e' n,
    plug C e e'
    -> plug (Proj1 C n) e (Proj e' n)
.

(* Small-step, call-by-value evaluation *)
Inductive step0 : exp -> exp -> Prop :=
| Beta : forall x e v,
    value v
    -> step0 (App (Abs x e) v) (subst v x e)

(* To project field 0 out of a tuple, just grab the first component. *)
| Proj0 : forall v1 v2,
    value v1
    -> value v2
    -> step0 (Proj (TupleCons v1 v2) 0) v1

(* To project field [1+n], drop the first component and continue with [n]. *)
| ProjS : forall v1 v2 n,
    value v1
    -> value v2
    -> step0 (Proj (TupleCons v1 v2) (1 + n)) (Proj v2 n)
.

Inductive step : exp -> exp -> Prop :=
| StepRule : forall C e1 e2 e1' e2',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 e1 e2
    -> step e1' e2'.

Definition trsys_of (e : exp) :=
  {| Initial := {e}; Step := step |}.

(* Syntax of types *)
Inductive type :=
| Fun (dom ran : type)
| TupleTypeNil
| TupleTypeCons (t1 t2 : type)
.

Inductive subtype : type -> type -> Prop :=

(* Two function types are related if their components are related pairwise.
 * Counterintuitively, we *reverse* the comparison order for function domains!
 * It may be worth working through some examples to see why the relation would
 * otherwise be unsound. *)
| StFun : forall t1' t2' t1 t2,
    subtype t1 t1' ->
    subtype t2' t2 ->
    subtype (Fun t1' t2') (Fun t1 t2)

(* An empty tuple type is its own subtype. *)
| StTupleNilNil :
    subtype TupleTypeNil TupleTypeNil

(* However, a nonempty tuple type is also a subtype of the empty tuple type.
 * This rule gives rise to *width* subtyping, where we can drop some fields of
 * a tuple type to produce a subtype. *)
| StTupeNilCons : forall t1 t2,
    subtype (TupleTypeCons t1 t2) TupleTypeNil

(* We also have *depth* subtyping: we can replace tuple components with
 * subtypes. *)
| StTupleCons : forall t1' t2' t1 t2,
    subtype t1' t1 ->
    subtype t2' t2 ->
    subtype (TupleTypeCons t1' t2') (TupleTypeCons t1 t2)
.

(* Here's a more compact notation for subtyping. *)
Infix "$<:" := subtype (at level 70).

Hint Constructors subtype.

(* Projecting out the nth field of a tuple type *)
Inductive proj_t : type -> nat -> type -> Prop :=
| ProjT0 : forall t1 t2,
    proj_t (TupleTypeCons t1 t2) 0 t1
| ProjTS : forall t1 t2 n t,
    proj_t t2 n t ->
    proj_t (TupleTypeCons t1 t2) (1 + n) t
.

(* Expression typing relation *)
Inductive hasty : fmap var type -> exp -> type -> Prop :=
| HtVar : forall G x t,
    G $? x = Some t ->
    hasty G (Var x) t
| HtAbs : forall G x e1 t1 t2,
    hasty (G $+ (x, t1)) e1 t2 ->
    hasty G (Abs x e1) (Fun t1 t2)
| HtApp : forall G e1 e2 t1 t2,
    hasty G e1 (Fun t1 t2) ->
    hasty G e2 t1 ->
    hasty G (App e1 e2) t2
| HtTupleNil : forall G,
    hasty G TupleNil TupleTypeNil
| HtTupleCons: forall G e1 e2 t1 t2,
    hasty G e1 t1 ->
    hasty G e2 t2 ->
    hasty G (TupleCons e1 e2) (TupleTypeCons t1 t2)
| HtProj : forall G e n t t',
    hasty G e t' ->
    proj_t t' n t ->
    hasty G (Proj e n) t

(* This is the crucial rule: when an expression has a type, it also has any
 * supertype of that type.  We call this rule *subsumption*. *)
| HtSub : forall G e t t',
    hasty G e t' ->
    t' $<: t ->
    hasty G e t
.

Hint Constructors value plug step0 step proj_t hasty.

(* BEGIN handy tactic that we suggest for these proofs *)
Ltac t0 := match goal with
           | [ H : ex _ |- _ ] => invert H
           | [ H : _ /\ _ |- _ ] => invert H
           | [ |- context[_ $+ (?x, _) $? ?y] ] => cases (x ==v y); simplify
           | [ |- context[?x ==v ?y] ] => cases (x ==v y); simplify

           | [ H : step _ _ |- _ ] => invert H
           | [ H : step0 _ _ |- _ ] => invert1 H
           | [ H : hasty _ _ _ |- _ ] => invert1 H
           | [ H : proj_t _ _ _ |- _ ] => invert1 H
           | [ H : plug _ _ _ |- _ ] => invert1 H
           | [ H : subtype _ _ |- _ ] => invert1 H
           | [ H : Some _ = Some _ |- _ ] => invert H
           end; subst.

Ltac t := simplify; subst; propositional; repeat (t0; simplify); try equality.
(* END handy tactic *)

Module Type S.
  (* Prove these two basic algebraic properties of subtyping. *)
  Axiom subtype_refl : forall t, t $<: t.
  Axiom subtype_trans : forall t1 t2 t3, t1 $<: t2 -> t2 $<: t3 -> t1 $<: t3.

  (* The real prize: prove soundness of this type system.
   * We suggest starting from a copy of the type-safety proof from the book's
   * LambdaCalculusAndTypeSoundness.v.  Essentially all of the lemmas from that
   * proof will be useful here, too, though some of their proofs need to
   * change. *)
  Axiom safety :
    forall e t,
      hasty $0 e t -> invariantFor (trsys_of e)
                                   (fun e' => value e'
                                              \/ exists e'', step e' e'').
End S.


   Theorem t54_10: forall A B C : Prop,
                     (A -> C) -> (B -> C) -> (A \/ B) -> C.
   Proof.
      intros. elim H1. intros. apply H. assumption.
      intros. apply H0. assumption.
   Qed.

   Theorem t54_11: forall A1 A2 B : Prop,
                     (A1 -> B) -> (A2 -> B) -> ((A1 /\ ~A2) \/ (~A1 /\ A2)) -> B.
   Proof.
      intros. elim H1. intros. apply H. apply H2.
      intros. apply H0. apply H2.
   Qed.

   Theorem t54_12: forall A B C D : Prop,
                     (A -> C) -> (B -> D) -> (A \/ B) -> (C \/ D).
   Proof.
      intros. elim H1. intros. left. apply H. assumption.
      intros. right. apply H0. assumption.
   Qed.

   Theorem t54_13: forall A B C D : Prop,
                     (C -> A) -> (C -> B) -> (~A \/ ~B) -> ~C.
   Proof.
      intros. elim H1. intros. intro. elim H2. apply H. assumption.
                       intros. intro. elim H2. apply H0. assumption.
   Qed.

   Theorem t54_14: forall A B1 B2 : Prop,
                (A -> B1) -> (A -> B2) -> ((~B1 /\ ~(~B2)) \/ (~(~B1) /\ ~B2)) -> ~A.
   Proof.
      intros. intro. elim H1. intros. elim H3. intros. apply H4. apply H. assumption.
                             intros. elim H3. intros. apply H5. apply H0. assumption.
   Qed.

   Theorem t54_15: forall A B C D : Prop,
                     (C -> A) -> (D -> B) -> (~A \/ ~B) -> (~C \/ ~D).
   Proof.
      intros. elim H1. intros. left. intro. apply H2. apply H. assumption.
      intros. right. intro. apply H2. apply H0. assumption.
   Qed.

   Theorem t54_16: forall A1 A2 A3 B : Prop,
                     (A1 -> B) -> (A2 -> B) -> (A3 -> B) -> (A1 \/ A2 \/ A3) -> B.
   Proof.
      intros. elim H2. intros. apply H. assumption.
      intros. elim H3. intros. apply H0. assumption.
      intros. apply H1. assumption.
   Qed.

   Theorem t54_17: forall A1 A2 A3 B1 B2 B3 : Prop,
    (A1 -> B1) -> (A2 -> B2) -> (A3 -> B3) -> (A1 \/ A2 \/ A3) -> (B1 \/ B2 \/ B3).
   Proof.
      intros. elim H2. intros. left. apply H. assumption.
      intros. elim H3. intros. right. left. apply H0. assumption.
      intros. right. right. apply H1. assumption.
   Qed.

   Theorem t54_18: forall A B1 B2 B3 : Prop,
    (A -> B1) -> (A -> B2) -> (A -> B3) -> (~B1 \/ ~B2 \/ ~B3) -> ~A.
   Proof.
      intros. intro. elim H2. intros. apply H4. apply H. assumption.
      intros. elim H4. intros. apply H5. apply H0. assumption.
      intros. apply H5. apply H1. assumption.
   Qed.

   Theorem t54_19: forall A1 A2 A3 B1 B2 B3 : Prop,
              (A1 -> B1) -> (A2 -> B2) -> (A3 -> B3) ->
              (~B1 \/ ~B2 \/ ~B3) -> (~A1 \/ ~A2 \/ ~A3).
   Proof.
      intros. elim H2. intros. left. intro. apply H3. apply H. assumption.
      intro. elim H3. intros. right. left. intro. apply H4. apply H0. assumption.
      intros. right. right. intro. apply H4. apply H1. assumption.
   Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** A modular implementation of mergesort (the complexity is O(n.log n) in
   the length of the list) *)

(* Initial author: Hugo Herbelin, Oct 2009 *)

Require Import List Setoid Permutation Sorted Orders.

(** Notations and conventions *)

Local Notation "[ ]" := nil.
Local Notation "[ a ; .. ; b ]" := (a :: .. (b :: []) ..).

Open Scope bool_scope.

Local Coercion is_true : bool >-> Sortclass.

(** The main module defining [mergesort] on a given boolean
    order [<=?]. We require minimal hypotheses : this boolean
    order should only be total: [forall x y, (x<=?y) \/ (y<=?x)].
    Transitivity is not mandatory, but without it one can
    only prove [LocallySorted] and not [StronglySorted].
*)

Module Sort (Import X:Orders.TotalLeBool').

Fixpoint merge l1 l2 :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

(** We implement mergesort using an explicit stack of pending mergings.
    Pending merging are represented like a binary number where digits are
    either None (denoting 0) or Some list to merge (denoting 1). The n-th
    digit represents the pending list to be merged at level n, if any.
    Merging a list to a stack is like adding 1 to the binary number
    represented by the stack but the carry is propagated by merging the
    lists. In practice, when used in mergesort, the n-th digit, if non 0,
    carries a list of length 2^n. For instance, adding singleton list
    [3] to the stack Some [4]::Some [2;6]::None::Some [1;3;5;5]
    reduces to propagate the carry [3;4] (resulting of the merge of [3]
    and [4]) to the list Some [2;6]::None::Some [1;3;5;5], which reduces
    to propagating the carry [2;3;4;6] (resulting of the merge of [3;4] and
    [2;6]) to the list None::Some [1;3;5;5], which locally produces
    Some [2;3;4;6]::Some [1;3;5;5], i.e. which produces the final result
    None::None::Some [2;3;4;6]::Some [1;3;5;5].

    For instance, here is how [6;2;3;1;5] is sorted:

<<
       operation             stack                list
       iter_merge            []                   [6;2;3;1;5]
    =  append_list_to_stack  [ + [6]]             [2;3;1;5]
    -> iter_merge            [[6]]                [2;3;1;5]
    =  append_list_to_stack  [[6] + [2]]          [3;1;5]
    =  append_list_to_stack  [ + [2;6];]          [3;1;5]
    -> iter_merge            [[2;6];]             [3;1;5]
    =  append_list_to_stack  [[2;6]; + [3]]       [1;5]
    -> merge_list            [[2;6];[3]]          [1;5]
    =  append_list_to_stack  [[2;6];[3] + [1]     [5]
    =  append_list_to_stack  [[2;6] + [1;3];]     [5]
    =  append_list_to_stack  [ + [1;2;3;6];;]     [5]
    -> merge_list            [[1;2;3;6];;]        [5]
    =  append_list_to_stack  [[1;2;3;6];; + [5]]  []
    -> merge_stack           [[1;2;3;6];;[5]]
    =                                             [1;2;3;5;6]
>>
    The complexity of the algorithm is n*log n, since there are
    2^(p-1) mergings to do of length 2, 2^(p-2) of length 4, ..., 2^0
    of length 2^p for a list of length 2^p. The algorithm does not need
    explicitly cutting the list in 2 parts at each step since it the
    successive accumulation of fragments on the stack which ensures
    that lists are merged on a dichotomic basis.
*)

Fixpoint merge_list_to_stack stack l :=
  match stack with
  | [] => [Some l]
  | None :: stack' => Some l :: stack'
  | Some l' :: stack' => None :: merge_list_to_stack stack' (merge l' l)
  end.

Fixpoint merge_stack stack :=
  match stack with
  | [] => []
  | None :: stack' => merge_stack stack'
  | Some l :: stack' => merge l (merge_stack stack')
  end.

Fixpoint iter_merge stack l :=
  match l with
  | [] => merge_stack stack
  | a::l' => iter_merge (merge_list_to_stack stack [a]) l'
  end.

Definition sort := iter_merge [].

(** The proof of correctness *)

Local Notation Sorted := (LocallySorted leb) (only parsing).

Fixpoint SortedStack stack :=
  match stack with
  | [] => True
  | None :: stack' => SortedStack stack'
  | Some l :: stack' => Sorted l /\ SortedStack stack'
  end.

Local Ltac invert H := inversion H; subst; clear H.

Fixpoint flatten_stack (stack : list (option (list t))) :=
  match stack with
  | [] => []
  | None :: stack' => flatten_stack stack'
  | Some l :: stack' => l ++ flatten_stack stack'
  end.

Theorem Sorted_merge : forall l1 l2,
  Sorted l1 -> Sorted l2 -> Sorted (merge l1 l2).
Proof.
induction l1; induction l2; intros; simpl; auto.
  destruct (a <=? a0) as ()_eqn:Heq1.
    invert H.
      simpl. constructor; trivial; rewrite Heq1; constructor.
      assert (Sorted (merge (b::l) (a0::l2))) by (apply IHl1; auto).
      clear H0 H3 IHl1; simpl in *.
      destruct (b <=? a0); constructor; auto || rewrite Heq1; constructor.
    assert (a0 <=? a) by
      (destruct (leb_total a0 a) as [H'|H']; trivial || (rewrite Heq1 in H'; inversion H')).
    invert H0.
      constructor; trivial.
      assert (Sorted (merge (a::l1) (b::l))) by auto using IHl1.
      clear IHl2; simpl in *.
      destruct (a <=? b); constructor; auto.
Qed.

Theorem Permuted_merge : forall l1 l2, Permutation (l1++l2) (merge l1 l2).
Proof.
  induction l1; simpl merge; intro.
    assert (forall l, (fix merge_aux (l0 : list t) : list t := l0) l = l)
    as -> by (destruct l; trivial). (* Technical lemma *)
    apply Permutation_refl.
  induction l2.
    rewrite app_nil_r. apply Permutation_refl.
    destruct (a <=? a0).
      constructor; apply IHl1.
      apply Permutation_sym, Permutation_cons_app, Permutation_sym, IHl2.
Qed.

Theorem Sorted_merge_list_to_stack : forall stack l,
  SortedStack stack -> Sorted l -> SortedStack (merge_list_to_stack stack l).
Proof.
  induction stack as [|[|]]; intros; simpl.
    auto.
    apply IHstack. destruct H as (_,H1). fold SortedStack in H1. auto.
      apply Sorted_merge; auto; destruct H; auto.
      auto.
Qed.

Theorem Permuted_merge_list_to_stack : forall stack l,
  Permutation (l ++ flatten_stack stack) (flatten_stack (merge_list_to_stack stack l)).
Proof.
  induction stack as [|[]]; simpl; intros.
    reflexivity.
    rewrite app_assoc.
    etransitivity.
      apply Permutation_app_tail.
      etransitivity.
        apply Permutation_app_comm.
      apply Permuted_merge.
    apply IHstack.
    reflexivity.
Qed.

Theorem Sorted_merge_stack : forall stack,
  SortedStack stack -> Sorted (merge_stack stack).
Proof.
induction stack as [|[|]]; simpl; intros.
  constructor; auto.
  apply Sorted_merge; tauto.
  auto.
Qed.

Theorem Permuted_merge_stack : forall stack,
  Permutation (flatten_stack stack) (merge_stack stack).
Proof.
induction stack as [|[]]; simpl.
  trivial.
  transitivity (l ++ merge_stack stack).
    apply Permutation_app_head; trivial.
    apply Permuted_merge.
  assumption.
Qed.

Theorem Sorted_iter_merge : forall stack l,
  SortedStack stack -> Sorted (iter_merge stack l).
Proof.
  intros stack l H; induction l in stack, H |- *; simpl.
    auto using Sorted_merge_stack.
    assert (Sorted [a]) by constructor.
    auto using Sorted_merge_list_to_stack.
Qed.

Theorem Permuted_iter_merge : forall l stack,
  Permutation (flatten_stack stack ++ l) (iter_merge stack l).
Proof.
  induction l; simpl; intros.
    rewrite app_nil_r. apply Permuted_merge_stack.
    change (a::l) with ([a]++l).
    rewrite app_assoc.
    etransitivity.
      apply Permutation_app_tail.
    etransitivity.
    apply Permutation_app_comm.
    apply Permuted_merge_list_to_stack.
    apply IHl.
Qed.

Theorem Sorted_sort : forall l, Sorted (sort l).
Proof.
intro; apply Sorted_iter_merge. constructor.
Qed.

Corollary LocallySorted_sort : forall l, Sorted.Sorted leb (sort l).
Proof. intro; eapply Sorted_LocallySorted_iff, Sorted_sort; auto. Qed.

Theorem Permuted_sort : forall l, Permutation l (sort l).
Proof.
intro; apply (Permuted_iter_merge l []).
Qed.

Corollary StronglySorted_sort : forall l,
  Transitive leb -> StronglySorted leb (sort l).
Proof. auto using Sorted_StronglySorted, LocallySorted_sort. Qed.

End Sort.

(** An example *)

Module NatOrder <: TotalLeBool.
  Definition t := nat.
  Fixpoint leb x y :=
    match x, y with
    | 0, _ => true
    | _, 0 => false
    | S x', S y' => leb x' y'
    end.
  Infix "<=?" := leb (at level 35).
  Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1.
  Proof.
    induction a1; destruct a2; simpl; auto.
  Qed.
End NatOrder.

Module Import NatSort := Sort NatOrder.

Example SimpleMergeExample := Eval compute in sort [5;3;6;1;8;6;0].


(**
This library provides vernacular files containing a formalization of real
analysis for Coq. It is a conservative extension of the standard library Reals
with a focus on usability. It has been developed by Sylvie Boldo, Catherine
Lelay, and Guillaume Melquiond.

The goal of Coquelicot is to ease the writing of formulas and theorem statements
for real analysis. This is achieved by using total functions in place of
dependent types for limits, derivatives, integrals, power series, and so on.
To help with the proof process, the library comes with a comprehensive set
of theorems that cover not only these notions, but also some extensions such
as parametric integrals, two-dimensional differentiability, asymptotic
properties. It also offers some automations for performing differentiability
proofs. Since Coquelicot is a conservative extension of Coq's standard
library, we provide correspondence theorems between the two libraries.

* Main types

- [R]: the set of real numbers defined by Coq's standard library.
- [Rbar]: [R] extended with signed infinities [p_infty] and [m_infty]. There is
  a coercion from [R] to [Rbar].
- [C]: the set of complex numbers, defined as pairs of real numbers. There is a
  coercion from [R] to [C].
- [@matrix T m n]: matrices with m rows and n columns of coefficients of type T.

* Main classes

- [UniformSpace]: a uniform space with a predicate [ball] defining an ecart.
- [CompleteSpace]: a [UniformSpace] that is also complete.
- [AbelianGroup]: a type with a commutative operator [plus] and a neutral
  element [zero]; elements are invertible ([opp], [minus]).
- [Ring]: an [AbelianGroup] with a noncommutative operator [mult] that is
  distributive with respect to [plus]; [one] is the neutral element of [mult].
- [AbsRing]: a [Ring] with an operator [abs] that is subdistributive
  with respect to [plus] and [mult].
- [ModuleSpace]: an [AbelianGroup] with an operator [scal] that defines a
  left module over a [Ring].
- [NormedModule]: a [ModuleSpace] that is also a [UniformSpace]; it provides an
  operator [norm] that defines the same topology as [ball].
- [CompleteNormedModule]: a [NormedModule] that is also a [CompleteSpace].

In the following definitions, K will designate either a [Ring] or an [AbsRing],
while U and V will designate a [ModuleSpace], a [NormedModule], or a
[CompleteNormedModule].

* Low-level concepts of topology

Limits and neighborhoods are expressed in terms of filters, that is, predicates
of type [(T -> Prop) -> Prop]. Sets from a filter are stable by intersection and
extension. Filters are used to describe limit points and how they are approached.
The properties of a filter are described by the [Filter] record. If a filter
does not contain the empty set, it is also a [PerfectFilter].

In a [UniformSpace], [ball x eps y] states that y lies in a ball of center x and
radius eps. [locally x] is the filter generated by all the balls of center x. As
such, its single limit point is x. Thus [locally x] matches the traditional notion
of convergence toward [x] in a metric space. Note: [locally x] is also the set of
neighborhoods of x.

The supported filters are as follows:
- [locally x].
- [locally' x] is similar to [locally x], except that x is missing from every
  set. Thus, while its limit point is x too, properties at point x do not
  matter.
- [Rbar_locally x] is defined for x in [Rbar]. It is [locally x] if x is finite,
  otherwise it is the set of half-bounded open intervals extending to either
  [m_infty] or [p_infty], depending on which infinity x is. In the latter case,
  the limit described by the filter is plus or minus infinity.
- [Rbar_locally' x] is to [Rbar_locally x] what [locally' x] is to [locally x].
- [at_left x] restricts the balls of [locally x] to points strictly less
  than x, thus properties of points on the right of x do not matter.
- [at_right x] is analogous to [at_left x] and is used to take limits on the right.
- [filter_prod G H] is a filter describing the neighborhoods of point (g,h) if
  G describes the neighborhoods of g while H describes the neighborhoods of h.
- [eventually] is a filter on natural numbers that converges to plus infinity.
- [within dom F] weakens a filter F by only considering points that satisfy dom.

Examples:
- [locally x P] can be interpreted in several ways depending on the meaning of P.
  As a set, it means that P contains a ball centered at x, that is, P is a
  neighborhood of x. As a predicate, it means that P holds on a neighborhood of x.
- [locally 2 (fun x => 0 < ln x)] means that [ln] has positive values in
  a neighborhood of 2.
- [at_left 1 (fun x => -1 < ln x < 0)] means that [ln] has values between -1
  and 0 in the left part of a neighborhood of 1.

Open sets are described by the [open] predicate. It states that a set is open
if it is a neighborhood of any of its points (in terms of [locally]). Closed sets
are described by [closed].

* Limits and continuity

Limits and continuity are expressed with filters using predicate [filterlim :
(S -> T) -> ((S -> Prop) -> Prop) -> ((T -> Prop) -> Prop)]. Property
[filterlim f K L] means that the preimage of any set of L by f is a set of K.
In other words, function f, at the limit point described by filter K tends to
the limit point described by filter L.

Examples:
- [filterlim f (locally x) (locally (f x))] means that f is continuous
  at point x. [filterlim f (locally' x) (locally (f x))] is another way to state
  it, since x is necessarily in the preimage of f x and thus can be ignored.
- [filterlim f (at_right x) (locally y)] means that f t tends to y when t tends
  to x from the right.
- [filterlim exp (Rbar_locally m_infty) (at_right 0)] means that [exp] tends
  to 0 at minus infinity but only takes positive values there.
- [forall x y : R, filterlim (fun z => fst z + snd z) (filter_prod (locally x)
  (locally y)) (locally (x + y))] states that [Rplus] is continuous.

Lemma [filterlim_locally] gives the traditional epsilon-delta definition of
continuity. Compatibility with the [continuity_pt] predicate from the standard
library is provided by lemmas such as [continuity_pt_filterlim].

The following predicates specialize [filterlim] to the usual cases of
real-valued sequences and functions:
- [is_lim_seq : (nat -> R) -> Rbar -> Prop], e.g. [is_lim_seq (fun n => 1 + /
  INR n) 1].
- [is_lim : (R -> R) -> Rbar -> Rbar -> Prop], e.g. [is_lim exp p_infty
  p_infty].

The unicity of the limits is given by lemmas [is_lim_seq_unique] and
[is_lim_unique]. The compatibility with the arithmetic operators is given
by lemmas such as [is_lim_seq_plus] and [is_lim_seq_plus']. They are
derived from the generic lemmas [filterlim_plus] and [filterlim_comp_2].

Lemmas [is_lim_seq_spec] and [is_lim_sprec] gives the traditional epsilon-delta
definition of convergence. Compatibility with the [Un_cv] and [limit1_in]
predicates from the standard library is provided by lemmas [is_lim_seq_Reals]
and [is_lim_Reals].

When only the convergence matters but not the actual value of the limit, the
following predicates can be used instead, depending on whether the value can
be infinite or not:
- [ex_lim_seq : (nat -> R) -> Prop].
- [ex_lim : (R -> R) -> Rbar -> Prop].
- [ex_finite_lim_seq : (nat -> R) -> Prop].
- [ex_finite_lim : (R -> R) -> Rbar -> Prop].

Finally, there are also some total functions that are guaranteed to return the
proper limits if the sequences or functions actually converge:
- [Lim_seq : (nat -> R) -> Rbar], e.g. [Lim_seq (fun n => 1 + / INR n)] is equal
  to 1.
- [Lim : (R -> R) -> Rbar -> Rbar].

If they do not converge, the returned value is arbitrary and no interesting
results can be derived. These functions are related to the previous predicates
by lemmas [Lim_seq_correct] and [Lim_correct].

As with predicates [filterlim], [is_lim_seq], and [is_lim], compatibility with
the arithmetic operators is given by lemmas such as [ex_lim_seq_mult] and
[Lim_inv].

Compatibility with predicates [Un_cv] and [limit1_in] from the standard library
is provided by lemmas [is_lim_seq_Reals] and [is_lim_Reals].

* Derivability and differentiability

The predicate of differentiability is [filterdiff : (U -> V) -> ((U -> Prop) ->
Prop) -> (U -> V) -> Prop]. Property [filterdiff f K l] means that, at the
limit point described by filter K, the differential of function f is the linear
function l. Linearity is described by the predicate [is_linear].

While [filterdiff_ext] states that two functions extensionally equal have the
same differential, [filterdiff_ext_lin] states that the differential can be
replaced by any linear function that is extensionally equal.

When the domain space of the function is an [AbsRing] rather than just a
[NormedModule] and the filter is [locally], the following specialized predicates
can be used instead:
- [is_derive : (K -> V) -> K -> V -> Prop].
- [ex_derive : (K -> V) -> K -> V -> Prop].

For real-valued functions, the following total function gives the value of the
derivative, if it exists: [Derive : (R -> R) -> R -> R]. The specification of
this function is given by lemma [Derive_correct]. Compatibility of the
predicates with [derivable_pt_lim] from the standard library is given by
[is_derive_Reals].

Tactic [auto_derive] can be used to automatically solve goals about [is_derive],
[ex_derive], [derivable_pt_lim], and [derivable_pt].

* Riemann integrals

The main predicate is [is_RInt : (R -> V) -> R -> R -> V -> Prop]. [is_RInt f a
b l] means that the Riemann sums of function f between a and b converge and
their limit is equal to l. This is a specialization of [filterlim] for a
function built using [Riemann_sum] and the [Riemann_fine] filter.

As before, there are a predicate and a total function related to it:
- [ex_RInt : (R -> V) -> R -> R -> Prop].
- [RInt : (R -> R) -> R -> R -> R].

Compatibility with predicate [Riemann_integrable] from the standard library is
provided by lemmas [ex_RInt_Reals_0] and [ex_RInt_Reals_1].

* Series and power series

The main predicates are [is_series : (nat -> V) -> V -> Prop] and [is_pseries :
(nat -> V) -> K -> V -> Prop].

The associated predicates and functions are as follows:
- [ex_series : (nat -> V) -> Prop].
- [ex_pseries : (nat -> V) -> K -> Prop].
- [Series : (nat -> R) -> R].
- [PSeries : (nat -> R) -> R -> R].

There is also a function [CV_radius : (nat -> R) -> Rbar] that returns the
possibly infinite convergence radius.

Compatibility with predicates [infinite_sum] and [Pser] from the standard
library is provided by lemmas [is_series_Reals] and [is_pseries_Reals].

* Naming conventions

- Theorems about a given predicate start with its name, generally followed
  by the name of the object it is applied to, e.g. [is_RInt_plus], or a property
  of the object, e.g. [filterdiff_linear].
- Correspondence theorems with the standard library end with [_Reals].
- Extensionality theorems end with [_ext]. If the equality only needs to
  be local, they end with [_ext_loc] instead.
- Uniqueness theorems end with [_unique].
- Theorems about asymptotic properties at plus, resp. minus, infinity end with
  [_p], resp. [_m].
  if they are at infinite points.
- Theorems about constant functions, resp. identity, end with [_const], resp.
  [_id].

*)

Require Export AutoDerive Compactness Complex Continuity Derive.
Require Export Derive_2d Equiv ElemFct Hierarchy Lim_seq.
Require Export Lub Markov PSeries Rbar Rcomplements.
Require Export RInt RInt_gen RInt_analysis Seq_fct Series SF_seq.

(** ## *)

(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)