(** This file presents a cofinite-quantification style mechanization of
 System Fsub without contexts using locally named representation.
 - Authors: Jonghyun Park, Sungwoo Park, and Gyesik Lee *)
Set Implicit Arguments.

(** We import a number of definitions from libraries *)
Require Import List Arith Max.
Require Import LibTactics LibNat.

(* *************************************************************** *)
(** * Contents
 - Syntax
 - Parameters
 - Substitution
 - Local closure
 - Subtyping relation
 - Typing relation
 - Values and evaluation
 - Tactical support
 - Challenge 1A: Transitivity of Subtyping
 - Challenge 2A: Type Safety  *)
(* *************************************************************** *)

(* *************************************************************** *)
(** * Syntax
 Both variables and parameters are represented as natural numbers.
 Since we use locally named representation, they are treated as
 distinct atoms. *)
Notation ltvar := nat.   (* type variable *)
Notation ftvar := nat.   (* type parameter *)

Notation lvar := nat.    (* term variable *)
Notation fvar := nat.    (* term parameter *)

(**  We use the following definition of types and terms:
<<
 types T, U, S := \top | A | X <: T | T -> U | \forall A <: T. U
 terms t, u, s := a | x : T | \lambda a : T. t | t u | \Lambda A <: T. t | t [ T ]
>>
 We use the following notations for variables and parameters:
  - type variables  A, B, C
  - type parameters X, Y, Z
  - term variables  a, b, c
  - term parameters x, y, z *)
Inductive typ : Set :=
| typ_top   : typ
| typ_ltvar : ltvar -> typ
| typ_ftvar : ftvar -> typ -> typ
| typ_arrow : typ -> typ -> typ
| typ_all   : ltvar -> typ -> typ -> typ.

Inductive tm : Set :=
| tm_lvar : lvar -> tm
| tm_fvar : fvar -> typ -> tm
| tm_abs  : lvar -> typ -> tm -> tm
| tm_app  : tm -> tm -> tm
| tm_tabs : ltvar -> typ -> tm -> tm
| tm_tapp : tm -> typ -> tm.

Notation " X ^^ T " := (typ_ftvar X T) (at level 65).
Notation " T --> U " := (typ_arrow T U) (at level 65).

Notation " x ** T " := (tm_fvar x T) (at level 65).

Lemma typ_dec : forall T U : typ, {T = U} + {T <> U}.
Proof.
  decide equality; apply eq_nat_dec.
Qed.

Lemma fvar_dec : forall (x y : (fvar * typ)), {x = y} + {x <> y}.
Proof.
  decide equality; [apply typ_dec | apply eq_nat_dec ].
Qed.

Lemma ftvar_dec : forall (X Y : (ftvar * typ)), {X = Y} + {X <> Y}.
Proof.
  decide equality; [apply typ_dec | apply eq_nat_dec ].
Qed.

Notation "p ==_t q" := (fvar_dec p q) (at level 70).
Notation "p ==_T q" := (ftvar_dec p q) (at level 70).
(* *************************************************************** *)

(* *************************************************************** *)
(** * Parameters
 ** Type parameters
 The functions [FV_tt] and [FV_te], defined below, calculate
 the set of type parameters in a type and a term, respectively.
 Locally named representation makes the [typ_all] case for [FV_tt]
 and the [tm_tabs] case for [FV_te] simple because variables and
 parameters are syntactically distinct. *)
Fixpoint FV_tt (T:typ) : list ftvar :=
  match T with
    | typ_top       => nil
    | typ_ltvar _   => nil
    | alpha ^^ T    => alpha :: FV_tt T
    | T --> U       => FV_tt T ++ FV_tt U
    | typ_all _ T U => FV_tt T ++ FV_tt U
  end.

Fixpoint FV_te (t:tm) : list ftvar :=
  match t with
    | tm_lvar _     => nil
    | tm_fvar _ T   => FV_tt T
    | tm_abs _ T t  => FV_tt T ++ FV_te t
    | tm_app t t'   => FV_te t ++ FV_te t'
    | tm_tabs _ T t => FV_tt T ++ FV_te t
    | tm_tapp t T   => FV_te t ++ FV_tt T
end.

(** ** Term parameters
 The function [FV_ee], defined below, calculates the set of term
 parameters in a term. Locally named representation also makes
 the [tm_abs] case simple for the same reason. *)
Fixpoint FV_ee (t:tm) : list fvar :=
  match t with
    | tm_lvar _     => nil
    | tm_fvar x _   => x :: nil
    | tm_abs _ _ t  => FV_ee t
    | tm_app t t'   => FV_ee t ++ FV_ee t'
    | tm_tabs _ _ t => FV_ee t
    | tm_tapp t _   => FV_ee t
  end.
(* *************************************************************** *)

(* *************************************************************** *)
(** * Substitution *)
(** ** Type variables
 The functions [lsubst_tt] and [lsubst_te], defined below, replace
 a type variable with a type for types and terms, respectively.
 Since we use names to represent a type variables, these functions
 check the equality between variables for the [typ_all] case
 (for [lsubst_tt]) and the [tm_tabs] case (for [lsubst_te]). *)
Fixpoint lsubst_tt (B : ltvar) (U : typ) (T : typ) {struct T} : typ :=
  match T with
    | typ_top         => typ_top
    | typ_ltvar A     => if A == B then U else typ_ltvar A
    | X ^^ T          => X ^^ T
    | T1 --> T2       => typ_arrow (lsubst_tt B U T1) (lsubst_tt B U T2)
    | typ_all A T1 T2 =>
      if A == B then typ_all A (lsubst_tt B U T1) T2
        else typ_all A (lsubst_tt B U T1) (lsubst_tt B U T2)
  end.

Fixpoint lsubst_te (B : ltvar) (U : typ)  (t : tm) {struct t} : tm :=
  match t with
    | tm_lvar a     => tm_lvar a
    | tm_fvar x T   => tm_fvar x T
    | tm_abs a T t  => tm_abs a (lsubst_tt B U T) (lsubst_te B U t)
    | tm_app t1 t2  => tm_app (lsubst_te B U t1) (lsubst_te B U t2)
    | tm_tabs A T t =>
      if A == B then tm_tabs A (lsubst_tt B U T) t
        else tm_tabs A (lsubst_tt B U T) (lsubst_te B U t)
    | tm_tapp t T   => tm_tapp (lsubst_te B U t) (lsubst_tt B U T)
  end.

(** ** Term variables
 The function [lsubst_ee], defined below, replaces a term variable
 with a term. Note that the [tm_abs] case also checks the equality
 between variables. *)
Fixpoint lsubst_ee (b : lvar) (u : tm) (t : tm) {struct t} : tm :=
  match t with
    | tm_lvar a     => if a == b then u else tm_lvar a
    | tm_fvar x T   => tm_fvar x T
    | tm_abs a T t  =>
      if a == b then tm_abs a T t else tm_abs a T (lsubst_ee b u t)
    | tm_app t1 t2  => tm_app (lsubst_ee b u t1) (lsubst_ee b u t2)
    | tm_tabs A T t => tm_tabs A T (lsubst_ee b u t)
    | tm_tapp t T   => tm_tapp (lsubst_ee b u t) T
  end.

(** ** Type parameters
   The functions [fsubst_tt] and [fsubst_te], defined below, replace
 a type parameter with a type. Note that [fsubst_tt] replaces a type
 parameter with a type only when both a parameter and its annotated
 type are matched. Locally named representation makes the [typ_all]
 case (for [fsubst_tt]) and the [tm_tabs] case (for [fsubst_te]) simple. *)
Fixpoint fsubst_tt (Y:ftvar) (U:typ) (S : typ) (T : typ) {struct T} : typ :=
  match T with
    | typ_top         => typ_top
    | typ_ltvar A     => typ_ltvar A
    | X ^^ T          =>
      if ftvar_dec (X, T) (Y, U)
        then S else (X ^^ (fsubst_tt Y U S T))
    | T1 --> T2       => (fsubst_tt Y U S T1) --> (fsubst_tt Y U S T2)
    | typ_all A T1 T2 => typ_all A (fsubst_tt Y U S T1) (fsubst_tt Y U S T2)
  end.

Fixpoint fsubst_te (Y:ftvar) (U:typ) (S:typ) (t:tm) {struct t} : tm :=
  match t with
    | tm_lvar a     => tm_lvar a
    | tm_fvar x T   => tm_fvar x (fsubst_tt Y U S T)
    | tm_abs a T t  => tm_abs a (fsubst_tt Y U S T) (fsubst_te Y U S t)
    | tm_app t1 t2  => tm_app (fsubst_te Y U S t1) (fsubst_te Y U S t2)
    | tm_tabs A T t => tm_tabs A (fsubst_tt Y U S T) (fsubst_te Y U S t)
    | tm_tapp t T   => tm_tapp (fsubst_te Y U S t) (fsubst_tt Y U S T)
  end.

(** ** Term parameters
 The function [fsubst_ee], defined below, replaces a type parameter
 with a term. Note that [fsubst_tt] replaces a term parameter with
 a term only when both a parameter and its annotated type are matched.
 Locally named representation makes the [tm_abs] case simple. *)
Fixpoint fsubst_ee (y : fvar) (U:typ) (u t: tm) {struct t} : tm :=
  match t with
    | tm_lvar a     => tm_lvar a
    | tm_fvar x T   => if fvar_dec (x, T) (y, U) then u else tm_fvar x T
    | tm_abs a T t  => tm_abs a T (fsubst_ee y U u t)
    | tm_app t1 t2  => tm_app (fsubst_ee y U u t1) (fsubst_ee y U u t2)
    | tm_tabs A T t => tm_tabs A T (fsubst_ee y U u t)
    | tm_tapp t T   => tm_tapp (fsubst_ee y U u t) T
  end.

(** We introduce several notations to simplify the presentation, which
 use the following conventions:
  - { ... } denotes variable substitution.
  - [ ... ] denotes parameter substitution.
  - ~> denotes type substitution over types.
  - :~> denotes type substitution over terms.
  - ::~> denotes term substitution over terms. *)
Notation "{ A ~> U } T" := (lsubst_tt A U T) (at level 67).
Notation "{ A :~> U } t" := (lsubst_te A U t) (at level 67).
Notation "{ a ::~> u } t " := (lsubst_ee a u t) (at level 67).

Notation "[ ( X , U ) ~> S ] T" := (fsubst_tt X U S T) (at level 67).
Notation "[ ( X , U ) :~> S ] t " := (fsubst_te X U S t) (at level 67).
Notation "[ ( x , U ) ::~> u ] t " := (fsubst_ee x U u t) (at level 67).
(* *************************************************************** *)

(* *************************************************************** *)
(** * Local closure
 A type (or term) is said to be locally closed if every type (and term)
 variable has a corresponding binder. To formalize local closure of types
 and terms, we introduce two inductive definitions [lclosed_t] and
 [lclosed_e] for types and terms, respectively.

 ** Local closure of types
 For a type variable set [I], [lclosed_t I T] holds if [I] is a set of all
 the unbounded type variable in [T]. Thus, a type [T] is locally closed
 if [lclosed_t emptyset T] holds. *)
Inductive lclosed_t : list ltvar -> typ -> Prop :=
| lclosed_t_top   : lclosed_t emptyset typ_top
| lclosed_t_ltvar : forall A,
  lclosed_t (A :: emptyset) (typ_ltvar A)
| lclosed_t_ftvar : forall X (T : typ),
  lclosed_t emptyset T ->
  lclosed_t emptyset (X ^^ T)
| lclosed_t_arrow : forall I1 I2 (T U : typ),
  lclosed_t I1 T ->
  lclosed_t I2 U ->
  lclosed_t (I1 ++ I2) (T --> U)
| lclosed_t_all   : forall I1 I2 A T U,
  lclosed_t I1 T ->
  lclosed_t I2 U ->
  lclosed_t (I1 ++ (remove eq_nat_dec A I2)) (typ_all A T U).

Hint Constructors lclosed_t.

(** ** Local closure of terms
 For a type variable set [I], a term variable set [i], [lclosed_e I i t] holds
 if [I] and [i] are sets of all the unbound type and term variable in [t],
 respectively. Thus, a term [t] is locally closed
 if [lclosed_e emptyset emptyset t] holds. *)
Inductive lclosed_e : list ltvar -> list lvar -> tm -> Prop :=
| lclosed_e_lvar : forall a, lclosed_e nil (a :: nil) (tm_lvar a)
| lclosed_e_fvar : forall x T,
  lclosed_t emptyset T ->
  lclosed_e emptyset emptyset (x ** T)
| lclosed_e_abs  : forall I1 I2 i a T t,
  lclosed_t I1 T ->
  lclosed_e I2 i t ->
  lclosed_e (I1 ++ I2) (remove eq_nat_dec a i) (tm_abs a T t)
| lclosed_e_app  : forall I1 I2 i1 i2 t1 t2,
  lclosed_e I1 i1 t1 ->
  lclosed_e I2 i2 t2 ->
  lclosed_e (I1 ++ I2) (i1 ++ i2) (tm_app t1 t2)
| lclosed_e_tabs : forall I1 I2 i A T t,
  lclosed_t I1 T ->
  lclosed_e I2 i t ->
  lclosed_e (I1 ++ (remove eq_nat_dec A I2)) i (tm_tabs A T t)
| lclosed_e_tapp : forall I1 I2 i t T,
  lclosed_e I1 i t ->
  lclosed_t I2 T ->
  lclosed_e (I1 ++ I2) i (tm_tapp t T).

Hint Constructors lclosed_e.
(* *************************************************************** *)

(* *************************************************************** *)
(** * Subtyping relation
 It is straightforward to define the subtyping relation. The [sub_top]
 and [sub_refl_tvar] cases require types to be locally closed. This
 implies that the subtyping relation holds only for locally closed types.
 The [sub_refl_tvar] case requires the annotated type to be well-formed,
 which corresponds the well-formed context requirement for the System Fsub
 with typing contexts. Note the use of the cofinite-quantification style
 in the [sub_all] case. *)
Inductive sub : typ -> typ -> Prop :=
| sub_top        : forall T,
  lclosed_t emptyset T ->
  sub T typ_top
| sub_refl_tvar  : forall T X,
  lclosed_t emptyset T ->
  sub (X ^^ T) (X ^^ T)
| sub_trans_tvar : forall T U X,
  sub T U ->
  sub (X ^^ T) U
| sub_arrow      : forall T1 T2 U1 U2,
  sub U1 T1 ->
  sub T2 U2 ->
  sub (T1 --> T2) (U1 --> U2)
| sub_all        : forall T1 T2 U1 U2 A B L,
  sub U1 T1 ->
  (forall X, ~ In X L -> sub ({A ~> X ^^ U1} T2) ({B ~> X ^^ U1} U2)) ->
  sub (typ_all A T1 T2) (typ_all B U1 U2).

Hint Constructors sub.
(* *************************************************************** *)

(* *************************************************************** *)
(** * Typing relation
 It is also straightforward to define the typing relation. The [typing_fvar]
 case requires the annotate type [T] to be locally closed, which implies the
 typing relation holds only for locally closed types (We will formally prove
 this later). Note the use of the cofinite-quantification style in the
 [typing_abs] and [typing_tabs] cases. *)
Inductive typing : tm -> typ -> Prop :=
| typing_fvar : forall x T,
  lclosed_t emptyset T ->
  typing (x ** T) T
