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

Require Import Rbase.
Require Import Rfunctions.
Require Import Rseries.
Require Import SeqProp.
Require Import PartSum.
Require Import Max.

Open Local Scope R_scope.

(***************************************************)
(* Various versions of the criterion of D'Alembert *)
(***************************************************)

Lemma Alembert_C1 :
  forall An:nat -> R,
    (forall n:nat, 0 < An n) ->
    Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof.
  intros An H H0.
  cut
    ({ l:R | is_lub (EUn (fun N:nat => sum_f_R0 An N)) l } ->
      { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }).
  intro X; apply X.
  apply completeness.
  unfold Un_cv in H0; unfold bound in |- *; cut (0 < / 2);
    [ intro | apply Rinv_0_lt_compat; prove_sup0 ].
  elim (H0 (/ 2) H1); intros.
  exists (sum_f_R0 An x + 2 * An (S x)).
  unfold is_upper_bound in |- *; intros; unfold EUn in H3; elim H3; intros.
  rewrite H4; assert (H5 := lt_eq_lt_dec x1 x).
  elim H5; intros.
  elim a; intro.
  replace (sum_f_R0 An x) with
    (sum_f_R0 An x1 + sum_f_R0 (fun i:nat => An (S x1 + i)%nat) (x - S x1)).
  pattern (sum_f_R0 An x1) at 1 in |- *; rewrite <- Rplus_0_r;
    rewrite Rplus_assoc; apply Rplus_le_compat_l.
  left; apply Rplus_lt_0_compat.
  apply tech1; intros; apply H.
  apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
  symmetry  in |- *; apply tech2; assumption.
  rewrite b; pattern (sum_f_R0 An x) at 1 in |- *; rewrite <- Rplus_0_r;
    apply Rplus_le_compat_l.
  left; apply Rmult_lt_0_compat; [ prove_sup0 | apply H ].
  replace (sum_f_R0 An x1) with
    (sum_f_R0 An x + sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x)).
  apply Rplus_le_compat_l.
  cut
    (sum_f_R0 (fun i:nat => An (S x + i)%nat) (x1 - S x) <=
      An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)).
  intro;
    apply Rle_trans with
      (An (S x) * sum_f_R0 (fun i:nat => (/ 2) ^ i) (x1 - S x)).
  assumption.
  rewrite <- (Rmult_comm (An (S x))); apply Rmult_le_compat_l.
  left; apply H.
  rewrite tech3.
  replace (1 - / 2) with (/ 2).
  unfold Rdiv in |- *; rewrite Rinv_involutive.
  pattern 2 at 3 in |- *; rewrite <- Rmult_1_r; rewrite <- (Rmult_comm 2);
    apply Rmult_le_compat_l.
  left; prove_sup0.
  left; apply Rplus_lt_reg_r with ((/ 2) ^ S (x1 - S x)).
  replace ((/ 2) ^ S (x1 - S x) + (1 - (/ 2) ^ S (x1 - S x))) with 1;
    [ idtac | ring ].
  rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
    apply Rplus_lt_compat_l.
  apply pow_lt; apply Rinv_0_lt_compat; prove_sup0.
  discrR.
  apply Rmult_eq_reg_l with 2.
  rewrite Rmult_minus_distr_l; rewrite <- Rinv_r_sym.
  ring.
  discrR.
  discrR.
  pattern 1 at 3 in |- *; replace 1 with (/ 1);
    [ apply tech7; discrR | apply Rinv_1 ].
  replace (An (S x)) with (An (S x + 0)%nat).
  apply (tech6 (fun i:nat => An (S x + i)%nat) (/ 2)).
  left; apply Rinv_0_lt_compat; prove_sup0.
  intro; cut (forall n:nat, (n >= x)%nat -> An (S n) < / 2 * An n).
  intro; replace (S x + S i)%nat with (S (S x + i)).
  apply H6; unfold ge in |- *; apply tech8.
  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR; ring.
  intros; unfold R_dist in H2; apply Rmult_lt_reg_l with (/ An n).
  apply Rinv_0_lt_compat; apply H.
  do 2 rewrite (Rmult_comm (/ An n)); rewrite Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r;
    replace (An (S n) * / An n) with (Rabs (Rabs (An (S n) / An n) - 0)).
  apply H2; assumption.
  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
    rewrite Rabs_Rabsolu; rewrite Rabs_right.
  unfold Rdiv in |- *; reflexivity.
  left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
    apply Rmult_lt_0_compat; [ apply H | apply Rinv_0_lt_compat; apply H ].
  red in |- *; intro; assert (H8 := H n); rewrite H7 in H8;
    elim (Rlt_irrefl _ H8).
  replace (S x + 0)%nat with (S x); [ reflexivity | ring ].
  symmetry  in |- *; apply tech2; assumption.
  exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
  intro X; elim X; intros.
  exists x; apply Un_cv_crit_lub;
    [ unfold Un_growing in |- *; intro; rewrite tech5;
      pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
	apply Rplus_le_compat_l; left; apply H
      | apply p ].
Defined.

Lemma Alembert_C2 :
  forall An:nat -> R,
    (forall n:nat, An n <> 0) ->
    Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof.
  intros.
  set (Vn := fun i:nat => (2 * Rabs (An i) + An i) / 2).
  set (Wn := fun i:nat => (2 * Rabs (An i) - An i) / 2).
  cut (forall n:nat, 0 < Vn n).
  intro; cut (forall n:nat, 0 < Wn n).
  intro; cut (Un_cv (fun n:nat => Rabs (Vn (S n) / Vn n)) 0).
  intro; cut (Un_cv (fun n:nat => Rabs (Wn (S n) / Wn n)) 0).
  intro; assert (H5 := Alembert_C1 Vn H1 H3).
  assert (H6 := Alembert_C1 Wn H2 H4).
  elim H5; intros.
  elim H6; intros.
  exists (x - x0); unfold Un_cv in |- *; unfold Un_cv in p;
    unfold Un_cv in p0; intros; cut (0 < eps / 2).
  intro; elim (p (eps / 2) H8); clear p; intros.
  elim (p0 (eps / 2) H8); clear p0; intros.
  set (N := max x1 x2).
  exists N; intros;
    replace (sum_f_R0 An n) with (sum_f_R0 Vn n - sum_f_R0 Wn n).
  unfold R_dist in |- *;
    replace (sum_f_R0 Vn n - sum_f_R0 Wn n - (x - x0)) with
      (sum_f_R0 Vn n - x + - (sum_f_R0 Wn n - x0)); [ idtac | ring ];
      apply Rle_lt_trans with
	(Rabs (sum_f_R0 Vn n - x) + Rabs (- (sum_f_R0 Wn n - x0))).
  apply Rabs_triang.
  rewrite Rabs_Ropp; apply Rlt_le_trans with (eps / 2 + eps / 2).
  apply Rplus_lt_compat.
  unfold R_dist in H9; apply H9; unfold ge in |- *; apply le_trans with N;
    [ unfold N in |- *; apply le_max_l | assumption ].
  unfold R_dist in H10; apply H10; unfold ge in |- *; apply le_trans with N;
    [ unfold N in |- *; apply le_max_r | assumption ].
  right; symmetry  in |- *; apply double_var.
  symmetry  in |- *; apply tech11; intro; unfold Vn, Wn in |- *;
    unfold Rdiv in |- *; do 2 rewrite <- (Rmult_comm (/ 2));
      apply Rmult_eq_reg_l with 2.
  rewrite Rmult_minus_distr_l; repeat rewrite <- Rmult_assoc;
    rewrite <- Rinv_r_sym.
  ring.
  discrR.
  discrR.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
  cut (forall n:nat, / 2 * Rabs (An n) <= Wn n <= 3 * / 2 * Rabs (An n)).
  intro; cut (forall n:nat, / Wn n <= 2 * / Rabs (An n)).
  intro; cut (forall n:nat, Wn (S n) / Wn n <= 3 * Rabs (An (S n) / An n)).
  intro; unfold Un_cv in |- *; intros; unfold Un_cv in H0; cut (0 < eps / 3).
  intro; elim (H0 (eps / 3) H8); intros.
  exists x; intros.
  assert (H11 := H9 n H10).
  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H11;
      unfold Rminus in H11; rewrite Ropp_0 in H11; rewrite Rplus_0_r in H11;
	rewrite Rabs_Rabsolu in H11; rewrite Rabs_right.
  apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)).
  apply H6.
  apply Rmult_lt_reg_l with (/ 3).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
    rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H11;
      exact H11.
  left; change (0 < Wn (S n) / Wn n) in |- *; unfold Rdiv in |- *;
    apply Rmult_lt_0_compat.
  apply H2.
  apply Rinv_0_lt_compat; apply H2.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
  intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
    replace 3 with (2 * (3 * / 2));
      [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
      apply Rle_trans with (Wn (S n) * 2 * / Rabs (An n)).
  rewrite Rmult_assoc; apply Rmult_le_compat_l.
  left; apply H2.
  apply H5.
  rewrite Rabs_Rinv.
  replace (Wn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Wn (S n));
    [ idtac | ring ];
    replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
      (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n))));
      [ idtac | ring ]; apply Rmult_le_compat_l.
  left; apply Rmult_lt_0_compat.
  prove_sup0.
  apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H.
  elim (H4 (S n)); intros; assumption.
  apply H.
  intro; apply Rmult_le_reg_l with (Wn n).
  apply H2.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (Rabs (An n)).
  apply Rabs_pos_lt; apply H.
  rewrite Rmult_1_r;
    replace (Rabs (An n) * (Wn n * (2 * / Rabs (An n)))) with
      (2 * Wn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ];
      rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; elim (H4 n); intros; assumption.
  discrR.
  apply Rabs_no_R0; apply H.
  red in |- *; intro; assert (H6 := H2 n); rewrite H5 in H6;
    elim (Rlt_irrefl _ H6).
  intro; split.
  unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
    apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; prove_sup0.
  pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
    unfold Rminus in |- *; rewrite Rplus_assoc; apply Rplus_le_compat_l.
  apply Rplus_le_reg_l with (An n).
  rewrite Rplus_0_r; rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
    rewrite Rplus_opp_l; rewrite Rplus_0_r; apply RRle_abs.
  unfold Wn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
    repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; prove_sup0.
  unfold Rminus in |- *; rewrite double;
    replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
      [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l.
  rewrite <- Rabs_Ropp; apply RRle_abs.
  cut (forall n:nat, / 2 * Rabs (An n) <= Vn n <= 3 * / 2 * Rabs (An n)).
  intro; cut (forall n:nat, / Vn n <= 2 * / Rabs (An n)).
  intro; cut (forall n:nat, Vn (S n) / Vn n <= 3 * Rabs (An (S n) / An n)).
  intro; unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / 3).
  intro; elim (H0 (eps / 3) H7); intros.
  exists x; intros.
  assert (H10 := H8 n H9).
  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold R_dist in H10;
      unfold Rminus in H10; rewrite Ropp_0 in H10; rewrite Rplus_0_r in H10;
	rewrite Rabs_Rabsolu in H10; rewrite Rabs_right.
  apply Rle_lt_trans with (3 * Rabs (An (S n) / An n)).
  apply H5.
  apply Rmult_lt_reg_l with (/ 3).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym; [ idtac | discrR ];
    rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H10;
      exact H10.
  left; change (0 < Vn (S n) / Vn n) in |- *; unfold Rdiv in |- *;
    apply Rmult_lt_0_compat.
  apply H1.
  apply Rinv_0_lt_compat; apply H1.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; prove_sup0 ].
  intro; unfold Rdiv in |- *; rewrite Rabs_mult; rewrite <- Rmult_assoc;
    replace 3 with (2 * (3 * / 2));
      [ idtac | rewrite <- Rmult_assoc; apply Rinv_r_simpl_m; discrR ];
      apply Rle_trans with (Vn (S n) * 2 * / Rabs (An n)).
  rewrite Rmult_assoc; apply Rmult_le_compat_l.
  left; apply H1.
  apply H4.
  rewrite Rabs_Rinv.
  replace (Vn (S n) * 2 * / Rabs (An n)) with (2 * / Rabs (An n) * Vn (S n));
    [ idtac | ring ];
    replace (2 * (3 * / 2) * Rabs (An (S n)) * / Rabs (An n)) with
      (2 * / Rabs (An n) * (3 * / 2 * Rabs (An (S n))));
      [ idtac | ring ]; apply Rmult_le_compat_l.
  left; apply Rmult_lt_0_compat.
  prove_sup0.
  apply Rinv_0_lt_compat; apply Rabs_pos_lt; apply H.
  elim (H3 (S n)); intros; assumption.
  apply H.
  intro; apply Rmult_le_reg_l with (Vn n).
  apply H1.
  rewrite <- Rinv_r_sym.
  apply Rmult_le_reg_l with (Rabs (An n)).
  apply Rabs_pos_lt; apply H.
  rewrite Rmult_1_r;
    replace (Rabs (An n) * (Vn n * (2 * / Rabs (An n)))) with
      (2 * Vn n * (Rabs (An n) * / Rabs (An n))); [ idtac | ring ];
      rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; apply Rmult_le_reg_l with (/ 2).
  apply Rinv_0_lt_compat; prove_sup0.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; elim (H3 n); intros; assumption.
  discrR.
  apply Rabs_no_R0; apply H.
  red in |- *; intro; assert (H5 := H1 n); rewrite H4 in H5;
    elim (Rlt_irrefl _ H5).
  intro; split.
  unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_comm (/ 2));
    apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; prove_sup0.
  pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r; rewrite double;
    rewrite Rplus_assoc; apply Rplus_le_compat_l.
  apply Rplus_le_reg_l with (- An n); rewrite Rplus_0_r;
    rewrite <- (Rplus_comm (An n)); rewrite <- Rplus_assoc;
      rewrite Rplus_opp_l; rewrite Rplus_0_l; rewrite <- Rabs_Ropp;
	apply RRle_abs.
  unfold Vn in |- *; unfold Rdiv in |- *; repeat rewrite <- (Rmult_comm (/ 2));
    repeat rewrite Rmult_assoc; apply Rmult_le_compat_l.
  left; apply Rinv_0_lt_compat; prove_sup0.
  unfold Rminus in |- *; rewrite double;
    replace (3 * Rabs (An n)) with (Rabs (An n) + Rabs (An n) + Rabs (An n));
      [ idtac | ring ]; repeat rewrite Rplus_assoc; repeat apply Rplus_le_compat_l;
	apply RRle_abs.
  intro; unfold Wn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
    rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
  apply Rinv_0_lt_compat; prove_sup0.
  apply Rplus_lt_reg_r with (An n); rewrite Rplus_0_r; unfold Rminus in |- *;
    rewrite (Rplus_comm (An n)); rewrite Rplus_assoc;
      rewrite Rplus_opp_l; rewrite Rplus_0_r;
	apply Rle_lt_trans with (Rabs (An n)).
  apply RRle_abs.
  rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
    apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
  intro; unfold Vn in |- *; unfold Rdiv in |- *; rewrite <- (Rmult_0_r (/ 2));
    rewrite <- (Rmult_comm (/ 2)); apply Rmult_lt_compat_l.
  apply Rinv_0_lt_compat; prove_sup0.
  apply Rplus_lt_reg_r with (- An n); rewrite Rplus_0_r; unfold Rminus in |- *;
    rewrite (Rplus_comm (- An n)); rewrite Rplus_assoc;
      rewrite Rplus_opp_r; rewrite Rplus_0_r;
	apply Rle_lt_trans with (Rabs (An n)).
  rewrite <- Rabs_Ropp; apply RRle_abs.
  rewrite double; pattern (Rabs (An n)) at 1 in |- *; rewrite <- Rplus_0_r;
    apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H.
