(* Some sanity tests for several definitions. We test agaist the tranlation acquired from the OCaml
 forcing translation plugin (up to notation) *)
Require Import Template.monad_utils Template.Ast
        Template.Template Template.LiftSubst translation_utils.
Require Import String PeanoNat.
Require Import Forcing.TemplateForcing.

Import List.ListNotations.
Import MonadNotation.
Open Scope string_scope.
Open Scope list_scope.

Import Level.

(* Some examples to play with  *)
Definition Obj := Type.
Definition Hom := (fun x y => x -> y).
Notation "P ≥ Q" := (Hom P Q) (at level 70).

Definition Id_hom := @id.
Notation "# R" := (Id_hom R) (at level 70).

Definition Comp := @Coq.Program.Basics.compose.
Notation "g ∘ f" := (Comp _ _ _ g f) (at level 40).

Definition test_cat : category :=
  makeCatS "Obj" "Hom" "Id_hom" "Comp".

Quote Recursively Definition q_def := Hom.
Definition g_ctx := fst q_def.

Quote Definition qId := (fun (A : Type) => A).

Definition tr_Id_syn :=
  Eval vm_compute in
    translate true None nil test_cat
                   {| Environ.env_globals := g_ctx|}
                   tt qId.

(*A translation of [fun (x : Type) => x] from the OCaml plugin *)
Definition fooᶠ  : forall p : Obj,
    (forall p0 : Obj, p ≥ p0 -> forall p1 : Obj, p0 ≥ p1 -> Type) ->
    forall p0 : Obj, p ≥ p0 -> Type
  := (fun (p : Obj) (x : forall p0 : Obj, p ≥ p0 -> forall p1 : Obj, p0 ≥ p1 -> Type) => x p (# _)).

Make Definition gId :=
  Eval vm_compute in (snd tr_Id_syn).

Lemma eq_gId_fooᶠ : gId = fooᶠ.
Proof. reflexivity. Qed.

Quote Definition qArr := (fun (A B : Type)  => A -> B).

Definition tr_Arr_syn :=
  Eval vm_compute in
    translate true None nil test_cat
                   {| Environ.env_globals := g_ctx|}
                   tt qArr.

(* Translation of [(fun (A B : Type)  => A -> B)] from the OCaml plugin*)
Definition barᶠ : forall p : Obj,
    (forall p0 : Obj, p ≥ p0 -> forall p1 : Obj, p0 ≥ p1 -> Type) ->
    (forall p0 : Obj, p ≥ p0 -> forall p1 : Obj, p0 ≥ p1 -> Type) ->
    forall p0 : Obj, p ≥ p0 -> Type
  := fun (p : Obj) (A B : forall p0 : Obj, p ≥ p0 -> forall p1 : Obj, p0 ≥ p1 -> Type)
         (p0 : Obj) (α : p ≥ p0) =>
       (forall (p1 : Obj) (α0 : p0 ≥ p1), A p1 ((# _) ∘ (α0 ∘ α)) p1 (# _)) -> B p0 (α ∘ (# _)) p0 (# _).

Make Definition bar := Eval vm_compute in (snd tr_Arr_syn).

Lemma eq_bar_barᶠ : bar = barᶠ.
Proof.
  reflexivity.
Qed.

Quote Definition bazz :=  (forall (A : Type), (A -> Type)).

Definition tr_bazz_syn :=
  Eval vm_compute in
    translate_type true None nil test_cat
                   {| Environ.env_globals := g_ctx|}
                   tt bazz.

(* Just testing that the definition can be reflected back from quoted. This covers a bug with
   top-level condition variable when building a chain of moprhisms by composition *)
Make Definition bazz' := Eval vm_compute in (snd tr_bazz_syn).

(* Testing appication of type constructors *)

Inductive prodᵗ (p : Obj)
            (A : forall p0 : Obj, p ≥ p0 -> forall p : Obj, p0 ≥ p -> Type)
            (B : forall p0 : Obj, p ≥ p0 -> forall p : Obj, p0 ≥ p -> Type)
  : Type :=
    pairᵗ : (forall (p0 : Obj) (α : p ≥ p0), A p0 α p0 (# _)) ->
            (forall (p0 : Obj) (α : p ≥ p0), B p0 α p0 (# _)) -> prodᵗ p A B.

(* translation of [fun (A B : Type) => prod A B] from the OCaml plugin *)
Definition prod_app_t :=
    fun (p : Obj) (A B : forall p0 : Obj, p≥ p0 -> forall p1 : Obj, p0≥ p1 -> Type)
        (p0 : Obj) (α : p≥ p0) =>
      prodᵗ p0
            (fun (p1 : Obj) (α0 : p0≥ p1) =>
               (fun (p2 : Obj) (α1 : p≥ p2) => A p2 α1) p1 (α0 ∘ α))
            (fun (p1 : Obj) (α0 : p0≥ p1) =>
               (fun (p2 : Obj) (α1 : p≥ p2) => B p2 α1) p1 (α0 ∘ α)).

Instance TestTranslation : Translation := ForcingTranslation test_cat.

Definition ΣE : tsl_context:= (Typing.reconstruct_global_context [],[]).

Run TemplateProgram (TC <- tAddExistingInd ΣE "Coq.Init.Datatypes.prod" "prodᵗ" ;;
                          tmDefinition "ctx_with_prod" TC).

Definition prod_ := (fun (A B : Type) => prod A B).

Run TemplateProgram (tTranslate ctx_with_prod "prod_").

Lemma prod_tr_eq : prod_ᵗ = prod_app_t.
Proof. reflexivity. Qed.

Inductive listᵗ (p : Obj) (A : forall p0 : Obj, p ≥ p0 -> forall p : Obj, p0 ≥ p -> Type) : Type :=
    nilᵗ : listᵗ p A
  | consᵗ : (forall (p0 : Obj) (α : p ≥ p0), A p0 α p0 (# _)) ->
            (forall (p0 : Obj) (α : p ≥ p0),
                listᵗ p0 (fun (p' : Obj) (α0 : p0 ≥ p') => A p' (α0 ∘ α))) ->
            listᵗ p A.

Inductive natᵗ (p : Obj) : Type :=
  Oᵗ : natᵗ p
| Sᵗ : (forall p0 : Obj, p ≥ p0 -> natᵗ p0) -> natᵗ p.

Inductive Falseᵗ (p : Obj) : Type := .

Inductive andᵗ (p : Obj) (A B : forall p0 : Obj, p ≥ p0 -> forall p : Obj, p0 ≥ p -> Prop) : Prop :=
    conjᵗ : (forall (p0 : Obj) (α : p ≥ p0), A p0 α p0 (# _)) ->
            (forall (p0 : Obj) (α : p ≥ p0), B p0 α p0 (# _)) -> andᵗ p A B.

Definition and_f : Prop -> Prop -> Type := fun a b => and a b.

Definition and_fᵗ
  : forall p : Obj, (forall p0 : Obj, p ≥ p0 -> forall p1 : Obj, p0 ≥ p1 -> Prop) ->
                    (forall p0 : Obj, p ≥ p0 -> forall p1 : Obj, p0 ≥ p1 -> Prop) ->
                    forall p0 : Obj, p ≥ p0 -> Prop
  := fun (p : Obj) (a b : forall p0 : Obj, p ≥ p0 -> forall p1 : Obj, p0 ≥ p1 -> Prop)
  (p0 : Obj) (α : p ≥ p0) => andᵗ p0  (fun (p1 : Obj) (α0 : p0 ≥ p1) =>
   (fun (p2 : Obj) (α1 : p ≥ p2) => a p2 (α1 ∘ (# _))) p1 (α0 ∘ (α ∘ (# _))))
  (fun (p1 : Obj) (α0 : p0 ≥ p1) =>
   (fun (p2 : Obj) (α1 : p ≥ p2) => b p2 (α1 ∘ (# _))) p1 (α0 ∘ (α ∘ (# _)))).

Inductive orᵗ (p : Obj) (A B : forall p0 : Obj, p ≥ p0 -> forall p : Obj, p0 ≥ p -> Prop) : Prop :=
    or_introlᵗ : (forall (p0 : Obj) (α : p ≥ p0), A p0 α p0 (# _)) -> orᵗ p A B
  | or_introrᵗ : (forall (p0 : Obj) (α : p ≥ p0), B p0 α p0 (# _)) -> orᵗ p A B.


(* * Consistency of ZF-Axiomatisation *)

From Undecidability.FOL.Sets.Models Require Import Aczel.
Require Import Setoid Morphisms.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Set Default Proof Using "Type".

(* ** Quotient Model *)

Class extensional_normaliser :=
  {
    tdelta : (Acz -> Prop) -> Acz;
    TDesc1 : forall P, (exists s, forall t, P t <-> Aeq t s) -> P (tdelta P);
    TDesc2 : forall P P', (forall s, P s <-> P' s) -> tdelta P = tdelta P';
    PI : forall s (H H' : tdelta (Aeq s) = s), H = H';
  }.

Section QM.

  Context { Delta : extensional_normaliser }.

  (* Auxiliary lemmas *)

  Definition N s :=
    tdelta (Aeq s).

  Fact CR1 :
    forall s, Aeq s (N s).
  Proof.
    intros s. pattern (N s). apply TDesc1. now exists s.
  Qed.

  Lemma CR2 :
    forall s t, Aeq s t -> N s = N t.
  Proof.
    intros s t H. apply TDesc2.
    intros u. rewrite H. tauto.
  Qed.

  Lemma N_idem s :
    N (N s) = N s.
  Proof.
    apply CR2. symmetry. apply CR1.
  Qed.

  Lemma N_eq_Aeq s t :
    N s = N t -> Aeq s t.
  Proof.
    intros H. rewrite (CR1 s), (CR1 t). now rewrite H.
  Qed.

  Global Instance N_proper :
    Proper (Aeq ==> Aeq) N.
  Proof.
    intros s t H. now rewrite <- (CR1 s), <- (CR1 t).
  Qed.

  Definition SET :=
    sig (fun s => N s = s).

  Definition NS s : SET :=
    exist (fun s => N s = s) (N s) (N_idem s).

  Definition IN (X Y : SET) :=
    Ain (proj1_sig X) (proj1_sig Y).

  Definition Subq (X Y : SET) :=
    forall Z, IN Z X -> IN Z Y.

  (* Helpful lemmas for automation *)

  Lemma Aeq_p1_NS s :
    Aeq s (proj1_sig (NS s)).
  Proof.
    exact (CR1 s).
  Qed.

  Lemma NS_eq_Aeq_p1 s X :
    NS s = X -> Aeq s (proj1_sig X).
  Proof.
    intros <-. apply Aeq_p1_NS.
  Qed.

  Lemma Ain_IN_p1 X Y :
    Ain (proj1_sig X) (proj1_sig Y) -> IN X Y.
  Proof.
    intros H1. unfold IN. exact H1.
  Qed.

  Lemma Ain_IN_NS s t :
    Ain s t -> IN (NS s) (NS t).
  Proof.
    intros H1. unfold IN. now repeat rewrite <- Aeq_p1_NS.
  Qed.

  Lemma Ain_IN_p1_NS X s :
    Ain (proj1_sig X) s -> IN X (NS s).
  Proof.
    intros H1. unfold IN. now rewrite <- Aeq_p1_NS.
  Qed.

  Lemma Ain_IN_NS_p1 s X :
    Ain s (proj1_sig X) -> IN (NS s) X.
  Proof.
    intros H1. unfold IN. now rewrite <- Aeq_p1_NS.
  Qed.

  Lemma IN_Ain_p1 X Y :
    IN X Y -> Ain (proj1_sig X) (proj1_sig Y).
  Proof.
    tauto.
  Qed.

  Lemma IN_Ain_NS s t :
    IN (NS s) (NS t) -> Ain s t.
  Proof.
    unfold IN. now repeat rewrite <- Aeq_p1_NS.
  Qed.

  Lemma IN_Ain_p1_NS X s :
    IN X (NS s) -> Ain (proj1_sig X) s.
  Proof.
    unfold IN. now rewrite <- Aeq_p1_NS.
  Qed.

  Lemma IN_Ain_NS_p1 s X :
    IN (NS s) X -> Ain s (proj1_sig X).
  Proof.
    unfold IN. now rewrite <- Aeq_p1_NS.
  Qed.

  Hint Resolve Ain_IN_p1 Ain_IN_NS Ain_IN_p1_NS Ain_IN_NS_p1 IN_Ain_p1 IN_Ain_NS IN_Ain_p1_NS IN_Ain_NS_p1 : core.

  Lemma ASubq_Subq_p1 X Y :
    ASubq (proj1_sig Y) (proj1_sig X) <-> Subq Y X.
  Proof.
    split; intros H Z H1.
    - apply Ain_IN_p1, H. auto.
    - apply IN_Ain_NS_p1, H. auto.
  Qed.

  Lemma PI_eq s t (H1 : N s = s) (H2 : N t = t) :
    s = t -> exist (fun s => N s = s) s H1 = exist (fun s => N s = s) t H2.
  Proof.
    intros XY. subst t. f_equal. apply PI.
  Qed.

  Lemma NS_p1_eq X :
    NS (proj1_sig X) = X.
  Proof.
    destruct X. simpl. now apply PI_eq.
  Qed.

  Lemma Aeq_p1_NS_eq X s :
    Aeq (proj1_sig X) s -> X = NS s.
  Proof.
    destruct X as [t H1]. simpl. intros H2. unfold NS.
    apply PI_eq. rewrite <- H1. now apply CR2.
  Qed.

  Lemma Aeq_p1_eq (X Y : SET) :
    Aeq (proj1_sig X) (proj1_sig Y) -> X = Y.
  Proof.
    intros H. rewrite <- (NS_p1_eq Y). now apply Aeq_p1_NS_eq.
  Qed.

  Lemma Aeq_NS_eq s t :
    Aeq s t -> NS s = NS t.
  Proof.
    intros H % CR2.
    now apply PI_eq.
  Qed.

  (* ** Extensional Axioms *)

  (* Lifted set operations *)

  Definition Sempty :=
    NS AEmpty.

  Definition Supair (X Y : SET) :=
    NS (Aupair (proj1_sig X) (proj1_sig Y)).

  Definition Sunion (X : SET) :=
    NS (Aunion (proj1_sig X)).

  Definition Spower (X : SET) :=
    NS (Apower (proj1_sig X)).

  Definition empred (P : SET -> Prop) :=
    fun s => P (NS s).

  Definition Ssep (P : SET -> Prop) (X : SET) :=
    NS (Asep (empred P) (proj1_sig X)).

  Definition emfun (F : SET -> SET) :=
    fun s => proj1_sig (F (NS s)).

  Definition Srepl (F : SET -> SET) (X : SET) :=
    NS (Arepl (emfun F) (proj1_sig X)).

  Definition Som :=
    NS Aom.

  (* Extensionality *)

  Lemma set_ext X Y :
    Subq X Y /\ Subq Y X <-> X = Y.
  Proof.
    split; intros H; try now rewrite H. destruct H as [H1 H2].
    apply Aeq_p1_eq, Aeq_ext; now apply ASubq_Subq_p1.
  Qed.

  (* Empty *)

  Lemma emptyE X :
    ~ IN X Sempty.
  Proof.
    intros H % IN_Ain_p1_NS. now apply AEmptyAx in H.
  Qed.

  (* Unordered Pairs *)

  Lemma upairAx X Y Z :
    IN Z (Supair X Y) <-> Z = X \/ Z = Y.
  Proof.
    split; intros H.
    - apply IN_Ain_p1_NS, AupairAx in H as [H|H].
      + left. now apply Aeq_p1_eq.
      + right. now apply Aeq_p1_eq.
    - apply Ain_IN_p1_NS, AupairAx.
      destruct H as [-> | ->]; auto.
  Qed.

  (* Union *)

  Lemma unionAx X Z :
    IN Z (Sunion X) <-> exists Y, IN Y X /\ IN Z Y.
  Proof.
    split; intros H.
    - apply IN_Ain_p1_NS, AunionAx in H as [y[Y1 Y2]].
      exists (NS y). split; auto.
    - destruct H as [Y[Y1 Y2]].
      apply Ain_IN_p1_NS, AunionAx.
      exists (proj1_sig Y). split; auto.
  Qed.

  (* Power *)

  Lemma powerAx X Y :
    IN Y (Spower X) <-> Subq Y X.
  Proof.
    split; intros H.
    - apply IN_Ain_p1_NS, ApowerAx in H.
      now apply ASubq_Subq_p1.
    - apply Ain_IN_p1_NS, ApowerAx.
      now apply ASubq_Subq_p1.
  Qed.

  (* Separation *)

  Fact empred_Aeq P :
    cres Aeq (empred P).
  Proof.
    intros s s' H % Aeq_NS_eq. unfold empred. now rewrite H.
  Qed.

  Lemma sepAx P X Y :
    IN Y (Ssep P X) <-> IN Y X /\ P Y.
  Proof with try apply empred_Aeq.
    split; intros H.
    - apply IN_Ain_p1_NS, AsepAx in H as [H1 H2]...
      split; auto. unfold empred in H2.
      now rewrite NS_p1_eq in H2.
    - destruct H as [H1 H2]. apply Ain_IN_p1_NS, AsepAx...
      split; trivial. unfold empred. now rewrite NS_p1_eq.
  Qed.

  (* Functional Replacement *)

  Fact emfun_Aeq F :
    fres Aeq (emfun F).
  Proof.
    intros s s' H % Aeq_NS_eq.
    unfold emfun. now rewrite H.
  Qed.

  Lemma replAx F X Y :
    IN Y (Srepl F X) <-> exists Z, IN Z X /\ Y = F Z.
  Proof with try apply emfun_Aeq.
    split; intros H.
    - apply IN_Ain_p1_NS, AreplAx in H as [z[Z1 Z2]]...
      exists (NS z). split; auto. now apply Aeq_p1_eq.
    - destruct H as [Z[Z1 Z2]].
      apply Ain_IN_p1_NS, AreplAx...
      exists (proj1_sig Z). split; auto.
      rewrite Z2. unfold emfun.
      now rewrite NS_p1_eq.
  Qed.

  (* Description Operator *)

  Definition desc (P : SET -> Prop) :=
    NS (tdelta (fun s => empred P s)).

  Lemma descAx (P : SET -> Prop) X :
    P X -> unique P X -> P (desc P).
  Proof.
    intros H1 H2.
    enough (empred P (tdelta (empred P))) by assumption.
    apply TDesc1. exists (proj1_sig X).
    intros t. split; intros H.
    - apply NS_eq_Aeq_p1. symmetry. now apply H2.
    - symmetry in H. apply (empred_Aeq H).
      hnf. now rewrite NS_p1_eq.
  Qed.

  Lemma descAx2 (P P' : SET -> Prop) :
    (forall x, P x <-> P' x) -> desc P = desc P'.
  Proof.
    intros H. apply Aeq_NS_eq, Aeq_ref', TDesc2.
    intros s. apply H.
  Qed.

  (* Relational Replacement *)

  Definition Srep (R : SET -> SET -> Prop) X :=
    Srepl (fun x => desc (R x)) (Ssep (fun x => exists y, R x y) X).

  Definition functional X (R : X -> X -> Prop) :=
    forall x y y', R x y -> R x y' -> y = y'.

  Lemma repAx R X Y :
    functional R -> IN Y (Srep R X) <-> exists Z, IN Z X /\ R Z Y.
  Proof.
    intros H. unfold Srep. rewrite replAx.
    split; intros [Z[H1 H2]]; exists Z; split.
    - now apply sepAx in H1.
    - apply sepAx in H1 as [_ [Y' H']].
      subst. eapply descAx; firstorder eauto.
    - apply sepAx; split; trivial. now exists Y.
    - eapply H; eauto. eapply descAx; firstorder eauto.
  Qed.

  (* Infinity *)

  Definition Ssucc X :=
    Sunion (Supair X (Supair X X)).

  Definition Sinductive X :=
    IN Sempty X /\ forall Y, IN Y X -> IN (Ssucc Y) X.

  Lemma Ainductive_Sinductive X :
    Ainductive (proj1_sig X) <-> Sinductive X.
  Proof.
    split; intros [H1 H2]; split.
    - now apply Ain_IN_NS_p1.
    - intros Y H % IN_Ain_p1. apply H2 in H.
      unfold IN. cbn. now rewrite <- !CR1.
    - now apply IN_Ain_NS_p1.
    - intros s H % Ain_IN_NS_p1. specialize (H2 (NS s) H).
      unfold IN in H2. cbn in H2. now rewrite <- !CR1 in H2.
  Qed.

  Lemma omAx1 :
    Sinductive Som.
  Proof.
    split.
    - apply Ain_IN_NS. apply AomAx1.
    - intros X H. unfold IN in *; cbn in *.
      rewrite <- !CR1 in *. now apply AomAx1.
  Qed.

  Lemma omAx2 :
    forall X, Sinductive X -> Subq Som X.
  Proof.
    intros X H. apply ASubq_Subq_p1. cbn.
    rewrite <- CR1. apply AomAx2.
    now apply Ainductive_Sinductive.
  Qed.

End QM.


(** * PHOAS Representation of Gallina *)
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.Notations.

(** We parameterize the language over a type of basic type codes (for
    things like [Z], [word], [bool]), as well as a type of n-ary
    operations returning one value, and n-ary operations returning two
    values. *)
Delimit Scope ctype_scope with ctype.
Local Open Scope ctype_scope.
Delimit Scope expr_scope with expr.
Local Open Scope expr_scope.
Section language.
  Context (base_type_code : Type).

  Inductive flat_type := Tbase (T : base_type_code) | Unit | Prod (A B : flat_type).
  Bind Scope ctype_scope with flat_type.

  Inductive type := Arrow (A : flat_type) (B : flat_type).
  Bind Scope ctype_scope with type.

  Infix "*" := Prod : ctype_scope.
  Notation "A -> B" := (Arrow A B) : ctype_scope.
  Local Coercion Tbase : base_type_code >-> flat_type.

  Section tuple.
    Context (T : flat_type).
    Fixpoint tuple' n :=
      match n with
      | O => T
      | S n' => (tuple' n' * T)%ctype
      end.
    Definition tuple n :=
      match n with
      | O => Unit
      | S n' => tuple' n'
      end.
  End tuple.

  Definition domain (t : type) : flat_type
    := match t with Arrow src dst => src end.
  Definition codomain (t : type) : flat_type
    := match t with Arrow src dst => dst end.

  Section interp.
    Definition interp_type_gen_hetero (interp_src interp_dst : flat_type -> Type) (t : type) :=
      (interp_src match t with Arrow x y => x end -> interp_dst match t with Arrow x y => y end)%type.
    Definition interp_type_gen (interp_flat_type : flat_type -> Type)
      := interp_type_gen_hetero interp_flat_type interp_flat_type.
    Section flat_type.
      Context (interp_base_type : base_type_code -> Type).
      Fixpoint interp_flat_type (t : flat_type) :=
        match t with
        | Tbase t => interp_base_type t
        | Unit => unit
        | Prod x y => prod (interp_flat_type x) (interp_flat_type y)
        end.
      Definition interp_type := interp_type_gen interp_flat_type.
    End flat_type.
  End interp.

  Section expr_param.
    Context (interp_base_type : base_type_code -> Type).
    Context (op : flat_type (* input tuple *) -> flat_type (* output type *) -> Type).
    Local Notation interp_type := (interp_type interp_base_type).
    Local Notation interp_flat_type_gen := interp_flat_type.
    Local Notation interp_flat_type := (interp_flat_type interp_base_type).
    Section expr.
      Context {var : base_type_code -> Type}.

      (** N.B. [Let] binds the components of a pair to separate variables, and does so recursively *)
      Inductive exprf : flat_type -> Type :=
      | TT : exprf Unit
      | Var {t} (v : var t) : exprf t
      | Op {t1 tR} (opc : op t1 tR) (args : exprf t1) : exprf tR
      | LetIn {tx} (ex : exprf tx) {tC} (eC : interp_flat_type_gen var tx -> exprf tC) : exprf tC
      | Pair {tx} (ex : exprf tx) {ty} (ey : exprf ty) : exprf (Prod tx ty).
      Bind Scope expr_scope with exprf.
      Inductive expr : type -> Type :=
      | Abs {src dst} (f : interp_flat_type_gen var src -> exprf dst) : expr (Arrow src dst).
      Bind Scope expr_scope with expr.
    End expr.

    Definition Expr (t : type) := forall var, @expr var t.

    Section interp.
      Context (interp_op : forall src dst, op src dst -> interp_flat_type src -> interp_flat_type dst).

      Definition interpf_step
                 (interpf : forall {t} (e : @exprf interp_flat_type t), interp_flat_type t)
                 {t} (e : @exprf interp_flat_type t) : interp_flat_type t
        := match e in exprf t return interp_flat_type t with
           | TT => tt
           | Var _ x => x
           | Op _ _ op args => @interp_op _ _ op (@interpf _ args)
           | LetIn _ ex _ eC => dlet x := @interpf _ ex in @interpf _ (eC x)
           | Pair _ ex _ ey => (@interpf _ ex, @interpf _ ey)
           end.

      Fixpoint interpf {t} e
        := @interpf_step (@interpf) t e.

      Definition interp {t} (e : @expr interp_base_type t) : interp_type t
        := fun x
           => @interpf
                _
                (match e in @expr _ t
                       return interp_flat_type (domain t)
                              -> exprf (codomain t)
                 with
                 | Abs _ _ f => f
                 end x).

      Definition Interp {t} (E : Expr t) : interp_type t := interp (E _).
    End interp.
  End expr_param.
End language.
Global Arguments tuple' {_}%type_scope _%ctype_scope _%nat_scope.
Global Arguments tuple {_}%type_scope _%ctype_scope _%nat_scope.
Global Arguments Unit {_}%type_scope.
Global Arguments Prod {_}%type_scope (_ _)%ctype_scope.
Global Arguments Arrow {_}%type_scope (_ _)%ctype_scope.
Global Arguments Tbase {_}%type_scope _%ctype_scope.
Global Arguments domain {_}%type_scope _%ctype_scope.
Global Arguments codomain {_}%type_scope _%ctype_scope.

Global Arguments Var {_ _ _ _} _.
Global Arguments TT {_ _ _}.
Global Arguments Op {_ _ _ _ _} _ _.
Global Arguments LetIn {_ _ _ _} _ {_} _.
Global Arguments Pair {_ _ _ _} _ {_} _.
Global Arguments Abs {_ _ _ _ _} _.
Global Arguments interp_type_gen_hetero {_} _ _ _.
Global Arguments interp_type_gen {_} _ _.
Global Arguments interp_flat_type {_} _ _.
Global Arguments interp_type {_} _ _.
Global Arguments Interp {_ _ _} interp_op {t} _ _.
Global Arguments interp {_ _ _} interp_op {t} _ _.
Global Arguments interpf {_ _ _} interp_op {t} _.
Global Arguments interp _ _ _ _ _ !_ / _.

Module Export Notations.
  Notation "()" := (@Unit _) : ctype_scope.
  Notation "A * B" := (@Prod _ A B) : ctype_scope.
  Notation "A -> B" := (@Arrow _ A B) : ctype_scope.
  Notation "'slet' x := A 'in' b" := (LetIn A (fun x => b)) : expr_scope.
  Notation "'λ'  x .. y , t" := (Abs (fun x => .. (Abs (fun y => t%expr)) ..)) : expr_scope.
  Notation "( x , y , .. , z )" := (Pair .. (Pair x%expr y%expr) .. z%expr) : expr_scope.
  Notation "( )" := TT : expr_scope.
  Notation "()" := TT : expr_scope.
  Bind Scope ctype_scope with flat_type.
  Bind Scope ctype_scope with type.
End Notations.


(** * Some standard combinators *)

Definition Succ := S%nat.  (* an alias for later *)

Require Import Coq.Program.Basics.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Arith.EqNat.
Require Export InformationOrdering.

(** ** Abstraction *)

(** Simple I,K,S-abstraction *)

Fixpoint code_abs0 {Var Var' : Set} (b : Var -> option Var') (x : Code Var) :
  Code Var' :=
  match x with
  | code_var v =>
      match b v with
      | None => I
      | Some v' => K * (code_var v')
      end
  | l * r => S * code_abs0 b l * code_abs0 b r
  | TOP => K * TOP
  | BOT => K * BOT
  | J => K * J
  | R => K * R
  | I => K * I
  | K => K * K
  | B => K * B
  | C => K * C
  | S => K * S
  end.

Section code_eq_abs0_sub.
  Variable Var Var' : Set.
  Variable b : Var -> option Var'.
  Variable x : Code Var.
  Variable y : Code Var'.
  Let f v := match b v with None => y | Some v' => code_var v' end.

  Lemma code_eq_abs0_sub : code_abs0 b x * y == code_sub f x.
  Proof.
    induction x; try (unfold f; simpl; auto; fail).
      unfold f; simpl; destruct (b v); beta_simpl; auto.
    rewrite code_sub_ap.
    unfold code_abs0; fold (@code_abs0 Var).
    rewrite beta_s; auto.
  Qed.
End code_eq_abs0_sub.

Instance code_abs0_proper_le (Var Var' : Set) :
  Proper (eq ==> code_le ==> code_le) (@code_abs0 Var Var').
Proof.
  intros b b' bb' x x' xx'.
  code_le_weaken; intros ys f.
  induction ys.
  - assert (TOP @ f = TOP) as TOP_f; [simpl; auto|].
    simpl; rewrite <- bb'; intro Hc.
    rewrite ap_top_conv; rewrite ap_top_conv in Hc.
    rewrite <- TOP_f; rewrite <- TOP_f in Hc.
    rewrite <- code_sub_ap; rewrite <- code_sub_ap in Hc.
    rewrite code_eq_abs0_sub; rewrite code_eq_abs0_sub in Hc.
    rewrite xx' in Hc; assumption.
  - set (Ha := code_sub_inverse _ f a); destruct Ha as [a' aa'].
    simpl.
    repeat rewrite <- aa'.
    repeat rewrite <- code_sub_ap.
    repeat rewrite code_eq_abs0_sub.
    rewrite xx', bb'; firstorder.
Qed.

Instance code_abs0_proper_eq (Var Var' : Set) :
  Proper (eq ==> code_eq ==> code_eq) (@code_abs0 Var Var').
Proof.
  intros b b' bb' x x' [xx' x'x]; rewrite <- bb'.
  split; [rewrite xx' | rewrite x'x]; auto.
Qed.

(** Efficient I,K,B,C,S,eta-abstraction *)

Fixpoint code_abs {Var Var' : Set} (b : Var -> option Var') (x : Code Var) :
  Code Var' :=
  match x with
  | code_var v =>
      match b v with
      | None => I
      | Some v' => K * (code_var v')
      end
  | l * r =>
      match code_abs b l, code_abs b r with
      | K * l', I => l'
      | K * l', K * r' => K * (l' * r')
      | K * l', r' => B * l' * r'
      | l', K * r' => C * l' * r'
      | l', r' => S * l' * r'
      end
  | TOP => K * TOP
  | BOT => K * BOT
  | J => K * J
  | R => K * R
  | I => K * I
  | K => K * K
  | B => K * B
  | C => K * C
  | S => K * S
  end.

Section code_eq_abs_sub.
  Variable Var Var' : Set.
  Variable b : Var -> option Var'.
  Variable x : Code Var.
  Variable y : Code Var'.
  Let f v := match b v with None => y | Some v' => code_var v' end.

  Lemma code_eq_abs_abs0_ext : code_abs b x * y == code_abs0 b x * y.
  Proof.
    induction x; unfold f; simpl; auto.
    rewrite beta_s.
    rewrite <- IHc1; clear IHc1.
    rewrite <- IHc2; clear IHc2.
    destruct (code_abs b c1);
    destruct (code_abs b c2);
    try rewrite beta_s; auto;
    reflexivity || (
        destruct c3; try rewrite beta_s; beta_simpl; auto; reflexivity || (
            destruct c5; try rewrite beta_s; beta_simpl; auto
    )).
  Qed.

  Lemma code_eq_abs_sub : code_abs b x * y == code_sub f x.
  Proof.
    transitivity (code_abs0 b x * y);
    [apply code_eq_abs_abs0_ext | apply code_eq_abs0_sub].
  Qed.
End code_eq_abs_sub.
Hint Resolve code_eq_abs_sub.

Lemma code_eq_abs_abs0
  (Var Var' : Set) (b : Var -> option Var') (x : Code Var) :
  code_abs b x == code_abs0 b x.
Proof.
  eta_expand as y; apply code_eq_abs_abs0_ext.
Qed.

Instance code_abs_proper_le (Var Var' : Set) :
  Proper (eq ==> code_le ==> code_le) (@code_abs Var Var').
Proof.
  intros b b' bb' x x' xx'.
  repeat rewrite code_eq_abs_abs0.
  rewrite bb', xx'; auto.
Qed.

Instance code_abs_proper_eq (Var Var' : Set) :
  Proper (eq ==> code_eq ==> code_eq) (@code_abs Var Var').
Proof.
  intros b b' bb' x x' xx'.
  repeat rewrite code_eq_abs_abs0.
  rewrite bb', xx'; auto.
Qed.

(** ** Informal lambda notation *)

Definition make_var (Var : Set) (n : nat) : Code (nat + Var) :=
  code_var (@inl nat Var n).

Definition open_var {Var : Set} (x : Code Var) : Code (nat + Var) :=
  code_sub (fun v => code_var (inr v)) x.

Definition close_var {Var : Set} (x : Code (nat + Var)) : Code Var :=
  code_sub (fun v => match v with inr v' => code_var v' | _ => code_top end) x.

Lemma close_open (Var : Set) (x : Code Var) : close_var (open_var x) = x.
Proof.
  unfold close_var, open_var.
  induction x; simpl; auto.
  rewrite IHx1; rewrite IHx2; auto.
Qed.

Definition code_lambda {Var : Set} (x y : Code (nat + Var)) :
  Code (nat + Var) :=
  let beq_var (v1 v2 : nat + Var) : bool :=
    match v1, v2 with
    | inl n1, inl n2 => beq_nat n1 n2
    | _, _ => false
    end
  in
  match x with
  | code_var v => code_abs (fun v' => if beq_var v v' then None else Some v') y
  | _ => BOT  (* TODO implement pattern matching here *)
  end.

Notation "\ x , y" := (code_lambda x y)%code : code_scope.

(** ** Standard combinators *)

Section Y.
  Context {Var : Set}.
  Let f := make_var Var 0.
  Let x := make_var Var 1.
  Definition Y := Eval compute in close_var
    (\f, (\x, f * (x * x)) * (\x, f * (x * x))).
    (* ((\x, \f, f * (x * x * f)) * (\x, \f, f * (x * x * f))). *)
End Y.

Lemma code_eq_y (Var : Set) (f : Code Var) : Y * f == f * (Y * f).
Proof.
  unfold Y.
  rewrite beta_s at 1.
  rewrite beta_c at 1.
  rewrite beta_b at 1.
  rewrite beta_s at 1.
  rewrite beta_i.
  rewrite <- beta_s at 1.
  reflexivity.
Qed.

Section V.
  Context {Var : Set}.
  Let a := make_var Var 0.
  Let x := make_var Var 1.
  Definition V := Eval compute in close_var (\a, Y * \x, I || a o x).
End V.

Lemma code_eq_v (Var : Set) (a : Code Var) : V * a == I || a o (V * a).
Proof.
  unfold V at 1; fold (@Y Var).
  rewrite beta_b at 1.
  rewrite code_eq_y.
  rewrite <- (beta_right beta_b) at 1.
  unfold Y; fold (@V Var).
  beta_simpl; reflexivity.
Qed.

Lemma code_eq_v' (Var : Set) (a : Code Var) : V * a == I || (V * a) o a.
Proof.
Admitted.

(* The [div] combinator is useful in convergence testing *)

Definition div {Var : Set} : Code Var := Eval compute in V * (C * I * TOP).

Lemma code_eq_div (Var : Set) (x : Code Var) : div * x == x || div * x * TOP.
Proof.
  unfold div; fold (@V Var).
  rewrite code_eq_v at 1; beta_simpl; auto.
Qed.

Lemma code_eq_div' (Var : Set) (x : Code Var) :
  div * x == x || div * (x * TOP).
Proof.
  unfold div; fold (@V Var).
  rewrite code_eq_v' at 1; beta_simpl; auto.
Qed.

Lemma conv_div (Var : Set) (x : Code Var) : code_conv x <-> code_conv (div * x).
Proof.
  split; intro Hc.
    rewrite code_eq_div.
    rewrite pi_j_left.
    auto.
  admit. (* TODO use limit characterization of div and induction on probe *)
Qed.

Lemma conv_div_top (x : Code Empty_set) : code_conv x <-> div * x == TOP.
Proof.
  split.
    (* OLD
    intro H; induction H; split; auto; intros Var' c f Hc.
      rewrite H; rewrite code_eq_div; rewrite pi_j_left; auto.
    rewrite code_eq_div'; rewrite pi_j_right; rewrite IHconv; auto.
    *)
    admit.
  intros [H' H]; clear H'; unfold code_le in H.
  (* rewrite <- var_monad_unit_right; rewrite <- beta_i. *)
  assert (code_conv (I * (TOP @ code_var) : Code Empty_set)) as Ht; code_simpl; auto.
  set (Hd := H Empty_set I code_var Ht).
  code_simpl in Hd.
  apply conv_div; auto.
Qed.


(* $Id: FunctSequence.v,v 1.19 2003/03/13 12:06:19 lcf Exp $ *)

Require Export Continuity.
Require Export PartInterval.

Section Definitions.

(* Tex_Prose
\chapter{Sequences of Functions}

In this file we define some more operators on functions, namely sequences and limits.  These concepts are defined only for continuous functions.

\begin{convention} Throughout this section:
\begin{itemize}
\item \verb!a! and \verb!b! will be real numbers and the interval $[a,b]$ will be denoted by \verb!I!;
\item \verb!f, g! and \verb!h! will denote sequences of \emph{continuous} functions;
\item \verb!F, G! and \verb!H! will denote continuous functions.
\end{itemize}
\end{convention}

\section{Definitions}

A sequence of functions is simply an object of type \verb!nat->PartIR!.  However, we will be interested mostly in \emph{convergent} and Cauchy sequences.  Several definitions of these concepts will be formalized; they mirror the several different ways in which a Cauchy sequence can be defined.  For a discussion on the different notions of convergent see Bishop [1967].
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variable f:nat->PartIR.
Variable F:PartIR.

Hypothesis contf:(n:nat)(Continuous_I Hab (f n)).
Hypothesis contF:(Continuous_I Hab F).

Local incf [n:nat] := (contin_imp_inc ???? (contf n)).
Local incF := (contin_imp_inc ???? contF).

(* Begin_Tex_Verb *)
Definition Cauchy_fun_seq := (e:IR)(Zero[<]e)->{N:nat |
  (m,n:nat)(le N m)->(le N n)->(x:IR)(Hx:(I x))
  (AbsIR ((f m) x (incf m x Hx))[-]((f n) x (incf n x Hx)))[<=]e}.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition conv_fun_seq' := (e:IR)(Zero[<]e)->{N:nat |
  (n:nat)(le N n)->(x:IR)(Hx:(I x))
  (AbsIR ((f n) x (incf n x Hx))[-](F x (incF x Hx)))[<=]e}.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition conv_norm_fun_seq := (k:nat){N:nat |
  (n:nat)(le N n)->
  (Norm_Funct (Continuous_I_minus ????? (contf n) contF))
    [<=](one_div_succ k)}.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Cauchy_fun_seq1:=(k:nat){N:nat |
  (m,n:nat)(le N m)->(le N n)->
  (Norm_Funct (Continuous_I_minus ????? (contf m) (contf n)))
    [<=](one_div_succ k)}.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Cauchy_fun_seq' := (k:nat){N:nat |
  (m,n:nat)(le N m)->(le N n)->(x:IR)(Hx:(I x))
  (AbsIR (pfpfun ? ? (incf m x Hx))[-](pfpfun ? ? (incf n x Hx)))
    [<=](one_div_succ k)}.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Cauchy_fun_seq2 := (e:IR)(Zero[<]e)->{N:nat |
  (m:nat)(le N m)->(x:IR)(Hx:(I x))
  (AbsIR (pfpfun ? ? (incf m x Hx))[-](pfpfun ? ? (incf N x Hx)))[<=]e}.
(* End_Tex_Verb *)

(* Tex_Prose
These definitions are all shown to be equivalent.
*)

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq_seq' : Cauchy_fun_seq->Cauchy_fun_seq'.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intro.
Exact (H (one_div_succ k) (one_div_succ_pos ? k)).
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq'_seq : Cauchy_fun_seq'->Cauchy_fun_seq.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intros e He.
Elim (Archimedes One[/]e[//](pos_ap_zero ?? He)).
Intros i Hei.
Cut (Zero[<](!nring IR i)).
Intro Hi.
Elim (H i).
Intros N HN; Exists N.
Intros.
Apply leEq_transitive with (!one_div_succ IR i).
Apply HN; Assumption.
Unfold one_div_succ.
RStepr (One[/]?[//](recip_ap_zero ?? (pos_ap_zero ?? He))).
Unfold Snring.
Apply recip_resp_leEq.
Apply recip_resp_pos; Assumption.
Apply less_leEq; Apply leEq_less_trans with (!nring IR i).
Assumption.
Simpl; Apply less_plusOne.
Apply less_leEq_trans with (One[/]e[//](pos_ap_zero ?? He)).
Apply recip_resp_pos; Assumption.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_Cauchy_fun_seq' : conv_fun_seq'->Cauchy_fun_seq.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intros e He.
Elim (H ? (pos_div_two ?? He)).
Intros N HN.
Exists N; Intros.
Apply leEq_wdl with
  (AbsIR (((f m) x (incf m x Hx))[-](F x (incF x Hx)))[+]((F x (incF x Hx))[-]((f n) x (incf n x Hx)))).
2: Apply AbsIR_wd; Rational.
EApply leEq_transitive.
Apply triangle_IR.
RStepr e[/]TwoNZ[+]e[/]TwoNZ.
Apply plus_resp_leEq_both.
Apply HN; Assumption.
EApply leEq_wdl.
2: Apply AbsIR_minus.
Apply HN; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq_seq2 : Cauchy_fun_seq->Cauchy_fun_seq2.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intros.
Elim (H e H0); Intros N HN; Exists N.
Intros; Apply HN; Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq2_seq : Cauchy_fun_seq2->Cauchy_fun_seq.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intros.
Elim (H ? (pos_div_two ?? H0)); Intros N HN; Exists N; Intros.
Apply leEq_wdl with (AbsIR ((pfpfun ? ? (incf m x Hx))[-](pfpfun ? ? (incf N x Hx)))[-]((pfpfun ? ? (incf n x Hx))[-](pfpfun ? ? (incf N x Hx)))).
2: Apply AbsIR_wd; Rational.
EApply leEq_transitive.
Apply triangle_IR_minus.
RStepr e[/]TwoNZ[+]e[/]TwoNZ.
Apply plus_resp_leEq_both; Apply HN; Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_fun_seq'_norm : conv_fun_seq'->conv_norm_fun_seq.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intro.
Elim (H (one_div_succ k) (one_div_succ_pos ? k)).
Intros N HN.
Exists N.
Intros.
Apply leEq_Norm_Funct.
Fold I; Intros.
EApply leEq_wdl.
Apply (HN n H0 x H1).
Apply AbsIR_wd; Simpl; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_fun_norm_seq : conv_norm_fun_seq->conv_fun_seq'.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intros e He.
Elim (Archimedes One[/]?[//](pos_ap_zero ?? He)).
Intros k Hk.
Elim (H k); Clear H.
Intros N HN.
Exists N.
Intros.
Cut (Pred (f n){-}F x); Intros.
Apply leEq_wdl with (AbsIR ((f n){-}F x H0)).
EApply leEq_transitive.
2: Apply leEq_transitive with (!one_div_succ IR k).
2: Apply HN with n:=n; Assumption.
Apply norm_bnd_AbsIR; Assumption.
Unfold one_div_succ.
Unfold Snring.
Apply less_leEq; Apply swap_div with (pos_ap_zero ?? He).
Apply pos_nring_S.
Assumption.
EApply leEq_less_trans.
Apply Hk.
Simpl; Apply less_plusOne.
Apply AbsIR_wd; Simpl; Rational.
Split.
Apply incf; Assumption.
Apply incF; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq1_seq' : Cauchy_fun_seq1->Cauchy_fun_seq'.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intro.
Elim (H k); Clear H; Intros N HN.
Exists N; Intros.
EApply leEq_transitive.
2: Apply HN with m:=m n:=n; Assumption.
Cut (Pred (f m){-}(f n) x); Intros.
Apply leEq_wdl with (AbsIR (pfpfun ? ? H1)).
Apply norm_bnd_AbsIR; Assumption.
Apply AbsIR_wd; Simpl; Rational.
Split; Simpl; Apply incf; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq'_seq1 : Cauchy_fun_seq'->Cauchy_fun_seq1.
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intro.
Elim (H k); Clear H; Intros N HN.
Exists N; Intros.
Apply leEq_Norm_Funct.
Intros.
EApply leEq_wdl.
Apply (HN m n H H0 x H1).
Apply AbsIR_wd; Simpl; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq_seq1 : Cauchy_fun_seq->Cauchy_fun_seq1.
(* End_Tex_Verb *)
Intro.
Apply Cauchy_fun_seq'_seq1.
Apply Cauchy_fun_seq_seq'.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq1_seq : Cauchy_fun_seq1->Cauchy_fun_seq.
(* End_Tex_Verb *)
Intro.
Apply Cauchy_fun_seq'_seq.
Apply Cauchy_fun_seq1_seq'.
Assumption.
Qed.

(* Tex_Prose
A Cauchy sequence of functions is pointwise a Cauchy sequence.
*)

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_real : Cauchy_fun_seq->
  (x:IR)(Hx:(I x))(Cauchy_prop [n:nat](pfpfun ? ? (incf n x Hx))).
(* End_Tex_Verb *)
Intros.
Red; Red in H.
Intros e He.
Elim (H ? He); Clear H; Intros N HN.
Exists N.
Intros.
Apply AbsIR_imp_AbsSmall.
Apply HN.
Assumption.
Apply le_n.
Qed.

End Definitions.

Section More_Definitions.

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variable f:nat->PartIR.
Hypothesis contf:(n:nat)(Continuous_I Hab (f n)).

(* Tex_Prose
We can also say that $f$ is simply convergent if it converges to some continuous function\footnote{Notice that we do not quantify directly over partial functions, for reasons which were already explained.}.
*)

(* Begin_Tex_Verb *)
Definition conv_fun_seq :=
  {f':(CSetoid_fun (subset (Compact Hab)) IR) &
    {contf':(Continuous_I Hab (PartInt f')) &
      (conv_fun_seq' a b Hab f (PartInt f') contf contf')}}.
(* End_Tex_Verb *)

(* Tex_Prose
It is useful to extract the Limit as a partial function:
*)

(* Begin_Tex_Verb *)
Hypothesis H:(Cauchy_fun_seq ??? f contf).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Cauchy_fun_seq_Lim : PartIR.
(* End_Tex_Verb *)
Apply Build_PartFunct with
  pfpfun:=[x:IR][Hx:(I x)](Lim (Build_CauchySeq ? [n:nat](pfpfun ? ? (contin_imp_inc ???? (contf n) x Hx))
    (Cauchy_fun_real ???? contf H x Hx))).
Unfold I; Apply compact_wd.
Intros.
Elim (Lim_strext ?? H0).
Intros n Hn.
Simpl in Hn.
Exact (pfstrx ?????? Hn).
Defined.

End More_Definitions.

Section Irrelevance_of_Proofs.

(* Tex_Prose
\section{Irrelevance of Proofs}

This section contains a number of technical results stating mainly that being a Cauchy sequence or converging to some Limit is a property of the sequence itself and independent of the proofs we supply of its continuity or the continuity of its Limit.
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variable f:nat->PartIR.
(* Begin_Tex_Verb *)
Hypothesis contf,contf0:(n:nat)(Continuous_I Hab (f n)).
(* End_Tex_Verb *)

Variable F:PartIR.
(* Begin_Tex_Verb *)
Hypothesis contF,contF0:(Continuous_I Hab F).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma conv_fun_seq'_wd : (conv_fun_seq' ????? contf contF)->
  (conv_fun_seq' ????? contf0 contF0).
(* End_Tex_Verb *)
Intro.
Red; Intros.
Elim (H e H0); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN n H1 x Hx).
Apply AbsIR_wd; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq'_wd : (Cauchy_fun_seq' ???? contf)->
  (Cauchy_fun_seq' ???? contf0).
(* End_Tex_Verb *)
Intro.
Red; Intros.
Elim (H k); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN m n H0 H1 x Hx).
Apply AbsIR_wd; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq2_wd : (Cauchy_fun_seq2 ???? contf)->
  (Cauchy_fun_seq2 ???? contf0).
(* End_Tex_Verb *)
Intro.
Red; Intros.
Elim (H e H0); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN m H1 x Hx).
Apply AbsIR_wd; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_norm_fun_seq_wd :
  (conv_norm_fun_seq ????? contf contF)->
  (conv_norm_fun_seq ????? contf0 contF0).
(* End_Tex_Verb *)
Intro.
Red; Intros.
Elim (H k); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN n H0).
Apply Norm_Funct_wd.
Apply Feq_reflexive; Included.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq1_wd : (Cauchy_fun_seq1 ???? contf)->
  (Cauchy_fun_seq1 ???? contf0).
(* End_Tex_Verb *)
Intro.
Red; Intros.
Elim (H k); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN m n H0 H1).
Apply Norm_Funct_wd.
Apply Feq_reflexive; Included.
Qed.

End Irrelevance_of_Proofs.

Section More_Proof_Irrelevance.

(* Begin_Tex_Verb *)
Lemma conv_fun_seq_wd : (a,b,Hab,f,contf,contf0:?)
  (conv_fun_seq a b Hab f contf)->(conv_fun_seq a b Hab f contf0).
(* End_Tex_Verb *)
Intro; Red; Intros.
Elim H; Intros f' Hf'.
Exists f'.
Inversion_clear Hf'.
Exists x.
EApply conv_fun_seq'_wd.
Apply H0.
Qed.

End More_Proof_Irrelevance.

Section More_Properties.

(* Tex_Prose
\section{Other Properties}

Still more technical details---a convergent sequence converges to its Limit; the Limit is a continuous function; and convergence is well defined with respect to functional equality in the interval $[a,b]$.
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variables f,g:nat->PartIR.
(* Begin_Tex_Verb *)
Hypothesis contf,contf0:(n:nat)(Continuous_I Hab (f n)).
Hypothesis contg,contg0:(n:nat)(Continuous_I Hab (g n)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Cauchy_conv_fun_seq' : (H:(Cauchy_fun_seq ??? f contf))
  (contf':(Continuous_I Hab (Cauchy_fun_seq_Lim ????? H)))
  (conv_fun_seq' ????? contf contf').
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (H e H0).
Intros N HN.
Exists N.
Intros.
LetTac incf:=[n:nat](contin_imp_inc ???? (contf n)).
LetTac incf':=(contin_imp_inc ???? contf').
Apply leEq_wdl with (AbsIR (Lim (Cauchy_const ((f n) x (incf n x Hx))))[-](Part (Cauchy_fun_seq_Lim ????? H) x (incf' x Hx))).
2: Apply AbsIR_wd; Apply cg_minus_wd.
2: Apply eq_symmetric_unfolded; Apply Lim_const.
2: Algebra.
Simpl.
Apply leEq_wdl with (AbsIR (Lim (Build_CauchySeq IR ?
  (Cauchy_minus (Cauchy_const (pfpfun ? ? (incf n x Hx))) (Build_CauchySeq ?? (Cauchy_fun_real ????? H x (incf' x Hx))))))).
2: Apply AbsIR_wd; Apply Lim_minus.
EApply leEq_wdl.
2: Apply Lim_abs.
Simpl.
Apply str_seq_leEq_so_Lim_leEq.
Exists N; Intros.
Simpl.
EApply leEq_wdl.
Apply (HN n i H1 H2 x Hx).
Apply AbsIR_wd; Rational.
Qed.

Variables F,G:PartIR.
(* Begin_Tex_Verb *)
Hypothesis contF,contF0:(Continuous_I Hab F).
Hypothesis contG,contG0:(Continuous_I Hab G).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma conv_fun_seq'_wdl : ((n:nat)(Feq I (f n) (g n)))->
  (conv_fun_seq' ????? contf contF)->
  (conv_fun_seq' ????? contg contF0).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (H0 e H1); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN n H2 x Hx).
Apply AbsIR_wd; Apply cg_minus_wd.
Elim (H n); Intros Haux inc.
Inversion_clear Haux.
Auto.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_fun_seq'_wdr : (Feq I F G)->
  (conv_fun_seq' ????? contf contF)->
  (conv_fun_seq' ????? contf0 contG).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (H0 e H1); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN n H2 x Hx).
Apply AbsIR_wd; Apply cg_minus_wd.
Algebra.
Elim H; Intros Haux inc.
Inversion_clear Haux.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_fun_seq'_wdl' : ((n:nat)(Feq I (f n) (g n)))->
  (conv_fun_seq' ????? contf contF)->
  (conv_fun_seq' ????? contg contF).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (H0 e H1); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN n H2 x Hx).
Apply AbsIR_wd; Apply cg_minus_wd.
Elim (H n); Intros Haux inc.
Inversion_clear Haux.
Auto.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_fun_seq'_wdr' : (Feq I F G)->
  (conv_fun_seq' ????? contf contF)->
  (conv_fun_seq' ????? contf contG).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (H0 e H1); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN n H2 x Hx).
Apply AbsIR_wd; Apply cg_minus_wd.
Algebra.
Elim H; Intros Haux inc.
Inversion_clear Haux.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_fun_seq_wd : ((n:nat)(Feq I (f n) (g n)))->
  (Cauchy_fun_seq ???? contf)->(Cauchy_fun_seq ???? contg).
(* End_Tex_Verb *)
Intros.
Red; Red in H0.
Intros.
Elim (H0 e H1); Clear H0; Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN m n H0 H2 x Hx).
Elim (H n); Intros.
Inversion_clear a0.
Elim (H m); Intros.
Inversion_clear a0.
Apply AbsIR_wd; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_cont_Lim : (H:(Cauchy_fun_seq a b Hab f contf))
  (Continuous_I Hab (Cauchy_fun_seq_Lim ???? contf H)).
(* End_Tex_Verb *)
Intros.
Split.
Included.
Intros e He.
Elim (H ? (pos_div_three ?? He)); Intros N HN.
Elim (contf N); Intros incf contf'.
Elim (contf' ? (pos_div_three ?? He)).
Intros d H0 H1.
Exists d.
Assumption.
Intros.
Cut (x,y,z,w:IR)(AbsIR x[-]w)[=](AbsIR (x[-]y)[+](y[-]z)[+](z[-]w)); Intros.
2: Apply AbsIR_wd; Rational.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply H5 with y:=(pfpfun ? ? (incf x H2)) z:=(pfpfun ? ? (incf y H3)).
RStepr e[/]ThreeNZ[+]e[/]ThreeNZ[+]e[/]ThreeNZ.
EApply leEq_transitive.
Apply triangle_IR.
Apply plus_resp_leEq_both.
EApply leEq_transitive.
Apply triangle_IR.
Apply plus_resp_leEq_both.
Apply leEq_wdl with (AbsIR (pfpfun ? ? Hx)[-](Lim (Cauchy_const (pfpfun ? ? (incf x H2))))).
2: Apply AbsIR_wd; Apply cg_minus_wd.
2: Algebra.
2: Apply eq_symmetric_unfolded; Apply Lim_const.
Simpl.
Apply leEq_wdl with (AbsIR (Lim (Build_CauchySeq IR ?
  (Cauchy_minus (Build_CauchySeq ?? (Cauchy_fun_real ????? H x Hx)) (Cauchy_const (pfpfun ? ? (incf x H2))))))).
2: Apply AbsIR_wd; Apply Lim_minus.
EApply leEq_wdl.
2: Apply Lim_abs.
Simpl.
Apply str_seq_leEq_so_Lim_leEq.
Exists N; Intros.
Simpl.
EApply leEq_wdl.
Apply (HN i N) with x:=x Hx:=Hx; Auto with arith.
Apply AbsIR_wd; Rational.
Apply H1; Assumption.
Apply leEq_wdl with (AbsIR (Lim (Cauchy_const (pfpfun ? ? (incf y H3))))[-](Part (Cauchy_fun_seq_Lim ????? H) y Hy)).
2: Apply AbsIR_wd; Apply cg_minus_wd.
2: Apply eq_symmetric_unfolded; Apply Lim_const.
2: Algebra.
Simpl.
Apply leEq_wdl with (AbsIR (Lim (Build_CauchySeq IR ?
  (Cauchy_minus (Cauchy_const (pfpfun ? ? (incf y H3))) (Build_CauchySeq ?? (Cauchy_fun_real ????? H y Hy)))))).
2: Apply AbsIR_wd; Apply Lim_minus.
EApply leEq_wdl.
2: Apply Lim_abs.
Simpl.
Apply str_seq_leEq_so_Lim_leEq.
Exists N; Intros.
Simpl.
EApply leEq_wdl.
Apply (HN N i) with x:=y Hx:=Hy; Auto.
Apply AbsIR_wd; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_conv_fun_seq :
  (Cauchy_fun_seq ???? contf)->(conv_fun_seq ???? contf).
(* End_Tex_Verb *)
Intros.
Cut (Continuous_I Hab (Cauchy_fun_seq_Lim ????? H)); Intros.
Exists (IntPartIR (contin_imp_inc ???? H0)).
Cut (Continuous_I Hab (PartInt (IntPartIR (contin_imp_inc ???? H0)))).
2: EApply Continuous_I_wd.
3: Apply Cauchy_cont_Lim with H:=H.
2: FEQ.
2: Simpl; Apply Lim_wd'; Intros; Algebra.
Intro H2; Exists H2.
Red; Intros.
Elim (Cauchy_conv_fun_seq' H H0 e H1); Intros N HN.
Exists N; Intros.
EApply leEq_wdl.
Apply (HN n H3 x Hx).
Apply AbsIR_wd; Apply cg_minus_wd.
Algebra.
Simpl; Apply Lim_wd'; Intros; Simpl; Rational.
Simpl; Algebra.
Simpl; Apply Cauchy_cont_Lim.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_Cauchy_fun_seq :
  (conv_fun_seq ???? contf)->(Cauchy_fun_seq ???? contf).
(* End_Tex_Verb *)
Intro.
Elim H; Intros ff Hff.
Inversion_clear Hff.
Apply conv_Cauchy_fun_seq' with (PartInt ff) x.
Unfold I; EApply conv_fun_seq'_wd.
Apply H0.
Qed.

(* Tex_Prose
More interesting is the fact that a convergent sequence of functions converges pointwise as a sequence of real numbers.
*)

(* Begin_Tex_Verb *)
Lemma fun_conv_imp_seq_conv :
  (conv_fun_seq' ????? contf contF)->
  (x:IR)(Compact Hab x)->(Hxf,HxF:?)
  (Cauchy_Lim_prop2 [n:nat]((f n) x (Hxf n)) (F x HxF)).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (H eps H1).
Intros N HN.
Exists N; Intros.
Apply AbsIR_imp_AbsSmall.
EApply leEq_wdl.
Apply (HN m H2 x H0).
Apply AbsIR_wd; Algebra.
Qed.

(* Tex_Prose
And a sequence of real numbers converges iff the corresponding sequence of constant functions converges to the corresponding constant function.
*)

(* Begin_Tex_Verb *)
Lemma seq_conv_imp_fun_conv : (x,y:?)(Cauchy_Lim_prop2 x y)->
  (Hf,HF:?)(conv_fun_seq' a b Hab [n:nat]{-C-}(x n) {-C-}y Hf HF).
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (H e H0); Intros N HN.
Exists N; Intros; Simpl.
Apply AbsSmall_imp_AbsIR.
Auto.
Qed.

End More_Properties.

Hints Resolve Cauchy_cont_Lim : continuous.

Section Algebraic_Properties.

(* Tex_Prose
\section{Algebraic Properties}

We now study how convergence is affected by algebraic operations, and some algebraic properties of the Limit function.
*)

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variables f,g:nat->PartIR.
Hypothesis contf:(n:nat)(Continuous_I Hab (f n)).
Hypothesis contg:(n:nat)(Continuous_I Hab (g n)).

(* Tex_Prose
First, the Limit function is unique.
*)

(* Begin_Tex_Verb *)
Lemma FLim_unique : (F,G,HF,HG:?)
  (conv_fun_seq' a b Hab f F contf HF)->
  (conv_fun_seq' a b Hab f G contf HG)->
  (Feq (Compact Hab) F G).
(* End_Tex_Verb *)
Intros.
Cut (Cauchy_fun_seq ?? Hab ? contf); Intros.
Apply Feq_transitive with (Cauchy_fun_seq_Lim ????? H1).
FEQ.
Simpl.
Apply Limits_unique.
Simpl.
EApply fun_conv_imp_seq_conv with Hab:=Hab Hxf:=[n:nat](contin_imp_inc ?? Hab ? (contf n) x Hx'); Auto.
Apply H.
Apply Feq_symmetric.
FEQ.
Simpl.
Apply Limits_unique.
Simpl.
EApply fun_conv_imp_seq_conv with Hab:=Hab Hxf:=[n:nat](contin_imp_inc ?? Hab ? (contf n) x Hx'); Auto.
Apply H0.
Apply conv_Cauchy_fun_seq' with F HF; Auto.
Qed.

(* Tex_Prose
Constant sequences\footnote{Not to be confused with sequences of constant functions!} always converge.
*)

(* Begin_Tex_Verb *)
Lemma fun_Lim_seq_const : (H:PartIR)(contH,contH':?)
  (conv_fun_seq' a b Hab [n:nat]H H contH contH').
(* End_Tex_Verb *)
Exists O; Intros.
EApply leEq_wdl.
2: EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply AbsIRz_isz.
Apply less_leEq; Assumption.
Apply AbsIR_wd; Rational.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Cauchy_prop_const : (H:PartIR)(contH:?)
  (Cauchy_fun_seq a b Hab [n:nat]H contH).
(* End_Tex_Verb *)
Intros.
Apply conv_Cauchy_fun_seq' with H (contH O).
Apply fun_Lim_seq_const.
Qed.

(* Tex_Prose
We now prove that if two sequences converge than their Sum (difference, product) also converge to the Sum (difference, product) of their Limits.
*)

Variables F,G:PartIR.
Hypothesis contF:(Continuous_I Hab F).
Hypothesis contG:(Continuous_I Hab G).

(* Begin_Tex_Verb *)
Hypothesis convF:(conv_fun_seq' a b Hab f F contf contF).
Hypothesis convG:(conv_fun_seq' a b Hab g G contg contG).
(* End_Tex_Verb *)

Local incf:=[n:nat](contin_imp_inc ???? (contf n)).
Local incg:=[n:nat](contin_imp_inc ???? (contg n)).
Local incF:=(contin_imp_inc ???? contF).
Local incG:=(contin_imp_inc ???? contG).

(* Begin_Tex_Verb *)
Lemma fun_Lim_seq_plus' : (H,H':?)
  (conv_fun_seq' a b Hab [n:nat](f n){+}(g n) F{+}G H H').
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (convF ? (pos_div_two ?? H0)); Intros Nf HNf.
Elim (convG ? (pos_div_two ?? H0)); Intros Ng HNg.
Cut (le Nf (max Nf Ng)); [Intro | Apply le_max_l].
Cut (le Ng (max Nf Ng)); [Intro | Apply le_max_r].
Exists (max Nf Ng); Intros.
Apply leEq_wdl with (AbsIR ((pfpfun ? ? (incf n x Hx))[+](pfpfun ? ? (incg n x Hx)))[-]((pfpfun ? ? (incF x Hx))[+](pfpfun ? ? (incG x Hx)))).
2: Apply AbsIR_wd; Simpl; Algebra.
Apply leEq_wdl with (AbsIR ((pfpfun ? ? (incf n x Hx))[-](pfpfun ? ? (incF x Hx)))[+]((pfpfun ? ? (incg n x Hx))[-](pfpfun ? ? (incG x Hx)))).
2: Apply AbsIR_wd; Simpl; Rational.
RStepr e[/]TwoNZ[+]e[/]TwoNZ.
EApply leEq_transitive.
Apply triangle_IR.
Apply plus_resp_leEq_both.
Unfold incf; Apply HNf; Apply le_trans with (max Nf Ng); Auto.
Unfold incg; Apply HNg; Apply le_trans with (max Nf Ng); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Lim_seq_minus' : (H,H':?)
  (conv_fun_seq' a b Hab [n:nat](f n){-}(g n) F{-}G H H').
(* End_Tex_Verb *)
Intros.
Red; Intros.
Elim (convF ? (pos_div_two ?? H0)); Intros Nf HNf.
Elim (convG ? (pos_div_two ?? H0)); Intros Ng HNg.
Cut (le Nf (max Nf Ng)); [Intro | Apply le_max_l].
Cut (le Ng (max Nf Ng)); [Intro | Apply le_max_r].
Exists (max Nf Ng); Intros.
Apply leEq_wdl with (AbsIR ((pfpfun ? ? (incf n x Hx))[-](pfpfun ? ? (incg n x Hx)))[-]((pfpfun ? ? (incF x Hx))[-](pfpfun ? ? (incG x Hx)))).
2: Apply AbsIR_wd; Simpl; Algebra.
Apply leEq_wdl with (AbsIR ((pfpfun ? ? (incf n x Hx))[-](pfpfun ? ? (incF x Hx)))[-]((pfpfun ? ? (incg n x Hx))[-](pfpfun ? ? (incG x Hx)))).
2: Apply AbsIR_wd; Simpl; Rational.
RStepr e[/]TwoNZ[+]e[/]TwoNZ.
EApply leEq_transitive.
Apply triangle_IR_minus.
Apply plus_resp_leEq_both.
Unfold incf; Apply HNf; Apply le_trans with (max Nf Ng); Auto.
Unfold incg; Apply HNg; Apply le_trans with (max Nf Ng); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Lim_seq_mult' : (H,H':?)
  (conv_fun_seq' a b Hab [n:nat](f n){*}(g n) F{*}G H H').
(* End_Tex_Verb *)
Intros.
LetTac nF := (Norm_Funct contF).
LetTac nG := (Norm_Funct contG).
Red; Intros.
LetTac ee:=(Min e One).
Cut (Zero[<]ee); Intros.
LetTac eg:= (ee[/]ThreeNZ)[/]?[//](max_one_ap_zero nF).
LetTac ef:= (ee[/]ThreeNZ)[/]?[//](max_one_ap_zero nG).
Cut (Zero[<]eg).
Intro Heg.
Cut (Zero[<]ef).
Intro Hef.
Elim (convF ? Hef); Intros NF HNF; Clear convF.
Elim (convG ? Heg); Intros NG HNG; Clear convG.
Cut (le NF (max NF NG)); [Intro | Apply le_max_l].
Cut (le NG (max NF NG)); [Intro | Apply le_max_r].
Exists (max NF NG); Intros.
Apply leEq_transitive with ee.
2: Unfold ee; Apply Min_leEq_lft.
Apply leEq_wdl with (AbsIR ((pfpfun ? ? (incf n x Hx))[*](pfpfun ? ? (incg n x Hx)))[-]((pfpfun ? ? (incF x Hx))[*](pfpfun ? ? (incG x Hx)))).
2: Apply AbsIR_wd; Simpl; Algebra.
Apply leEq_wdl with (AbsIR (pfpfun ? ? (incF x Hx))[*]((pfpfun ? ? (incg n x Hx))[-](pfpfun ? ? (incG x Hx)))[+]
  ((pfpfun ? ? (incf n x Hx))[-](pfpfun ? ? (incF x Hx)))[*]((pfpfun ? ? (incg n x Hx))[-](pfpfun ? ? (incG x Hx)))[+]
  (pfpfun ? ? (incG x Hx))[*]((pfpfun ? ? (incf n x Hx))[-](pfpfun ? ? (incF x Hx)))).
2: Apply AbsIR_wd; Simpl; Rational.
RStepr ee[/]ThreeNZ[+]ee[/]ThreeNZ[+]ee[/]ThreeNZ.
EApply leEq_transitive.
Apply triangle_IR.
Apply plus_resp_leEq_both.
EApply leEq_transitive.
Apply triangle_IR.
Apply plus_resp_leEq_both.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_resp_mult.
Apply leEq_transitive with (Max nF One)[*](AbsIR (pfpfun ? ? (incg n x Hx))[-](pfpfun ? ? (incG x Hx))).
Apply mult_resp_leEq_rht.
Apply leEq_transitive with nF.
Unfold nF; Apply norm_bnd_AbsIR; Assumption.
Apply lft_leEq_Max.
Apply AbsIR_nonneg.
EApply shift_mult_leEq'.
Apply pos_max_one.
Unfold eg in HNG; Unfold incg; Apply HNG; Apply le_trans with (max NF NG); Auto.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_resp_mult.
Apply leEq_transitive with (ee[/]ThreeNZ)[*](ee[/]ThreeNZ).
2: Stepr ee[/]ThreeNZ[*]One; Apply mult_resp_leEq_lft.
Apply mult_resp_leEq_both; Try Apply AbsIR_nonneg.
EApply leEq_transitive.
Unfold incf; Apply HNF; Apply le_trans with (max NF NG); Auto.
Unfold ef.
Apply shift_div_leEq.
Apply pos_max_one.
Step (ee[/]ThreeNZ)[*]One; Apply mult_resp_leEq_lft.
Apply rht_leEq_Max.
Apply less_leEq; Apply shift_less_div; Step (Zero::IR); [Apply pos_three | Assumption].
EApply leEq_transitive.
Unfold incg; Apply HNG; Apply le_trans with (max NF NG); Auto.
Unfold eg.
Apply shift_div_leEq.
Apply pos_max_one.
Step (ee[/]ThreeNZ)[*]One; Apply mult_resp_leEq_lft.
Apply rht_leEq_Max.
Apply less_leEq; Apply shift_less_div; Step (Zero::IR); [Apply pos_three | Assumption].
Apply shift_div_leEq.
Apply pos_three.
Stepr (Three::IR).
Unfold ee; Apply leEq_transitive with (One::IR).
Apply Min_leEq_rht.
Apply less_leEq; Apply one_less_three.
Apply less_leEq; Apply shift_less_div.
Apply pos_three.
Step (Zero::IR); Assumption.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_resp_mult.
Apply leEq_transitive with (Max nG One)[*](AbsIR (pfpfun ? ? (incf n x Hx))[-](pfpfun ? ? (incF x Hx))).
Apply mult_resp_leEq_rht.
Apply leEq_transitive with nG.
Unfold nG; Apply norm_bnd_AbsIR; Assumption.
Apply lft_leEq_Max.
Apply AbsIR_nonneg.
EApply shift_mult_leEq'.
Apply pos_max_one.
Unfold ef in HNF; Unfold incf; Apply HNF; Apply le_trans with (max NF NG); Auto.
Unfold ef.
Apply div_resp_pos.
Apply pos_max_one.
Apply shift_less_div; Step (Zero::IR); [Apply pos_three | Assumption].
Unfold eg.
Apply div_resp_pos.
Apply pos_max_one.
Apply shift_less_div; Step (Zero::IR); [Apply pos_three | Assumption].
Unfold ee; Apply less_Min.
Assumption.
Apply pos_one.
Qed.

End Algebraic_Properties.

Section More_Algebraic_Properties.

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variables f,g:nat->PartIR.
Hypothesis contf : (n:nat)(Continuous_I Hab (f n)).
Hypothesis contg : (n:nat)(Continuous_I Hab (g n)).

(* Tex_Prose
The same is true if we don't make the limits explicit.
*)

(* Begin_Tex_Verb *)
Hypothesis Hf:(Cauchy_fun_seq ???? contf).
Hypothesis Hg:(Cauchy_fun_seq ???? contg).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma fun_Lim_seq_plus : (H,H':?)
  (conv_fun_seq' a b Hab [n:nat](f n){+}(g n)
    (Cauchy_fun_seq_Lim ????? Hf){+}(Cauchy_fun_seq_Lim ????? Hg)
    H H').
(* End_Tex_Verb *)
Intros.
LetTac F:=(Cauchy_fun_seq_Lim ????? Hf).
Cut (Continuous_I Hab F); Intros.
2: Unfold F; Apply Cauchy_cont_Lim.
Cut (conv_fun_seq' ????? contf H0).
2: Unfold F; Apply Cauchy_conv_fun_seq'; Assumption.
Intro Hf'.
LetTac G:=(Cauchy_fun_seq_Lim ????? Hg).
Cut (Continuous_I Hab G); Intros.
2: Unfold G; Apply Cauchy_cont_Lim.
Cut (conv_fun_seq' ????? contg H1).
2: Unfold G; Apply Cauchy_conv_fun_seq'; Assumption.
Intro Hg'.
Apply fun_Lim_seq_plus' with contf contg H0 H1; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Cauchy_prop_plus : (H:?)
  (Cauchy_fun_seq a b Hab [n:nat](f n){+}(g n) H).
(* End_Tex_Verb *)
Intro.
Cut (Continuous_I Hab (Cauchy_fun_seq_Lim ????? Hf){+}(Cauchy_fun_seq_Lim ????? Hg)); [Intro | Contin].
Apply conv_Cauchy_fun_seq' with (Cauchy_fun_seq_Lim ????? Hf){+}(Cauchy_fun_seq_Lim ????? Hg) H0.
Apply fun_Lim_seq_plus.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Lim_seq_minus : (H,H':?)
  (conv_fun_seq' a b Hab [n:nat](f n){-}(g n)
    (Cauchy_fun_seq_Lim ????? Hf){-}(Cauchy_fun_seq_Lim ????? Hg)
    H H').
(* End_Tex_Verb *)
Intros.
LetTac F:=(Cauchy_fun_seq_Lim ????? Hf).
Cut (Continuous_I Hab F); Intros.
2: Unfold F; Apply Cauchy_cont_Lim.
Cut (conv_fun_seq' ????? contf H0).
2: Unfold F; Apply Cauchy_conv_fun_seq'; Assumption.
Intro Hf'.
LetTac G:=(Cauchy_fun_seq_Lim ????? Hg).
Cut (Continuous_I Hab G); Intros.
2: Unfold G; Apply Cauchy_cont_Lim.
Cut (conv_fun_seq' ????? contg H1).
2: Unfold G; Apply Cauchy_conv_fun_seq'; Assumption.
Intro Hg'.
Apply fun_Lim_seq_minus' with contf contg H0 H1; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Cauchy_prop_minus : (H:?)
  (Cauchy_fun_seq a b Hab [n:nat](f n){-}(g n) H).
(* End_Tex_Verb *)
Intro.
Cut (Continuous_I Hab (Cauchy_fun_seq_Lim ????? Hf){-}(Cauchy_fun_seq_Lim ????? Hg)); [Intro | Contin].
Apply conv_Cauchy_fun_seq' with ((Cauchy_fun_seq_Lim ????? Hf){-}(Cauchy_fun_seq_Lim ????? Hg)) H0.
Apply fun_Lim_seq_minus.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Lim_seq_mult : (H,H':?)
  (conv_fun_seq' a b Hab [n:nat](f n){*}(g n)
    (Cauchy_fun_seq_Lim ????? Hf){*}(Cauchy_fun_seq_Lim ????? Hg)
    H H').
(* End_Tex_Verb *)
Intros.
LetTac F:=(Cauchy_fun_seq_Lim ????? Hf).
Cut (Continuous_I Hab F); [Intro | Unfold F; Contin].
Cut (conv_fun_seq' ????? contf H0).
2: Unfold F; Apply Cauchy_conv_fun_seq'; Assumption.
Intro convF.
LetTac G:=(Cauchy_fun_seq_Lim ????? Hg).
Cut (Continuous_I Hab G); [Intro | Unfold G; Contin].
Cut (conv_fun_seq' ????? contg H1).
2: Unfold G; Apply Cauchy_conv_fun_seq'; Assumption.
Intro convG.
Cut (Continuous_I Hab F); [Intro HF' | Unfold F I; Apply Cauchy_cont_Lim; Assumption].
Cut (Continuous_I Hab G); [Intro HG' | Unfold G I; Apply Cauchy_cont_Lim; Assumption].
Apply fun_Lim_seq_mult' with contf contg H0 H1; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Cauchy_prop_mult : (H:?)
  (Cauchy_fun_seq a b Hab [n:nat](f n){*}(g n) H).
(* End_Tex_Verb *)
Intro.
Cut (Continuous_I Hab ((Cauchy_fun_seq_Lim ????? Hf){*}(Cauchy_fun_seq_Lim ????? Hg))); [Intro | Contin].
Apply conv_Cauchy_fun_seq' with ((Cauchy_fun_seq_Lim ????? Hf){*}(Cauchy_fun_seq_Lim ????? Hg)) H0.
Apply fun_Lim_seq_mult.
Qed.

End More_Algebraic_Properties.

Section Still_More_Algebraic_Properties.

Variables a,b:IR.
Hypothesis Hab:a[<=]b.
Local I:=(Compact Hab).

Variable f:nat->PartIR.
Hypothesis contf : (n:nat)(Continuous_I Hab (f n)).
Hypothesis Hf:(Cauchy_fun_seq ???? contf).

(* Tex_Prose
As a corollary, we get the analogous property for the sequence of algebraic inverse functions.
*)

(* Begin_Tex_Verb *)
Lemma fun_Lim_seq_inv : (H,H':?)
  (conv_fun_seq' a b Hab [n:nat]{--}(f n)
    {--}(Cauchy_fun_seq_Lim ????? Hf) H H').
(* End_Tex_Verb *)
Intros.
Cut (n:nat)(Continuous_I Hab ({-C-}Zero{-}(f n))); Intros.
Unfold I; EApply conv_fun_seq'_wdl with [n:nat]{-C-}Zero{-}(f n) H0 H'.
Intro; FEQ; Try (Apply contin_imp_inc; Apply contf).
Cut (Continuous_I Hab (Cauchy_fun_seq_Lim ????? (fun_Cauchy_prop_const a b Hab {-C-}Zero [n:nat](Continuous_I_const ????))){-}(Cauchy_fun_seq_Lim ????? Hf)); Intros.
Apply conv_fun_seq'_wdr with H0
  (Cauchy_fun_seq_Lim ????? (fun_Cauchy_prop_const a b Hab {-C-}Zero [n:nat](Continuous_I_const ????))){-}(Cauchy_fun_seq_Lim ????? Hf) H1.
Apply eq_imp_Feq.
Included.
Included.
Intros; Simpl.
Stepr Zero[-](Lim (Build_CauchySeq ?? (Cauchy_fun_real ???? contf Hf x Hx'))).
Apply cg_minus_wd.
EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply Lim_const.
Apply Lim_wd'; Intros; Simpl; Algebra.
Apply Lim_wd'; Intros; Simpl; Rational.
Apply fun_Lim_seq_minus with f:=[n:nat]({-C-}Zero::PartIR).
Contin.
Contin.
Qed.

(* Begin_Tex_Verb *)
Lemma fun_Cauchy_prop_inv : (H:?)
  (Cauchy_fun_seq a b Hab [n:nat]{--}(f n) H).
(* End_Tex_Verb *)
Intro.
Cut (Continuous_I Hab {--}(Cauchy_fun_seq_Lim ????? Hf)); [Intro | Contin].
Apply conv_Cauchy_fun_seq' with ({--}(Cauchy_fun_seq_Lim ????? Hf)) H0.
Apply fun_Lim_seq_inv.
Qed.

End Still_More_Algebraic_Properties.

Hints Resolve Continuous_I_Sum Continuous_I_Sumx Continuous_I_Sum0 : continuous.


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

Require Import Bool ZArith OrdersFacts Nnat ZAxioms ZSig Lia.

(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] *)

Module ZTypeIsZAxioms (Import ZZ : ZType').

#[global]
Hint Rewrite
 spec_0 spec_1 spec_2 spec_add spec_sub spec_pred spec_succ
 spec_mul spec_opp spec_of_Z spec_div spec_modulo spec_square spec_sqrt
 spec_compare spec_eqb spec_ltb spec_leb spec_max spec_min
 spec_abs spec_sgn spec_pow spec_log2 spec_even spec_odd spec_gcd
 spec_quot spec_rem spec_testbit spec_shiftl spec_shiftr
 spec_land spec_lor spec_ldiff spec_lxor spec_div2
 : zsimpl.

Ltac zsimpl := autorewrite with zsimpl.
Ltac zcongruence := repeat red; intros; zsimpl; congruence.
Ltac zify := unfold eq, lt, le in *; zsimpl.

#[global]
Instance eq_equiv : Equivalence eq.
Proof. split; zcongruence. Qed.

Local Obligation Tactic := zcongruence.

#[global]
Program Instance succ_wd : Proper (eq ==> eq) succ.
#[global]
Program Instance pred_wd : Proper (eq ==> eq) pred.
#[global]
Program Instance add_wd : Proper (eq ==> eq ==> eq) add.
#[global]
Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
#[global]
Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul.

Theorem pred_succ : forall n, pred (succ n) == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem one_succ : 1 == succ 0.
Proof.
now zify.
Qed.

Theorem two_succ : 2 == succ 1.
Proof.
now zify.
Qed.

Section Induction.

Variable A : ZZ.t -> Prop.
Hypothesis A_wd : Proper (eq==>iff) A.
Hypothesis A0 : A 0.
Hypothesis AS : forall n, A n <-> A (succ n).

Let B (z : Z) := A (of_Z z).

Lemma B0 : B 0.
Proof.
unfold B; simpl.
rewrite <- (A_wd 0); auto.
zify. auto.
Qed.

Lemma BS : forall z : Z, B z -> B (z + 1).
Proof.
intros z H.
unfold B in *. apply -> AS in H.
setoid_replace (of_Z (z + 1)) with (succ (of_Z z)); auto.
zify. auto.
Qed.

Lemma BP : forall z : Z, B z -> B (z - 1).
Proof.
intros z H.
unfold B in *. rewrite AS.
setoid_replace (succ (of_Z (z - 1))) with (of_Z z); auto.
zify. auto with zarith.
Qed.

Lemma B_holds : forall z : Z, B z.
Proof.
intros; destruct (Z_lt_le_dec 0 z).
apply natlike_ind; auto with zarith.
apply B0.
intros; apply BS; auto.
replace z with (-(-z))%Z in * by (auto with zarith).
remember (-z)%Z as z'.
pattern z'; apply natlike_ind.
apply B0.
intros; rewrite Z.opp_succ; unfold Z.pred; apply BP; auto.
subst z'; auto with zarith.
Qed.

Theorem bi_induction : forall n, A n.
Proof.
intro n. setoid_replace n with (of_Z (to_Z n)).
apply B_holds.
zify. auto.
Qed.

End Induction.

Theorem add_0_l : forall n, 0 + n == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m).
Proof.
intros. zify. auto with zarith.
Qed.

Theorem sub_0_r : forall n, n - 0 == n.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m).
Proof.
intros. zify. auto with zarith.
Qed.

Theorem mul_0_l : forall n, 0 * n == 0.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m.
Proof.
intros. zify. ring.
Qed.

(** Order *)

Lemma eqb_eq x y : eqb x y = true <-> x == y.
Proof.
 zify. apply Z.eqb_eq.
Qed.

Lemma leb_le x y : leb x y = true <-> x <= y.
Proof.
 zify. apply Z.leb_le.
Qed.

Lemma ltb_lt x y : ltb x y = true <-> x < y.
Proof.
 zify. apply Z.ltb_lt.
Qed.

Lemma compare_eq_iff n m : compare n m = Eq <-> n == m.
Proof.
 intros. zify. apply Z.compare_eq_iff.
Qed.

Lemma compare_lt_iff n m : compare n m = Lt <-> n < m.
Proof.
 intros. zify. reflexivity.
Qed.

Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m.
Proof.
 intros. zify. reflexivity.
Qed.

Lemma compare_antisym n m : compare m n = CompOpp (compare n m).
Proof.
 intros. zify. apply Z.compare_antisym.
Qed.

Include BoolOrderFacts ZZ ZZ ZZ [no inline].

#[global]
Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

#[global]
Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

#[global]
Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

#[global]
Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb.
Proof.
intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy.
Qed.

#[global]
Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
Proof.
intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition.
Qed.

Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m.
Proof.
intros. zify. lia.
Qed.

Theorem min_l : forall n m, n <= m -> min n m == n.
Proof.
now intros n m; zify; lia.
Qed.

Theorem min_r : forall n m, m <= n -> min n m == m.
Proof.
now intros n m; zify; lia.
Qed.

Theorem max_l : forall n m, m <= n -> max n m == n.
Proof.
now intros n m; zify; lia.
Qed.

Theorem max_r : forall n m, n <= m -> max n m == m.
Proof.
now intros n m; zify; lia.
Qed.

(** Part specific to integers, not natural numbers *)

Theorem succ_pred : forall n, succ (pred n) == n.
Proof.
intros. zify. auto with zarith.
Qed.

(** Opp *)

#[global]
Program Instance opp_wd : Proper (eq ==> eq) opp.

Theorem opp_0 : - 0 == 0.
Proof.
intros. zify. auto with zarith.
Qed.

Theorem opp_succ : forall n, - (succ n) == pred (- n).
Proof.
intros. zify. auto with zarith.
Qed.

(** Abs / Sgn *)

Theorem abs_eq : forall n, 0 <= n -> abs n == n.
Proof.
now intros n; zify; lia.
Qed.

Theorem abs_neq : forall n, n <= 0 -> abs n == -n.
Proof.
now intros n; zify; lia.
Qed.

Theorem sgn_null : forall n, n==0 -> sgn n == 0.
Proof.
now intros n; zify; lia.
Qed.

Theorem sgn_pos : forall n, 0<n -> sgn n == 1.
Proof.
now intros n; zify; lia.
Qed.

Theorem sgn_neg : forall n, n<0 -> sgn n == opp 1.
Proof.
now intros n; zify; lia.
Qed.

(** Power *)

#[global]
Program Instance pow_wd : Proper (eq==>eq==>eq) pow.

Lemma pow_0_r : forall a, a^0 == 1.
Proof.
 intros. now zify.
Qed.

Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b.
Proof.
 intros a b. zify. intros. now rewrite Z.add_1_r, Z.pow_succ_r.
Qed.

Lemma pow_neg_r : forall a b, b<0 -> a^b == 0.
Proof.
 intros a b. zify. intros Hb.
 destruct [b]; reflexivity || discriminate.
Qed.

Lemma pow_pow_N : forall a b, 0<=b -> a^b == pow_N a (Z.to_N (to_Z b)).
Proof.
 intros a b. zify. intros Hb. now rewrite spec_pow_N, Z2N.id.
Qed.

Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p).
Proof.
 intros a b. red. now rewrite spec_pow_N, spec_pow_pos.
Qed.

(** Square *)

Lemma square_spec n : square n == n * n.
Proof.
 now zify.
Qed.

(** Sqrt *)

Lemma sqrt_spec : forall n, 0<=n ->
 (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)).
Proof.
 intros n. zify. apply Z.sqrt_spec.
Qed.

Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0.
Proof.
 intros n. zify. apply Z.sqrt_neg.
Qed.

(** Log2 *)

Lemma log2_spec : forall n, 0<n ->
 2^(log2 n) <= n /\ n < 2^(succ (log2 n)).
Proof.
 intros n. zify. apply Z.log2_spec.
Qed.

Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0.
Proof.
 intros n. zify. apply Z.log2_nonpos.
Qed.

(** Even / Odd *)

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

Lemma even_spec n : even n = true <-> Even n.
Proof.
 unfold Even. zify. rewrite Z.even_spec.
 split; intros (m,Hm).
 - exists (of_Z m). now zify.
 - exists [m]. revert Hm. now zify.
Qed.

Lemma odd_spec n : odd n = true <-> Odd n.
Proof.
 unfold Odd. zify. rewrite Z.odd_spec.
 split; intros (m,Hm).
 - exists (of_Z m). now zify.
 - exists [m]. revert Hm. now zify.
Qed.

(** Div / Mod *)

#[global]
Program Instance div_wd : Proper (eq==>eq==>eq) div.
#[global]
Program Instance mod_wd : Proper (eq==>eq==>eq) modulo.

Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b).
Proof.
intros a b. zify. intros. apply Z.div_mod; auto.
Qed.

Theorem mod_pos_bound :
 forall a b, 0 < b -> 0 <= modulo a b /\ modulo a b < b.
Proof.
intros a b. zify. intros. apply Z_mod_lt; auto with zarith.
Qed.

Theorem mod_neg_bound :
 forall a b, b < 0 -> b < modulo a b /\ modulo a b <= 0.
Proof.
intros a b. zify. intros. apply Z_mod_neg; auto with zarith.
Qed.

Definition mod_bound_pos :
 forall a b, 0<=a -> 0<b -> 0 <= modulo a b /\ modulo a b < b :=
 fun a b _ H => mod_pos_bound a b H.

(** Quot / Rem *)

#[global]
Program Instance quot_wd : Proper (eq==>eq==>eq) quot.
#[global]
Program Instance rem_wd : Proper (eq==>eq==>eq) rem.

Theorem quot_rem : forall a b, ~b==0 -> a == b*(quot a b) + rem a b.
Proof.
intros a b. zify. apply Z.quot_rem.
Qed.

Theorem rem_bound_pos :
 forall a b, 0<=a -> 0<b -> 0 <= rem a b /\ rem a b < b.
Proof.
intros a b. zify. apply Z.rem_bound_pos.
Qed.

Theorem rem_opp_l : forall a b, ~b==0 -> rem (-a) b == -(rem a b).
Proof.
intros a b. zify. apply Z.rem_opp_l.
Qed.

Theorem rem_opp_r : forall a b, ~b==0 -> rem a (-b) == rem a b.
Proof.
intros a b. zify. apply Z.rem_opp_r.
Qed.

(** Gcd *)

Definition divide n m := exists p, m == p*n.
Local Notation "( x | y )" := (divide x y) (at level 0).

Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m].
Proof.
 intros n m. split.
 - intros (p,H). exists [p]. revert H; now zify.
 - intros (z,H). exists (of_Z z). now zify.
Qed.

Lemma gcd_divide_l : forall n m, (gcd n m | n).
Proof.
 intros n m. apply spec_divide. zify. apply Z.gcd_divide_l.
Qed.

Lemma gcd_divide_r : forall n m, (gcd n m | m).
Proof.
 intros n m. apply spec_divide. zify. apply Z.gcd_divide_r.
Qed.

Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m).
Proof.
 intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest.
Qed.

Lemma gcd_nonneg : forall n m, 0 <= gcd n m.
Proof.
 intros. zify. apply Z.gcd_nonneg.
Qed.

(** Bitwise operations *)

#[global]
Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit.

Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true.
Proof.
 intros. zify. apply Z.testbit_odd_0.
Qed.

Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false.
Proof.
 intros. zify. apply Z.testbit_even_0.
Qed.

Lemma testbit_odd_succ : forall a n, 0<=n ->
 testbit (2*a+1) (succ n) = testbit a n.
Proof.
 intros a n. zify. apply Z.testbit_odd_succ.
Qed.

Lemma testbit_even_succ : forall a n, 0<=n ->
 testbit (2*a) (succ n) = testbit a n.
Proof.
 intros a n. zify. apply Z.testbit_even_succ.
Qed.

Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false.
Proof.
 intros a n. zify. apply Z.testbit_neg_r.
Qed.

Lemma shiftr_spec : forall a n m, 0<=m ->
 testbit (shiftr a n) m = testbit a (m+n).
Proof.
 intros a n m. zify. apply Z.shiftr_spec.
Qed.

Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m ->
 testbit (shiftl a n) m = testbit a (m-n).
Proof.
 intros a n m. zify. intros Hn H.
 now apply Z.shiftl_spec_high.
Qed.

Lemma shiftl_spec_low : forall a n m, m<n ->
 testbit (shiftl a n) m = false.
Proof.
 intros a n m. zify. intros H. now apply Z.shiftl_spec_low.
Qed.

Lemma land_spec : forall a b n,
 testbit (land a b) n = testbit a n && testbit b n.
Proof.
 intros a n m. zify. now apply Z.land_spec.
Qed.

Lemma lor_spec : forall a b n,
 testbit (lor a b) n = testbit a n || testbit b n.
Proof.
 intros a n m. zify. now apply Z.lor_spec.
Qed.

Lemma ldiff_spec : forall a b n,
 testbit (ldiff a b) n = testbit a n && negb (testbit b n).
Proof.
 intros a n m. zify. now apply Z.ldiff_spec.
Qed.

Lemma lxor_spec : forall a b n,
 testbit (lxor a b) n = xorb (testbit a n) (testbit b n).
Proof.
 intros a n m. zify. now apply Z.lxor_spec.
Qed.

Lemma div2_spec : forall a, div2 a == shiftr a 1.
Proof.
 intros a. zify. now apply Z.div2_spec.
Qed.

End ZTypeIsZAxioms.

Module ZType_ZAxioms (ZZ : ZType)
 <: ZAxiomsSig <: OrderFunctions ZZ <: HasMinMax ZZ
 := ZZ <+ ZTypeIsZAxioms.