| typing_abs  : forall a T U t L,
  lclosed_t emptyset T ->
  (forall x, ~ In x L -> typing ({a ::~> x ** T} t) U) ->
  typing (tm_abs a T t) (T --> U)
| typing_app  : forall t t' T U,
  typing t (T --> U) ->
  typing t' T ->
  typing (tm_app t t') U
| typing_tabs : forall A T t B U L,
  lclosed_t emptyset T ->
  (forall X, ~ In X L -> typing ({A :~> X ^^ T} t) ({B ~> X ^^ T} U)) ->
  typing (tm_tabs A T t) (typ_all B T U)
| typing_tapp : forall t A T U S,
  typing t (typ_all A U S) ->
  sub T U ->
  typing (tm_tapp t T) ({A ~> T} S)
| typing_sub  : forall t T U,
  typing t T ->
  sub T U ->
  typing t U.

Hint Constructors typing.
(* *************************************************************** *)

(* *************************************************************** *)
(** * Values and evaluation
 To state the preservation lemma, we first need to define values
 and the small-step evaluation relation. These inductive relations
 are straightforward to define. *)
Inductive value : tm -> Prop :=
| value_abs  : forall a T t, value (tm_abs a T t)
| value_tabs : forall A T t, value (tm_tabs A T t).

Inductive red : tm -> tm -> Prop :=
| red_app_1 : forall t1 t1' t2,
              red t1 t1' ->
              red (tm_app t1 t2) (tm_app t1' t2)
| red_app_2 : forall t1 t2 t2',
              value t1 ->
              red t2 t2' ->
              red (tm_app t1 t2) (tm_app t1 t2')
| red_abs   : forall a T t u,
              value u ->
              red (tm_app (tm_abs a T t) u) ({a ::~> u} t)
| red_tapp  : forall t t' T,
              red t t' ->
              red (tm_tapp t T) (tm_tapp t' T)
| red_tabs  : forall A T t U,
              red (tm_tapp (tm_tabs A T t) U) ({A :~> U} t).

Hint Constructors red.
(* *************************************************************** *)

(* *************************************************************** *)
(** * Tactical support
 We introduce an automation tactic [Simplify] to simplify the proof.
 [Simplify] attempts to evaluate several fixpoint functions, such as
 [FV_tt] and [lsubst_tt], as much as possible. This simplification is
 useful for the following case:
<<
 ...
 H : ~ In X (FV_tt (Gamma_1 ++ Gamma_2 ++ Gamma_3 ++ Gamma_4) )
 ...
 --------------------------------------------------------------
 ~ In X (FV_tt Gamma_4)
>>
 [Simplify by eauto] first decomposes the hypothesis H as follows:
<<
 ...
 ? : ~ In X (FV_tt Gamma_1)
 ? : ~ In X (FV_tt Gamma_2)
 ? : ~ In X (FV_tt Gamma_3)
 ? : ~ In X (FV_tt Gamma_4)
 ...
 --------------------------------------------------------------
 ~ In X (FV_tt Gamma_4)
>>
 Then it applies [eauto] to solve the goal. *)
Ltac simplifyTac tac :=
let rec filter_list l :=
  match l with
    | emptyset => idtac
    | _ :: _ => idtac
    | _ => fail
  end
with filter_t t :=
  match t with
    | typ_top => idtac
    | typ_ltvar _ => idtac
    | typ_ftvar _ _ => idtac
    | typ_arrow _ _ => idtac
    | typ_all _ _ _ => idtac
    | _ => fail
  end
with filter_e e :=
  match e with
    | tm_lvar _ => idtac
    | tm_fvar _ _ => idtac
    | tm_abs _ _ _ => idtac
    | tm_app _ _ => idtac
    | tm_tabs _ _ _ => idtac
    | tm_tapp _ _ => idtac
  end
with filter_var_t C :=
  match C with
    | FV_tt => idtac
    | _ => idtac
  end
with filter_var_e C :=
  match C with
    | FV_te => idtac
    | FV_ee => idtac
    | _ => idtac
  end
with filter_lsubst_e S :=
  match S with
    | lsubst_te => idtac
    | lsubst_ee => idtac
    | _ => fail
  end
with filter_fsubst_e S :=
  match S with
    | fsubst_te => idtac
    | fsubst_ee => idtac
    | _ => fail
  end in
  match goal with
    | H: ?X = ?X |- _ => clear H; simplifyTac tac
    | H: ?X <> ?X |- _ => try congruence
    | H: context [?X == ?Y] |- _ =>
      destruct (X == Y); [ try subst X | idtac ]; simplifyTac tac
    | H: context [?X ==_t ?Y] |- _ =>
      destruct (X ==_t Y); [ try subst X | idtac ]; simplifyTac tac
    | H: context [?X ==_T ?Y] |- _ =>
      destruct (X ==_T Y); [ try subst X | idtac ]; simplifyTac tac
    | |- context [?X == ?Y] =>
      destruct (X == Y); [ try subst X | idtac ]; simplifyTac tac
    | |- context [?X ==_t ?Y] =>
      destruct (X ==_t Y); [ try subst X | idtac ]; simplifyTac tac
    | |- context [?X ==_T ?Y] =>
      destruct (X ==_T Y); [ try subst X | idtac ]; simplifyTac tac
    | H: context[ remove _ _ ?l ] |- _ =>
      filter_list l; simpl remove in H; simplifyTac tac
    | H : context[ ?C ?t ] |- _ =>
      filter_var_t C; filter_t t; simpl C in H; simplifyTac tac
    | H : context[ ?C ?e ] |- _ =>
      filter_var_e C; filter_e e; simpl C in H; simplifyTac tac
    | H : context[ lsubst_tt _ _ ?t ] |- _ =>
      filter_t t; simpl lsubst_tt in H; simplifyTac tac
    | H : context[ fsubst_tt _ _ _ ?t ] |- _ =>
      filter_t t; simpl fsubst_tt in H; simplifyTac tac
    | H : context[ ?S _ _ ?e ] |- _ =>
      filter_lsubst_e S; filter_e e; simpl S in H; simplifyTac tac
    | H : context[ ?S _ _ _ ?e ] |- _ =>
      filter_fsubst_e S; filter_e e; simpl S in H; simplifyTac tac
    | |- context[ remove _ _ ?l ] =>
      filter_list l; simpl remove; simplifyTac tac
    | |- context[ ?C ?t ] =>
      filter_var_t C; filter_t t; simpl C; simplifyTac tac
    | |- context[ ?C ?e ] =>
      filter_var_e C; filter_e e; simpl C; simplifyTac tac
    | |- context[ lsubst_tt _ _ ?t ] =>
      filter_t t; simpl lsubst_tt; simplifyTac tac
    | |- context[ fsubst_tt _ _ _ ?t ] =>
      filter_t t; simpl fsubst_tt; simplifyTac tac
    | |- context[ ?S _ _ ?e ] =>
      filter_lsubst_e S; filter_e e; simpl S; simplifyTac tac
    | |- context[ ?S _ _ _ ?e ] =>
      filter_fsubst_e S; filter_e e; simpl S; simplifyTac tac
    | _ => tac
  end.

Tactic Notation "Simplify" "by" tactic(tac) := simplifyTac tac.
(* *************************************************************** *)

(* *************************************************************** *)
(** * Challenge 1A: Transitivity of Subtyping
 This section presents our solution to the POPLmark Challenge 1A. *)

(* *************************************************************** *)
(** ** Properties of [lclosed_t]
 Note that [sub] uses [lclosed_t] in its definition. To reason about
 [sub], therefore, we need the properties of [lclosed_t]. Here we
 present several properties of [lclosed_t] that we use in our solution. *)

(** [lclosed_t] is invertible. *)
Lemma lclosed_t_ltvar_split : forall T A X U I0,
  lclosed_t I0 ({A ~> X ^^ U} T) ->
  (exists I, (lclosed_t I T /\ remove eq_nat_dec A I = I0)).
Proof.
  induction T; intros; auto.
  inversion H; exists (emptyset:list ltvar); Simplify by eauto.
  Simplify by eauto; inversion H; subst.
    exists (A :: emptyset); Simplify by eauto.
    exists (n :: emptyset); Simplify by eauto.
  Simplify by eauto; inversion H; subst.
     exists (emptyset : list ltvar); Simplify by eauto.
  Simplify by eauto; inversion H; subst.
  destruct (IHT1 _ _ _ _ H3) as [I1' [Ha Ha']].
  destruct (IHT2 _ _ _ _ H4) as [I2' [Hb Hb']].
  exists (I1' ++ I2'); split; Simplify by eauto.
    rewrite list_remove_app; rewrite Ha'; rewrite Hb'; eauto.
  Simplify by eauto; inversion H; clear H.
    destruct (IHT1 _ _ _ _ H3) as [I1' [Ha Ha']].
    exists (I1' ++ (remove eq_nat_dec A I2)); split; auto.
      rewrite list_remove_app; rewrite list_remove_repeat; rewrite Ha'; eauto.
    destruct (IHT1 _ _ _ _ H3) as [I1' [Ha Ha']].
    destruct (IHT2 _ _ _ _ H5) as [I2' [Hb Hb']].
    exists (I1' ++ (remove eq_nat_dec n I2')); split; eauto.
      rewrite list_remove_app; rewrite list_remove_twice.
      rewrite Ha'; rewrite Hb'; eauto.
Qed.

(** [lclosed_t] is stable under type variable substitution. *)
Lemma lclosed_t_subst_ltvar : forall T U I A,
  lclosed_t emptyset U ->
  lclosed_t I T ->
  lclosed_t (remove eq_nat_dec A I) ({A ~> U} T).
Proof.
  induction T; intros; inversion H0; subst; Simplify by eauto.
    rewrite list_remove_app; eauto.
    rewrite list_remove_app; rewrite list_remove_repeat; eauto.
    rewrite list_remove_app; rewrite list_remove_twice; eauto.
Qed.