Defined.

Lemma AlembertC3_step1 :
  forall (An:nat -> R) (x:R),
    x <> 0 ->
    (forall n:nat, An n <> 0) ->
    Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
    { l:R | Pser An x l }.
Proof.
  intros; set (Bn := fun i:nat => An i * x ^ i).
  cut (forall n:nat, Bn n <> 0).
  intro; cut (Un_cv (fun n:nat => Rabs (Bn (S n) / Bn n)) 0).
  intro; assert (H4 := Alembert_C2 Bn H2 H3).
  elim H4; intros.
  exists x0; unfold Bn in p; apply tech12; assumption.
  unfold Un_cv in |- *; intros; unfold Un_cv in H1; cut (0 < eps / Rabs x).
  intro; elim (H1 (eps / Rabs x) H4); intros.
  exists x0; intros; unfold R_dist in |- *; unfold Rminus in |- *;
    rewrite Ropp_0; rewrite Rplus_0_r; rewrite Rabs_Rabsolu;
      unfold Bn in |- *;
	replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
  rewrite Rabs_mult; apply Rmult_lt_reg_l with (/ Rabs x).
  apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
  rewrite <- (Rmult_comm (Rabs x)); rewrite <- Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H5;
    replace (Rabs (An (S n) / An n)) with (R_dist (Rabs (An (S n) * / An n)) 0).
  apply H5; assumption.
  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Ropp_0;
    rewrite Rplus_0_r; rewrite Rabs_Rabsolu; unfold Rdiv in |- *;
      reflexivity.
  apply Rabs_no_R0; assumption.
  replace (S n) with (n + 1)%nat; [ idtac | ring ]; rewrite pow_add;
    unfold Rdiv in |- *; rewrite Rinv_mult_distr.
  replace (An (n + 1)%nat * (x ^ n * x ^ 1) * (/ An n * / x ^ n)) with
    (An (n + 1)%nat * x ^ 1 * / An n * (x ^ n * / x ^ n));
    [ idtac | ring ]; rewrite <- Rinv_r_sym.
  simpl in |- *; ring.
  apply pow_nonzero; assumption.
  apply H0.
  apply pow_nonzero; assumption.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ].
  intro; unfold Bn in |- *; apply prod_neq_R0;
    [ apply H0 | apply pow_nonzero; assumption ].
Defined.

Lemma AlembertC3_step2 :
  forall (An:nat -> R) (x:R), x = 0 -> { l:R | Pser An x l }.
Proof.
  intros; exists (An 0%nat).
  unfold Pser in |- *; unfold infinite_sum in |- *; intros; exists 0%nat; intros;
    replace (sum_f_R0 (fun n0:nat => An n0 * x ^ n0) n) with (An 0%nat).
  unfold R_dist in |- *; unfold Rminus in |- *; rewrite Rplus_opp_r;
    rewrite Rabs_R0; assumption.
  induction  n as [| n Hrecn].
  simpl in |- *; ring.
  rewrite tech5; rewrite Hrecn;
    [ rewrite H; simpl in |- *; ring | unfold ge in |- *; apply le_O_n ].
Qed.

(** A useful criterion of convergence for power series *)
Theorem Alembert_C3 :
  forall (An:nat -> R) (x:R),
    (forall n:nat, An n <> 0) ->
    Un_cv (fun n:nat => Rabs (An (S n) / An n)) 0 ->
    { l:R | Pser An x l }.
Proof.
  intros; case (total_order_T x 0); intro.
  elim s; intro.
  cut (x <> 0).
  intro; apply AlembertC3_step1; assumption.
  red in |- *; intro; rewrite H1 in a; elim (Rlt_irrefl _ a).
  apply AlembertC3_step2; assumption.
  cut (x <> 0).
  intro; apply AlembertC3_step1; assumption.
  red in |- *; intro; rewrite H1 in r; elim (Rlt_irrefl _ r).
Defined.

Lemma Alembert_C4 :
  forall (An:nat -> R) (k:R),
    0 <= k < 1 ->
    (forall n:nat, 0 < An n) ->
    Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof.
  intros An k Hyp H H0.
  cut
    ({ l:R | is_lub (EUn (fun N:nat => sum_f_R0 An N)) l } ->
      { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }).
  intro X; apply X.
  apply completeness.
  assert (H1 := tech13 _ _ Hyp H0).
  elim H1; intros.
  elim H2; intros.
  elim H4; intros.
  unfold bound in |- *; exists (sum_f_R0 An x0 + / (1 - x) * An (S x0)).
  unfold is_upper_bound in |- *; intros; unfold EUn in H6.
  elim H6; intros.
  rewrite H7.
  assert (H8 := lt_eq_lt_dec x2 x0).
  elim H8; intros.
  elim a; intro.
  replace (sum_f_R0 An x0) with
    (sum_f_R0 An x2 + sum_f_R0 (fun i:nat => An (S x2 + i)%nat) (x0 - S x2)).
  pattern (sum_f_R0 An x2) at 1 in |- *; rewrite <- Rplus_0_r.
  rewrite Rplus_assoc; apply Rplus_le_compat_l.
  left; apply Rplus_lt_0_compat.
  apply tech1.
  intros; apply H.
  apply Rmult_lt_0_compat.
  apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
    replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
  apply H.
  symmetry  in |- *; apply tech2; assumption.
  rewrite b; pattern (sum_f_R0 An x0) at 1 in |- *; rewrite <- Rplus_0_r;
    apply Rplus_le_compat_l.
  left; apply Rmult_lt_0_compat.
  apply Rinv_0_lt_compat; apply Rplus_lt_reg_r with x; rewrite Rplus_0_r;
    replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
  apply H.
  replace (sum_f_R0 An x2) with
    (sum_f_R0 An x0 + sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0)).
  apply Rplus_le_compat_l.
  cut
    (sum_f_R0 (fun i:nat => An (S x0 + i)%nat) (x2 - S x0) <=
      An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)).
  intro;
    apply Rle_trans with (An (S x0) * sum_f_R0 (fun i:nat => x ^ i) (x2 - S x0)).
  assumption.
  rewrite <- (Rmult_comm (An (S x0))); apply Rmult_le_compat_l.
  left; apply H.
  rewrite tech3.
  unfold Rdiv in |- *; apply Rmult_le_reg_l with (1 - x).
  apply Rplus_lt_reg_r with x; rewrite Rplus_0_r.
  replace (x + (1 - x)) with 1; [ elim H3; intros; assumption | ring ].
  do 2 rewrite (Rmult_comm (1 - x)).
  rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; apply Rplus_le_reg_l with (x ^ S (x2 - S x0)).
  replace (x ^ S (x2 - S x0) + (1 - x ^ S (x2 - S x0))) with 1;
    [ idtac | ring ].
  rewrite <- (Rplus_comm 1); pattern 1 at 1 in |- *; rewrite <- Rplus_0_r;
    apply Rplus_le_compat_l.
  left; apply pow_lt.
  apply Rle_lt_trans with k.
  elim Hyp; intros; assumption.
  elim H3; intros; assumption.
  apply Rminus_eq_contra.
  red in |- *; intro.
  elim H3; intros.
  rewrite H10 in H12; elim (Rlt_irrefl _ H12).
  red in |- *; intro.
  elim H3; intros.
  rewrite H10 in H12; elim (Rlt_irrefl _ H12).
  replace (An (S x0)) with (An (S x0 + 0)%nat).
  apply (tech6 (fun i:nat => An (S x0 + i)%nat) x).
  left; apply Rle_lt_trans with k.
  elim Hyp; intros; assumption.
  elim H3; intros; assumption.
  intro.
  cut (forall n:nat, (n >= x0)%nat -> An (S n) < x * An n).
  intro.
  replace (S x0 + S i)%nat with (S (S x0 + i)).
  apply H9.
  unfold ge in |- *.
  apply tech8.
  apply INR_eq; rewrite S_INR; do 2 rewrite plus_INR; do 2 rewrite S_INR;
    ring.
  intros.
  apply Rmult_lt_reg_l with (/ An n).
  apply Rinv_0_lt_compat; apply H.
  do 2 rewrite (Rmult_comm (/ An n)).
  rewrite Rmult_assoc.
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r.
  replace (An (S n) * / An n) with (Rabs (An (S n) / An n)).
  apply H5; assumption.
  rewrite Rabs_right.
  unfold Rdiv in |- *; reflexivity.
  left; unfold Rdiv in |- *; change (0 < An (S n) * / An n) in |- *;
    apply Rmult_lt_0_compat.
  apply H.
  apply Rinv_0_lt_compat; apply H.
  red in |- *; intro.
  assert (H11 := H n).
  rewrite H10 in H11; elim (Rlt_irrefl _ H11).
  replace (S x0 + 0)%nat with (S x0); [ reflexivity | ring ].
  symmetry  in |- *; apply tech2; assumption.
  exists (sum_f_R0 An 0); unfold EUn in |- *; exists 0%nat; reflexivity.
  intro X; elim X; intros.
  exists x; apply Un_cv_crit_lub;
    [ unfold Un_growing in |- *; intro; rewrite tech5;
      pattern (sum_f_R0 An n) at 1 in |- *; rewrite <- Rplus_0_r;
	apply Rplus_le_compat_l; left; apply H
      | apply p ].