(** [lclosed_t] is also stable under type parameter substitution. *)
Lemma lclosed_t_subst_ftvar : forall T U U' X I,
  lclosed_t I T ->
  lclosed_t emptyset U ->
  lclosed_t I ([(X, U') ~> U] T).
Proof.
  induction 1; intros; Simplify by eauto.
Qed.

Hint Resolve lclosed_t_subst_ltvar lclosed_t_subst_ftvar : subst_aux.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Properties of substitution over types
 Our solution exploits several properties of substitution over types. *)
Hint Resolve sym_eq list_remove_in : nochange.

(** Type variable substitution over types has no effect if they do not
 include such a type variable. *)
Lemma subst_ltvar_nochange_t : forall I T,
  lclosed_t I T ->
  forall A U,
    ~ In A I -> {A ~> U} T = T.
Proof.
  induction 1; intros;
    Simplify by (Destruct notIn by (f_equal; eauto with nochange)).
Qed.

(** Type parameter substitution over types also has no effect if they
 do not include such a type parameter. *)
Lemma subst_ftvar_nochange_t : forall T U S X,
  ~ In X (FV_tt T) -> [(X, U) ~> S] T = T.
Proof.
  induction T; intros;
    Simplify by (Destruct notIn by (f_equal; eauto with nochange)).
    inversion e; subst; congruence.
Qed.

Hint Resolve subst_ltvar_nochange_t subst_ftvar_nochange_t : nochange.

Fixpoint synsize_t (T:typ) :=
  match T with
    | typ_top       => 0
    | typ_ltvar _   => 0
    | _ ^^ T        => S (synsize_t T)
    | T --> U       => S (synsize_t T + synsize_t U)
    | typ_all _ T U => S (synsize_t T + synsize_t U)
  end.

Lemma lem_subst_ftvar_nochange_t_idemp : forall T S,
  synsize_t S <= synsize_t T ->
  forall X U, [(X, T) ~> U] S = S.
Proof.
  induction S; intros; Simplify by (f_equal; eauto with arith).
    inversion e; subst; firstorder using le_Sn_n.
Qed.

(** We may swap parameter and variable substitutions. *)
Lemma subst_ftvar_ltvar_t : forall T U S S' X,
  lclosed_t emptyset S ->
  forall A,
    [(X,U) ~> S] ({A ~> S'} T) = {A ~> [(X,U) ~> S] S'} ([(X,U) ~> S] T).
Proof.
  induction T; intros; Simplify by (f_equal; eauto with nochange; congruence).
Qed.

(** We may replace a type variable with a fresh type parameter, and then
 replace the type parameter with a given type instead of directly replacing
 the type variable with the given type. *)
Lemma subst_seq_ftvar_ltvar_t : forall T U S X,
  ~ In X (FV_tt T) ->
  forall A,
    [(X,U) ~> S] ({A ~> (X^^U)} T) = {A ~> S} T.
Proof.
  induction T; intros;
    Simplify by (Destruct notIn by (f_equal; eauto with nochange; congruence)).
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Basic properties of [sub] *)

(** [sub] deals with locally closed types only. *)
Lemma sub_lclosed_t : forall T U,
  sub T U -> lclosed_t emptyset T /\ lclosed_t emptyset U.
Proof.
  induction 1; intros; try solve [firstorder].
  unsimpl (emptyset ++ emptyset:list ltvar); firstorder.
  destruct (pick_fresh L) as [X Hfresh].
  destruct (H1 X Hfresh) as [Ha Hb].
  split.
    destruct (lclosed_t_ltvar_split _ _ _ _ Ha) as [I1 [Ha' Ha'']].
    replace (emptyset:list ltvar) with (emptyset ++ (remove eq_nat_dec A I1));
      firstorder.
    destruct (lclosed_t_ltvar_split _ _ _ _ Hb) as [I2 [Ha' Ha'']].
    replace (emptyset:list ltvar) with (emptyset ++ (remove eq_nat_dec B I2));
      firstorder.
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Transitivity of [sub]
 Finally, we present the major result of this section: the transitivity
 of [sub]. The proof is challenging because we need to prove the
 transitivity and the narrowing property simultaneously. *)

(** *** Narrowing property of subtyping
 To simplify the proof, we first prove the narrowing property under
 the assumption that the transitivity of [sub] holds for a specific
 type.

 We use [sub_transitivity_on T] to state the assumption that the
 transitivity of [sub] holds for a specific type [T]. *)
Definition sub_transitivity_on T := forall U S,
  sub U T -> sub T S -> sub U S.

Lemma sub_narrowing : forall T U,
  sub T U ->
  forall S S',
    sub_transitivity_on S ->
    sub S' S ->
    forall X,
      sub ([(X, S) ~> X ^^ S'] T)
          ([(X, S) ~> X ^^ S'] U).
Proof.
  induction 1; intros; try solve [Simplify by eauto].
  destruct (sub_lclosed_t H1) as [? ?].
  Simplify by eauto with subst_aux.
  destruct (sub_lclosed_t H1) as [? ?].
  Simplify by eauto with subst_aux.
  Simplify by eauto.
    inversion e; subst; clear e.
    eapply H0; eauto.
    erewrite <- lem_subst_ftvar_nochange_t_idemp at 1; eauto.
  Simplify by eauto.
  constructor 5 with (X :: L); intros; Destruct notIn by eauto.
    destruct (sub_lclosed_t H3) as [? _].
    replace (X0 ^^ [ (X, S)~> X ^^ S']U1)
      with ([ (X, S) ~> X ^^ S' ] X0 ^^ U1) by Simplify by congruence.
    repeat rewrite <- subst_ftvar_ltvar_t by eauto.
    apply H1; eauto.
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** *** Transitivity
 We then prove the transitivity of [sub] by induction on the size
 of types. The size of types is defined by function [size_t]. *)
Fixpoint size_t (T : typ) : nat :=
  match T with
    | typ_top         => 0
    | typ_ltvar _     => 0
    | typ_ftvar _ _   => 0
    | typ_arrow T1 T2 => S (size_t T1 + size_t T2)
    | typ_all _ T1 T2 => S (size_t T1 + size_t T2)
  end.

Lemma size_t_nochange_ltvar : forall T A X U,
  size_t ({A ~> X ^^ U} T) = size_t T.
Proof.
  induction T; intros; Simplify by (simpl; eauto).
Qed.

(** Lemma [sub_trans_ftvar_aux] deals with the [typ_ftvar] case. *)
Lemma sub_trans_ftvar_aux : forall A S U X,
  sub A S ->
  S = (X ^^ U) ->
  forall S', sub S S' -> sub A S'.
Proof.
  induction 1; intros; try discriminate; eauto.
Qed.

(** Lemma [sub_trans_fun_aux] deals with the [typ_arrow] case. *)
Lemma sub_trans_fun_aux : forall T U U1 U2 S,
  sub_transitivity_on U1 ->
  sub_transitivity_on U2 ->
  sub T U ->
  sub U S ->
  U = U1 --> U2 ->
  sub T S.
Proof.
  induction 3; intros; try discriminate; eauto.
  inversion H2; subst; clear H2.
    destruct (sub_lclosed_t H1_) as [? ?].
    destruct (sub_lclosed_t H1_0) as [? ?].
    inversion H1; subst; econstructor; eauto.
      unsimpl (emptyset ++ emptyset:list ltvar); eauto.
Qed.

(** Lemma [sub_trans_forall_aux] deals with the [typ_all] case. *)
Lemma sub_trans_forall_aux : forall T U U1 U2 S A,
  (forall S, size_t S < size_t U -> sub_transitivity_on S) ->
  sub T U ->
  U = typ_all A U1 U2 ->
  sub U S ->
  sub T S.
Proof.
  intros until 2.
  induction H0; intros; try discriminate; eauto.
  inversion H3; inversion H4; subst.
  constructor 1.
  destruct (pick_fresh L) as [X Hfresh].
  destruct (sub_lclosed_t H0) as [_ ?].
  destruct (sub_lclosed_t (H1 _ Hfresh)) as [H_T2 _].
  destruct (lclosed_t_ltvar_split _ _ _ _ H_T2) as [I [Ha Hb]].
  replace (emptyset:list ltvar) with (emptyset ++ (remove eq_nat_dec A0 I));
    eauto.
  set (L' := L ++ L0 ++ FV_tt T2 ++ FV_tt U2).
  econstructor 5 with L'.
    eapply (H U1); Simplify by eauto with arith.
    intros; unfold L' in H5; Destruct notIn by eauto.
  apply (H ({A ~> X ^^ U4} U2)); Simplify by eauto.
    rewrite size_t_nochange_ltvar; eauto with arith.
  erewrite <- subst_seq_ftvar_ltvar_t with (T := T2) (X := X) by eauto.
  erewrite <- subst_seq_ftvar_ltvar_t with (T := U2) (X := X) by eauto.
  eapply sub_narrowing; eauto with arith.
Qed.

(** Using these lemmas, we may complete the proof of the transitivity. *)
Lemma sub_transitivity_aux : forall n T,
  size_t T < n -> sub_transitivity_on T.
Proof.
  induction n; intros.
  firstorder using lt_n_O.
  destruct T; unfold sub_transitivity_on; intros.
  inversion H1; assumption.
  inversion H1; inversion H2; eauto.
  eauto using sub_trans_ftvar_aux.
  Simplify by idtac.
  assert (size_t T1 < n) by eauto with arith.
  assert (size_t T2 < n) by eauto with arith.
  eauto using sub_trans_fun_aux.
  Simplify by idtac.
  assert (forall S,
    size_t S < size_t (typ_all n0 T1 T2) ->
    sub_transitivity_on S) by eauto with arith.
  eauto using sub_trans_forall_aux.
Qed.

Lemma sub_transitivity : forall T U S, sub T U -> sub U S -> sub T S.
Proof.
  intros.
  forwards Ha : sub_transitivity_aux (Datatypes.S (size_t U)) U;
    eauto with arith.
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Reflexivity of [sub]
 Reflexivity of [sub] is straightforward to prove. The proof proceeds
 by induction on the size of types.*)
Lemma sub_reflexivity_aux : forall n T,
  size_t T < n -> lclosed_t emptyset T -> sub T T.
Proof.
  induction n.
  firstorder using lt_n_O.
  destruct T; intros H' H; inversion H; subst; Simplify by eauto.
  assert (size_t T1 < n) by eauto with arith.
  assert (size_t T2 < n) by eauto with arith.
  assert (I1 = emptyset) by firstorder using app_eq_nil.
  assert (I2 = emptyset) by firstorder using app_eq_nil.
  subst; eauto.
  set (L := FV_tt T1 ++ FV_tt T2).
  assert (I1 = emptyset) by firstorder using app_eq_nil; subst I1.
  constructor 5 with L.
    apply IHn; eauto with arith.
    intros; apply IHn.
      rewrite size_t_nochange_ltvar; eauto with arith.
      replace (emptyset : list ltvar) with (remove eq_nat_dec n0 I2).
      eauto with subst_aux.
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** * Challenge 2A: Type Safety
 This section presents our solution to the POPLmark Challenge 2A. *)
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Properties of [lclosed_e]
 Unlike [sub] which uses [lclosed_t] only, [typing] uses both [lclosed_t]
 and [lclosed_e]. This section presents properties of [lclosed_e] that
 we will use in the rest. *)

(** [lclosed_e] is also invertible. *)
Lemma lclosed_e_lvar_split : forall t I i0 a x T,
  lclosed_e I i0 ({a ::~> x ** T} t) ->
    (exists i, lclosed_e I i t /\ remove eq_nat_dec a i = i0).
Proof.
  induction t; intros; Simplify by try congruence.
  inversion H; subst.
    exists (a :: emptyset); split; Simplify by eauto.
  inversion H; subst.
    exists (n :: emptyset); split; Simplify by eauto.
  inversion H; subst.
    exists (emptyset : list lvar); eauto.
  inversion H; subst.
    exists (remove eq_nat_dec a i); eauto using list_remove_repeat.
  inversion H; subst.
    forwards Ha : (IHt _ _ _ _ _ H6).
    destruct Ha as [i0 [Hb Hc]].
    exists (remove eq_nat_dec n i0).
    rewrite <- Hc; eauto using list_remove_twice.
  inversion H.
    forwards Ha : (IHt1 _ _ _ _ _ H4); destruct Ha as [ia [? ?]].
    forwards Hb : (IHt2 _ _ _ _ _ H5); destruct Hb as [ib [? ?]].
    exists (ia ++ ib); split; eauto.
      rewrite <- H7; rewrite <- H9; eauto using list_remove_app.
  inversion H; subst.
    forwards Ha : (IHt _ _ _ _ _ H6); destruct Ha as [ia [? ?]].
    exists ia; eauto.
  inversion H; subst.
    forwards Ha : (IHt _ _ _ _ _ H4); destruct Ha as [ia [? ?]].
    exists ia; eauto.
Qed.

Lemma lclosed_e_ltvar_split : forall t I0 i A X T,
  lclosed_e I0 i ({A :~> X ^^ T} t) ->
    (exists I, lclosed_e I i t /\ remove eq_nat_dec A I = I0).
Proof.
  induction t; intros; Simplify by try congruence.
  inversion H; subst.
    exists (emptyset:list ltvar); Simplify by eauto.
  inversion H; subst.
    exists (emptyset:list ltvar); Simplify by eauto.
  inversion H.
    forwards Ha : (IHt _ _ _ _ _ H6); destruct Ha as [Ia [? ?]].
    forwards Hb : (lclosed_t_ltvar_split _ _ _ _ H4); destruct Hb as [Ib [? ?]].
    subst; exists (Ib ++ Ia); eauto using list_remove_app.
  inversion H; subst.
    forwards Ha : (IHt1 _ _ _ _ _ H4); destruct Ha as [Ia [? ?]].
    forwards Hb : (IHt2 _ _ _ _ _ H5); destruct Hb as [Ib [? ?]].
    subst; exists (Ia ++ Ib); eauto using list_remove_app.
  inversion H; subst.
    destruct (lclosed_t_ltvar_split _ _ _ _ H4) as [I0 [? ?]]; subst.
    exists (I0 ++ (remove eq_nat_dec A I2)); split; eauto.
      rewrite list_remove_app; rewrite list_remove_repeat; eauto.
  inversion H; subst.
    destruct (lclosed_t_ltvar_split _ _ _ _ H4) as [Ia [? ?]].
    destruct (IHt _ _ _ _ _ H6) as [Ib [? ?]].
    subst; exists (Ia ++ (remove eq_nat_dec n Ib)); split; eauto.
      rewrite list_remove_app; rewrite list_remove_twice; eauto.
  inversion H; subst.
    destruct (IHt _ _ _ _ _ H4) as [Ia [? ?]].
    destruct (lclosed_t_ltvar_split _ _ _ _ H5) as [Ib [? ?]].
    subst; exists (Ia ++ Ib); eauto using list_remove_app.
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Properties of substitution over terms.
 For the proof of type safety, we deal with not only substitution over
 types but also substitution over terms, and thus we will present its
 properties in this section. *)

(** Variable substitution over terms has no effect if they do not
 include such a variable. *)
Lemma subst_lvar_nochange_e : forall t I i a u,
  lclosed_e I i t ->
  ~ In a i ->
  { a ::~> u } t = t.
Proof.
  induction t; intros; inversion H; subst;
    Simplify by Destruct notIn by (f_equal; firstorder).
Qed.

Lemma subst_ltvar_nochange_e : forall t I i A T,
  lclosed_e I i t ->
  ~ In A I ->
  {A :~> T} t = t.
Proof.
  induction t; intros; inversion H; subst;
    Destruct notIn by Simplify by (f_equal; eauto with nochange).
Qed.

(** Parameter substitution over terms also has no effect on terms
 if they do not include such a parameter. *)
Lemma subst_fvar_nochange_e : forall t u x T,
  ~ In x (FV_ee t) -> [(x, T) ::~> u] t = t.
Proof.
  induction t; intros; Simplify by Destruct notIn by (f_equal; eauto).
    inversion e; subst; congruence.
Qed.

Lemma subst_ftvar_nochange_e : forall t X T U,
  ~ In X (FV_te t) -> ([ ( X , T ) :~> U ] t) = t.
Proof.
  induction t; intros;
    Simplify by Destruct notIn by (f_equal; eauto with nochange).
Qed.

Hint Resolve subst_lvar_nochange_e subst_ltvar_nochange_e : nochange.
Hint Resolve subst_fvar_nochange_e subst_ftvar_nochange_e : nochange.

(** We may swap variable and parameter substitutions. *)
Lemma subst_fvar_lvar_e : forall t u a x T y U I,
  lclosed_e I emptyset u ->
  x <> y ->
  [(y, U) ::~> u]({a ::~> x ** T} t) = {a ::~> x ** T}([(y, U) ::~> u] t).
Proof.
  induction t; intros;
    Simplify by (f_equal; eauto with nochange; congruence).
Qed.

Lemma subst_ltvar_fvar_e : forall t A X T x U u,
  lclosed_e emptyset emptyset u ->
  {A :~> X^^T}([(x, U) ::~> u] t) = [(x, U) ::~> u]({A :~> X^^T}t).
Proof.
  induction t; intros; Simplify by (f_equal; eauto with nochange; congruence).
Qed.

Lemma subst_ftvar_lvar_e : forall t u X T U a,
  [(X, T) :~> U]({a ::~> u} t) = {a ::~> ([(X, T) :~> U] u)}([ (X, T) :~> U] t).
Proof.
  induction t; intros; Simplify by (f_equal; eauto).
Qed.

Lemma subst_ftvar_ltvar_e : forall t A X T U U',
  lclosed_t emptyset U ->
  [(X, T) :~> U] ({A :~> U'} t) = {A :~> [(X, T) ~> U] U'} ([(X, T) :~> U] t).
Proof.
  induction t; intros; Simplify by (f_equal; eauto using subst_ftvar_ltvar_t).
Qed.

(** We may replace a variable with a fresh parameter, and then replace
 the parameter with a given type (or term) instead of directly replacing
 the variable with the given type (or term). *)
Lemma subst_seq_fvar_lvar_e : forall t u a x T,
  ~ In x (FV_ee t) ->
  [(x, T) ::~> u]({a ::~> x ** T} t) = {a ::~> u} t.
Proof.
  induction t; intros; Simplify by Destruct notIn
    by (f_equal; eauto with nochange; congruence).
Qed.

(** [FV_te] and [FV_ee] are stable under substitutions. *)
Lemma FV_te_nochange_lvar : forall t a x y T,
  FV_te ({a ::~> x ** T} t) = FV_te ({a ::~> y ** T} t).
Proof.
  induction t; intros; Simplify by (f_equal; eauto).
Qed.

Hint Resolve FV_te_nochange_lvar : nochange.

Lemma FV_ee_nochange_ltvar : forall A T t,
  FV_ee ({A :~> T} t) = FV_ee t.
Proof.
  induction t; intros; Simplify by eauto.
    rewrite IHt1; rewrite IHt2; eauto.
Qed.

Lemma FV_ee_nochange_ftvar : forall t X T Y U,
  FV_ee ([(X, T) :~> Y^^U] t) = FV_ee t.
Proof.
  induction t; intros; Simplify by eauto.
    rewrite IHt1; rewrite IHt2; eauto.
Qed.

Hint Resolve FV_ee_nochange_ltvar FV_ee_nochange_ftvar : nochange.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Basic properties of [typing] *)

(** [typing] deals with locally closed types and terms only. *)
Lemma typing_lclosed_et : forall t T,
  typing t T -> lclosed_e emptyset emptyset t /\ lclosed_t emptyset T.
Proof.
  induction 1; Simplify by eauto.
  destruct (pick_fresh L) as [x Hfresh].
  destruct (H1 _ Hfresh) as [Ha Hb].
  destruct (lclosed_e_lvar_split _ _ _ _ Ha) as [I [? ?]].
  split.
    rewrite <- emptyset_plus at 1.
    pattern (emptyset: list ltvar) at 3;
      replace (emptyset:list ltvar) with (remove eq_nat_dec a I); eauto.
    unsimpl (emptyset ++ emptyset : list ltvar); eauto.
  destruct IHtyping1; destruct IHtyping2.
  split.
    rewrite <- emptyset_plus; eauto.
    inversion H2; subst.
    destruct (app_eq_nil _ _ H5) as [? ?]; subst; eauto.
  destruct (pick_fresh L) as [X Hfresh].
  destruct (H1 _ Hfresh) as [? ?].
  destruct (lclosed_e_ltvar_split _ _ _ _ H2) as [Ia [? ?]].
  destruct (lclosed_t_ltvar_split _ _ _ _ H3) as [Ib [? ?]].
  split.
    pattern (emptyset:list ltvar) at 1;
      replace (emptyset:list ltvar) with (emptyset ++ remove eq_nat_dec A Ia);
        eauto.
    pattern (emptyset:list ltvar) at 1;
      replace (emptyset:list ltvar) with (emptyset ++ remove eq_nat_dec B Ib);
        eauto.
  destruct IHtyping.
  destruct (sub_lclosed_t H0) as [? ?].
  split.
    rewrite <- emptyset_plus at 1; eauto.
    inversion H2; subst.
    destruct (app_eq_nil _ _ H5) as [? ?]; subst.
    simpl; eauto using lclosed_t_subst_ltvar.
  destruct (sub_lclosed_t H0).
  destruct IHtyping; eauto.
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Substitution lemma
 This section presents the main result: [typing] is stable under type
 and term parameter substitution.

 *** Type parameter substitution lemma
 We first prove Lemma [typing_subst_ftvar] which shows that [typing]
 is stable under type parameter substitution. The proof proceeds by
 induction on the structure of [typing] proofs. *)
Lemma sub_subst_ftvar : forall T U,
  sub T U ->
  forall X S S',
    sub S' S ->
    sub ([(X, S) ~> S'] T) ([(X, S) ~> S'] U).
Proof.
  induction 1; intros ? ? ? Hsub; destruct (sub_lclosed_t Hsub);
    Simplify by eauto with subst_aux.
  eauto using sub_reflexivity_aux with arith.
  inversion e; subst.
  eapply sub_transitivity with (U := [ (X0, S) ~> S' ] S); eauto.
  rewrite lem_subst_ftvar_nochange_t_idemp; eauto with arith.
  constructor 5 with (L := X :: L); eauto.
    intros; Destruct notIn by eauto.
    replace (X0 ^^ ([ (X, S)~> S']U1))
      with ([ (X, S) ~> S' ] X0 ^^ U1) by Simplify by congruence.
    repeat (rewrite <- subst_ftvar_ltvar_t by eauto).
    eapply H1; eauto.
Qed.

Hint Resolve sub_subst_ftvar : subst_aux.

Lemma typing_sub_subst_ftvar : forall t X T U U',
  typing t T ->
  sub U' U ->
  typing ([(X, U) :~> U'] t) ([(X, U) ~> U'] T).
Proof.
  induction 1; intros Hsub; destruct (sub_lclosed_t Hsub);
    Simplify by eauto with subst_aux.
  constructor 2 with L; eauto with subst_aux.
    intros; Destruct notIn by eauto.
    replace ( x ** ([ (X, U)~> U']T) )
      with ( [ (X, U) :~> U' ] x **  T ) by Simplify by congruence.
    rewrite <- subst_ftvar_lvar_e.
    eapply H1; eauto.
  constructor 4 with (X :: L); eauto with subst_aux.
    intros; Destruct notIn by eauto.
    replace ( X0 ^^ ([ (X, U)~> U']T) )
      with ( [ (X, U) ~> U' ] X0 ^^ T ) by Simplify by congruence.
    rewrite <- subst_ftvar_ltvar_e by eauto.
    rewrite <- subst_ftvar_ltvar_t by eauto.
    apply H1; eauto.
  rewrite subst_ftvar_ltvar_t by assumption.
  constructor 5 with (U := [ (X, U) ~> U' ] U0); eauto with subst_aux.
Qed.

Lemma typing_subst_ltvar : forall t T A B X U U',
  typing ({A :~> X ^^ U} t) ({B ~> X ^^ U} T)
  -> ~ In X (FV_te t ++ FV_tt T)
  -> sub U' U
  -> typing ({A :~> U'} t) ({B ~> U'} T).
Proof.
  intros.
  destruct (sub_lclosed_t H1) as [? ?].
  Destruct notIn by idtac.
  replace U' with ([ (X, U)~> U'] X ^^ U) by Simplify by congruence.
  erewrite <- subst_ftvar_nochange_t with (T := T) (X := X) (U := U) (S := U')
    by eauto.
  rewrite <- subst_ftvar_ltvar_t by eauto.
  rewrite <- subst_ftvar_nochange_e with (t := t) (X := X) (T := U) (U := U')
    by eauto.
  rewrite <- subst_ftvar_ltvar_e by eauto.
  eauto using typing_sub_subst_ftvar.
Qed.

(** *** Term parameter substitution lemma
 We then prove Lemma [typing_subst_fvar] which shows that [typing] is stable
 under term parameter substitution. The proof also proceeds by induction on
 the structure of [typing] proofs. *)
Lemma typing_subst_fvar : forall t T u x U,
  typing t T ->
  typing u U ->
  typing ([(x, U) ::~> u] t) T.
Proof.
  induction 1; intros; Simplify by eauto.
  inversion e; subst; eauto.
  constructor 2 with (x :: L); eauto.
    intros; Destruct notIn by eauto.
    destruct (typing_lclosed_et H2) as [? _].
    erewrite <- subst_fvar_lvar_e by eauto.
    apply H1; eauto.
  constructor 4 with L; eauto.
    intros; Destruct notIn by eauto.
    destruct (typing_lclosed_et H2) as [? _].
    rewrite subst_ltvar_fvar_e by eauto.
    apply H1; eauto.
Qed.

Lemma typing_subst_lvar : forall a x T t u U,
  ~ In x (FV_ee t)
  -> typing ({a ::~> x ** U} t) T
  -> typing u U
  -> typing ({a ::~> u} t) T.
Proof.
  intros.
  rewrite <- subst_seq_fvar_lvar_e with (x := x) (T := U) by eauto.
  eauto using typing_subst_fvar.
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Preservation
 Preservation is straightforward to prove once we prove the substitution
 lemmas. Lemma [app_red_preservation] deals with the [red_abs] case, and
 Lemma [tapp_red_preservation] deals with the [red_tabs] case. *)
Lemma app_red_preservation : forall t0 T a U0 U1 U2 t u,
  typing t0 T ->
  t0 = tm_abs a U0 t ->
  sub T (U1 --> U2) ->
  typing u U1 ->
  typing ({a ::~> u} t) U2.
Proof.
  induction 1; intros He0 Hsub He'; inversion He0; subst.
  inversion Hsub; subst.
    set (L' := L ++ FV_ee t).
    destruct (pick_fresh L') as [x Hfresh].
    unfold L' in Hfresh; Destruct notIn by eauto.
    eapply typing_subst_lvar with (x := x); eauto.
    eapply IHtyping; eauto using sub_transitivity.
Qed.

Lemma tapp_red_preservation : forall t0 T0 A B T t U U1 U2,
  typing t0 T0
  -> t0 = tm_tabs A T t
  -> sub T0 (typ_all B U1 U2)
  -> sub U U1
  -> typing ({A :~> U} t) ({B ~> U} U2).
Proof.
  induction 1; simpl; intros He HsubD HsubA; inversion He; subst.
    inversion HsubD; subst.
    set (L' := FV_te t ++ FV_tt U2 ++ FV_tt U0 ++ L ++ L0).
    destruct (pick_fresh L') as [X Hfresh].
    unfold L' in Hfresh; Destruct notIn by eauto.
    constructor 6 with (T := {B0 ~> U} U0).
      eapply typing_subst_ltvar with (X := X); Destruct notIn by eauto.
        eauto using sub_transitivity.
      erewrite <- subst_seq_ftvar_ltvar_t with (T := U0) (X := X) by eauto.
      erewrite <- subst_seq_ftvar_ltvar_t with (T := U2) (X := X) by eauto.
      eapply sub_subst_ftvar; eauto.
    eauto using sub_transitivity.
Qed.

Lemma preservation_t : forall t T,
  typing t T ->
  forall u, red t u -> typing u T.
Proof.
  induction 1; intros u Ha; inversion Ha; subst; eauto.
  destruct (typing_lclosed_et H) as [_ Hclosed_t].
  inversion Hclosed_t.
  eapply app_red_preservation; eauto using sub_reflexivity_aux.
  destruct (typing_lclosed_et H) as [_ Hclosed_t].
  inversion Hclosed_t; subst.
  eapply tapp_red_preservation; eauto using sub_reflexivity_aux.
Qed.

(** To guarantee the soundness, we additionally show that reduction does
 not introduce new parameters. *)
Lemma FV_ee_sum : forall t u x,
  incl (FV_ee ({x ::~> u} t)) (FV_ee t ++ FV_ee u).
Proof.
  induction t; intros; Simplify by eauto with v62.
    eapply incl_app; eapply incl_tran; eauto with v62.
Qed.

Lemma preservation_fv : forall t u,
  red t u -> incl (FV_ee u) (FV_ee t).
Proof.
  induction 1; intros; Simplify by eauto using FV_ee_sum with v62.
    rewrite FV_ee_nochange_ltvar; eauto with v62.
Qed.

Lemma preservation : forall t T,
  typing t T ->
  forall u, red t u -> typing u T /\ incl (FV_ee u) (FV_ee t).
Proof.
  eauto using preservation_t, preservation_fv.
Qed.
(* *************************************************************** *)

(* *************************************************************** *)
(** ** Progress
 Progress is also straightforward to prove. *)
Hint Constructors value.

(** We first show that there are canonical types for type and term
 abstraction. *)
Lemma abs_subtype_form : forall T1 T2 S,
  sub (T1 --> T2) S ->
  S = typ_top \/ exists S1 S2, S = S1 --> S2.
Proof.
  intros; inversion H; auto.
  right; exists U1 U2; auto.
Qed.

Lemma abs_typing_form : forall t a T0 t0 S,
  typing t S
  -> t = tm_abs a T0 t0
  -> S = typ_top \/ exists S0 S1, S = S0 --> S1.
Proof.
  intros; induction H; try congruence.
  right; exists T U; auto.
  intuition.
    left; subst; inversion H1; auto.
    destruct H3 as [S0 [S1 Ha]]; subst.
    eauto using abs_subtype_form.
Qed.

Lemma tabs_subtype_form : forall A T1 T2 S,
  sub (typ_all A T1 T2) S
  -> S = typ_top \/ exists B S1 S2, S = typ_all B S1 S2.
Proof.
  intros; inversion H; auto.
  right; exists B U1 U2; auto.
Qed.

Lemma tabs_typing_form : forall t A T0 t0 S,
  typing t S
  -> t = tm_tabs A T0 t0
  -> S = typ_top \/ exists A0 S0 S1, S = typ_all A0 S0 S1.
Proof.
  intros; induction H; try congruence.
  right; exists B T U; auto.
  intuition.
    left; subst; inversion H1; auto.
    destruct H3 as [A0 [S0 [S1 Ha]]]; subst.
    eauto using tabs_subtype_form.
Qed.

(** We then show that there are canonical values for arrow and all types *)
Lemma canonical_form_abs : forall t T U,
  value t
  -> typing t (T --> U)
  -> exists a T0 t0, t = tm_abs a T0 t0.
Proof.
  induction 1; simpl; intros; eauto.
  inversion H.
  assert (tm_tabs A T0 t = tm_tabs A T0 t); auto.
  destruct (tabs_typing_form H0 H4).
    subst; inversion H1.
    destruct H5 as [A0 [S0 [S1 Hb]]]; subst.
    inversion H1.
Qed.

Lemma canonical_form_tabs : forall t A T U,
  value t
  -> typing t (typ_all A T U)
  -> exists A0 T0 t0, t = tm_tabs A0 T0 t0.
Proof.
  induction 1; simpl; intros; eauto.
  inversion H.
  assert (tm_abs a T0 t = tm_abs a T0 t); auto.
  destruct (abs_typing_form H0 H4).
    subst; inversion H1.
    destruct H5 as [S0 [S1 Hb]]; subst.
    inversion H1.
Qed.

(** Finally, we show that a well-typed term is never stuck: either it is
 a value, or it can reduce. The proof proceeds by simple induction on the
 typing relation, and exploits the canonical forms of values for arrow and
 all types. *)
Lemma progress : forall t T,
  typing t T ->
  FV_ee t = emptyset ->
  value t \/ exists u, red t u.
Proof.
  induction 1; simpl; intro Hve; try congruence; auto.
  assert (FV_ee t = emptyset) by firstorder using app_eq_nil.
  assert (FV_ee t' = emptyset) by firstorder using app_eq_nil.
  destruct (IHtyping1 H1).
    destruct (IHtyping2 H2).
      destruct (canonical_form_abs H3 H) as [a0 [T0 [t0 ?]]]; subst.
      right; eauto.
      destruct H4 as [t'0 ?].
      right; exists (tm_app t t'0); auto.
    destruct H3 as [t'' ?].
    right; exists (tm_app t'' t'); auto.
  destruct (IHtyping Hve).
    destruct (canonical_form_tabs H1 H) as [A0 [T0 [t0 ?]]]; subst.
    right; eauto.
    destruct H1 as [t'0 ?].
    right; exists (tm_tapp t'0 T); auto.
Qed.
(* *************************************************************** *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export BinNums.
Require Import BinPos RelationClasses Morphisms Setoid
 Equalities OrdersFacts GenericMinMax Bool NAxioms NMaxMin NProperties.
Require BinNatDef.

(**********************************************************************)
(** * Binary natural numbers, operations and properties *)
(**********************************************************************)

(** The type [N] and its constructors [N0] and [Npos] are now
    defined in [BinNums.v] *)

(** Every definitions and properties about binary natural numbers
    are placed in a module [N] for qualification purpose. *)

Local Open Scope N_scope.

(** Every definitions and early properties about positive numbers
    are placed in a module [N] for qualification purpose. *)

Module N
 <: NAxiomsSig
 <: UsualOrderedTypeFull
 <: UsualDecidableTypeFull
 <: TotalOrder.

(** Definitions of operations, now in a separate file *)

Include BinNatDef.N.

(** When including property functors, only inline t eq zero one two *)

Set Inline Level 30.

(** Logical predicates *)

Definition eq := @Logic.eq N.
Definition eq_equiv := @eq_equivalence N.

Definition lt x y := (x ?= y) = Lt.
Definition gt x y := (x ?= y) = Gt.
Definition le x y := (x ?= y) <> Gt.
Definition ge x y := (x ?= y) <> Lt.

Infix "<=" := le : N_scope.
Infix "<" := lt : N_scope.
Infix ">=" := ge : N_scope.
Infix ">" := gt : N_scope.

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

Definition divide p q := exists r, q = r*p.
Notation "( p | q )" := (divide p q) (at level 0) : N_scope.

Definition Even n := exists m, n = 2*m.
Definition Odd n := exists m, n = 2*m+1.

(** Proofs of morphisms, obvious since eq is Leibniz *)

Local Obligation Tactic := simpl_relation.
Program Definition succ_wd : Proper (eq==>eq) succ := _.
Program Definition pred_wd : Proper (eq==>eq) pred := _.
Program Definition add_wd : Proper (eq==>eq==>eq) add := _.
Program Definition sub_wd : Proper (eq==>eq==>eq) sub := _.
Program Definition mul_wd : Proper (eq==>eq==>eq) mul := _.
Program Definition lt_wd : Proper (eq==>eq==>iff) lt := _.
Program Definition div_wd : Proper (eq==>eq==>eq) div := _.
Program Definition mod_wd : Proper (eq==>eq==>eq) modulo := _.
Program Definition pow_wd : Proper (eq==>eq==>eq) pow := _.
Program Definition testbit_wd : Proper (eq==>eq==>Logic.eq) testbit := _.

(** Decidability of equality. *)

Definition eq_dec : forall n m : N, { n = m } + { n <> m }.
Proof.
 decide equality.
 apply Pos.eq_dec.
Defined.

(** Discrimination principle *)

Definition discr n : { p:positive | n = pos p } + { n = 0 }.
Proof.
 destruct n; auto.
 left; exists p; auto.
Defined.

(** Convenient induction principles *)

Definition binary_rect (P:N -> Type) (f0 : P 0)
  (f2 : forall n, P n -> P (double n))
  (fS2 : forall n, P n -> P (succ_double n)) (n : N) : P n :=
 let P' p := P (pos p) in
 let f2' p := f2 (pos p) in
 let fS2' p := fS2 (pos p) in
 match n with
 | 0 => f0
 | pos p => positive_rect P' fS2' f2' (fS2 0 f0) p
 end.

Definition binary_rec (P:N -> Set) := binary_rect P.
Definition binary_ind (P:N -> Prop) := binary_rect P.

(** Peano induction on binary natural numbers *)

Definition peano_rect
  (P : N -> Type) (f0 : P 0)
    (f : forall n : N, P n -> P (succ n)) (n : N) : P n :=
let P' p := P (pos p) in
let f' p := f (pos p) in
match n with
| 0 => f0
| pos p => Pos.peano_rect P' (f 0 f0) f' p
end.

Theorem peano_rect_base P a f : peano_rect P a f 0 = a.
Proof.
reflexivity.
Qed.

Theorem peano_rect_succ P a f n :
 peano_rect P a f (succ n) = f n (peano_rect P a f n).
Proof.
destruct n; simpl.
trivial.
now rewrite Pos.peano_rect_succ.
Qed.

Definition peano_ind (P : N -> Prop) := peano_rect P.

Definition peano_rec (P : N -> Set) := peano_rect P.

Theorem peano_rec_base P a f : peano_rec P a f 0 = a.
Proof.
apply peano_rect_base.
Qed.

Theorem peano_rec_succ P a f n :
 peano_rec P a f (succ n) = f n (peano_rec P a f n).
Proof.
apply peano_rect_succ.
Qed.

(** Generic induction / recursion *)

Theorem bi_induction :
  forall A : N -> Prop, Proper (Logic.eq==>iff) A ->
    A 0 -> (forall n, A n <-> A (succ n)) -> forall n : N, A n.
Proof.
intros A A_wd A0 AS. apply peano_rect. assumption. intros; now apply -> AS.
Qed.

Definition recursion {A} : A -> (N -> A -> A) -> N -> A :=
  peano_rect (fun _ => A).

Instance recursion_wd {A} (Aeq : relation A) :
 Proper (Aeq==>(Logic.eq==>Aeq==>Aeq)==>Logic.eq==>Aeq) recursion.
Proof.
intros a a' Ea f f' Ef x x' Ex. subst x'.
induction x using peano_ind.
trivial.
unfold recursion in *. rewrite 2 peano_rect_succ. now apply Ef.
Qed.

Theorem recursion_0 {A} (a:A) (f:N->A->A) : recursion a f 0 = a.
Proof. reflexivity. Qed.

Theorem recursion_succ {A} (Aeq : relation A) (a : A) (f : N -> A -> A):
 Aeq a a -> Proper (Logic.eq==>Aeq==>Aeq) f ->
  forall n : N, Aeq (recursion a f (succ n)) (f n (recursion a f n)).
Proof.
unfold recursion; intros a_wd f_wd n. induction n using peano_ind.
rewrite peano_rect_succ. now apply f_wd.
rewrite !peano_rect_succ in *. now apply f_wd.
Qed.

(** Specification of constants *)

Lemma one_succ : 1 = succ 0.
Proof. reflexivity. Qed.

Lemma two_succ : 2 = succ 1.
Proof. reflexivity. Qed.

Definition pred_0 : pred 0 = 0.
Proof. reflexivity. Qed.

(** Properties of mixed successor and predecessor. *)

Lemma pos_pred_spec p : Pos.pred_N p = pred (pos p).
Proof.
 now destruct p.
Qed.

Lemma succ_pos_spec n : pos (succ_pos n) = succ n.
Proof.
 now destruct n.
Qed.

Lemma pos_pred_succ n : Pos.pred_N (succ_pos n) = n.
Proof.
 destruct n. trivial. apply Pos.pred_N_succ.
Qed.

Lemma succ_pos_pred p : succ (Pos.pred_N p) = pos p.
Proof.
 destruct p; simpl; trivial. f_equal. apply Pos.succ_pred_double.
Qed.

(** Properties of successor and predecessor *)

Theorem pred_succ n : pred (succ n) = n.
Proof.
destruct n; trivial. simpl. apply Pos.pred_N_succ.
Qed.

Theorem pred_sub n : pred n = sub n 1.
Proof.
 now destruct n as [|[p|p|]].
Qed.

Theorem succ_0_discr n : succ n <> 0.
Proof.
now destruct n.
Qed.

(** Specification of addition *)

Theorem add_0_l n : 0 + n = n.
Proof.
reflexivity.
Qed.

Theorem add_succ_l n m : succ n + m = succ (n + m).
Proof.
destruct n, m; unfold succ, add; now rewrite ?Pos.add_1_l, ?Pos.add_succ_l.
Qed.

(** Specification of subtraction. *)

Theorem sub_0_r n : n - 0 = n.
Proof.
now destruct n.
Qed.

Theorem sub_succ_r n m : n - succ m = pred (n - m).
Proof.
destruct n as [|p], m as [|q]; trivial.
now destruct p.
simpl. rewrite Pos.sub_mask_succ_r, Pos.sub_mask_carry_spec.
now destruct (Pos.sub_mask p q) as [|[r|r|]|].
Qed.

(** Specification of multiplication *)

Theorem mul_0_l n : 0 * n = 0.
Proof.
reflexivity.
Qed.

Theorem mul_succ_l n m : (succ n) * m = n * m + m.
Proof.
destruct n, m; simpl; trivial. f_equal. rewrite Pos.add_comm.
apply Pos.mul_succ_l.
Qed.

(** Specification of boolean comparisons. *)

Lemma eqb_eq n m : eqb n m = true <-> n=m.
Proof.
destruct n as [|n], m as [|m]; simpl; try easy'.
rewrite Pos.eqb_eq. split; intro H. now subst. now destr_eq H.
Qed.

Lemma ltb_lt n m : (n <? m) = true <-> n < m.
Proof.
  unfold ltb, lt. destruct compare; easy'.
Qed.

Lemma leb_le n m : (n <=? m) = true <-> n <= m.
Proof.
  unfold leb, le. destruct compare; easy'.
Qed.

(** Basic properties of comparison *)

Theorem compare_eq_iff n m : (n ?= m) = Eq <-> n = m.
Proof.
destruct n, m; simpl; rewrite ?Pos.compare_eq_iff; split; congruence.
Qed.

Theorem compare_lt_iff n m : (n ?= m) = Lt <-> n < m.
Proof.
reflexivity.
Qed.

Theorem compare_le_iff n m : (n ?= m) <> Gt <-> n <= m.
Proof.
reflexivity.
Qed.

Theorem compare_antisym n m : (m ?= n) = CompOpp (n ?= m).
Proof.
destruct n, m; simpl; trivial. apply Pos.compare_antisym.
Qed.

(** Some more advanced properties of comparison and orders,
    including [compare_spec] and [lt_irrefl] and [lt_eq_cases]. *)

Include BoolOrderFacts.

(** Specification of minimum and maximum *)

Theorem min_l n m : n <= m -> min n m = n.
Proof.
unfold min, le. case compare; trivial. now destruct 1.
Qed.

Theorem min_r n m : m <= n -> min n m = m.
Proof.
unfold min, le. rewrite compare_antisym.
case compare_spec; trivial. now destruct 2.
Qed.

Theorem max_l n m : m <= n -> max n m = n.
Proof.
unfold max, le. rewrite compare_antisym.
case compare_spec; auto. now destruct 2.
Qed.

Theorem max_r n m : n <= m -> max n m = m.
Proof.
unfold max, le. case compare; trivial. now destruct 1.
Qed.

(** Specification of lt and le. *)

Lemma lt_succ_r n m : n < succ m <-> n<=m.
Proof.
destruct n as [|p], m as [|q]; simpl; try easy'.
split. now destruct p. now destruct 1.
apply Pos.lt_succ_r.
Qed.

(** We can now derive all properties of basic functions and orders,
    and use these properties for proving the specs of more advanced
    functions. *)

Include NBasicProp <+ UsualMinMaxLogicalProperties <+ UsualMinMaxDecProperties.

(** Properties of [double] and [succ_double] *)

Lemma double_spec n : double n = 2 * n.
Proof.
 reflexivity.
Qed.

Lemma succ_double_spec n : succ_double n = 2 * n + 1.
Proof.
 now destruct n.
Qed.

Lemma double_add n m : double (n+m) = double n + double m.
Proof.
 now destruct n, m.
Qed.

Lemma succ_double_add n m : succ_double (n+m) = double n + succ_double m.
Proof.
 now destruct n, m.
Qed.

Lemma double_mul n m : double (n*m) = double n * m.
Proof.
 now destruct n, m.
Qed.

Lemma succ_double_mul n m :
 succ_double n * m = double n * m + m.
Proof.
 destruct n; simpl; destruct m; trivial.
 now rewrite Pos.add_comm.
Qed.

Lemma div2_double n : div2 (double n) = n.
Proof.
now destruct n.
Qed.

Lemma div2_succ_double n : div2 (succ_double n) = n.
Proof.
now destruct n.
Qed.

Lemma double_inj n m : double n = double m -> n = m.
Proof.
intro H. rewrite <- (div2_double n), H. apply div2_double.
Qed.

Lemma succ_double_inj n m : succ_double n = succ_double m -> n = m.
Proof.
intro H. rewrite <- (div2_succ_double n), H. apply div2_succ_double.
Qed.

Lemma succ_double_lt n m : n<m -> succ_double n < double m.
Proof.
 destruct n as [|n], m as [|m]; intros H; try easy.
 unfold lt in *; simpl in *. now rewrite Pos.compare_xI_xO, H.
Qed.

(** 0 is the least natural number *)

Theorem compare_0_r n : (n ?= 0) <> Lt.
Proof.
now destruct n.
Qed.

(** Specifications of power *)

Lemma pow_0_r n : n ^ 0 = 1.
Proof. reflexivity. Qed.

Lemma pow_succ_r n p : 0<=p -> n^(succ p) = n * n^p.
Proof.
 intros _.
 destruct n, p; simpl; trivial; f_equal. apply Pos.pow_succ_r.
Qed.

Lemma pow_neg_r n p : p<0 -> n^p = 0.
Proof.
 now destruct p.
Qed.

(** Specification of square *)

Lemma square_spec n : square n = n * n.
Proof.
 destruct n; trivial. simpl. f_equal. apply Pos.square_spec.
Qed.

(** Specification of Base-2 logarithm *)

Lemma size_log2 n : n<>0 -> size n = succ (log2 n).
Proof.
 destruct n as [|[n|n| ]]; trivial. now destruct 1.
Qed.

Lemma size_gt n : n < 2^(size n).
Proof.
 destruct n. reflexivity. simpl. apply Pos.size_gt.
Qed.

Lemma size_le n : 2^(size n) <= succ_double n.
Proof.
 destruct n. discriminate. simpl.
 change (2^Pos.size p <= Pos.succ (p~0))%positive.
 apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le.
Qed.

Lemma log2_spec n : 0 < n ->
 2^(log2 n) <= n < 2^(succ (log2 n)).
Proof.
 destruct n as [|[p|p|]]; discriminate || intros _; simpl; split.
 apply (size_le (pos p)).
 apply Pos.size_gt.
 apply Pos.size_le.
 apply Pos.size_gt.
 discriminate.
 reflexivity.
Qed.

Lemma log2_nonpos n : n<=0 -> log2 n = 0.
Proof.
 destruct n; intros Hn. reflexivity. now destruct Hn.
Qed.

(** Specification of parity functions *)

Lemma even_spec n : even n = true <-> Even n.
Proof.
 destruct n.
 split. now exists 0.
 trivial.
 destruct p; simpl; split; try easy.
 intros (m,H). now destruct m.
 now exists (pos p).
 intros (m,H). now destruct m.
Qed.

Lemma odd_spec n : odd n = true <-> Odd n.
Proof.
 destruct n.
 split. discriminate.
 intros (m,H). now destruct m.
 destruct p; simpl; split; try easy.
 now exists (pos p).
 intros (m,H). now destruct m.
 now exists 0.
Qed.

(** Specification of the euclidean division *)

Theorem pos_div_eucl_spec (a:positive)(b:N) :
  let (q,r) := pos_div_eucl a b in pos a = q * b + r.
Proof.
  induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta.
  (* a~1 *)
  destruct pos_div_eucl as (q,r).
  change (pos a~1) with (succ_double (pos a)).
  rewrite IHa, succ_double_add, double_mul.
  case leb_spec; intros H; trivial.
  rewrite succ_double_mul, <- add_assoc. f_equal.
  now rewrite (add_comm b), sub_add.
  (* a~0 *)
  destruct pos_div_eucl as (q,r).
  change (pos a~0) with (double (pos a)).
  rewrite IHa, double_add, double_mul.
  case leb_spec; intros H; trivial.
  rewrite succ_double_mul, <- add_assoc. f_equal.
  now rewrite (add_comm b), sub_add.
  (* 1 *)
  now destruct b as [|[ | | ]].
Qed.

Theorem div_eucl_spec a b :
 let (q,r) := div_eucl a b in a = b * q + r.
Proof.
  destruct a as [|a], b as [|b]; unfold div_eucl; trivial.
  generalize (pos_div_eucl_spec a (pos b)).
  destruct pos_div_eucl. now rewrite mul_comm.
Qed.

Theorem div_mod' a b : a = b * (a/b) + (a mod b).
Proof.
  generalize (div_eucl_spec a b).
  unfold div, modulo. now destruct div_eucl.
Qed.

Definition div_mod a b : b<>0 -> a = b * (a/b) + (a mod b).
Proof.
 intros _. apply div_mod'.
Qed.

Theorem pos_div_eucl_remainder (a:positive) (b:N) :
  b<>0 -> snd (pos_div_eucl a b) < b.
Proof.
  intros Hb.
  induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta.
  (* a~1 *)
  destruct pos_div_eucl as (q,r); simpl in *.
  case leb_spec; intros H; simpl; trivial.
  apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial.
  destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ].
  apply (succ_double_lt _ _ IHa).
  (* a~0 *)
  destruct pos_div_eucl as (q,r); simpl in *.
  case leb_spec; intros H; simpl; trivial.
  apply add_lt_mono_l with b. rewrite add_comm, sub_add by trivial.
  destruct b as [|b]; [now destruct Hb| simpl; rewrite Pos.add_diag ].
  now destruct r.
  (* 1 *)
  destruct b as [|[ | | ]]; easy || (now destruct Hb).
Qed.

Theorem mod_lt a b : b<>0 -> a mod b < b.
Proof.
  destruct b as [ |b]. now destruct 1.
  destruct a as [ |a]. reflexivity.
  unfold modulo. simpl. apply pos_div_eucl_remainder.
Qed.

Theorem mod_bound_pos a b : 0<=a -> 0<b -> 0 <= a mod b < b.
Proof.
 intros _ H. split. apply le_0_l. apply mod_lt. now destruct b.
Qed.

(** Specification of square root *)

Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n.
Proof.
 destruct n. reflexivity.
 unfold sqrtrem, sqrt, Pos.sqrt.
 destruct (Pos.sqrtrem p) as (s,r). now destruct r.
Qed.

Lemma sqrtrem_spec n :
 let (s,r) := sqrtrem n in n = s*s + r /\ r <= 2*s.
Proof.
 destruct n. now split.
 generalize (Pos.sqrtrem_spec p). simpl.
 destruct 1; simpl; subst; now split.
Qed.

Lemma sqrt_spec n : 0<=n ->
 let s := sqrt n in s*s <= n < (succ s)*(succ s).
Proof.
 intros _. destruct n. now split. apply (Pos.sqrt_spec p).
Qed.

Lemma sqrt_neg n : n<0 -> sqrt n = 0.
Proof.
 now destruct n.
Qed.

(** Specification of gcd *)

(** The first component of ggcd is gcd *)

Lemma ggcd_gcd a b : fst (ggcd a b) = gcd a b.
Proof.
 destruct a as [|p], b as [|q]; simpl; auto.
 assert (H := Pos.ggcd_gcd p q).
 destruct Pos.ggcd as (g,(aa,bb)); simpl; now f_equal.
Qed.

(** The other components of ggcd are indeed the correct factors. *)

Lemma ggcd_correct_divisors a b :
  let '(g,(aa,bb)) := ggcd a b in
  a=g*aa /\ b=g*bb.
Proof.
 destruct a as [|p], b as [|q]; simpl; auto.
 now rewrite Pos.mul_1_r.
 now rewrite Pos.mul_1_r.
 generalize (Pos.ggcd_correct_divisors p q).
 destruct Pos.ggcd as (g,(aa,bb)); simpl.
 destruct 1; split; now f_equal.
Qed.

(** We can use this fact to prove a part of the gcd correctness *)

Lemma gcd_divide_l a b : (gcd a b | a).
Proof.
 rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b).
 destruct ggcd as (g,(aa,bb)); simpl. intros (H,_). exists aa.
  now rewrite mul_comm.
Qed.

Lemma gcd_divide_r a b : (gcd a b | b).
Proof.
 rewrite <- ggcd_gcd. generalize (ggcd_correct_divisors a b).
 destruct ggcd as (g,(aa,bb)); simpl. intros (_,H). exists bb.
  now rewrite mul_comm.
Qed.

(** We now prove directly that gcd is the greatest amongst common divisors *)

Lemma gcd_greatest a b c : (c|a) -> (c|b) -> (c|gcd a b).
Proof.
 destruct a as [ |p], b as [ |q]; simpl; trivial.
 destruct c as [ |r]. intros (s,H). destruct s; discriminate.
 intros ([ |s],Hs) ([ |t],Ht); try discriminate; simpl in *.
 destruct (Pos.gcd_greatest p q r) as (u,H).
 exists s. now inversion Hs.
 exists t. now inversion Ht.
 exists (pos u). simpl; now f_equal.
Qed.

Lemma gcd_nonneg a b : 0 <= gcd a b.
Proof. apply le_0_l. Qed.

(** Specification of bitwise functions *)

(** Correctness proofs for [testbit]. *)

Lemma testbit_even_0 a : testbit (2*a) 0 = false.
Proof.
 now destruct a.
Qed.

Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true.
Proof.
 now destruct a.
Qed.

Lemma testbit_succ_r_div2 a n : 0<=n ->
 testbit a (succ n) = testbit (div2 a) n.
Proof.
 intros _. destruct a as [|[a|a| ]], n as [|n]; simpl; trivial;
  f_equal; apply Pos.pred_N_succ.
Qed.

Lemma testbit_odd_succ a n : 0<=n ->
 testbit (2*a+1) (succ n) = testbit a n.
Proof.
 intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a.
Qed.

Lemma testbit_even_succ a n : 0<=n ->
 testbit (2*a) (succ n) = testbit a n.
Proof.
 intros H. rewrite testbit_succ_r_div2 by trivial. f_equal. now destruct a.
Qed.

Lemma testbit_neg_r a n : n<0 -> testbit a n = false.
Proof.
 now destruct n.
Qed.

(** Correctness proofs for shifts *)

Lemma shiftr_succ_r a n :
 shiftr a (succ n) = div2 (shiftr a n).
Proof.
 destruct n; simpl; trivial. apply Pos.iter_succ.
Qed.

Lemma shiftl_succ_r a n :
 shiftl a (succ n) = double (shiftl a n).
Proof.
 destruct n, a; simpl; trivial. f_equal. apply Pos.iter_succ.
Qed.

Lemma shiftr_spec a n m : 0<=m ->
 testbit (shiftr a n) m = testbit a (m+n).
Proof.
 intros _. revert a m.
 induction n using peano_ind; intros a m. now rewrite add_0_r.
 rewrite add_comm, add_succ_l, add_comm, <- add_succ_l.
 now rewrite <- IHn, testbit_succ_r_div2, shiftr_succ_r by apply le_0_l.
Qed.

Lemma shiftl_spec_high a n m : 0<=m -> n<=m ->
 testbit (shiftl a n) m = testbit a (m-n).
Proof.
 intros _ H.
 rewrite <- (sub_add n m H) at 1.
 set (m' := m-n). clearbody m'. clear H m. revert a m'.
 induction n using peano_ind; intros a m.
 rewrite add_0_r; now destruct a.
 rewrite shiftl_succ_r.
 rewrite add_comm, add_succ_l, add_comm.
 now rewrite testbit_succ_r_div2, div2_double by apply le_0_l.
Qed.

Lemma shiftl_spec_low a n m : m<n ->
 testbit (shiftl a n) m = false.
Proof.
 revert a m.
 induction n using peano_ind; intros a m H.
 elim (le_0_l m). now rewrite compare_antisym, H.
 rewrite shiftl_succ_r.
 destruct m. now destruct (shiftl a n).
 rewrite <- (succ_pos_pred p), testbit_succ_r_div2, div2_double by apply le_0_l.
 apply IHn.
 apply add_lt_mono_l with 1. rewrite 2 (add_succ_l 0). simpl.
 now rewrite succ_pos_pred.
Qed.

Definition div2_spec a : div2 a = shiftr a 1.
Proof.
 reflexivity.
Qed.

(** Semantics of bitwise operations *)

Lemma pos_lxor_spec p p' n :
 testbit (Pos.lxor p p') n = xorb (Pos.testbit p n) (Pos.testbit p' n).
Proof.
 revert p' n.
 induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl;
 (specialize (IH p'); destruct Pos.lxor; trivial; now rewrite <-IH) ||
 (now destruct Pos.testbit).
Qed.

Lemma lxor_spec a a' n :
 testbit (lxor a a') n = xorb (testbit a n) (testbit a' n).
Proof.
 destruct a, a'; simpl; trivial.
 now destruct Pos.testbit.
 now destruct Pos.testbit.
 apply pos_lxor_spec.
Qed.

Lemma pos_lor_spec p p' n :
 Pos.testbit (Pos.lor p p') n = (Pos.testbit p n) || (Pos.testbit p' n).
Proof.
 revert p' n.
 induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl;
  apply IH || now rewrite orb_false_r.
Qed.

Lemma lor_spec a a' n :
 testbit (lor a a') n = (testbit a n) || (testbit a' n).
Proof.
 destruct a, a'; simpl; trivial.
 now rewrite orb_false_r.
 apply pos_lor_spec.
Qed.

Lemma pos_land_spec p p' n :
 testbit (Pos.land p p') n = (Pos.testbit p n) && (Pos.testbit p' n).
Proof.
 revert p' n.
 induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl;
 (specialize (IH p'); destruct Pos.land; trivial; now rewrite <-IH) ||
 (now rewrite andb_false_r).
Qed.

Lemma land_spec a a' n :
 testbit (land a a') n = (testbit a n) && (testbit a' n).
Proof.
 destruct a, a'; simpl; trivial.
 now rewrite andb_false_r.
 apply pos_land_spec.
Qed.

Lemma pos_ldiff_spec p p' n :
 testbit (Pos.ldiff p p') n = (Pos.testbit p n) && negb (Pos.testbit p' n).
Proof.
 revert p' n.
 induction p as [p IH|p IH|]; intros [p'|p'|] [|n]; trivial; simpl;
 (specialize (IH p'); destruct Pos.ldiff; trivial; now rewrite <-IH) ||
 (now rewrite andb_true_r).
Qed.

Lemma ldiff_spec a a' n :
 testbit (ldiff a a') n = (testbit a n) && negb (testbit a' n).
Proof.
 destruct a, a'; simpl; trivial.
 now rewrite andb_true_r.
 apply pos_ldiff_spec.
Qed.

(** Instantiation of generic properties of advanced functions
    (pow, sqrt, log2, div, gcd, ...) *)

Include NExtraProp.

(** In generic statements, the predicates [lt] and [le] have been
  favored, whereas [gt] and [ge] don't even exist in the abstract
  layers. The use of [gt] and [ge] is hence not recommended. We provide
  here the bare minimal results to related them with [lt] and [le]. *)

Lemma gt_lt_iff n m : n > m <-> m < n.
Proof.
 unfold lt, gt. now rewrite compare_antisym, CompOpp_iff.
Qed.

Lemma gt_lt n m : n > m -> m < n.
Proof.
 apply gt_lt_iff.
Qed.

Lemma lt_gt n m : n < m -> m > n.
Proof.
 apply gt_lt_iff.
Qed.

Lemma ge_le_iff n m : n >= m <-> m <= n.
Proof.
 unfold le, ge. now rewrite compare_antisym, CompOpp_iff.
Qed.

Lemma ge_le n m : n >= m -> m <= n.
Proof.
 apply ge_le_iff.
Qed.

Lemma le_ge n m : n <= m -> m >= n.
Proof.
 apply ge_le_iff.
Qed.

(** Auxiliary results about right shift on positive numbers,
    used in BinInt *)

Lemma pos_pred_shiftl_low : forall p n m, m<n ->
 testbit (Pos.pred_N (Pos.shiftl p n)) m = true.
Proof.
 induction n using peano_ind.
 now destruct m.
 intros m H. unfold Pos.shiftl.
 destruct n as [|n]; simpl in *.
 destruct m. now destruct p. elim (Pos.nlt_1_r _ H).
 rewrite Pos.iter_succ. simpl.
 set (u:=Pos.iter xO p n) in *; clearbody u.
 destruct m as [|m]. now destruct u.
 rewrite <- (IHn (Pos.pred_N m)).
 rewrite <- (testbit_odd_succ _ (Pos.pred_N m)).
 rewrite succ_pos_pred. now destruct u.
 apply le_0_l.
 apply succ_lt_mono. now rewrite succ_pos_pred.
Qed.

Lemma pos_pred_shiftl_high : forall p n m, n<=m ->
 testbit (Pos.pred_N (Pos.shiftl p n)) m =
 testbit (shiftl (Pos.pred_N p) n) m.
Proof.
 induction n using peano_ind; intros m H.
 unfold shiftl. simpl. now destruct (Pos.pred_N p).
 rewrite shiftl_succ_r.
 destruct n as [|n].
 destruct m as [|m]. now destruct H. now destruct p.
 destruct m as [|m]. now destruct H.
 rewrite <- (succ_pos_pred m).
 rewrite double_spec, testbit_even_succ by apply le_0_l.
 rewrite <- IHn.
 rewrite testbit_succ_r_div2 by apply le_0_l.
 f_equal. simpl. rewrite Pos.iter_succ.
 now destruct (Pos.iter xO p n).
 apply succ_le_mono. now rewrite succ_pos_pred.
Qed.

Lemma pred_div2_up p : Pos.pred_N (Pos.div2_up p) = div2 (Pos.pred_N p).
Proof.
 destruct p as [p|p| ]; trivial.
 simpl. apply Pos.pred_N_succ.
 destruct p; simpl; trivial.
Qed.

End N.

Bind Scope N_scope with N.t N.

(** Exportation of notations *)

Infix "+" := N.add : N_scope.
Infix "-" := N.sub : N_scope.
Infix "*" := N.mul : N_scope.
Infix "^" := N.pow : N_scope.

Infix "?=" := N.compare (at level 70, no associativity) : N_scope.

Infix "<=" := N.le : N_scope.
Infix "<" := N.lt : N_scope.
Infix ">=" := N.ge : N_scope.
Infix ">" := N.gt : N_scope.

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

Infix "=?" := N.eqb (at level 70, no associativity) : N_scope.
Infix "<=?" := N.leb (at level 70, no associativity) : N_scope.
Infix "<?" := N.ltb (at level 70, no associativity) : N_scope.

Infix "/" := N.div : N_scope.
Infix "mod" := N.modulo (at level 40, no associativity) : N_scope.

Notation "( p | q )" := (N.divide p q) (at level 0) : N_scope.

(** Compatibility notations *)

Notation N_rect := N_rect (only parsing).
Notation N_rec := N_rec (only parsing).
Notation N_ind := N_ind (only parsing).
Notation N0 := N0 (only parsing).
Notation Npos := N.pos (only parsing).

Notation Ndiscr := N.discr (compat "8.6").
Notation Ndouble_plus_one := N.succ_double (only parsing).
Notation Ndouble := N.double (compat "8.6").
Notation Nsucc := N.succ (compat "8.6").
Notation Npred := N.pred (compat "8.6").
Notation Nsucc_pos := N.succ_pos (compat "8.6").
Notation Ppred_N := Pos.pred_N (compat "8.6").
Notation Nplus := N.add (only parsing).
Notation Nminus := N.sub (only parsing).
Notation Nmult := N.mul (only parsing).
Notation Neqb := N.eqb (compat "8.6").
Notation Ncompare := N.compare (compat "8.6").
Notation Nlt := N.lt (compat "8.6").
Notation Ngt := N.gt (compat "8.6").
Notation Nle := N.le (compat "8.6").
Notation Nge := N.ge (compat "8.6").
Notation Nmin := N.min (compat "8.6").
Notation Nmax := N.max (compat "8.6").
Notation Ndiv2 := N.div2 (compat "8.6").
Notation Neven := N.even (compat "8.6").
Notation Nodd := N.odd (compat "8.6").
Notation Npow := N.pow (compat "8.6").
Notation Nlog2 := N.log2 (compat "8.6").

Notation nat_of_N := N.to_nat (only parsing).
Notation N_of_nat := N.of_nat (only parsing).
Notation N_eq_dec := N.eq_dec (compat "8.6").
Notation Nrect := N.peano_rect (only parsing).
Notation Nrect_base := N.peano_rect_base (only parsing).
Notation Nrect_step := N.peano_rect_succ (only parsing).
Notation Nind := N.peano_ind (only parsing).
Notation Nrec := N.peano_rec (only parsing).
Notation Nrec_base := N.peano_rec_base (only parsing).
Notation Nrec_succ := N.peano_rec_succ (only parsing).

Notation Npred_succ := N.pred_succ (compat "8.6").
Notation Npred_minus := N.pred_sub (only parsing).
Notation Nsucc_pred := N.succ_pred (compat "8.6").
Notation Ppred_N_spec := N.pos_pred_spec (only parsing).
Notation Nsucc_pos_spec := N.succ_pos_spec (compat "8.6").
Notation Ppred_Nsucc := N.pos_pred_succ (only parsing).
Notation Nplus_0_l := N.add_0_l (only parsing).
Notation Nplus_0_r := N.add_0_r (only parsing).
Notation Nplus_comm := N.add_comm (only parsing).
Notation Nplus_assoc := N.add_assoc (only parsing).
Notation Nplus_succ := N.add_succ_l (only parsing).
Notation Nsucc_0 := N.succ_0_discr (only parsing).
Notation Nsucc_inj := N.succ_inj (compat "8.6").
Notation Nminus_N0_Nle := N.sub_0_le (only parsing).
Notation Nminus_0_r := N.sub_0_r (only parsing).
Notation Nminus_succ_r:= N.sub_succ_r (only parsing).
Notation Nmult_0_l := N.mul_0_l (only parsing).
Notation Nmult_1_l := N.mul_1_l (only parsing).
Notation Nmult_1_r := N.mul_1_r (only parsing).
Notation Nmult_comm := N.mul_comm (only parsing).
Notation Nmult_assoc := N.mul_assoc (only parsing).
Notation Nmult_plus_distr_r := N.mul_add_distr_r (only parsing).
Notation Neqb_eq := N.eqb_eq (compat "8.6").
Notation Nle_0 := N.le_0_l (only parsing).
Notation Ncompare_refl := N.compare_refl (compat "8.6").
Notation Ncompare_Eq_eq := N.compare_eq (only parsing).
Notation Ncompare_eq_correct := N.compare_eq_iff (only parsing).
Notation Nlt_irrefl := N.lt_irrefl (compat "8.6").
Notation Nlt_trans := N.lt_trans (compat "8.6").
Notation Nle_lteq := N.lt_eq_cases (only parsing).
Notation Nlt_succ_r := N.lt_succ_r (compat "8.6").
Notation Nle_trans := N.le_trans (compat "8.6").
Notation Nle_succ_l := N.le_succ_l (compat "8.6").
Notation Ncompare_spec := N.compare_spec (compat "8.6").
Notation Ncompare_0 := N.compare_0_r (only parsing).
Notation Ndouble_div2 := N.div2_double (only parsing).
Notation Ndouble_plus_one_div2 := N.div2_succ_double (only parsing).
Notation Ndouble_inj := N.double_inj (compat "8.6").
Notation Ndouble_plus_one_inj := N.succ_double_inj (only parsing).
Notation Npow_0_r := N.pow_0_r (compat "8.6").
Notation Npow_succ_r := N.pow_succ_r (compat "8.6").
Notation Nlog2_spec := N.log2_spec (compat "8.6").
Notation Nlog2_nonpos := N.log2_nonpos (compat "8.6").
Notation Neven_spec := N.even_spec (compat "8.6").
Notation Nodd_spec := N.odd_spec (compat "8.6").
Notation Nlt_not_eq := N.lt_neq (only parsing).
Notation Ngt_Nlt := N.gt_lt (only parsing).

(** More complex compatibility facts, expressed as lemmas
    (to preserve scopes for instance) *)

Lemma Nplus_reg_l n m p : n + m = n + p -> m = p.
Proof (proj1 (N.add_cancel_l m p n)).
Lemma Nmult_Sn_m n m : N.succ n * m = m + n * m.
Proof (eq_trans (N.mul_succ_l n m) (N.add_comm _ _)).
Lemma Nmult_plus_distr_l n m p : p * (n + m) = p * n + p * m.
Proof (N.mul_add_distr_l p n m).
Lemma Nmult_reg_r n m p : p <> 0 -> n * p = m * p -> n = m.
Proof (fun H => proj1 (N.mul_cancel_r n m p H)).
Lemma Ncompare_antisym n m : CompOpp (n ?= m) = (m ?= n).
Proof (eq_sym (N.compare_antisym n m)).

Definition N_ind_double a P f0 f2 fS2 := N.binary_ind P f0 f2 fS2 a.
Definition N_rec_double a P f0 f2 fS2 := N.binary_rec P f0 f2 fS2 a.

(** Not kept : Ncompare_n_Sm Nplus_lt_cancel_l *)


(** * Use propositional truncation to construct an interval

Martin Escardo's version in Agda is
%\href{http://www.cs.bham.ac.uk/~mhe/truncation-and-extensionality/hsetfunext.html#6060}{here}.%
#here.# *)

Unset Automatic Introduction.
Require Import Foundations.hlevel1.hProp.
Notation "a == b" := (paths a b) (at level 70, no associativity).
Notation "! p " := (pathsinv0 p) (at level 50).

Definition bool_map {Y} := bool_rect (fun _ => Y) : Y -> Y -> bool -> Y.

(** ** The definition of the interval

We define the interval as the propositional truncation of [bool]. *)

Definition interval := ishinh bool.
Definition left := hinhpr _ true : interval.
Definition right := hinhpr _ false : interval.
Definition interval_path : left == right.
Proof. apply (pr2 (ishinh _)). Defined.
Definition interval_map {Y} {y y':Y} : y == y' -> interval -> Y.
Proof.
  intros ? ? ? e h.
  set (f := bool_map y y').
  set (q := fun y => y == f false).
  exact (pr1 (h (hProppair (coconustot Y (f false))
                           (isapropifcontr (iscontrcoconustot _ _)))
                (fun v =>
                  tpair _ (f v)
                        (bool_rect (funcomp f q) e (idpath _) v)))).
Defined.

(** We verify some computations are judgmental. *)

Goal forall Y (y y':Y) (e:y == y'), interval_map e left == y.
Proof. reflexivity. Qed.

Goal forall Y (y y':Y) (e:y == y'), interval_map e right == y'.
Proof. reflexivity. Qed.

Goal forall Y (y y':Y) (e:y == y'),
       funcomp (hinhpr _) (interval_map e) == bool_map y y'.
Proof. reflexivity. Qed.

(* next task, for completeness:

Goal forall Y (y y':Y) (e:y == y'),
       maponpaths (interval_map e) interval_path == e.

*)

(** ** Functional extensionality for sections using the interval *)

Definition funextsec2 X (Y:X->Type) (f g:forall x,Y x) :
           (forall x, f x==g x) -> f == g.
Proof. intros ? ? ? ? e.
  exact (maponpaths (fun h x => interval_map (e x) h) interval_path). Defined.

(**    Notice that [ishinh] depends on [funextfunax],
       so we don't get something for nothing, but this is
       a quick way of deducing [funextsec] from [funextfunax].

       The proof above depends also on eta-reduction.  Without it,
       the conclusion must be weakened to (fun x => f x) == (fun x => g x)
*)


From mathcomp Require Import ssreflect ssrfun ssrbool ssrint eqtype ssrnat seq choice fintype rat finfun.
From mathcomp Require Import bigop ssralg div ssrnum ssrint.
Open Scope R.
Import GRing.Theory.
Import Num.Theory.

Definition Qnneg := [qualify a x : rat | 0 <= x].
Lemma Qnneg_def x : (x \is a Qnneg) = (0 <= x).
  done.
Qed.

Fact Qnneg_key : pred_key Qnneg. done. Qed.
Canonical Qnneg_keyed := KeyedQualifier Qnneg_key.

Section PosRatDef.
  Record posrat :=
    Posrat {
        mprat :> rat;
        _ : mprat \is a Qnneg}.

  Canonical Structure posratSub := [subType for mprat].
    Definition pEqmix := [eqMixin of posrat by <:].
    Canonical Structure pEqtype := EqType posrat pEqmix.
    Definition pChoicemix := [choiceMixin of posrat by <: ].
    Canonical pChoisetype := ChoiceType posrat pChoicemix.
    Canonical pCountmix := [countMixin of posrat by <: ].
    Canonical PCount := CountType posrat pCountmix.
End PosRatDef.

Definition padd_ (a b : posrat) : posrat.
  destruct a,b.
  econstructor.
  instantiate (1 := mprat0 + mprat1).
  apply Num.Theory.addr_ge0; done.
Defined.

Definition padd a b := locked (padd_ a b).

Definition pmul_ (a b : posrat) : posrat.
  destruct a,b.
  econstructor.
  instantiate (1 := mprat0 * mprat1).
  apply Num.Theory.mulr_ge0; done.
Defined.

Definition pmul a b := locked (pmul_ a b).

Lemma pmulrA : @associative posrat pmul.
  unlock pmul.
move=> x y z; apply/eqP; rewrite /pmul /eq_op //=; destruct x,y,z; rewrite //=; rewrite mulrA.
done.
Qed.

Lemma paddrA : @associative posrat padd.
  unlock padd.
move=> x y z; apply/eqP; rewrite /padd /eq_op //=; destruct x,y,z; rewrite //=; rewrite addrA.
done.
Qed.

Lemma pmul1r : @left_id posrat posrat (Posrat 1 is_true_true) pmul.
  unlock pmul;
move=>x; destruct x; apply/eqP; rewrite /pmul /eq_op //=; rewrite mul1r; done.
Qed.

Lemma pmulr1 : @right_id posrat posrat (Posrat 1 is_true_true) pmul.
  unlock pmul;
move=>x; destruct x; apply/eqP; rewrite /pmul /eq_op //=; rewrite mulr1; done.
Qed.

Lemma pmul0r : @left_zero posrat posrat (Posrat 0 is_true_true) pmul.
  unlock pmul;
move=>x; destruct x; apply/eqP; rewrite /pmul /eq_op //=; rewrite mul0r; done.
Qed.

Lemma pmulr0 : @right_zero posrat posrat (Posrat 0 is_true_true) pmul.
  unlock pmul;
move=>x; destruct x; apply/eqP; rewrite /pmul /eq_op //=; rewrite mulr0; done.
Qed.

Lemma padd0r : @left_id posrat posrat (Posrat 0 is_true_true) padd.
  unlock padd pmul;
move=>x; destruct x; apply/eqP; rewrite /padd /eq_op //=; rewrite add0r; done.
Qed.

Lemma paddr0 : @right_id posrat posrat (Posrat 0 is_true_true) padd.
  unlock padd pmul;
move=>x; destruct x; apply/eqP; rewrite /padd /eq_op //=; rewrite addr0; done.
Qed.

Lemma pmulrDl : @left_distributive posrat posrat pmul padd.
  unlock padd pmul;
move=> x y z; destruct x,y,z; apply/eqP; rewrite /pmul /padd /eq_op //=; rewrite mulrDl; done.
Qed.

Lemma pmulrDr : @right_distributive posrat posrat pmul padd.
  unlock padd pmul;
move=> x y z; destruct x,y,z; apply/eqP; rewrite /pmul /padd /eq_op //=; rewrite mulrDr; done.
Qed.

Lemma pmulrC : @commutative posrat posrat pmul.
  unlock padd pmul;
move=> x y; destruct x,y; apply/eqP; rewrite /pmul /eq_op //=; rewrite mulrC; done.
Qed.

Lemma paddrC : @commutative posrat posrat padd.
  unlock padd pmul;
move=> x y; destruct x,y; apply/eqP; rewrite /padd /eq_op //=; rewrite addrC; done.
Qed.

Canonical padd_monoid := Monoid.Law paddrA padd0r paddr0.
Canonical padd_comid := Monoid.ComLaw paddrC.
Canonical pmul_monoid := Monoid.Law pmulrA pmul1r pmulr1.
Canonical pmul_muloid := Monoid.MulLaw pmul0r pmulr0.
Canonical pmul_addoid := Monoid.AddLaw pmulrDl pmulrDr.
Canonical pmul_comid := Monoid.ComLaw pmulrC.

Notation "x + y" := (padd x y) : posrat_scope.
Notation "x * y" := (pmul x y) : posrat_scope.
Notation "0" := (Posrat 0 is_true_true) : posrat_scope.
Notation "1" := (Posrat 1 is_true_true) : posrat_scope.

Delimit Scope posrat_scope with PR.

Open Scope PR.
Import Monoid.Theory.

Lemma pmul0 (x y : posrat) : (x == 0) || (y == 0) = (x * y == 0).
  destruct x,y.
  apply /eqP; rewrite /eq_op //=.
  destruct (eqVneq mprat0 0).
  subst.
  apply/eqP.
  unlock pmul.
  simpl.
  rewrite mul0r; done.

  destruct (eqVneq mprat1 0).
  subst.
  unlock pmul.
  simpl; rewrite eq_refl orbT mulr0 eq_refl; done.
  Check GRing.mulf_eq0.
  have H := (GRing.mulf_eq0 mprat0 mprat1).
  rewrite (negbTE i1) in H.
  rewrite (negbTE i2) in H.
  simpl in H.
  unlock pmul.
  rewrite H.
  rewrite (negbTE i1).
  rewrite (negbTE i2).
  simpl.
  done.
Qed.

Lemma padd0 (x y : posrat) : (x == 0) && (y == 0) = (x + y == 0).
  destruct x,y.
  apply /eqP; rewrite /eq_op //=.
  destruct (eqVneq mprat0 0).
  subst.
  destruct (eqVneq mprat1 0).

  subst.
  simpl.
  unlock padd; simpl.
  rewrite add0r.
  done.
  unlock padd; simpl. rewrite (negbTE i1) add0r.
  done.

  destruct (eqVneq mprat1 0).
  subst.
  rewrite (negbTE i1).
  simpl.
  unlock padd; simpl; rewrite addr0.
  done.

  rewrite (negbTE i1) (negbTE i2).
  simpl.
  unlock padd; simpl; rewrite Qnneg_def in i.
  rewrite Qnneg_def in i0.
  have: (0 < mprat0 + mprat1)%R .

  apply addr_gt0.
  rewrite ltr_def i i1; done.
  rewrite ltr_def i0 i2; done.
  intros.
  rewrite ltr_def in x.
  move/andP: x => [x0 x1].
  rewrite (negbTE x0).
  done.
Qed.

Definition pinv_ (a : posrat) : posrat.
  destruct a.
  econstructor.
  instantiate (1 := mprat0^-1).
  rewrite Qnneg_def.
  rewrite invr_ge0.
  rewrite -Qnneg_def; done.
Defined.

Definition pinv a := locked (pinv_ a).

Definition pexp_ (a : posrat) (n : nat) : posrat.
  destruct a.
  econstructor.
  instantiate (1 := mprat0 ^+ n).
  rewrite Qnneg_def.
  apply exprn_ge0.
  done.
Defined.

Definition pexp a n := locked (pexp_ a n).

Notation "x / y" := (x * (pinv y)) : posrat_scope.

Notation "x ^+ n" := (pexp x n) : posrat_scope.

Lemma pexp_S (a : posrat) (n : nat) :
  a ^+ (S n) =
  a * (a ^+ n).
  unlock pexp.
  destruct a; simpl.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  unlock pmul.
  unlock pexp.
  rewrite exprS.
  simpl.
  done.
Qed.

Lemma pexp1 (x  :posrat) : x ^+ 1 = x.
destruct x.
unlock pexp.
apply/eqP; rewrite /eq_op //=.
Qed.

Definition posrat_of_nat_ (x : nat) : posrat.
  econstructor.
  instantiate (1 := x%:Q).
  rewrite Qnneg_def.
  apply ler0n.
Defined.

Definition posrat_of_nat x := locked (posrat_of_nat_ x).

Definition ple (a b : posrat) : bool.
  destruct a,b.
  exact (mprat0 <= mprat1).
Defined.

Definition plt (a b : posrat) : bool.
  destruct a,b.
  exact (mprat0 < mprat1).
Defined.

Notation "x <= y" := (ple x y) : posrat_scope.
Notation "x < y" := (plt x y) : posrat_scope.

Definition plt_def (a b : posrat) : (a < b) = ((a != b) && (a <= b)).
  destruct a,b.
  rewrite /plt.
  rewrite /ple.
  rewrite /eq_op //=.
  rewrite ltr_def //=.
  rewrite eq_sym.
  done.
Qed.

Lemma plt_trans (a b c : posrat) : a < b -> b < c -> a < c.
  destruct a,b,c; rewrite /plt.
  apply ltr_trans.
Qed.

Lemma plt_add (a b c d : posrat) : a < b -> c < d -> a + c < b + d.
  destruct a,b,c,d; rewrite /plt.
  unlock padd.
  apply ltr_add.
Qed.

Lemma plt_mulr (a  c d : posrat) : a != 0 -> c < d -> a * c < a * d.
  destruct a,c,d; rewrite /plt.
  simpl.
  intros.

  unlock pmul; simpl.
  rewrite (mulrC mprat0).
  rewrite (mulrC mprat0).
  rewrite ltr_pmul2r.
  done.
  rewrite ltr_def.
  rewrite H.
  rewrite -Qnneg_def; done.
Qed.

Lemma ple_le0 a : (a <= 0) = (a == 0).
  have: (a <= 0) <-> (a == 0).
  split.
  destruct a; simpl; intros; apply/eqP.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  apply/eqP; rewrite eqr_le.
  apply/andP; split; done.

  intro H; rewrite (eqP H); done.

  intros.
  apply/iffP.
  apply idP.
  apply x.
  apply x.
  destruct (a == 0); done.
Qed.

Lemma ple_refl a : a <= a.
  destruct a; simpl; done.
Qed.

Lemma ple_antisymm a b : a <= b -> b <= a -> a = b.
  destruct a,b; simpl.
  intros.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  apply/eqP;
  rewrite eqr_le.
  apply/andP; split; done.
Qed.

Lemma ple_trans a b c : a <= b -> b <= c -> a <= c.
  destruct a,b,c; simpl.
  apply ler_trans.
Qed.

Lemma ple_total a b : (a <= b) || (b <= a).
  destruct a,b;simpl.
  apply ger_leVge.
  rewrite Qnneg_def in i; done.
  rewrite Qnneg_def in i0; done.
Qed.

Lemma ple_add_is_le a b c : a + b <= c -> (a <= c) && (b <= c).
  destruct a,b,c.
  unfold ple.
  simpl.
  unlock padd; simpl.
  intro; apply/andP; split.
  apply/contraT.
  rewrite -real_ltrNge.
  unlock padd in H; simpl in H.
  rewrite real_lerNgt in H.
  intro.

  have: (mprat2 < mprat0 + mprat1)%R.
  remember (mprat1 == 0) as b; symmetry in Heqb; destruct b.
  rewrite (eqP Heqb) addr0; done.
  rewrite -(addr0 mprat2).
  apply ltr_add.
  done.
  rewrite ltr_def.
  rewrite Heqb.
  rewrite Qnneg_def in i0.
  rewrite i0.
  done.
  rewrite (negbTE H); done.
  rewrite realE; apply/orP; left.
  apply addr_ge0.
  rewrite Qnneg_def in i; done.
  rewrite Qnneg_def in i0; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i1; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i1; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i; done.

  apply/contraT.
  rewrite -real_ltrNge.
  rewrite real_lerNgt in H.
  intro.

  have: (mprat2 < mprat0 + mprat1)%R.
  remember (mprat0 == 0) as b; symmetry in Heqb; destruct b.
  rewrite (eqP Heqb) add0r; done.
  rewrite -(addr0 mprat2) -(addrC 0%R mprat2).
  apply ltr_add.
  rewrite ltr_def Heqb.
  rewrite Qnneg_def in i; rewrite i; done.
  done.
  rewrite (negbTE H); done.

  rewrite realE; apply/orP; left.
  apply addr_ge0.
  rewrite Qnneg_def in i; done.
  rewrite Qnneg_def in i0; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i1; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i1; done.
  rewrite realE; apply/orP; left; rewrite Qnneg_def in i; done.
Qed.

Lemma ple_add_r a b c : a <= b -> a + c <= b + c.
  destruct a,b,c; simpl.
  unlock padd.
  intros.
  apply ler_add.
  done.
  done.
Qed.

Lemma ple_add_l a b c : a <= b -> c + a <= c + b.
 rewrite (paddrC c a).
 rewrite (paddrC c b).
 apply ple_add_r.
Qed.

Lemma ple_add_lr a b c d : a <= b -> c <= d -> a + c <= b + d.
 intros.
 eapply ple_trans.
 instantiate (1 := b + c).
 apply ple_add_r; done.
 apply ple_add_l; done.
Qed.

Lemma ple_mul_r a b c : a <= b -> a * c <= b * c.
  destruct a,b,c; simpl.
  intros.
  unlock pmul; simpl.
  eapply ler_pmul.
  done.
  done.
  done.
  done.
Qed.

Lemma ple_mul_l a b c : a <= b -> c * a <= c * b.
 rewrite (pmulrC c a).
 rewrite (pmulrC c b).
 apply ple_mul_r.
Qed.

Lemma ple_mul_lr a b c d : a <= b -> c <= d -> a * c <= b * d.
  destruct a,b,c,d ;simpl; intros.
  unlock pmul; simpl.
  apply ler_pmul; done.
Qed.

Definition pdist_ (a b : posrat) : posrat.
  destruct a,b.
  econstructor.
  instantiate (1 := `|mprat0 - mprat1|).
  rewrite Qnneg_def.
  apply normr_ge0.
Defined.

Definition pdist a b := locked (pdist_ a b).

Lemma pdist_eq0 a b : (pdist a b == 0) = (a == b).
  unlock pdist.
  apply/(iffP idP).
  instantiate (1 := (a == b)).
  rewrite /pdist.
  destruct a,b.
  intro.
  rewrite /eq_op //=; apply/eqP.
  rewrite /eq_op //= in H.
  rewrite normr_eq0 in H.
  rewrite subr_eq0 in H.
  apply/eqP; done.
  intro H; rewrite (eqP H).
  rewrite /pdist.
  destruct b; simpl.
  rewrite /eq_op //=; apply/eqP.
  apply/eqP; rewrite normr_eq0.
  rewrite subr_eq0.
  done.
  destruct (a == b); done.
Qed.

Lemma pdist_le0 a b : (pdist a b <= 0) = (a == b).
  apply/(iffP idP).
  instantiate (1 := a == b).
  intro.
  rewrite ple_le0 in H.
  rewrite pdist_eq0 in H.
  done.
  intro.
  rewrite ple_le0.
  rewrite pdist_eq0.
  done.
  destruct (a == b); done.
Qed.

Lemma pdist_symm a b : pdist a b = pdist b a.
  unlock pdist.
  rewrite /pdist_; destruct a,b.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  rewrite distrC; done.
Qed.

Lemma pdist_triangle a b c : pdist a c <= pdist a b + pdist b c.
  unlock pdist;
  rewrite /pdist_; destruct a,b, c.
  simpl.
  unlock padd.
  simpl.
  apply ler_dist_add.
Qed.

Lemma pdist_add_r a b c : pdist a b = pdist (a + c) (b + c).
  unlock pdist;
  rewrite/pdist_; destruct a,b,c; simpl.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  unlock padd; simpl.
  rewrite (addrC mprat1 mprat2).
  rewrite GRing.addrKA.
  done.
Qed.

Lemma pdist_add_l a b c : pdist a b = pdist (c + a) (c + b).
  rewrite (paddrC c a).
  rewrite (paddrC c b).
  apply pdist_add_r.
Qed.

Lemma pdist_add_lr a b c d : pdist (a + c) (b + d) <= pdist a b + pdist c d.

  unlock pdist;
  rewrite/pdist_; destruct a,b,c,d; simpl.
  have: (mprat0 + mprat2 - (mprat1 + mprat3))%R =
        ((mprat0 - mprat1) + (mprat2 - mprat3))%R.
  rewrite -mulN1r.
  rewrite mulrDr.
  rewrite !mulN1r.
  rewrite addrA.
  rewrite addrA.
  congr (_ + _)%R.
  rewrite -addrA.
  rewrite (addrC mprat2 (-mprat1)).
  rewrite addrA.
  done.
  intro.
  unlock padd; simpl.
  rewrite x.
  apply ler_norm_add.
Qed.

Lemma pdist_mul_l a b c : pdist (c * a) (c * b) = c * (pdist a b).
  unlock pdist;
  rewrite/pdist_;destruct a,b,c; simpl.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
  have: (mprat2 * mprat0 - mprat2 * mprat1)%R =
        (mprat2 * (mprat0 - mprat1))%R.
  rewrite -mulN1r.
  rewrite mulrA.
  rewrite (mulrC (-1) mprat2).
  rewrite -mulrA.
  rewrite -mulrDr.
  rewrite mulN1r.
  done.
  intro.
  unlock pmul; simpl.
  rewrite x.
  rewrite normrM.
  have: `|mprat2| == mprat2.
  rewrite -ger0_def.
  done.
  intro H; rewrite (eqP H).
  done.
Qed.

Lemma pdist_mul_r a b c : pdist (a * c) (b * c) = c * (pdist a b).
  rewrite (pmulrC a c).
  rewrite (pmulrC b c).
  apply pdist_mul_l.
Qed.

Lemma ple_sum {A} (c : seq A) (F1 F2 : A -> posrat) (f : A -> bool) :
  (forall x, f x -> F1 x <= F2 x) ->
  (\big[padd/0]_(p <- c | f p) F1 p) <= (\big[padd/0]_(p <- c | f p) F2 p).
  intros.
  induction c.
  rewrite !big_nil; done.
  rewrite !big_cons.
  remember (f a) as b; destruct b.
  apply ple_add_lr.
  apply H; rewrite -Heqb //=.
  done.
  done.
Qed.

Lemma padd2 (a : posrat) :
  a + a = (Posrat 2%:Q is_true_true) * a.
  destruct a; apply/eqP; rewrite /eq_op //=; apply/eqP.
  have: intr 2 = (intr 1 + intr 1)%R.
  done.
  intro.
  unlock padd pmul; simpl.
  rewrite x.
  rewrite mulrDl.
  rewrite (mulrC (intr 1)).
  rewrite !mulr1z.
  rewrite mulr1.
  done.
Qed.

Lemma pinv_0 : pinv 0 = 0.
  simpl.
  apply/eqP; rewrite /eq_op //=.
  unlock pinv; simpl.
  rewrite invr0.
  done.
Qed.

Lemma pinv_neq0 a :
  a != 0 -> pinv a != 0.
  unlock pinv;
  destruct a; rewrite /pinv_; intro; rewrite /eq_op //=.
  apply invr_neq0.
  done.
Qed.

Definition pdiv_neq0 a b :
  a != 0 -> b != 0 -> a / b != 0.
  intros; rewrite -pmul0.
  rewrite negb_or.
  apply/andP; split.
  done.
  apply pinv_neq0; done.
Qed.

Definition pexp_neq0 a c :
  a != 0 -> (a ^+ c != 0).
  unlock pexp;
  destruct a; rewrite /pexp_; simpl.
  intro; rewrite /eq_op //=.
  apply expf_neq0.
  done.
Qed.

Definition pdiv_lt1 a b :
  b != 0 -> a < b -> a / b < 1.
  destruct a,b.
  unfold plt; simpl.
  intros.
  unlock pmul pinv; simpl.

  rewrite ltr_pdivr_mulr.
  rewrite mul1r. done.
  rewrite ltr_def.
  rewrite -Qnneg_def i0.
  rewrite /eq_op //= in H.
  rewrite H; done.
Qed.

Lemma pmul_div a b c d:
  (a / b) * (c / d) = (a * c) / (b * d).
  unlock pmul pinv; simpl.
  destruct a,b,c,d; apply/eqP; rewrite /eq_op //=; apply/eqP.
  apply mulf_div.
Qed.

Lemma pinv_1 :
  pinv 1 = 1.
  unlock pinv.
  rewrite /pinv.
  apply/eqP; rewrite /eq_op //=; apply/eqP.
Qed.

Lemma pdiv_pmul_num a b c :
  (a * b) / c = a * (b / c).
  rewrite -(pmul1r c).
  rewrite -pmul_div.
  rewrite pinv_1.
  rewrite pmulr1.
  rewrite pmul1r.
  done.
Qed.

Lemma pdiv_pmul_denom a b c:
  a / (b * c) = a / b * (1 / c).
  rewrite pmul_div.
  rewrite pmulr1.
  done.
Qed.

  Lemma psum_neq0 {A : eqType} (xs : seq A) f :
    (\big[padd/0]_(x <- xs) f x != 0) = (has (fun x => f x != 0) xs).
    induction xs.
    rewrite big_nil //=.
    rewrite big_cons //=.
    rewrite -IHxs.
    apply Bool.eq_true_iff_eq; split.
    rewrite -padd0 negb_and; move/orP; elim => H; rewrite H //= ?orbT //=.

    move/orP; elim => H.
    rewrite -padd0 negb_and H //=.
    rewrite -padd0 negb_and H //= orbT //=.
  Qed.

  Lemma psum_eq0 {A : eqType} (xs : seq A) f :
    (\big[padd/0]_(x <- xs) f x == 0) = (all (fun x => f x == 0) xs).
    induction xs.
    rewrite big_nil //=.
    rewrite big_cons //=.
    rewrite -IHxs.
    rewrite padd0; done.
  Qed.

Lemma pdivK (p : posrat) :
  p != 0 -> p / p = 1.
  move => H.
  destruct p; simpl in *; unlock pmul pinv; simpl.
  apply/eqP; rewrite /eq_op //=.
  rewrite GRing.Theory.divff.
  done.
  done.
Qed.

Lemma posrat_of_nat_0 :
  posrat_of_nat 0 = 0.
  unlock posrat_of_nat; simpl.
  apply/eqP; rewrite /eq_op //=.
Qed.

Lemma posrat_of_nat_neq0 n :
  posrat_of_nat (S n) != 0.
  unlock posrat_of_nat; simpl.
  rewrite /posrat_of_nat_; rewrite /eq_op //=.
  rewrite /intr //=.
  have: (0%R < n.+1%:R)%R.
  intro.
  apply ltr0Sn.
  intros.
  rewrite gtr_eqF.
  done.
  apply x.
Qed.

Lemma posrat_of_nat_S n :
  posrat_of_nat (S n) = 1 + posrat_of_nat n.
  unlock posrat_of_nat; simpl.
  rewrite /posrat_of_nat_.
  unlock padd; simpl.
  apply/eqP; rewrite /eq_op //=.
  rewrite /intr //=.
  have -> : (n.+1) = (1 + n)%N.
  done.
  rewrite natrD.
  apply/eqP; congr (_ + _)%R.
Qed.

Lemma iter_padd (n : nat) (p1 p2 : posrat) :
  iter n (padd p1) p2 =
  p2 + (posrat_of_nat n * p1).
  induction n.
  simpl.
  rewrite posrat_of_nat_0 pmul0r paddr0 //=.
  simpl.
  rewrite IHn.
  rewrite posrat_of_nat_S.
  rewrite pmulrDl pmul1r !paddrA.
  congr (_ + _).
  rewrite paddrC //=.
Qed.