Qed.

Lemma Alembert_C5 :
  forall (An:nat -> R) (k:R),
    0 <= k < 1 ->
    (forall n:nat, An n <> 0) ->
    Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
    { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }.
Proof.
  intros.
  cut
    ({ l:R | Un_cv (fun N:nat => sum_f_R0 An N) l } ->
      { l:R | Un_cv (fun N:nat => sum_f_R0 An N) l }).
  intro Hyp0; apply Hyp0.
  apply cv_cauchy_2.
  apply cauchy_abs.
  apply cv_cauchy_1.
  cut
    ({ l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l } ->
      { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => Rabs (An i)) N) l }).
  intro Hyp; apply Hyp.
  apply (Alembert_C4 (fun i:nat => Rabs (An i)) k).
  assumption.
  intro; apply Rabs_pos_lt; apply H0.
  unfold Un_cv in |- *.
  unfold Un_cv in H1.
  unfold Rdiv in |- *.
  intros.
  elim (H1 eps H2); intros.
  exists x; intros.
  rewrite <- Rabs_Rinv.
  rewrite <- Rabs_mult.
  rewrite Rabs_Rabsolu.
  unfold Rdiv in H3; apply H3; assumption.
  apply H0.
  intro X.
  elim X; intros.
  exists x.
  assumption.
  intro X.
  elim X; intros.
  exists x.
  assumption.
Qed.

(** Convergence of power series in D(O,1/k)
    k=0 is described in Alembert_C3     *)
Lemma Alembert_C6 :
  forall (An:nat -> R) (x k:R),
    0 < k ->
    (forall n:nat, An n <> 0) ->
    Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
    Rabs x < / k -> { l:R | Pser An x l }.
  intros.
  cut { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l }.
  intro X.
  elim X; intros.
  exists x0.
  apply tech12; assumption.
  case (total_order_T x 0); intro.
  elim s; intro.
  eapply Alembert_C5 with (k * Rabs x).
  split.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  left; assumption.
  left; apply Rabs_pos_lt.
  red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
  apply Rmult_lt_reg_l with (/ k).
  apply Rinv_0_lt_compat; assumption.
  rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  rewrite Rmult_1_r; assumption.
  red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
  intro; apply prod_neq_R0.
  apply H0.
  apply pow_nonzero.
  red in |- *; intro; rewrite H3 in a; elim (Rlt_irrefl _ a).
  unfold Un_cv in |- *; unfold Un_cv in H1.
  intros.
  cut (0 < eps / Rabs x).
  intro.
  elim (H1 (eps / Rabs x) H4); intros.
  exists x0.
  intros.
  replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
  unfold R_dist in |- *.
  rewrite Rabs_mult.
  replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
    (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
  rewrite Rabs_mult.
  rewrite Rabs_Rabsolu.
  apply Rmult_lt_reg_l with (/ Rabs x).
  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
  rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  rewrite <- (Rmult_comm eps).
  unfold R_dist in H5.
  unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
  apply Rabs_no_R0.
  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
  unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
  rewrite pow_add.
  simpl in |- *.
  rewrite Rmult_1_r.
  rewrite Rinv_mult_distr.
  replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
    (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n));
    [ idtac | ring ].
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; reflexivity.
  apply pow_nonzero.
  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
  apply H0.
  apply pow_nonzero.
  red in |- *; intro; rewrite H7 in a; elim (Rlt_irrefl _ a).
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  assumption.
  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
  red in |- *; intro H7; rewrite H7 in a; elim (Rlt_irrefl _ a).
  exists (An 0%nat).
  unfold Un_cv in |- *.
  intros.
  exists 0%nat.
  intros.
  unfold R_dist in |- *.
  replace (sum_f_R0 (fun i:nat => An i * x ^ i) n) with (An 0%nat).
  unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
  induction  n as [| n Hrecn].
  simpl in |- *; ring.
  rewrite tech5.
  rewrite <- Hrecn.
  rewrite b; simpl in |- *; ring.
  unfold ge in |- *; apply le_O_n.
  eapply Alembert_C5 with (k * Rabs x).
  split.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  left; assumption.
  left; apply Rabs_pos_lt.
  red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
  apply Rmult_lt_reg_l with (/ k).
  apply Rinv_0_lt_compat; assumption.
  rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  rewrite Rmult_1_r; assumption.
  red in |- *; intro; rewrite H3 in H; elim (Rlt_irrefl _ H).
  intro; apply prod_neq_R0.
  apply H0.
  apply pow_nonzero.
  red in |- *; intro; rewrite H3 in r; elim (Rlt_irrefl _ r).
  unfold Un_cv in |- *; unfold Un_cv in H1.
  intros.
  cut (0 < eps / Rabs x).
  intro.
  elim (H1 (eps / Rabs x) H4); intros.
  exists x0.
  intros.
  replace (An (S n) * x ^ S n / (An n * x ^ n)) with (An (S n) / An n * x).
  unfold R_dist in |- *.
  rewrite Rabs_mult.
  replace (Rabs (An (S n) / An n) * Rabs x - k * Rabs x) with
    (Rabs x * (Rabs (An (S n) / An n) - k)); [ idtac | ring ].
  rewrite Rabs_mult.
  rewrite Rabs_Rabsolu.
  apply Rmult_lt_reg_l with (/ Rabs x).
  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
  rewrite <- Rmult_assoc.
  rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l.
  rewrite <- (Rmult_comm eps).
  unfold R_dist in H5.
  unfold Rdiv in |- *; unfold Rdiv in H5; apply H5; assumption.
  apply Rabs_no_R0.
  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
  unfold Rdiv in |- *; replace (S n) with (n + 1)%nat; [ idtac | ring ].
  rewrite pow_add.
  simpl in |- *.
  rewrite Rmult_1_r.
  rewrite Rinv_mult_distr.
  replace (An (n + 1)%nat * (x ^ n * x) * (/ An n * / x ^ n)) with
    (An (n + 1)%nat * / An n * x * (x ^ n * / x ^ n));
    [ idtac | ring ].
  rewrite <- Rinv_r_sym.
  rewrite Rmult_1_r; reflexivity.
  apply pow_nonzero.
  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
  apply H0.
  apply pow_nonzero.
  red in |- *; intro; rewrite H7 in r; elim (Rlt_irrefl _ r).
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  assumption.
  apply Rinv_0_lt_compat; apply Rabs_pos_lt.
  red in |- *; intro H7; rewrite H7 in r; elim (Rlt_irrefl _ r).
Qed.


Require Import Wellfounded Wf_nat.
Require Import Program SetoidList Equality.
Require Import Arith.
Require Import SetDecide Containers.OrderedType.

(** Fix the easy tactic to include auto and order *)

Ltac easy_base :=
  let rec use_hyp H :=
      (match type of H with
         | _ /\ _ => exact H || destruct_hyp H
         | _ => try (solve [ inversion H ])
       end)
  with do_intro := (let H := fresh in
                    intro H; use_hyp H)
  with destruct_hyp H := (case H; clear H; do_intro; do_intro) in
  let rec use_hyps :=
   (match goal with
    | H:_ /\ _ |- _ => exact H || (destruct_hyp H; use_hyps)
    | H:_ |- _ => solve [ inversion H ]
    | _ => idtac
    end) in
  let rec do_atom :=
   ((solve [ reflexivity | symmetry ; trivial ]) ||
      contradiction  || (split; do_atom))
  with do_ccl := (trivial with eq_true; repeat do_intro; do_atom) in
  (use_hyps; do_ccl) || fail "Cannot solve this goal".

Ltac easy ::= solve [ auto || order || easy_base ] || fail "Cannot solve this goal".

Ltac depelim id ::=
  do_depelim ltac:(fun hyp => do_case hyp) id
  || (reduce in id; do_depelim ltac:(fun hyp => do_case hyp) id).

Ltac forward H :=
  match type of H with
    | ?X -> _ => cut X; [let H' := fresh in intro H'; specialize (H H'); clear H'|]
  end.

Lemma list_length_ind {A} {P : list A -> Prop}
      (Psucc : forall l, (forall l', length l' < length l -> P l') -> P l) : forall l, P l.
Proof.
  apply induction_ltof1 with (f := @length A).
  apply Psucc.
Qed.

Section ListLastInd.
  Context {A : Type}.
  Context (P : list A -> Prop)
          (Pnil : P [])
          (Papp_end : forall l x, P l -> P (l ++ [x])%list).

  Fixpoint list_split_last (l : list A) (opt : A) : list A * A :=
    match l with
      | [] => ([], opt)
      | a :: [] => ([opt], a)
      | a :: b :: l =>
          let (r, x) := list_split_last l b in
            (opt :: a :: r, x)
    end.

  Lemma list_split_last_spec l :
    forall opt l' a', list_split_last l opt = (l', a') -> opt :: l = (l' ++ [a'])%list.
  Proof. revert l.
    refine (list_length_ind _). intros.
    destruct l; depelim H0.
    reflexivity.

    simpl in x.
    destruct l. depelim x.
    reflexivity.

    case_eq (list_split_last l a0); intros l'' a'' Heq.
    rewrite Heq in x.
    depelim x.
    simpl. repeat f_equal.
    apply (H l). simpl. auto.
    auto.
  Qed.

  Program
  Fixpoint list_elim_last (l : list A) {measure (length l)} : P l :=
    match l with
      | [] => Pnil
      | a :: [] => Papp_end [] a Pnil
      | a :: l =>
          let '(l', b) := list_split_last l a in
            Papp_end l' b (list_elim_last l')
    end.

  Next Obligation.
  Proof.
    symmetry in Heq_anonymous. apply list_split_last_spec in Heq_anonymous.
    destruct l'; simpl; auto. auto with arith.
    simpl in Heq_anonymous. inversion Heq_anonymous; subst.
    rewrite app_length. simpl; rewrite NPeano.Nat.add_1_r. auto with datatypes arith.
  Qed.

  Next Obligation.
  Proof.
    symmetry in Heq_anonymous. apply list_split_last_spec in Heq_anonymous. auto.
  Qed.

End ListLastInd.

Lemma app_comm_cons' : forall A (x y:list A) (a:A), x ++ a :: y = (x ++ [a]) ++ y.
Proof. induction x; simpl; intros; auto. now rewrite IHx. Qed.


(** * RecordSub: Subtyping with Records *)

(** In this chapter, we combine two significant extensions of the pure
    STLC -- records (from chapter [Records]) and subtyping (from
    chapter [Sub]) -- and explore their interactions.  Most of the
    concepts have already been discussed in those chapters, so the
    presentation here is somewhat terse.  We just comment where things
    are nonstandard. *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.

Module RecordSub.

(* ################################################################# *)
(** * Core Definitions *)

(* ----------------------------------------------------------------- *)
(** *** Syntax *)

Inductive ty : Type :=
  (* proper types *)
  | Ty_Top   : ty
  | Ty_Base  : string -> ty
  | Ty_Arrow : ty -> ty -> ty
  (* record types *)
  | Ty_RNil : ty
  | Ty_RCons : string -> ty -> ty -> ty.

Inductive tm : Type :=
  (* proper terms *)
  | tm_var : string -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : string -> ty -> tm -> tm
  | tm_rproj : tm -> string -> tm
  (* record terms *)
  | tm_rnil :  tm
  | tm_rcons : string -> tm -> tm -> tm.

Declare Custom Entry stlc.
Declare Custom Entry stlc_ty.

Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "<{{ e }}>" := e (e custom stlc_ty at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "( x )" := x (in custom stlc_ty, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "x" := x (in custom stlc_ty at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc_ty at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc_ty at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.

Notation "{ x }" := x (in custom stlc at level 1, x constr).

Notation "'Base' x" := (Ty_Base x) (in custom stlc_ty at level 0).

Notation "  l ':' t1  '::' t2" := (Ty_RCons l t1 t2) (in custom stlc_ty at level 3, right associativity).
Notation " l := e1 '::' e2" := (tm_rcons l e1 e2) (in custom stlc at level 3, right associativity).
Notation "'nil'" := (Ty_RNil) (in custom stlc_ty).
Notation "'nil'" := (tm_rnil) (in custom stlc).
Notation "o --> l" := (tm_rproj o l) (in custom stlc at level 0).

Notation "'Top'" := (Ty_Top) (in custom stlc_ty at level 0).

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** The syntax of terms and types is a bit too loose, in the sense
    that it admits things like a record type whose final "tail" is
    [Top] or some arrow type rather than [Nil].  To avoid such cases,
    it is useful to assume that all the record types and terms that we
    see will obey some simple well-formedness conditions.

    [An interesting technical question is whether the basic properties
    of the system -- progress and preservation -- remain true if we
    drop these conditions.  I believe they do, and I would encourage
    motivated readers to try to check this by dropping the conditions
    from the definitions of typing and subtyping and adjusting the
    proofs in the rest of the chapter accordingly.  This is not a
    trivial exercise (or I'd have done it!), but it should not involve
    changing the basic structure of the proofs.  If someone does do
    it, please let me know. --BCP 5/16.] *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty <{{ nil }}>
  | RTcons : forall i T1 T2,
        record_ty <{{ i : T1 :: T2 }}>.

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm <{ nil }>
  | rtcons : forall i t1 t2,
        record_tm <{ i := t1 :: t2 }>.

Inductive well_formed_ty : ty -> Prop :=
  |  wfTop :
        well_formed_ty <{{ Top }}>
  | wfBase : forall (i : string),
        well_formed_ty <{{ Base i }}>
  | wfArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty <{{ T1 -> T2 }}>
  | wfRNil :
        well_formed_ty <{{ nil }}>
  | wfRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty <{{ i : T1 :: T2 }}>.

Hint Constructors record_ty record_tm well_formed_ty : core.

(* ----------------------------------------------------------------- *)
(** *** Substitution *)

(** Substitution and reduction are as before. *)

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | tm_var y =>
      if eqb_string x y then s else t
  | <{\y:T, t1}> =>
      if eqb_string x y then t else <{\y:T, [x:=s] t1}>
  | <{t1 t2}> =>
      <{([x:=s] t1) ([x:=s] t2)}>
  | <{ t1 --> i }> =>
      <{ ( [x := s] t1) --> i }>
  | <{ nil }> =>
      <{ nil }>
  | <{ i := t1 :: tr }> =>
     <{ i :=  [x := s] t1 :: ( [x := s] tr) }>
  end

where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc).

(* ----------------------------------------------------------------- *)
(** *** Reduction *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T2 t1,
      value  <{ \ x : T2, t1 }>
  | v_rnil : value <{ nil }>
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value <{ i := v1 :: vr }>.

Hint Constructors value : core.

Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
  match Tr with
  | <{{ i' : T :: Tr' }}> =>
      if eqb_string i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:string) (tr:tm) : option tm :=
  match tr with
  | <{ i' := t :: tr' }> =>
      if eqb_string i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t '-->' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2,
         value v2 ->
         <{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }>
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 t2}> --> <{t1' t2}>
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 t2}> --> <{v1  t2'}>
  | ST_Proj1 : forall t1 t1' i,
        t1 --> t1' ->
        <{ t1 --> i }> --> <{ t1' --> i }>
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        <{ tr --> i }> --> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 --> t1' ->
        <{ i := t1 :: tr2 }> --> <{ i := t1' :: tr2 }>
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 --> tr2' ->
        <{ i := v1 :: tr2 }> --> <{ i := v1 :: tr2' }>

where "t '-->' t'" := (step t t').

Hint Constructors step : core.

(* ################################################################# *)
(** * Subtyping *)

(** Now we come to the interesting part, where the features we've
    added start to interact.  We begin by defining the subtyping
    relation and developing some of its important technical
    properties. *)

(* ================================================================= *)
(** ** Definition *)

(** The definition of subtyping is essentially just what we sketched
    in the discussion of record subtyping in chapter [Sub], but we
    need to add well-formedness side conditions to some of the rules.
    Also, we replace the "n-ary" width, depth, and permutation
    subtyping rules by binary rules that deal with just the first
    field. *)

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    T <: T
  | S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
  | S_Top : forall S,
    well_formed_ty S ->
    S <: <{{ Top }}>
  | S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    <{{ S1 -> S2 }}> <: <{{ T1 -> T2 }}>
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty <{{ i : T1 :: T2 }}> ->
    <{{ i : T1 :: T2 }}> <: <{{ nil }}>
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    S1 <: T1 ->
    Sr2 <: Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    <{{ i : S1 :: Sr2 }}> <: <{{ i : T1 :: Tr2 }}>
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty <{{ i1 : T1 :: i2 : T2 :: Tr3 }}> ->
    i1 <> i2 ->
       <{{ i1 : T1 :: i2 : T2 :: Tr3 }}>
    <: <{{ i2 : T2 :: i1 : T1 :: Tr3 }}>

where "T '<:' U" := (subtype T U).

Hint Constructors subtype : core.

(* ================================================================= *)
(** ** Examples *)

Module Examples.
Open Scope string_scope.

Notation x := "x".
Notation y := "y".
Notation z := "z".
Notation j := "j".
Notation k := "k".
Notation i := "i".
Notation A := <{{ Base "A" }}>.
Notation B := <{{ Base "B" }}>.
Notation C := <{{ Base "C" }}>.

Definition TRcd_j  :=
  <{{ j  : (B -> B) :: nil }}>.     (* {j:B->B} *)
Definition TRcd_kj :=
  <{{ k : (A -> A) :: TRcd_j }}>.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  <{{ C -> TRcd_kj }}> <: <{{ C -> nil }}>.
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get full
    benefit, make sure you also understand how to prove them on
    paper! *)

(** **** Exercise: 2 stars, standard (subtyping_example_1)  *)
Example subtyping_example_1 :
  TRcd_kj <: TRcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  unfold TRcd_kj.
  unfold TRcd_j.

  eapply S_Trans.
  apply S_RcdPerm; auto. easy.

  apply S_RcdDepth; auto.
Qed.

(** [] *)

(** **** Exercise: 1 star, standard (subtyping_example_2)  *)
Example subtyping_example_2 :
  <{{ Top -> TRcd_kj }}> <:
          <{{ (C -> C) -> TRcd_j }}>.
Proof with eauto.
  apply S_Arrow.
  auto.
  apply subtyping_example_1.
Qed.
(** [] *)

(** **** Exercise: 1 star, standard (subtyping_example_3)  *)
Example subtyping_example_3 :
  <{{ nil -> (j : A :: nil) }}> <:
          <{{ (k : B :: nil) -> nil }}>.
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  auto.
Qed.

(** **** Exercise: 2 stars, standard (subtyping_example_4)  *)
Example subtyping_example_4 :
  <{{ x : A :: y : B :: z : C :: nil }}> <:
  <{{ z : C :: y : B :: x : A :: nil }}>.
Proof with eauto.
  eapply S_Trans.
  apply S_RcdPerm... easy.

  eapply S_Trans.
  apply S_RcdDepth.
  apply S_Refl. auto.
  apply S_RcdPerm. auto. easy.
  auto.
  auto.

  eapply S_RcdPerm... easy.
Qed.
(** [] *)

End Examples.

(* ================================================================= *)
(** ** Properties of Subtyping *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** To get started proving things about subtyping, we need a couple of
    technical lemmas that intuitively (1) allow us to extract the
    well-formedness assumptions embedded in subtyping derivations
    and (2) record the fact that fields of well-formed record types
    are themselves well-formed types.  *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  induction Hsub;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  - (* S_RcdPerm *)
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve_by_invert.
  - (* RCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (eqb_string i s)...  inversion H0; subst...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

(** The record matching lemmas get a little more complicated in the
    presence of subtyping, for two reasons.  First, record types no
    longer necessarily describe the exact structure of the
    corresponding terms.  And second, reasoning by induction on typing
    derivations becomes harder in general, because typing is no longer
    syntax directed. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  induction Hsub; intros Ti Hget;
    try solve_by_invert.
  - (* S_Refl *)
    exists Ti...
  - (* S_Trans *)
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  - (* S_RcdDepth *)
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (eqb_string i k)...
    + (* i = k -- we're looking up the first field *)
      inversion Hget. subst. exists S1...
  - (* S_RcdPerm *)
    exists Ti. split.
    + (* lookup *)
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (eqb_stringP i i1)...
      * (* i = i1 -- we're looking up the first field *)
        destruct (eqb_stringP i i2)...
        (* i = i2 -- contradictory *)
        destruct H0.
        subst...
    + (* subtype *)
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars, standard (rcd_types_match_informal)

    Write a careful informal proof of the [rcd_types_match]
    lemma. *)

(*

We want to prove that if a record type S is the subtype of record type
T, then every field in T has a subtype as the field in S.

We prove this by induction on the fact that [S <: T]. Most of the
cases are trivial to prove, we will focus on those recursive cases.

- In case where S <: U <: T for some U, By hypothesis, T include a
  field i of type Ti, by the two IHs, U includes a field i of type Ui
  and thus S includes field i of type Si.

  Also by the IHs, Ui <: Ti and Si <: Ui, thus Si <: Ti.

- In case where S and T both have an extra field k, the field's type
  satisfies Sk <: Tk and the rest of the fields Sr <: Tr.

  We do a case analysis on k = i:

  + when k = i, then we already have this field (Sk) and have Sk <: Tk.
  + when k <> i, by IH, there is some i in Sr that satisfies the conditions.

- In case where S and T both have two permuted fields i1 and i2 of the same
  type T1 and T2. By IH, T has field i of type Ti. We will find the same Ti
  in S.

  We do a case analysis on i:

  + when i = i1, then Ti = T1. Because S have {i1 : T1}, therefore S contains i2.
  + when i = i2, then Ti = T2. Because S have {i2 : T2}, therefore S contains i2.
  + when i <> i1 and i <> i2, then {i:Ti} must be found in Tr.
    because S also contains Tr, thus S can also find field i of type Ti.

  In all cases, the type we found Ti is always a subtype of Ti by Sub_Refl.
Qed.
 *)

(* Do not modify the following line: *)
Definition manual_grade_for_rcd_types_match_informal : option (nat*string) := None.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, standard, optional (sub_inversion_arrow)  *)
Lemma sub_inversion_arrow : forall U V1 V2,
     U <: <{{ V1 -> V2 }}> ->
     exists U1 U2,
       (U= <{{ U1 -> U2 }}> ) /\ (V1 <: U1) /\ (U2 <: V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember <{{ V1 -> V2 }}> as V.
  generalize dependent V2. generalize dependent V1.
  induction Hs; intros; try solve_by_invert; subst.

  - inversion H; subst.
    exists V1. exists V2. eauto.

  - edestruct IHHs2... destruct H. destruct H. destruct H0. subst.
    edestruct IHHs1... destruct H. destruct H. destruct H2. subst.
    clear IHHs2. clear IHHs1.
    exists x1. exists x2. split...

  - inversion HeqV; subst. eauto.
Qed.

(** [] *)

(* ################################################################# *)
(** * Typing *)

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40,
                                          t custom stlc at level 99, T custom stlc_ty at level 0).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma (x : string) T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      (x |-> T11; Gamma) |- t12 \in T12 ->
      Gamma |- (\ x : T11, t12) \in (T11 -> T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (T1 -> T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- t1 t2 \in T2
  | T_Proj : forall Gamma i t T Ti,
      Gamma |- t \in T ->
      Tlookup i T = Some Ti ->
      Gamma |- t --> i \in Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      subtype S T ->
      Gamma |- t \in T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      Gamma |- nil \in nil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- i := t :: tr \in (i : T :: Tr)

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type : core.

(* ================================================================= *)
(** ** Typing Examples *)

Module Examples2.
Import Examples.

(** **** Exercise: 1 star, standard (typing_example_0)  *)
Definition trcd_kj :=
  <{ k := (\z : A, z) :: j := (\z : B, z) :: nil }>.

Example typing_example_0 :
  empty |- trcd_kj \in TRcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof.
  unfold trcd_kj.
  unfold TRcd_kj.
  eapply T_Sub.

  apply T_RCons; auto.
  apply T_Abs; auto.
  apply T_Var; auto. unfold update. rewrite t_update_eq. reflexivity.

  apply T_RCons; auto.
  apply T_Abs; auto.
  apply T_Var; auto. unfold update. rewrite t_update_eq. reflexivity.

  apply S_RcdDepth; unfold TRcd_j; auto.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard (typing_example_1)  *)
Example typing_example_1 :
  empty |- (\x : TRcd_j, x --> j) trcd_kj \in (B -> B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j)
              {k=(\z:A.z), j=(\z:B.z)}
         : B->B *)
Proof with eauto.
  unfold TRcd_j.
  unfold trcd_kj.

  econstructor.
  constructor; auto.
  econstructor.
  constructor.
  unfold update; rewrite t_update_eq. auto. auto. auto.

  eapply T_Sub. constructor; auto.
  apply T_Abs; auto; apply T_Var; auto; unfold update; rewrite t_update_eq; auto.
  constructor; auto.
  apply T_Abs; auto; apply T_Var; auto; unfold update; rewrite t_update_eq; auto.

  eapply S_Trans.
  eapply S_RcdPerm; auto. easy.
  apply S_RcdDepth; auto.
Qed.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (typing_example_2)  *)
Example typing_example_2 :
  empty |- (\ z : (C -> C) -> TRcd_j, (z (\ x : C, x) ) --> j )
            ( \z : (C -> C), trcd_kj ) \in (B -> B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto.
  unfold TRcd_j.
  unfold trcd_kj.

  econstructor.
  constructor. auto.
  econstructor.
  econstructor.
  apply T_Var. constructor. auto.
  apply T_Abs; auto; apply T_Var; auto; unfold update; rewrite t_update_eq; auto.
  constructor.
  constructor.
  auto.

  eapply T_Sub.
  repeat constructor.
  eapply S_Trans.
  eapply S_RcdPerm; auto. easy.
  apply S_RcdDepth; auto.
Qed.

(** [] *)

End Examples2.

(* ================================================================= *)
(** ** Properties of Typing *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
  - (* T_Sub *)
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr --> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  empty |- v \in T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ empty |- vi \in Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. generalize dependent Ti.
  induction Htyp; intros; subst; try solve_by_invert.
  - (* T_Sub *)
    apply (rcd_types_match S) in H0...
    destruct H0 as [Si [HgetSi Hsub]].
    eapply IHHtyp in HgetSi...
    destruct HgetSi as [vi [Hget Htyvi]]...
  - (* T_RCons *)
    simpl in H0. simpl. simpl in H1.
    destruct (eqb_string i i0).
    + (* i is first *)
      injection H1 as H1. subst. exists t...
    + (* i in tail *)
      eapply IHHtyp2 in H1...
      inversion Hval...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Progress *)

(** **** Exercise: 3 stars, standard (canonical_forms_of_arrow_types)  *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     Gamma |- s \in (T1 -> T2) ->
     value s ->
     exists x S1 s2,
        s = <{ \ x  : S1, s2 }>.
Proof with eauto.
  intros.
  generalize dependent H0.
  remember <{{T1 -> T2}}> as V.
  generalize dependent HeqV.
  generalize dependent T1.
  generalize dependent T2.
  induction H; intros T1' T2' HeqV; intros; subst; eauto;
    try solve_by_invert.

  apply sub_inversion_arrow in H0.
  destruct H0. destruct H0. destruct H0. destruct H2.
  eauto.
Qed.

(** [] *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t --> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht;
    intros HeqGamma; subst...
  - (* T_Var *)
    inversion H.
  - (* T_App *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists <{ [x:=t2] t12 }>...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists <{ t1 t2' }> ...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists <{ t1' t2 }>...
  - (* T_Proj *)
    right. destruct IHHt...
    + (* rcd is value *)
      destruct (lookup_field_in_value t T i Ti)
        as [t' [Hget Ht']]...
    + (* rcd_steps *)
      destruct H0 as [t' Hstp]. exists <{ t' --> i }>...
  - (* T_RCons *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2...
      * (* tail steps *)
        right. destruct H2 as [tr' Hstp].
        exists <{ i := t :: tr' }>...
    + (* head steps *)
      right. destruct H1 as [t' Hstp].
      exists <{ i := t' :: tr}>...  Qed.

(** _Theorem_ : For any term [t] and type [T], if [empty |- t : T]
    then [t] is a value or [t --> t'] for some term [t'].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We
    proceed by induction on the given typing derivation.

      - The cases where the last step in the typing derivation is
        [T_Abs] or [T_RNil] are immediate because abstractions and
        [{}] are always values.  The case for [T_Var] is vacuous
        because variables cannot be typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that [t =
        t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 :
        T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.

        - Suppose [t1 --> t1'] for some term [t1'].  Then [t1 t2 -->
          t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 --> t2'] for some term [t2'].  Then [t1 t2 -->
            t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By Lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for
            some [x], [S1], and [s2].  But then [(\x:S1.s2) t2 -->
            [x:=t2]s2] by [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        are a term [tr], a type [Tr], and a label [i] such that [t =
        tr.i], [empty |- tr : Tr], and [Tlookup i Tr = Some T].

        By the IH, either [tr] is a value or it steps.  If [tr -->
        tr'] for some term [tr'], then [tr.i --> tr'.i] by rule
        [ST_Proj1].

        If [tr] is a value, then Lemma [lookup_field_in_value] yields
        that there is a term [ti] such that [tlookup i tr = Some ti].
        It follows that [tr.i --> ti] by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then
        there exist some terms [t1] [tr], types [T1 Tr] and a label
        [t] such that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_ty
        tr], [record_tm Tr], [empty |- t1 : T1] and [empty |- tr :
        Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 --> t1'] for some term [t1'].  Then [{i=t1, tr}
          --> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr --> tr'] for some term [tr'].  Then [{i=t1,
            tr} --> {i=t1, tr'}] by rule [ST_Rcd_Tail], since [t1] is
            a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemma *)

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     Gamma |- \ x : S1, t2 \in T ->
     (exists S2, <{{ S1 -> S2 }}> <: T
              /\ (x |-> S1; Gamma) |- t2 \in S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember <{ \ x : S1, t2 }> as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  - (* T_Abs *)
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  - (* T_Sub *)
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  empty |- \x : S1, s2 \in (T1 -> T2) ->
     T1 <: S1
  /\ (x |-> S1) |- s2 \in T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

(* ================================================================= *)
(** ** Weakening *)

(** The weakening lemma is proved as in pure STLC. *)

Lemma weakening : forall Gamma Gamma' t T,
     inclusion Gamma Gamma' ->
     Gamma  |- t \in T  ->
     Gamma' |- t \in T.
Proof.
  intros Gamma Gamma' t T H Ht.
  generalize dependent Gamma'.
  induction Ht; eauto using inclusion_update.
Qed.

Lemma weakening_empty : forall Gamma t T,
     empty |- t \in T  ->
     Gamma |- t \in T.
Proof.
  intros Gamma t T.
  eapply weakening.
  discriminate.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Preservation *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
   (x |-> U ; Gamma) |- t \in T ->
   empty |- v \in U   ->
   Gamma |- [x:=v]t \in T.
Proof.
Proof.
  intros Gamma x U t v T Ht Hv.
  remember (x |-> U; Gamma) as Gamma'.
  generalize dependent Gamma.
  induction Ht; intros Gamma' G; simpl; eauto.
  - (* T_Var *)
    rename x0 into y.
    destruct (eqb_stringP x y) as [Hxy|Hxy]; subst.
    + (* x = y *)
      rewrite update_eq in H.
      injection H as H. subst.
      apply weakening_empty. assumption.
    + (* x<>y *)
      apply T_Var; [|assumption].
      rewrite update_neq in H; assumption.
  - (* T_Abs *)
    rename x0 into y. subst.
    destruct (eqb_stringP x y) as [Hxy|Hxy]; apply T_Abs; try assumption.
    + (* x=y *)
      subst. rewrite update_shadow in Ht. assumption.
    + (* x <> y *)
      subst. apply IHHt.
      rewrite update_permute; auto.
      - (* rcons *)   (* <=== only new case compared to pure STLC *)
      apply T_RCons; eauto.
      inversion H0; subst; simpl; auto.
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t --> t'  ->
     empty |- t' \in T.
Proof with eauto.
  intros t t' T HT. generalize dependent t'.
  remember empty as Gamma.
  induction HT;
       intros t' HE; subst;
       try solve [inversion HE; subst; eauto].
  - (* T_App *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T0...
  - (* T_Proj *)
    inversion HE; subst...
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    inversion HE; subst...
    eauto using step_preserves_record_tm.  Qed.

(** _Theorem_: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t --> t'], then [empty |- t' : T].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and [{}] don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [Tlookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr --> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr --> i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tlookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = i:=t1 :: tr}], [T = i:T1 :: Tr], [record_ty tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)

End RecordSub.

(* 2020-09-09 21:08 *)


Require Export Unicode.Utf8_core.
Require Import String List.
Require Export Showable PartialOrder TErrorMonad Connection HoTT Decidable DepEquivAnti.

Notation "x .1" := (projT1 x) (at level 3).
Notation "x .2" := (projT2 x) (at level 3).
Notation " ( x ; p ) " := (existT _ x p).
Notation "{ x : A & P }" := (sigT_HSet A (fun x => P)) : type_scope.

Local Open Scope string_scope.

Set Universe Polymorphism.

(** * Dependent equivalences *)

(**

A _simple_ type is an inhabitant of [Type], e.g. [A: Type], [A → B: Type].

A _rich_ type is a dependent pair, e.g. [{ a : A | B a}].

A _dependent_ type is a type family [A → Type] indexed by some type
[A], e.g. [C: nat → Type], [C (S n) → C n].

  We define the following family of cast operators:
  - [to_rich]: from [A] to [{a: A & P a}]
  - [to_dep]: from [A] to [B a]
  - [to_simp]: from [B a] to [A]

   We don't provide an explicit [rich_to_simpl], since this is just [projT1]
*)

(**

  A dependent equivalence between [B : A -> Type] and [C : Type] is
  witnessed by a (proof-irrelevant) predicate [P : A -> C -> Type]
  such that [B] and [{C & P}] are equivalent while [{C & P}] and [C]
  are partially equivalent. It also a partial index synthesis function
  [c_to_a], which tries to compute an index from a computational
  element [C].

*)

(* =DepEquiv= *)
Class DepConnection (A: HSet) (B: A -> HSet) (C: HSet) := {
    P: A -> C -> HProp;
    total_equiv:> forall a, B a ≃ {c: C & P a c};
    partial_equiv:> forall a, {c: C & P a c} ≲K C;
    c_to_a: C ⇀ A;
    prop_c_to_a: forall a (b: B a), c_to_a °° ((partial_equiv a).(pc_fun))
                                  ((total_equiv a).(e_fun) b) = Some a;
}.
Notation "B ≲K□ C" := (DepConnection _ B C)
(* =end= *)
                      (at level 50).

Hint Extern 1 (IsEquiv ?f) => apply (e_isequiv (e := total_equiv _)) :
             typeclass_instances.

Hint Extern 1 (IsConnectionK ?f) => apply (pc_isconn (c := partial_equiv _)) :
                                      typeclass_instances.

(* Connection between coercion and anticoercion *)

Instance DepConnection_DepAnticonnection (A: HSet) (B: A -> HSet) (C: HSet)
  (H : B ≲K□ C) : B ≈K□ C.
Proof.
  unshelve econstructor.
  - exact P.
  - exact total_equiv.
  - intro a. apply Connection_Anticonnection. exact (partial_equiv a).
  - exact c_to_a.
  - exact prop_c_to_a.
Defined.

Instance DepAnticonnection_DepConnection (A: HSet) (B: A -> HSet) (C: HSet)
  (H : B ≈K□ C) (H' : forall a, creturn ≼ (apc_inv (apc_fun (a_partial_equiv a))) °° (apc_fun (a_partial_equiv a))) : B ≲K□ C.
Proof.
  unshelve econstructor.
  - exact a_P.
  - exact a_total_equiv.
  - intro a. unshelve eapply Anticonnection_Connection. exact (a_partial_equiv a).
    exact (H' a).
  - exact a_c_to_a.
  - exact a_prop_c_to_a.
Defined.

Program
(* =DepEquiv_PartialEquivK= *)
Definition DepConnection_ConnectionK  (A: HSet) (B: A -> HSet)
         (C: HSet) `{B ≲K□ C} (a: A): B a ≲K C :=
  {|  pc_fun := to_simpl;
      pc_isconn := {| pc_inv := to_dep a|} |}.
(* =end= *)
Next Obligation.
  - rename a0 into b. change (creturn b ≼ (to_dep a) °° to_simpl b). unfold kleisliComp, compose.
    unfold to_dep, to_rich, to_simpl, compose in *.
    assert (f := pc_sect (IsConnectionK := pc_isconn (c := partial_equiv a)) _ (b_to_c b)).
    unfold kleisliComp in f.
    revert f. unfold b_to_c, compose.
    apply sub_eq_implies_op. intro c.
    apply sub_eq_implies_op_simpl. intro x.
    intro e. pose (ap (e_inv _) (Some_inj e)). apply (ap (@Some _ _)).
    pose (e_sect (IsEquiv := e_isequiv (e := total_equiv a)) _ b).
    refine (e1 ^ @ e0).
Defined.
Next Obligation.
    rename a0 into c. unfold kleisliComp.
    unfold to_dep, to_rich in *.
    unfold to_simpl, clift, compose.
    assert (f := pc_retr (IsConnectionK := pc_isconn (c := partial_equiv a)) _ c).
    unfold kleisliComp in f.
    revert f. apply sub_eq_implies_complex. intros s e.
    pose (e_retr (IsEquiv := e_isequiv (e := total_equiv a)) _ s).
    unfold compose in e0. simpl in *.
    simpl.
    rewrite e0. exact e.
Defined.

(** ** Casts for non-dependent functions *)

Definition
(* =IsDepEquiv= *)
DepConnection_hset (A: HSet) (B: A -> HSet) (C: HSet) P
  `{forall a c, Decidable (P a c)}
  (b_to_c: forall a, B a -> {c: C & P a c}) (c_to_b: forall a, {c: C & P a c} -> B a) (c_to_a: C ⇀ A):
  (forall a, (c_to_b a) ° (b_to_c a) == id ) -> (forall a, (b_to_c a) ° (c_to_b a) == id) ->
  (forall a (b: B a), c_to_a (b_to_c a b).1 = Some a) -> B ≲K□ C.
(* =end= *)
Proof.
  intros prop_b_to_b prop_c_to_c prop_c_to_a.
  unshelve  eapply DepAnticonnection_DepConnection.
  eapply IsDepAnticonnection; eauto. intros;  apply decidable_is_checkable, H.
  intros a c.
  exact (@pc_sect _ _ _ (@pc_isconn _ _ (Decidable_ConnectionK C (P a))) c).
Defined.

(** Given a relation [R : TError A -> A -> Type], one can automatically
construct a partial type equivalence between [B: A → Type] and [C:
Type] as long as we can recompute the index from an inhabitant of
[C]. This is the role of the function [c_to_a_rel]. *)

Definition DepConnection_rel {A:HSet} {B: A -> HSet} {C:HSet} (R : TError A info_str -> A -> HProp)
   (c_to_a_rel : C ⇀ A)
   (P := fun a c => R (c_to_a_rel c) a)
   (b_to_c_rel : forall a, B a -> {c : C & P a c})
   (c_to_b_rel : forall a, {c : C & P a c} -> B a)
   (prop_b_to_b_rel : forall a, (c_to_b_rel a) ° (b_to_c_rel a) == id)
   (prop_c_to_c_rel : forall a, (b_to_c_rel a) ° (c_to_b_rel a) == id)
   {DepEquiv_check_rel : forall a a', Decidable (R a a')}
   {HSet_C : IsHSet C}
   (prop_c_to_a_R : forall a (b:B a), c_to_a_rel (b_to_c_rel _ b).1 = Some a) :
  B ≲K□ C.
Proof.
  unshelve  eapply DepAnticonnection_DepConnection.
  eapply Anticonnection_rel; eauto. intros;  apply decidable_is_checkable, DepEquiv_check_rel.
  intros a c.
  exact (@pc_sect _ _ _ (@pc_isconn _ _ (Decidable_ConnectionK C (P a))) c).
Defined.

(** A particular case of the above scenario consists in taking
equality (which is likely to decidable, so as to be in hprop) on
[A]. *)

Definition DepConnection_eq {A : HSet} (B: A -> HSet) (C:HSet)
   {DecidablePaths_A : DecidablePaths A}
   (c_to_a_eq : C ⇀ A)
   (P := fun a c => hprop (c_to_a_eq c = Some a))
   (b_to_c_eq : forall a, B a -> {c : C & P a c})
   (c_to_b_eq : forall a, {c : C & P a c} -> B a)
   {prop_b_to_b_eq : forall a, (c_to_b_eq a) ° (b_to_c_eq a) == id}
   {prop_c_to_c_eq : forall a, (b_to_c_eq a) ° (c_to_b_eq a) == id}
   {prop_c_to_a_eq : forall a (b:B a), c_to_a_eq (b_to_c_eq _ b).1 = Some a} :
  B ≲K□ C :=
  DepConnection_rel (fun c a => hprop (c = Some a))
              c_to_a_eq b_to_c_eq c_to_b_eq prop_b_to_b_eq prop_c_to_c_eq
 (fun a b => prop_c_to_a_eq a b) (DepEquiv_check_rel := fun a c => DecidablePaths_DecidableProp (DecidablePaths_TError _ _) a (Some c)).


From Coq Require Import ProofIrrelevance.
From Coq Require Import String.
From Coq Require Import NArith.NArith.
From Coq Require Import ZArith.ZArith.

Class EqualDec A :=
  equal : forall x y : A, { x = y } + { x <> y }.

Module EqualDecNotation.
  Infix "==" := (equal) (no associativity, at level 70).
End EqualDecNotation.

(* For unit, an explicit definition has better computational behavior.
Specifically it is syntactically a [left], so any matches on [u == u']
automatically reduce to the true case; [decide equality] would first destruct
the arguments before producing [left]. *)
Global Instance unit_equal_dec : EqualDec unit :=
  fun x y => left (match x, y with
                | tt, tt => eq_refl
                end).

Global Hint Extern 2 (EqualDec _) => hnf; repeat (decide equality) : typeclass_instances.

Global Instance nat_equal_dec : EqualDec nat := _.
Global Instance bool_equal_dec : EqualDec bool := _.
Global Instance positive_equal_dec : EqualDec positive := _.
Global Instance N_equal_dec : EqualDec N := _.
Global Instance Z_equal_dec : EqualDec Z := _.

Global Instance sigT_eq_dec A (P: A -> Prop) (dec:EqualDec A) : EqualDec (sig P).
Proof.
  hnf; intros.
  destruct x as [x ?], y as [y ?].
  destruct (equal x y); subst; [ left | right ].
  - f_equal.
    apply proof_irrelevance.
  - intro.
    inversion H; congruence.
Qed.

Definition ascii_cmp (x y: Ascii.ascii) : bool :=
  match x, y with
  | Ascii.Ascii x0 x1 x2 x3 x4 x5 x6 x7,
    Ascii.Ascii y0 y1 y2 y3 y4 y5 y6 y7 =>
    Bool.eqb x0 y0 &&
             Bool.eqb x1 y1 &&
             Bool.eqb x2 y2 &&
             Bool.eqb x3 y3 &&
             Bool.eqb x4 y4 &&
             Bool.eqb x5 y5 &&
             Bool.eqb x6 y6 &&
             Bool.eqb x7 y7
  end.

Local Theorem eqb_spec b1 b2 : {Bool.eqb b1 b2 = true /\ b1 = b2} +
                         {Bool.eqb b1 b2 = false /\ b1 <> b2}.
Proof.
  destruct b1, b2; simpl; auto.
  right; (intuition idtac); congruence.
Qed.

Local Ltac checkeq b1 b2 :=
  let Heqb := fresh "Heqb" in
  let Hb := fresh "Hb" in
  destruct (eqb_spec b1 b2) as [ (Heqb & Hb) | (Heqb & Hb) ];
  rewrite Heqb; simpl; clear Heqb;
  [ | inversion 1; congruence ].

Theorem ascii_cmp_ok : forall x y,
    if ascii_cmp x y then x = y else x <> y.
Proof.
  destruct x as [x0 x1 x2 x3 x4 x5 x6 x7], y as [y0 y1 y2 y3 y4 y5 y6 y7];
    simpl.
  checkeq x0 y0.
  checkeq x1 y1.
  checkeq x2 y2.
  checkeq x3 y3.
  checkeq x4 y4.
  checkeq x5 y5.
  checkeq x6 y6.
  checkeq x7 y7.
  simpl; f_equal; auto.
Qed.

Global Instance ascii_eq_dec : EqualDec Ascii.ascii.
Proof.
  hnf; intros.
  pose proof (ascii_cmp_ok x y).
  destruct (ascii_cmp x y); auto.
Defined.

Global Instance string_eq_dec : EqualDec string.
Proof.
  hnf; decide equality.
  destruct (equal a a0); auto.
Defined.

Definition inj_eq_dec {A} {dec:EqualDec A}
           {B} (f: B -> A) (f_inj: forall x y, f x = f y -> x = y)
  : EqualDec B.
Proof.
  hnf; intros.
  destruct (equal (f x) (f y));
    [ left | right ].
  - auto.
  - now intros ->.
Defined.

Global Instance pair_eq_dec {A B}
           {decA:EqualDec A} {decB:EqualDec B} : EqualDec (A * B) := _.

Global Instance sum_eq_dec {A B}
           {decA:EqualDec A} {decB:EqualDec B} : EqualDec (A + B) := _.

Global Instance option_eq_dec {A} {dec:EqualDec A} : EqualDec (option A) := _.

Global Instance list_eq_dec {A} {dec:EqualDec A} : EqualDec (list A) := _.


(** * Category of [hSet]s

Started by: Benedikt Ahrens, Chris Kapulkin, Mike Shulman

January 2013

Extended by: Anders Mörtberg (October 2015)

*)

(** ** Contents:

- Category [HSET] of [hSet]s ([hset_category])
- Some particular HSETs
- Hom functors

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.Foundations.UnivalenceAxiom.
Require Import UniMath.Foundations.NaturalNumbers.
Require Import UniMath.Foundations.HLevels.
Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.

Local Open Scope cat.

(** ** Category HSET of [hSet]s ([hset_category]) *)
Section HSET_precategory.

  Definition hset_precategory_ob_mor : precategory_ob_mor :=
    make_precategory_ob_mor
      hSet
      (λ A B : hSet, A -> B).

Definition hset_precategory_data : precategory_data :=
  make_precategory_data hset_precategory_ob_mor (fun (A:hSet) (x : A) => x)
     (fun (A B C : hSet) (f : A -> B) (g : B -> C) (x : A) => g (f x)).

Lemma is_precategory_hset_precategory_data :
  is_precategory hset_precategory_data.
Proof.
repeat split.
Qed.

Definition hset_precategory : precategory :=
  tpair _ _ is_precategory_hset_precategory_data.

Local Notation "'HSET'" := hset_precategory : cat.

Lemma has_homsets_HSET : has_homsets HSET.
Proof.
intros a b; apply isaset_set_fun_space.
Qed.

(*
  Canonical Structure hset_precategory. :-)
 *)

Definition hset_category : category := (HSET ,, has_homsets_HSET).

End HSET_precategory.

Notation "'HSET'" := hset_category : cat.
Notation "'SET'" := hset_category : cat.

(** ** Some particular HSETs *)

Definition emptyHSET : HSET.
Proof.
  exists empty.
  abstract (apply isasetempty).
Defined.

Definition unitHSET : HSET.
Proof.
  exists unit.
  abstract (apply isasetunit).
Defined.

Definition natHSET : HSET.
Proof.
  exists nat.
  abstract (apply isasetnat).
Defined.

(*Definition of HomFunctor for categories, analagous definition for precategories is in ../Type/Core*)
Section HomSetFunctors.

Context {C : category}.

Definition homSet_functor_data :
  functor_data (category_binproduct (C^op) C) hset_category.
Proof.
  use make_functor_data.
  + intros pair.
    induction pair as (p1, p2).
    use make_hSet.
    - exact (C ⟦ p1, p2 ⟧).
    - use (homset_property C).
  + intros x y fg h.
    induction fg as (fg1, fg2).
    cbn in fg1.
    exact (fg1 · h · fg2).
Defined.

Lemma is_functor_homSet_functor_type : is_functor homSet_functor_data.
Proof.
  use make_dirprod.
  - intro; cbn.
    apply funextsec; intro.
    refine (id_right _ @ _).
    apply id_left.
  - repeat intro.
    apply funextsec; intro; cbn.
    do 3 rewrite assoc.
    reflexivity.
Defined.

Definition homSet_functor : functor (category_binproduct (C^op) C) hset_category :=
  make_functor _ is_functor_homSet_functor_type.

Context (c : C).

Definition cov_homSet_functor : functor C hset_category :=
  functor_fix_fst_arg (C^op) _ _ homSet_functor c.

Definition contra_homSet_functor : functor (C^op) hset_category :=
  functor_fix_snd_arg (C^op) _ _ homSet_functor c.

End HomSetFunctors.


Require Import notations.

Set Implicit Arguments.
Set Strict Implicit.
Set Asymmetric Patterns.
Set Universe Polymorphism.
Set Printing Universes.

(** Core Type and Functions **)
Section hlist.
  Polymorphic Universe Ui Uv.

  Context {iT : Type@{Ui}}.
  Variable F : iT -> Type@{Uv}.

  Inductive hlist : list iT -> Type :=
  | Hnil  : hlist nil
  | Hcons : forall l ls, F l -> hlist ls -> hlist (l :: ls).

  Local Open Scope list_scope.

  Definition hlist_hd {a b} (hl : hlist (a :: b)) : F a :=
    match hl in hlist x return match x with
                               | nil => unit
                               | l :: _ => F l
                               end with
    | Hnil => tt
    | Hcons _ _ x _ => x
    end.

  Definition hlist_tl {a b} (hl : hlist (a :: b)) : hlist b :=
    match hl in hlist x return match x with
                                 | nil => unit
                                 | _ :: ls => hlist ls
                               end with
      | Hnil => tt
      | Hcons _ _ _ x => x
    end.

  Lemma hlist_eta : forall ls (h : hlist ls),
    h = match ls as ls return hlist ls -> hlist ls with
          | nil => fun _ => Hnil
          | a :: b => fun h => Hcons (hlist_hd h) (hlist_tl h)
        end h.
  Proof.
    intros. destruct h; auto.
  Qed.

  Fixpoint hlist_app ll lr (h : hlist ll) : hlist lr -> hlist (ll ++ lr) :=
    match h in hlist ll return hlist lr -> hlist (ll ++ lr) with
      | Hnil => fun x => x
      | Hcons _ _ hd tl => fun r => Hcons hd (hlist_app tl r)
    end.

End hlist.

Arguments Hnil {_ _}.
Arguments Hcons {_ _ _ _} _ _.

Eval compute in Hcons true  Hnil.

Section hlist.

Inductive hlist (A:Type): list A -> Type :=
| HNil : hlist A nil
| HCons : forall (x:A)(ls:list A), F x -> hlist A ls -> hlist A (x::ls).

(* Implicit Arguments hlist [A F]. *)
Implicit Arguments HCons [A F x ls].
Implicit Arguments HNil [A F].
Print hlist.

Open Scope list_scope.
Eval compute in HCons true HNil.

Definition someTypes : list Set := nat :: nil.
Example someValues : hlist (Set) (fun T : Set => T) someTypes :=
HCons 2 HNil.
Example someValues : hlist (Set) (fun T : Set => T) someTypes :=
HCons 2 (HCons true nil nil HNil).

Eval compute in HCons true  HNil.
Eval compute in HCons 2 (HCons true (HNil)).

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

Inductive hlist : list A -> Type :=
| HNil : hlist nil
| HCons : forall (x:A)(ls:list A), B x -> hlist ls -> hlist (x::ls).

Variable elm: A.

Inductive member : list A -> Type :=
| HFirst : forall ls, member (elm :: ls)
| HNext : forall x ls, member ls -> member (x :: ls).
Print HNil.
(*
Arguments HNil [A B].
Implicit Arguments HCons [ A B x ls ]. *)
Open Scope list_scope.

Print hlist.
Implicit Arguments hlist [A].

Definition someTypes : list Set := nat :: bool :: nil.
Example someValues : hlist (fun T : Set => T) someTypes.
Print HCons.

Implicit Arguments HCons [x ls (B x)].
Print HCons.

Definition test : nat -> nat := fun x => 2.

Eval compute in HCons test 2 (HCons true (HNil)).
Implicit Arguments HCons [A B x ls].

Example someValues : hlist someTypes := HCons 2 (HCons true (HNil)).
Eval compute in HCons 2 (HCons true (HNil)).

End hlist.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo107:
  prime  33594023621->
  prime  71824034781593.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      71824034781593
      2138
      ((33594023621,1)::nil)
      30513722420705
      0
      34112585734099
      68225171468199)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
Proof.  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    *
      rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      -
        rewrite 3 drop_Nil. reflexivity.
    * simpl. rewrite 2 drop_Nil. reflexivity.
  + intros. simpl. destruct (drop x1 l); reflexivity.
  + intros. simpl. destruct (drop x2 l); reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  +
    rewrite 2 drop_Cons_assoc. reflexivity.
  +
    lfind. Admitted.


(**
Derivation of a  signature (in order to build the signature Θ^(n) as we like it)
*)
Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.CategoryTheory.Monads.Derivative.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.terminal.

Require Import Modules.Prelims.lib.
Require Import Modules.Prelims.LModulesCoproducts.
Require Import Modules.Prelims.DerivationIsFunctorial.
Require Import Modules.Signatures.Signature.

Section DAr.

  Context {C : category}
          (bcpC : limits.bincoproducts.BinCoproducts C)
          (CT : limits.terminal.Terminal C).
Local Notation "∂" := (LModule_deriv_functor (TerminalObject CT) bcpC
                                              _).

Local Notation Signature := (signature C).
Local Notation MOD R := (category_LModule R C).

Variable (a : signature C).

  Definition signature_deriv_on_objects (R : Monad C) : LModule R C :=
    ∂ (a R).

  Definition signature_deriv_on_morphisms (R S : Monad C)
             (f : Monad_Mor R S) : LModule_Mor _ (signature_deriv_on_objects R)
                                               (pb_LModule f (signature_deriv_on_objects S)) :=
    (# ∂ (# a f)%ar ) · (inv_from_iso (pb_LModule_deriv_iso _ bcpC  f _ )).

  Definition signature_deriv_data : @signature_data C
    := signature_deriv_on_objects ,, signature_deriv_on_morphisms.

  Lemma signature_deriv_is_signature : is_signature signature_deriv_data.
  Proof.
    split.
    - intros R c.
      cbn -[LModule_deriv_functor identity].
      repeat rewrite id_right.
      etrans.
      {
        set (f := ((#a)%ar _)).
        eapply (maponpaths  (fun (z : LModule_Mor _ _ _) => (# ∂ z : LModule_Mor _ _ _) c )(t1 := f)
                            (t2 := morphism_from_iso (pb_LModule_id_iso _ ))
               ).
        apply LModule_Mor_equiv;[apply homset_property|].
        apply nat_trans_eq;[apply homset_property|].
        apply signature_id.
      }
      apply idpath.
    - intros R S T f g.
      etrans.
      {
      apply (cancel_postcomposition (C := MOD R)).
      rewrite signature_comp.
      apply functor_comp.
      }
      apply LModule_Mor_equiv;[apply homset_property|].
      apply nat_trans_eq;[apply homset_property|].
      intro x.
      cbn.
      repeat rewrite id_right.
      apply idpath.
  Qed.

  Definition signature_deriv : Signature := _ ,, signature_deriv_is_signature.

  Lemma signature_to_deriv_laws : is_signature_Mor a signature_deriv
                                                        (fun R => LModule_to_deriv CT bcpC  R (a R)).
  Proof.
    intros R S f.
    apply (nat_trans_eq (homset_property _)).
    intro c.
    cbn.
    repeat rewrite id_left.
    rewrite id_right.
    apply pathsinv0.
    apply nat_trans_ax.
  Qed.

  Definition signature_to_deriv : signature_Mor a signature_deriv := _ ,, signature_to_deriv_laws.

End DAr.

Fixpoint signature_deriv_n {C : category} bcp T a (n :nat) : signature C :=
  match n with
    0 => a
  | S m => @signature_deriv C bcp T (@signature_deriv_n C bcp T a m)
  end.


Require Import Coq.Classes.Morphisms.
Require Import VCF.KnasterTarski.
Require Import VCF.TraceGeneral.
Require Import VCF.InfSem.
Require Import VCF.SetsDomain.
Require Import VCF.FinTraceRelDomain.

Module iTrRel.

Definition concat
             {A B C finT infT}
             {finTr: Trace.FinTrace finT}
             {infTr: Trace.InfTrace finT infT}
             (d1: InfSem (A -> finT -> B -> Prop) (A -> infT -> Prop))
             (d2: InfSem (B -> finT -> C -> Prop) (B -> infT -> Prop)):
  InfSem (A -> finT -> C -> Prop) (A -> infT -> Prop) :=
{|
  fin_cases := TrRel.concat (fin_cases d1) (fin_cases d2);
  inf_cases := Sets.union (TrRel.dia (fin_cases d1) (inf_cases d2)) (inf_cases d1);
|}.

Definition id
             {A finT infT}
             {finTr: Trace.FinTrace finT}
             {infTr: Trace.InfTrace finT infT}
  : InfSem (A -> finT -> A -> Prop) (A -> infT -> Prop) :=
{|
  fin_cases := TrRel.id;
  inf_cases := Sets.empty;
|}.

Definition test
             {A finT infT}
             {finTr: Trace.FinTrace finT}
             {infTr: Trace.InfTrace finT infT}
             (X: A -> Prop) (tr0: finT)
  : InfSem (A -> finT -> A -> Prop) (A -> infT -> Prop) :=
{|
  fin_cases := TrRel.test X tr0;
  inf_cases := Sets.empty;
|}.

End iTrRel.

Lemma iTrRel_test_congr {A finT infT}
             {finTr: Trace.FinTrace finT}
             {infTr: Trace.InfTrace finT infT}:
  Proper (Sets.equiv ==> eq ==> Domain_R') (@iTrRel.test A finT infT _ _).
Proof.
  unfold Proper, respectful, iTrRel.test; unfold_SETS_tac no_extra_simplify.
  intros; constructor.
  + apply TrRel_test_congr; auto.
  + reflexivity.
Qed.

Lemma iTrRel_concat_congr {A B C finT infT}
             {finTr: Trace.FinTrace finT}
             {infTr: Trace.InfTrace finT infT}:
  Proper (Domain_R' ==> Domain_R' ==> Domain_R') (@iTrRel.concat A B C finT infT _ _).
Proof.
  unfold Proper, respectful, iTrRel.concat.
  intros.
  destruct H as [?H ?H], H0 as [?H ?H].
  constructor.
  + apply TrRel_concat_congr; auto.
  + apply Sets_union_congr; [apply TrRel_dia_congr |]; auto.
Qed.

Lemma iTrRel_concat_mono {A B C finT infT}
             {finTr: Trace.FinTrace finT}
             {infTr: Trace.InfTrace finT infT} a:
  Proper (Domain_R ==> Domain_R) (@iTrRel.concat A B C finT infT _ _ a).
Proof.
  unfold Proper, respectful, iTrRel.concat.
  intros.
  destruct H as [?H ?H].
  constructor.
  + apply TrRel_concat_mono; auto.
    reflexivity.
  + apply Sets_union_mono; [apply TrRel_dia_mono |]; auto;
    reflexivity.
Qed.

Lemma iTrRel_concat_id: forall  {A B finT infT}
             {finTr: Trace.FinTrace finT}
             {infTr: Trace.InfTrace finT infT}
             (r: InfSem (A -> finT -> B -> Prop) (A -> infT -> Prop)),
  Domain_R' (iTrRel.concat r iTrRel.id) r.
Proof.
  intros.
  constructor.
  + apply TrRel_concat_id.
  + rewrite <- (empty_union (inf_cases r)).
    apply Sets_union_congr; [| reflexivity].
    apply TrRel_dia_empty.
Qed.

Existing Instances iTrRel_test_congr
                   iTrRel_concat_congr
                   iTrRel_concat_mono.


Require Export CommaCategory Category.Product Functor.Product.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope functor_scope.
Local Open Scope category_scope.

Section CommaCategory.
  Variable A : PreCategory.
  Variable B : PreCategory.
  Variable C : PreCategory.
  Variable S : Functor A C.
  Variable T : Functor B C.

  Definition CommaCategoryProjection : Functor (S ↓ T) (A * B)
    := Build_Functor (S ↓ T) (A * B)
                     (fun abf => (CCO_a abf, CCO_b abf)%core)
                     (fun _ _ m => (CCM_g m, CCM_h m)%core)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).
End CommaCategory.

Section SliceCategory.
  Variable A : PreCategory.

  Local Arguments ComposeFunctors / .
  Local Arguments ComposeFunctors_FCompositionOf / .
  Local Arguments ComposeFunctors_FIdentityOf / .
  Local Arguments path_prod / .
  Local Arguments path_prod' / .
  Local Arguments path_prod_uncurried / .
  Local Transparent ComposeFunctors_FCompositionOf.
  Local Transparent ComposeFunctors_FIdentityOf.

  Definition ArrowCategoryProjection : Functor (ArrowCategory A) A
    := Eval simpl in fst_Functor ∘ CommaCategoryProjection _ (IdentityFunctor A).

  Definition SliceCategoryOverProjection (a : A) : Functor (A / a) A
    := Eval simpl in fst_Functor ∘ CommaCategoryProjection (IdentityFunctor A) _.

  Definition CosliceCategoryOverProjection (a : A) : Functor (a \ A) A
    := Eval simpl in snd_Functor ∘ CommaCategoryProjection _ (IdentityFunctor A).

  Section Slice_Coslice.
    Variable C : PreCategory.
    Variable a : C.
    Variable S : Functor A C.

    Definition SliceCategoryProjection : Functor (S ↓ a) A
      := Eval simpl in fst_Functor ∘ CommaCategoryProjection S (FunctorFromTerminal C a).

    Definition CosliceCategoryProjection : Functor (a ↓ S) A
      := Eval simpl in snd_Functor ∘ CommaCategoryProjection (FunctorFromTerminal C a) S.
  End Slice_Coslice.
End SliceCategory.


(** Authors:
 - Anthony Bordg, March-April 2017
 - Langston Barrett (@siddharthist), November-December 2017 *)

Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.Algebra.Modules.
Require Import UniMath.Algebra.Modules.Examples.
Require Import UniMath.CategoryTheory.limits.zero.

(** * Contents:

- The category of (left) R-modules ([mod_category])
- Mod is a univalent category ([is_univalent_mod])
- Abelian structure
 - Zero object and zero arrow
 - Preadditive structure
 - Additive structure
*)

Section Mod.

Local Open Scope cat.

Context {R : ring}.

(** * The category of (left) R-modules ([mod_category]) *)

Definition mod_precategory_ob_mor : precategory_ob_mor :=
  make_precategory_ob_mor (module R) (λ M N, modulefun M N).

Definition mod_precategory_data : precategory_data :=
  make_precategory_data
    mod_precategory_ob_mor (λ (M : module R), (idfun M,, id_modulefun M))
    (fun M N P => @modulefun_comp R M N P).

Lemma is_precategory_mod_precategory_data :
  is_precategory (mod_precategory_data).
Proof.
  apply is_precategory_one_assoc_to_two.
  apply make_dirprod.
  - apply make_dirprod.
    + intros M N f.
      use total2_paths_f.
      * apply funextfun. intro x. apply idpath.
      * apply isapropismodulefun.
    + intros M N f.
      use total2_paths_f.
      * apply funextfun. intro x. apply idpath.
      * apply isapropismodulefun.
  - intros M N P Q f g h.
    use total2_paths_f.
    + apply funextfun. intro x.
      unfold compose. cbn.
      apply idpath.
    + apply isapropismodulefun.
Defined.

Definition mod_precategory : precategory :=
  make_precategory (mod_precategory_data) (is_precategory_mod_precategory_data).

Definition has_homsets_mod : has_homsets mod_precategory := isasetmodulefun.

Definition mod_category : category := make_category mod_precategory has_homsets_mod.

Definition mor_to_modulefun {M N : ob mod_category} : mod_category⟦M, N⟧ -> modulefun M N := idfun _.

(** Mod is a univalent category ([Mod_is_univalent]) *)

Definition modules_univalence_weq (M N : mod_category) : (M ╝ N) ≃ (moduleiso' M N).
Proof.
   use weqbandf.
   - apply abgr_univalence.
   - intro e.
     use invweq.
     induction M. induction N. cbn in e. induction e.
     use weqimplimpl.
     + intro i.
       use total2_paths2_f.
       * use funextfun. intro r.
         use total2_paths2_f.
           apply funextfun. intro x. exact (i r x).
           apply isapropismonoidfun.
       * apply isapropisrigfun.
     + intro i. cbn.
       intros r x.
       unfold idmonoidiso. cbn in i.
       induction i.
       apply idpath.
     + apply isapropislinear.
     + apply isasetrigfun.
Defined.

Definition modules_univalence_map (M N : mod_category) : (M = N) -> (moduleiso M N).
Proof.
   intro p.
   induction p.
   exact (idmoduleiso M).
Defined.

Definition modules_univalence_map_isweq (M N : mod_category) : isweq (modules_univalence_map M N).
Proof.
   use isweqhomot.
   - exact (weqcomp (weqcomp (total2_paths_equiv _ M N) (modules_univalence_weq M N)) (moduleiso'_to_moduleweq_iso M N)).
   - intro p.
     induction p.
     apply (pathscomp0 weqcomp_to_funcomp_app).
     apply idpath.
   - apply weqproperty.
Defined.

Definition modules_univalence (M N : mod_category) : (M = N) ≃ (moduleiso M N).
Proof.
   use make_weq.
   - exact (modules_univalence_map M N).
   - exact (modules_univalence_map_isweq M N).
Defined.

(** Equivalence between isomorphisms and moduleiso in Mod R *)

Lemma moduleisweq_z_iso {M N : ob mod_category} (f : z_iso M N) :
  isweq (pr1modulefun (morphism_from_z_iso _ _ f)).
Proof.
   use (isweq_iso (pr1modulefun (morphism_from_z_iso _ _ f))).
   - exact (pr1modulefun (inv_from_z_iso f)).
   - intro; set (T:= z_iso_inv_after_z_iso f).
     apply subtypeInjectivity in T.
     + apply (toforallpaths _ _ _ T).
     + intro; apply isapropismodulefun.
   - intro; set (T:= z_iso_after_z_iso_inv f).
     apply subtypeInjectivity in T.
     + apply (toforallpaths _ _ _ T).
     + intro; apply isapropismodulefun.
Defined.

Lemma z_iso_moduleiso (M N : ob mod_category) : z_iso M N -> moduleiso M N.
Proof.
   intro f.
   use make_moduleiso.
   - use make_weq.
     + exact (pr1modulefun (morphism_from_z_iso _ _ f)).
     + exact (moduleisweq_z_iso f).
   - exact (modulefun_ismodulefun (morphism_from_z_iso _ _ f)).
Defined.

Lemma moduleiso_is_z_iso {M N : ob mod_category} (f : moduleiso M N) :
  @is_z_isomorphism _ M N (moduleiso_to_modulefun f).
Proof.
   exists (make_modulefun (invmoduleiso f) (pr2 (invmoduleiso f))).
   split; use total2_paths_f.
    + apply funextfun. intro.
      apply homotinvweqweq.
    + apply isapropismodulefun.
    + apply funextfun. intro.
      apply homotweqinvweq.
    + apply isapropismodulefun.
Defined.

Lemma moduleiso_z_iso (M N : ob mod_category) : moduleiso M N -> z_iso M N.
Proof.
   intro f.
   use make_z_iso'.
   - exact (moduleiso_to_modulefun f).
   - exact (moduleiso_is_z_iso f).
Defined.

Lemma moduleiso_isweq_z_iso (M N : ob mod_category) : isweq (@moduleiso_z_iso M N).
Proof.
   apply (isweq_iso _ (z_iso_moduleiso M N)).
   - intro.
     apply subtypePath.
     + intro; apply isapropismodulefun.
     + unfold moduleiso_z_iso, z_iso_moduleiso.
       use total2_paths_f.
       * apply idpath.
       * apply isapropisweq.
   - intro; unfold z_iso_moduleiso, moduleiso_z_iso.
     use total2_paths_f.
     + apply idpath.
     + apply isaprop_is_z_isomorphism.
Defined.

Definition moduleiso_weq_z_iso (M N : mod_category) : (moduleiso M N) ≃ (z_iso M N) :=
   make_weq (moduleiso_z_iso M N) (moduleiso_isweq_z_iso M N).

Definition mod_category_idtoisweq_z_iso :
  ∏ M N : mod_category, isweq (fun p : M = N => idtoiso p).
Proof.
   intros M N.
   use (isweqhomot (weqcomp (modules_univalence M N) (moduleiso_weq_z_iso M N)) _).
   - intro p.
     induction p.
     use (pathscomp0 weqcomp_to_funcomp_app). cbn.
     use total2_paths_f.
     + apply idpath.
     + apply (isaprop_is_z_isomorphism (identity M)).
   - apply weqproperty.
Defined.

Definition is_univalent_mod : is_univalent mod_category.
Proof.
  intros ? ? .
  apply mod_category_idtoisweq_z_iso.
Defined.

Definition univalent_category_mod_precategory : univalent_category
  := make_univalent_category mod_category is_univalent_mod.

(** * Abelian structure *)

(** ** Zero object and zero arrow
- The zero object (0) is the zero abelian group, considered as a module.
- The type (hSet) Hom(0, M) is contractible, the center is the zero map.
- The type (hSet) Hom(M, 0) is contractible, the center is the zero map.
 *)

(** ** Zero in abelian category *)

(** The set of maps 0 -> M is contractible, it only contains the zero morphism. *)
Lemma iscontrfromzero_module (M : mod_category) : iscontr (mod_category⟦zero_module R, M⟧).
Proof.
  refine (unelmodulefun _ _,, _).
  intros f; apply modulefun_paths.
  apply funextfun; intro x.
  unfold unelmodulefun; cbn.
  refine (!maponpaths (fun z => (pr1 f) z)
           (isProofIrrelevantUnit (@unel (zero_module R)) _ ) @ _).
  apply (monoidfununel (modulefun_to_monoidfun f)).
Defined.

(** The set of maps M -> 0 is contractible, it only contains the zero morphism. *)
Lemma iscontrtozero_module (M : mod_category) : iscontr (mod_category⟦M, zero_module R⟧).
Proof.
  refine (unelmodulefun _ _,, _).
  intros f; apply modulefun_paths.
  apply funextfun.
  exact (fun x => isProofIrrelevantUnit _ _).
Defined.

Lemma isZero_zero_module : @isZero mod_category (zero_module R).
Proof.
  exact (@make_isZero mod_category (zero_module _)
                    iscontrfromzero_module iscontrtozero_module).
Defined.

Definition mod_category_Zero : Zero mod_category :=
  @make_Zero mod_category (zero_module _) isZero_zero_module.

(** ** Preadditive structure *)

(** ** Additive structure *)

End Mod.