Require Import Maps.
Require Import Aux.
Require Import Coq.Logic.FunctionalExtensionality.

Require Import Coq.Bool.Bool.

(*****************************************************************************
 * DATATYPE DEFINITIONS AND OPERATIONS                                       *
 *****************************************************************************)

Inductive ty : Type :=
  | TNat : ty
  | TArrow : ty -> ty -> ty.

Inductive exp : Type :=
  | Var : id -> exp
  | Z : exp
  | S : exp -> exp
  | Rec : exp -> id -> id -> exp -> exp -> exp
  | Abs : id -> ty -> exp -> exp
  | App : exp -> exp -> exp.

Definition env : Type := partial_map ty.

Fixpoint subst (z : id) (e' : exp) (e : exp) : exp :=
  let do_subst := subst z e' in
  match e with
  | Var x as v => if beq_id x z then e' else v
  | Z => Z
  | S n => S (do_subst n)
  | Rec e0 x y e1 e =>
      let e1' := if beq_id x z || beq_id y z then e1 else do_subst e1 in
      Rec (do_subst e0) x y e1' (do_subst e)
  | Abs x t e as abs => if beq_id x z then abs else Abs x t (do_subst e)
  | App e1 e2 => App (do_subst e1) (do_subst e2)
  end.
Notation "'[' x ':=' e1 ']' e" := (subst x e1 e) (at level 70).

(*****************************************************************************
 * STATICS SPECIFICATION                                                     *
 *****************************************************************************)

Reserved Notation "Gamma |- e \in T" (at level 80).
Inductive has_type : env -> exp -> ty -> Prop :=
  | T_Var : forall Gamma x T,
              Gamma x = Some T -> Gamma |- Var x \in T
  | T_Z : forall Gamma, Gamma |- Z \in TNat
  | T_S : forall Gamma n, Gamma |- n \in TNat ->
                          Gamma |- S n \in TNat
  | T_Abs : forall Gamma t1 t2 x e,
              (update Gamma x t1) |- e \in t2 ->
              Gamma |- Abs x t1 e \in (TArrow t1 t2)
  | T_App : forall Gamma e1 e2 t t2,
              Gamma |- e1 \in TArrow t2 t -> Gamma |- e2 \in t2 ->
              Gamma |- App e1 e2 \in t
  | T_Rec : forall Gamma e0 x y e1 e t,
              Gamma |- e \in TNat -> Gamma |- e0 \in t ->
              x <> y ->
              (update (update Gamma y t) x TNat) |- e1 \in t ->
              Gamma |- (Rec e0 x y e1 e) \in t
where "Gamma |- e \in T" := (has_type Gamma e T).

Inductive value : exp -> Prop :=
  | Val_Z : value Z
  | Val_S : forall n, value n -> value (S n)
  | Val_Abs : forall x t e, value (Abs x t e).

Inductive nat_value : exp -> Prop :=
  | NatVal_Z : nat_value Z
  | NatVal_S : forall n, nat_value n -> nat_value (S n).

Inductive appears_free_in : id -> exp -> Prop :=
  | Afi_Var : forall x, appears_free_in x (Var x)
  | Afi_S : forall x e, appears_free_in x e -> appears_free_in x (S e)
  | Afi_App1 : forall x e1 e2,
      appears_free_in x e1 -> appears_free_in x (App e1 e2)
  | Afi_App2 : forall x e1 e2,
      appears_free_in x e2 -> appears_free_in x (App e1 e2)
  | Afi_Abs : forall x y t e,
      x <> y -> appears_free_in x e ->
      appears_free_in x (Abs y t e)
  | Afi_Rec : forall x y z e0 e1 e,
      appears_free_in z e -> appears_free_in z (Rec e0 x y e1 e)
  | Afi_RecZ : forall z e0 x y e1 e,
      appears_free_in z e0 -> appears_free_in z (Rec e0 x y e1 e)
  | Afi_RecS : forall z e0 x y e1 e,
      x <> z -> y <> z -> appears_free_in z e1 ->
      appears_free_in z (Rec e0 x y e1 e).

Definition closed (e : exp) :=
  forall x, ~ appears_free_in x e.

(*****************************************************************************
 * DYNAMICS SPECIFICATION                                                    *
 *****************************************************************************)

Reserved Notation "e ==> e'" (at level 75).
Inductive step : exp -> exp -> Prop :=
  | S_Succ : forall e e', e ==> e' -> S(e) ==> S(e')
  | S_App1 : forall e1 e1' e2,
      e1 ==> e1' -> App e1 e2 ==> App e1' e2
  | S_App2 : forall e1 e2 e2',
      value e1 -> e2 ==> e2' -> App e1 e2 ==> App e1 e2'
  | S_AppAbs : forall e e2 x t,
      value e2 -> App (Abs x t e) e2 ==> [x := e2] e
  | S_Rec1 : forall e0 x y e1 e e',
      e ==> e' -> Rec e0 x y e1 e ==> Rec e0 x y e1 e'
  | S_RecZ : forall e0 x y e1, Rec e0 x y e1 Z ==> e0
  | S_RecS : forall e0 x y e1 e,
      value (S e) -> Rec e0 x y e1 (S e) ==>
                    [x := e][y := (Rec e0 x y e1 e)] e1
where "e ==> e'" := (step e e').

Reserved Notation "e ==>* e'" (at level 75).
Inductive multistep : exp -> exp -> Prop :=
  | Multi_Refl : forall e, e ==>* e
  | Multi_Step : forall e e' e'', e ==> e' -> e' ==>* e'' -> e ==>* e''
where "e ==>* e'" := (multistep e e').

(*****************************************************************************)
Hint Constructors ty exp has_type value nat_value appears_free_in step multistep.
(*****************************************************************************)

(*****************************************************************************
 * STATIC LEMMAS                                                             *
 *****************************************************************************)

Lemma free_in_context : forall x e t Gamma,
   appears_free_in x e ->
   Gamma |- e \in t ->
   exists t', Gamma x = Some t'.
Proof with auto.
  intros x e t Gamma Hfree Hte.
  generalize dependent t. generalize dependent Gamma.
  induction Hfree; try (intros Gamma t Ht;
    inversion Ht; subst; clear Ht; solve [eauto]).

  - intros Gamma t2 Ht. inversion Ht; subst; clear Ht.
    apply IHHfree in H5. rewrite update_neq in H5.
     + assumption.
     + rewrite symmetry_neq. assumption.

  - intros Gamma t2 Ht. inversion Ht; subst; clear Ht.
    apply IHHfree in H11.
    rewrite update_neq in H11...
    rewrite update_neq in H11...
Qed.

Lemma typable_empty_closed : forall e t,
    empty |- e \in t  -> closed e.
Proof.
  intros e t Hempty x Hfree.
  apply free_in_context with (t:=t) (Gamma:=empty) in Hfree.
  - inversion Hfree. inversion H.
  - assumption.
Qed.

Lemma weakening : forall Gamma Gamma' e t,
     Gamma |- e \in t  ->
     (forall x, appears_free_in x e -> Gamma x = Gamma' x) ->
     Gamma' |- e \in t.
Proof with eauto.
  intros.
  generalize dependent Gamma'.
  induction H; intros Gamma' Hfree; auto.
  - apply T_Var. rewrite <- Hfree...
  - apply T_Abs. apply IHhas_type. intros x1 Hx1_free.
    unfold update. unfold t_update. destruct (beq_id x x1) eqn: Heq.
    + reflexivity.
    + rewrite beq_id_false_iff in Heq.
      rewrite Hfree...
  - apply T_App with t2...
  - apply T_Rec... apply IHhas_type3. intros x1 Hx1_free.
    unfold update. unfold t_update.
    destruct (beq_id x x1) eqn: Heqx...
    destruct (beq_id y x1) eqn: Heqy...
    rewrite beq_id_false_iff in Heqx.
    rewrite beq_id_false_iff in Heqy.
    apply Hfree. apply Afi_RecS...
Qed.

Lemma closed_typable_empty :
  forall Gamma e t, Gamma |- e \in t -> closed e ->
                    empty |- e \in t.
Proof with eauto.
  intros Gamma e t Hte Hclosed.
  unfold closed in Hclosed. unfold not in Hclosed.
  generalize dependent Gamma. generalize dependent t.
  induction e; try intros t Gamma Ht.
  - exfalso. eapply Hclosed...
  - eapply weakening. eassumption.
    intros x Hafi. apply Hclosed in Hafi. inversion Hafi.
  - eapply weakening. eassumption.
    intros x Hafi. apply Hclosed in Hafi. inversion Hafi.
  - rename e1 into e0. rename i into x. rename i0 into y.
    rename e2 into e1. rename e3 into e.
    inversion Ht; subst; clear Ht. apply T_Rec...
Admitted.

Lemma substitution_preserves_typing : forall Gamma e e' t t' x,
  update Gamma x t |- e' \in t' -> empty |- e \in t ->
  Gamma |- [x := e] e' \in t'.
Proof with eauto.
  intros Gamma e e' t t' x Hte' Hte.
  generalize dependent Gamma.
  generalize dependent t'.
  induction e'; subst; intros t' Gamma H;
  inversion H; simpl; subst...
  - rename i into y. destruct (beq_idP y x) as [Hyx|Hyx].
    + subst.
      rewrite update_eq in H2. inversion H2; subst.
      apply weakening with empty. assumption.

      intros y Hy_free.
      apply typable_empty_closed in Hte. unfold closed in Hte.
      apply Hte in Hy_free. inversion Hy_free.
    + apply T_Var. rewrite update_neq in H2.
      * assumption.
      * rewrite symmetry_neq. assumption.
  - rename x into z. rename i into x. rename i0 into y.
    apply T_Rec...
    destruct (beq_idP x z) as [Hxz|Hxz]...
    + subst. simpl. rewrite update_split_shadow in H10...
    + destruct (beq_idP y z) as [Hyz|Hyz]...
      * subst. simpl. rewrite update_shadow in H10...
      * simpl. apply IHe'2.
        rewrite update_permute...
        assert (Hhelp: update (update Gamma y t') z t =
                       update (update Gamma z t) y t').
        { rewrite update_permute... }
        rewrite Hhelp...
  - rename i into y. destruct (beq_idP y x) as [Hyx|Hyx].
    + subst. apply T_Abs. rewrite update_shadow in H5...
    + apply T_Abs. apply IHe'. rewrite update_permute...
Qed.

(*****************************************************************************
 * DYNAMIC LEMMAS                                                            *
 *****************************************************************************)

(*****************************************************************************
 * EXERCISE SOLUTIONS                                                        *
 *****************************************************************************)

(* Exercise 9.1 - Prove Lemma 9.2 *)
Lemma canonical_nat : forall Gamma e,
  value e -> Gamma |- e \in TNat ->
  e = Z \/ exists e', e = (S e').
Proof.
  intros Gamma e Hv HNat.
  inversion Hv; subst; clear Hv.
  - left. reflexivity.
  - right. exists n. reflexivity.
  - inversion HNat.
Qed.

Lemma canonical_arrow : forall Gamma t1 t2 e,
  value e -> Gamma |- e \in TArrow t1 t2 ->
  exists x e2, e = Abs x t1 e2.
Proof.
  intros Gamma t1 t2 e Hv Harrow.
  remember (TArrow t1 t2).
  inversion Hv; subst; clear Hv.
  - inversion Harrow.
  - inversion Harrow.
  - exists x. exists e0.
    inversion Harrow; subst; clear Harrow.
    reflexivity.
Qed.

Lemma canonical_forms :
  forall Gamma e, value e ->
              (Gamma |- e \in TNat -> (e = Z \/ exists e', e = S e')) \/
              (forall t1 t2, Gamma |- e \in TArrow t1 t2 ->
                             exists x e2, e = Abs x t1 e2).
Proof with eauto.
  intros Gamma e Hve.

  inversion Hve; subst; clear Hve.
  - left. apply canonical_nat...
  - left. apply canonical_nat...
  - right. intros t1 t2. eapply canonical_arrow...
Qed.

(*****************************************************************************)
(* Exercise 9.2 - Prove Lemma 9.3 *)

Lemma preservation : forall e e' t,
  empty |- e \in t -> e ==> e' -> empty |- e' \in t.
Proof with eauto.
  intros e e' t Ht Hstep.
  generalize dependent e'.
  remember empty.
  induction Ht;
  try solve [subst; intros e' Habsurd; inversion Habsurd; subst; eauto].

  - intros e_appd Hstep. inversion Hstep; subst; clear Hstep...
    inversion Ht1; subst; clear Ht1.
    eapply substitution_preserves_typing...

  - intros e_appd Hstep. inversion Hstep; subst; clear Hstep...
    apply substitution_preserves_typing with (t:=TNat)...
    + specialize (IHHt1 (eq_refl empty)).
      specialize (IHHt2 (eq_refl empty)).

      apply substitution_preserves_typing with (t:=t)...
      * rewrite update_permute...
      * apply T_Rec...
        inversion Ht1...
    + inversion Ht1...
Qed.

(*****************************************************************************)
(* Exercise 9.3 - Prove Normalization to Nat *)

Lemma multi_succ : forall e n, e ==>* n -> S e ==>* S n.
Proof.
  intros e n Hstep. induction Hstep.
  - apply Multi_Refl.
  - eapply Multi_Step with (e':=S e').
    + apply S_Succ. assumption.
    + assumption.
Qed.

Lemma multi_app : forall e1 e2 e1' e2',
  e1 ==>* e1' -> e2 ==>* e2' -> value e1' -> App e1 e2 ==>* App e1' e2'.
Proof with eauto.
  intros e1 e2 e1' e2' Hstep1 Hstep2 Hval.
  induction Hstep1.
  - induction Hstep2.
    + apply Multi_Refl.
    + eapply Multi_Step...
  - eapply Multi_Step...
Qed.

Lemma normalizing_nat :
  forall e, empty |- e \in TNat -> exists n, nat_value n /\ e ==>* n.
Proof with eauto.
  intros e Hte. remember empty. remember TNat.
  induction Hte; subst...
  - inversion H.
  - destruct IHHte... destruct H. clear Heqt.
    exists (S x). split... apply multi_succ. assumption.
  - inversion Heqt.
  - give_up.
Abort.
(* The proof breaks down due to the inability of the inductive hypothesis
   to handle function application. Despite clearing the base cases with a
   maximally general inductive hypothesis, the inductive hypothesis only
   encompasses values that type to Nat, but application may be on functions
   from ANYTHING to Nat. *)

(*****************************************************************************)
(* Exercise 9.4 - Prove Normalization of Well-Typed Terms *)

Lemma multi_preservation :
  forall e e' t, empty |- e \in t -> e ==>* e' -> empty |- e' \in t.
Proof with eauto.
  intros e e' t Hte Hstep. induction Hstep...
  apply IHHstep. eapply preservation...
Qed.

Lemma multi_trans : forall e e' e'',
  e ==>* e' -> e' ==>* e'' -> e ==>* e''.
Proof with eauto.
  intros e e' e'' Hstep1 Hstep2.
  induction Hstep1...
Qed.

Lemma closed_succ : forall e, closed (S e) -> closed e.
Proof with eauto.
  intros e Hcse. unfold closed in Hcse. unfold not in Hcse.
  induction e; intros x Hfree...
Qed.

Lemma closed_app : forall e1 e2, closed (App e1 e2) -> closed e1 /\ closed e2.
Proof with eauto.
  intros e1 e2 Hcse. unfold closed in Hcse. unfold not in Hcse.
  split.
  - induction e1; intros x Hfree...
  - induction e2; intros x Hfree...
Qed.

Theorem termination : forall Gamma e t,
  Gamma |- e \in t -> closed e -> exists e', value e' /\ e ==>* e'.
Proof with eauto.
  intros Gamma e t Hte Hclosed.
  induction Hte; subst.
  - exfalso. unfold closed in Hclosed. unfold not in Hclosed. eapply Hclosed...
  - exists Z...
  - destruct IHHte...
    + apply closed_succ...
    + exists (S x). destruct H. split.
      * apply Val_S...
      * apply multi_succ...
  - eexists...
  - apply closed_app in Hclosed. destruct Hclosed as [Hcl_e1 Hcl_e2].
    destruct IHHte1; destruct IHHte2...
    destruct H. destruct H0.
    rename t2 into t1. rename t into t2. rename x into v2. rename x0 into v1.

    apply closed_typable_empty in Hte1...
    apply closed_typable_empty in Hte2...

    assert (Htv2:=Hte1).
    eapply multi_preservation in Htv2...
    apply canonical_arrow in Htv2...
    destruct Htv2 as (x & e_body & Heq). subst.

    rename v1 into v2. eexists. split.

    + admit.
    + apply multi_trans with (e':=App (Abs x t1 e_body) v2).
      * apply multi_app...
      * eapply Multi_Step.
        -- apply S_AppAbs...
        -- give_up. (* PROBLEM *)
  - admit.
  Unshelve. assumption.
Abort.

(* The problem arises after substitution occurs in the application case.
   There is nothing in the hypotheses that speaks to the ability of the
   body to reduce to a value (as needed to satisfy the prior admitted case. *)

(*****************************************************************************)
(* Hereditary Termination *)
(*

Definition terminating_nat e :=
  exists e', e ==>* e' /\ nat_value e'.

Inductive hereditarily_terminating : exp -> ty -> Prop :=
  | HT_Nat : forall e, terminating_nat e ->
             hereditarily_terminating e TNat
  | HT_Arrow : forall e t1 t2,
                   (forall e1, hereditarily_terminating e1 t1 ->
                   hereditarily_terminating (App e e1) t2) ->
                   hereditarily_terminating e (TArrow t1 t2).

Lemma hereditary_termination :
  forall e t, empty |- e \in t -> hereditarily_terminating e t.
Proof with eauto.
  intros e t. generalize dependent e. induction t.
  - intros e Ht. apply HT_Nat... unfold terminating_nat. intros _.

*)


(* Copy and paste this whole file into https://x80.org/collacoq/ *)
From Coq Require Import Arith Bool.

(* At its core, Coq is a *typed* programing language *)
(* There are a few (not many!) built-in types *)
(*

   On the online version, you can move your cursor up and down with
   Alt+p and Alt+n respectively.

   The result of the command should show up in the lower right hand
   side of the screen.

   Remember to leave it time to load up at the very beginning!

 *)
Check 3.
Check 3 + 4.
Check true.
Check (true && false).

(* And so it can evaluate programs *)
Eval compute in 3 + 4.
Eval compute in (true && false).

(* Every top-level command starts with a capital letter and ends with a period. *)
(* Grammar was very important to the original implementers... *)

(* No side effects though, so no printing, scanning or reading from a file! *)
Fail Check print.

(* Not to be confused with the *top level command* "Print", which asks
the Coq *system* to print a definition. *)
Print bool.

(*

  NB: Every piece of data in a program is *constant* and *immutable*
  There are good reasons for this, which we will go into later.

 *)

(* We can define types. This is a simple sum type *)
Inductive week_day :=
| Monday : week_day
| Tuesday : week_day
| Wednesday : week_day
| Thursday : week_day
| Friday : week_day
| Saturday : week_day
| Sunday : week_day.

Check Thursday.

(* And we can define functions *)
Definition add_one (x : nat) : nat := x + 1.
Definition return_monday (w : week_day) : week_day := Monday.

Check add_one.
Check return_monday.

(* We can work by cases over sum types. *)
Definition is_monday (w : week_day) : bool :=
  match w with
  | Monday => true
  | _ => false
  end.

Check is_monday.

Eval compute in (is_monday Tuesday).

(* There is a powerful search feature, which takes types and returns
     potentially useful functions with similar types *)
(* WARNING: this does not work on the online version! *)
Search (bool -> bool).

(* We can define types which may be recursive, e.g. the type of lists *)
Inductive week_day_list :=
| Nil : week_day_list
| Cons : week_day -> week_day_list -> week_day_list.

Check (Cons Monday (Cons Tuesday Nil)).

(* Ok, we have lisp-style lists. Can we define head? *)
Definition head (l : week_day_list) (default : week_day) : week_day :=
  match l with
  | Nil => default
  | Cons w _ => w
  end.
(* We need a default value! A little unfortunate... but the price of being pure! *)

Eval compute in head (Cons Monday (Cons Tuesday Nil)) Sunday.

(* How about tail? *)
Definition tail (l : week_day_list) : week_day_list :=
  match l with
  | Nil => Nil
  | Cons _ tail => tail
  end.

Eval compute in tail (Cons Monday (Cons Tuesday Nil)).

(* List notation a la lisp is tedious. Thankfully, Coq's notation system is incredibly powerful! *)

Notation "[ ]" := Nil.

Notation "[ w ]" := (Cons w Nil).

Notation "[ w1 ; w2 ; .. ; wn ]" := (Cons w1 (Cons w2 .. (Cons wn Nil) .. )).

Definition work_week := [Monday; Tuesday; Wednesday; Thursday; Friday].

(* All right, let's define some funner things. *)

Definition eq_wd (w1 w2 : week_day) : bool :=
  match (w1, w2) with
  | (Monday,Monday) => true
  | (Tuesday,Tuesday) => true
  | (Wednesday,Wednesday) => true
  | (Thursday,Thursday) => true
  | (Friday,Friday) => true
  | (Saturday,Saturday) => true
  | (Sunday,Sunday) => true
  | _ => false
  end.

(* How about a length function? This requires a special syntax: *)
Fixpoint length (l : week_day_list) : nat :=
  match l with
  | [] => 0
  | Cons w ws => 1 + (length ws)
  end.

Eval compute in (length work_week).

(* Now let's define a membership function *)
Fixpoint is_a_member (w : week_day) (l : week_day_list) : bool :=
  match l with
  | [] => false
  | Cons w' ws => eq_wd w w' || is_a_member w ws
  end.

(* Let's test it: *)
Eval compute in (is_a_member Monday work_week).
Eval compute in (is_a_member Sunday work_week).

(* Ok, we're ready for some specifications! *)
(* The simplest kind of specification is equality: *)
Check (Monday = Monday).

(* The Prop type is the type of *specifications*. It is *not* bool! *)
Check (forall w, w = Monday).
Check (exists w, w = Monday).

Check True.
Check False.

(* The basic propositional connectives: *)
(* True. Always provable. *)
(* False. Never provable. *)
(* P\/Q. Provable if one of P or Q (or both) is provable. *)
(* P/\Q. Provable if both P and Q are provable. *)
(* P -> Q. Provable if, when *assuming* P is provable, then so is Q. *)
(* ~P. Provable if P is *never* provable *)
(* forall x : A, P x. Provable if for an *arbitrary* x (of type A), P x is provable. *)
(* exists x : A, P x. Provable if there is some *specific* a such that P a is provable. *)
(* a = b. Provable if, in fact, a is equal to b. Not to be confused
   with ":=" which is how we define functions and constants (and is
   *not* a connective).  *)

(* Obviously, we can state specifications about infinite types as well: *)

Check (forall l : week_day_list, l = [] \/ exists w l', l = Cons w l').

(* Some of these specifications are provable, some are not. *)

(* We give some basic tools to prove some of these specs: *)

Lemma test1 : forall w1 w2 : week_day, w1 = w2 -> w1 = w2.
Proof.
  intros.
  apply H.
Qed.

Check test1.
(* ---------------------------------------------------------
     There are some simple cheats on how to prove various kinds of specifications:
     roughly, one can try certain tactics based on the *shape* of the goal and the
     hypotheses. The breakdown is like this:

     |               |   in goal   |   in hypotheses   |
     |---------------+-------------+------------------ |
     | A -> B        |  intros     |      apply        |
     | A /\ B        |  split      |     destruct      |
     | A \/ B        |  left/right |     destruct      |
     | ~A            |  intro      |      apply        |
     |  True         |  trivial    |       N/A         |
     |  False        |    N/A      |   contradiction   |
     | forall x, P x |  intros     |      apply        |
     | exists x, P x |  exists t   |     destruct      |
     | t = u         | reflexivity | rewrite/inversion |

     but of course, these will not always suffice in all situations.
 *)

(* Here's how one proves trivial equalities: *)
Lemma test2 : Monday = Monday.
Proof.
 trivial.
Qed.

(* It's nice to know that this doesn't always work: *)
Lemma test2_fail : Monday = Friday.
Proof.
  Fail reflexivity.
Abort.

(* We can also perform computation steps in proofs, in order to
     prove things about functions: *)
Lemma test3 : return_monday Friday = Monday.
Proof.
  trivial.
Qed.

Lemma test3' : length work_week = 5.
Proof.
  reflexivity.
Qed.

(* But really we're interested in behavior over *all inputs*. *)
Lemma test4 : forall x : week_day, return_monday x = Monday.
Proof.
  reflexivity.
Qed.

(* How about this? Hint: use the [case some_variable] tactic *)
Lemma test5 : forall x : week_day, eq_wd x x = true.
Proof.
  intros.
  case x; compute; reflexivity.
Qed.

(* Let's play with some logical connectives *)
Lemma test6 : forall x y z : week_day, x = y -> y = z -> x = y /\ y = z.
Proof.
  intros.
  split.
  - apply H.
  - apply H0.
Qed.

Lemma test7 : forall x y z : week_day, x = y -> x = y \/ y = z.
Proof.
  intros.
  left.
  - apply H.
Qed.

Lemma test8 : forall x y z : week_day, x = y /\ y = z -> y = z.
Proof.
  intros.
  apply H.
Qed.

(* This one is a little tougher! tactic order matters! *)
Lemma test9 : forall x y z : week_day, x = y \/ x = z -> x = z \/ x = y.
Proof.
  intros.
  destruct H; [right; apply H | left; apply H].
Qed.

(* Proofs involving equalities *)
Lemma test10 : forall x y, x = Monday -> y = x -> y = Monday.
Proof.
  intros.
  rewrite H0.
  apply H.
Qed.

Lemma test11 : Monday = Tuesday -> False.
Proof.
  intros.
  inversion H.
Qed.

(* All right we're ready for some serious stuff *)
Lemma first_real_lemma : forall x y, x = y -> eq_wd x y = true.
Proof.
  intros.
  rewrite H.
  apply test5.
Qed.

(* The other direction is harder! *)
Lemma second_real_lemma : forall x y, eq_wd x y = true -> x = y.
Proof.
  intros x y.
  case x; case y; compute; (reflexivity || intros H0; inversion H0).
Qed.

(* Now we have a program which we have proven correct! We can use this to prove some theorems! *)
Lemma test12 : Monday = Monday.
Proof.
  apply second_real_lemma.
  compute.
  reflexivity.
Qed.

(* Let's show correctness of our membership function! But first we need to *specify* membership. *)
(* To do this, we specify an *inductive predicate*, which describes all the ways an element can be in a list. *)
(* We can again use the keyword inductive. *)
Inductive Mem : forall (w : week_day) (l : week_day_list), Prop :=
| Mem_head : forall w l, Mem w (Cons w l)
| Mem_tail : forall w w' l, Mem w l -> Mem w (Cons w' l).

(* We can apply constructors of Mem like lemmas *)
Lemma test13 : Mem Monday [Tuesday; Monday; Thursday].
Proof.
  apply Mem_tail.
  apply Mem_head.
Qed.

(* Here's some fun existential statements: *)
Lemma test14 : exists w, Mem w work_week.
Proof.
  exists Monday.
  unfold work_week.
  apply Mem_head.
Qed.

(* This is harder! We'll be able to prove this easily once we have the
     theorems.
 *)
Lemma test15 : exists w, ~ (Mem w work_week).
Proof.
  unfold work_week.
  exists Saturday.
  intro.
Abort.

(* The theorems we want are these: *)
Theorem is_a_member_correct : forall w l, is_a_member w l = true -> Mem w l.
Proof.
  intros w l.
  induction l.
  - compute.
    intro H.
    inversion H.
  - simpl.
    case_eq (eq_wd w w0).
    + intros.
      assert (w = w0).
      apply second_real_lemma.
      apply H.
      rewrite H1.
      apply Mem_head.
    + simpl.
      intros.
      apply Mem_tail.
      apply IHl.
      apply H0.
Qed.

Theorem is_a_member_complete : forall w l, Mem w l -> is_a_member w l = true.
Proof.
Admitted.

Lemma test15 : exists w, ~ (Mem w work_week).
Proof.
  exists Saturday.
  intro.
  assert (is_a_member Saturday work_week = false).
  compute; reflexivity.
  assert (is_a_member Saturday work_week = true).
  apply is_a_member_complete.
  apply H.
  rewrite H1 in H0.
  inversion H0.
Abort.

(*

  Finally, it's important to note that I purposefully hid a number of
  powerful tactics from you, for pedagogical reasons. The easiest of
  these is [auto], which tries to apply simple steps to finish a
  goal. Exercise: how much easier are the lemmas to prove using
  [auto]?

*)

(*

  There is still a lot to learn! You can check out the resources on
  https://coq.inria.fr/, most notably the tutorials on
  https://coq.inria.fr/documentation.

  You can try more online stuff on rhino-coq:
  https://x80.org/rhino-coq/

  I have a few things on my github:
  https://github.com/codyroux?tab=repositories&q=&type=&language=coq

  Or create an account on https://coq.zulipchat.com, and ask questions
  there!

  Go forth and prove!

 *)


Require Import region.
Require Import option.

Section customlist.
(* Le type inductif [clist] permet de construire des listes.
   Le parametre A permet de garantir le polymorphisme des listes. *)
Inductive clist (A:Type): Type :=
  | nil : clist A
  | cons : A -> clist A -> clist A.

(* Il n'est pas nécessaire de spécifier le type de liste A pour les constructeurs nil et cons.
   Celui-ci peut être déduit des autres éléments de la liste. On le défini donc comme implicite. *)
Implicit Arguments nil [A].
Implicit Arguments cons [A].

(* Permet de compter le nombre d'éléments d'une liste.
   La notation {A:Type} permet d'inférer le type de la liste à partir de l.
   Le paramètre A est donc implicite.
   Pour déclarer explicitement A dans une preuve, utiliser la notation: @list_count A l *)
Fixpoint list_count {A:Type} (l:clist A) : nat :=
  match l with
  | nil => 0
  | cons _ l' =>  1 + list_count l'
  end.

(* Permet de concatener deux listes de meme type. *)
Fixpoint concat_list {A:Type}(l1 l2:clist A): clist A :=
match l1 with
| nil => l2
| cons n l' => cons n (concat_list l' l2)
end.

(* Permet de récuperer l'élement d'une liste l à la position n.
   On renvoie [None] lorsque la liste est trop courte et [Some x]
   lorsqu'elle est assez longue et contient x. *)
Fixpoint get_list_elm {A:Type}(l:clist A)(n:nat): option :=
  match l, n with
  | nil, _ => None
  | cons x l', 0 => Some x
  | cons x l', S n' => get_list_elm l' n'
  end.

End customlist.
Implicit Arguments nil [A].
Implicit Arguments cons [A].

(* Notations standard pour les listes *)
Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).
Notation "x ++ y" := (concat_list x y) (at level 60, right associativity).

(* Permet de vérifier qu'une region est dans une liste de regions.
   Si on voulait généraliser cette fonction pour tous les types de liste [A]
   il faudrait définir l'égalité pour des types polymorphes. (contrairement au == en scala) *)
Fixpoint is_in_list (l:clist region)(x:region): bool :=
match l with
| nil => false
| cons n l' => if equal_region x n then
                true
               else
                is_in_list l' x
end.

(* Permet de récupérer la position d'une region dans une liste de regions. *)
Fixpoint get_row_region (l:clist region)(x:region): option :=
match l with
| nil => None (* x n'est pas dans l *)
| cons n l' => if equal_region x n then
                Some 0
               else
                add_opt (Some 1) (get_row_region l' x)
end.

Eval compute in [1].
Eval compute in [OO Z].

Eval compute in list_count [OO Z, IO(II Z), OO Z, IO Z].
Eval compute in list_count [0, 1, 2].
Eval compute in list_count [].

Eval compute in [1,2] ++ [3,4].
Eval compute in [OO Z,IO Z] ++ [OI Z,II Z].

Eval compute in get_list_elm [1,2,3] 1.

Eval compute in is_in_list [OO Z,OI Z,IO Z] (II Z).
Eval compute in is_in_list [OO Z,OI Z,IO Z] (IO Z).

(* Permet d'alléger le code lorsqu'on récupère des regions à partir d'options *)
Definition get_list_reg (l:clist region)(n:nat): region := option_elim Z (get_list_elm l n).

Eval compute in get_list_reg [OO Z,IO Z,II Z] 2.
Eval compute in get_row_region [OO Z, IO Z, II Z] (II Z).
Eval compute in get_row_region [OO Z, IO Z, II Z] (II (OO Z)).

(* Permet de vérifier que 2 listes de regions sont égales *)
Fixpoint equal_list_region (l1 l2:clist region): bool :=
match l1, l2 with
| nil, nil => true
| cons x1 l1', cons x2 l2' => if(equal_region x1 x2) then equal_list_region l1' l2' else false
| _, _ => false
end.

Eval compute in equal_list_region [OO Z, II Z, IO Z] [OO Z, II Z].
Eval compute in equal_list_region [OO Z, II Z, IO Z] [OO Z, II Z, IO Z, II Z].
Eval compute in equal_list_region [OO Z, II Z, IO Z] [OO Z, II Z, IO Z].

(* ### Preuves ### *)

Theorem concat_list_count {A:Type}(l1 l2:clist A):
list_count (l1 ++ l2) = list_count l1 + list_count l2 .
Proof.
  induction l1.
  reflexivity.
  simpl.
  rewrite IHl1.
  reflexivity.
Qed.

Theorem concat_list_nil {A:Type}(l:clist A): l ++ [] = l.
Proof.
 induction l.
 reflexivity.
 simpl.
 rewrite IHl.
 reflexivity.
Qed.


Require Export A_5_4.

Module A6_1.

(* 罗尔定理 *)
Theorem Theorem6_1 : ∀ (f : Fun) (a b : R), a < b
  -> ContinuousClose f a b
  -> (∀ x, a < x < b -> derivable f x)
  -> f[a] = f[b]
  -> ∃ ξ, a < ξ < b /\ derivative f ξ 0.
Proof.
  intros f a b H0 H1 H2 H3.
  generalize (Theorem4_6 f a b H0 H1).
  intros [[M [H4 [H5 [ξ1 [H6 H10]]]]] [m [H7 [H8 [ξ2 [H9 H11]]]]]].
  assert (H12 : m <= M).
  { assert (I1 : a ∈ \[ a, b \]).
    { apply AxiomII. lra. }
    apply H5 in I1 as I2. apply H8 in I1 as I3. lra. }
  destruct H12 as [H12 | H12].
  - assert (I1 : a < ξ1 < b \/ a < ξ2 < b).
    { apply NNPP. intro J1. apply not_or_and in J1 as [J1 J2].
      applyAxiomII H6. applyAxiomII H9.
      assert (J3 : ξ1 = a \/ ξ1 = b). lra.
      assert (J4 : ξ2 = a \/ ξ2 = b). lra.
      destruct J3 as [J3 | J3]; rewrite J3 in *;
      destruct J4 as [J4 | J4]; rewrite J4 in *; lra. }
    destruct I1 as [I1 | I1].
    + exists ξ1. split; auto. apply Theorem5_3.
      * apply H2; assumption.
      * left. unfold localMax. split; try apply H1.
        assert (J1 : ∃ δ, δ > 0 /\ δ < ξ1 - a /\ δ < b - ξ1).
        { destruct (Rlt_or_le (ξ1 - a) (b - ξ1)) as [J1 | J1].
          - exists ((ξ1 - a) / 2). repeat split; lra.
          - exists ((b - ξ1) / 2). repeat split; lra. }
        destruct J1 as [δ [J1 [J2 J3]]].
        exists δ. repeat split; auto.
        -- intros x K1. applyAxiomII K1.
          apply H4. apply AxiomII. apply Abs_R in K1. lra.
        -- intros x K1. applyAxiomII K1. apply Abs_R in K1.
          rewrite H10. apply H5. apply AxiomII. lra.
    + exists ξ2. split; auto. apply Theorem5_3.
      * apply H2; assumption.
      * right. unfold localMin. split; try apply H1.
        assert (J1 : ∃ δ, δ > 0 /\ δ < ξ2 - a /\ δ < b - ξ2).
        { destruct (Rlt_or_le (ξ2 - a) (b - ξ2)) as [J1 | J1].
          - exists ((ξ2 - a) / 2). repeat split; lra.
          - exists ((b - ξ2) / 2). repeat split; lra. }
        destruct J1 as [δ [J1 [J2 J3]]].
        exists δ. repeat split; auto.
        -- intros x K1. applyAxiomII K1.
          apply H4. apply AxiomII. apply Abs_R in K1. lra.
        -- intros x K1. applyAxiomII K1. apply Abs_R in K1.
          rewrite H11. apply H8. apply AxiomII. lra.
  - assert (I1 : ∀ x, x ∈ \[ a, b \] -> f[x] = m).
    { intros x J1. apply H5 in J1 as J2.
      apply H8 in J1 as J3. lra. }
    exists ((a + b) / 2). split; try lra.
    apply Theorem5_3.
    + apply H2; lra.
    + left. unfold localMax. split; try apply H1.
      exists ((b - a) / 2). repeat split; try lra.
      * intros x J1. applyAxiomII J1. apply H4.
        apply Abs_R in J1. apply AxiomII. lra.
      * intros x J1. applyAxiomII J1. apply Abs_R in J1.
        rewrite I1. rewrite I1. lra.
        -- apply AxiomII. lra.
        -- apply AxiomII. lra.
Qed.

(* 拉格朗日中值定理 *)
Theorem Theorem6_2 : ∀ (f : Fun) (a b : R), a < b
  -> ContinuousClose f a b
  -> (∀ x, a < x < b -> derivable f x)
  -> ∃ ξ, a < ξ < b /\ derivative f ξ ((f[b] - f[a]) / (b - a)).
Proof.
  intros f a b H0 H1 H2.
  assert (H3 : ∃ F, F = {` λ x y, y = f[x] - f[a]
    - (f[b] - f[a])/(b - a)*(x - a) `}).
  { exists {` λ x y, y = f[x] - f[a]
    - (f[b] - f[a])/(b - a)*(x - a) `}; reflexivity. }
  destruct H3 as [F H3].
  assert (H4 : Function F).
  { rewrite H3. unfold Function. intros x y z I1 I2.
    applyAxiomII' I1. applyAxiomII' I2.
    rewrite I2. assumption. }
  assert (H5 : ∀ x, F[x] = f[x] - f[a]
    - (f[b] - f[a])/(b - a)*(x - a)).
  { intro x. apply f_x; auto. rewrite H3. apply AxiomII'.
    reflexivity. }
  destruct H1 as [H1 [H6 H7]].
  unfold ContinuousOpen in H1.
  assert (H8 : ContinuousClose F a b).
  { unfold ContinuousClose. split; [idtac | split].
    - unfold ContinuousOpen. intros x I1.
      unfold Continuous. split.
      + apply AxiomII. exists (f[x] - f[a]
          - (f[b] - f[a])/(b - a)*(x - a)).
        rewrite H3. apply AxiomII'. reflexivity.
      + unfold limit. split; auto. apply H1 in I1 as I2.
        unfold Continuous in I2. destruct I2 as [I2 I3].
        unfold limit in I3. destruct I3 as [I3 [δ' [I4 [I5 I6]]]].
        exists δ'. split; auto. split.
        * intros x0 J1. apply AxiomII. exists (f[x0] - f[a]
          - (f[b] - f[a])/(b - a)*(x0 - a)).
          rewrite H3. apply AxiomII'. reflexivity.
        * intros ε J1. assert (J2 : ε/2 > 0). lra.
          apply I6 in J2 as J3.
          destruct J3 as [δ1 [J3 J4]].
          assert (J5 : ∃ δ2, 0 < δ2 /\ ∀ x0 : R,0 < Abs [x0 - x] < δ2 ->
            Abs[(f [b] - f [a]) / (b - a) * (x0 - x)] < ε/2).
          { destruct classic with (P := (f [b] - f [a] = 0)) as [K1 | K1].
            - exists 1. split; try lra. intros x0 K2.
              rewrite K1. unfold Rdiv. rewrite Rmult_0_l. rewrite Rmult_0_l.
              rewrite Abs_ge; try lra.
            - exists ((ε / 2 * ((b - a) / Abs [f [b] - f [a]] ))).
              split.
              + apply Rmult_lt_0_compat; auto.
                apply Rdiv_lt_0_compat; try lra.
                apply Abs_not_eq_0; auto.
              + intros x0 K2. rewrite Abs_mult. rewrite Abs_div; try lra.
                rewrite (Abs_gt (b - a)); try lra.
                destruct K2 as [K2 K3].
                assert (K4 : 0 < Abs [f [b] - f [a]] / (b - a)).
                { apply Rdiv_lt_0_compat; try lra.
                  apply Abs_not_eq_0; auto. }
                apply Rmult_lt_compat_r with
                  (r := Abs [f [b] - f [a]] / (b - a)) in K3; auto.
                assert (K5 : ε / 2 * ((b - a) / Abs [f [b] - f [a]]) *
                  (Abs [f [b] - f [a]] / (b - a)) = ε / 2).
                { apply Abs_not_eq_0 in K1. field; split; lra. }
                rewrite K5 in K3. clear K5.
                assert (K5 : Abs [x0 - x] * (Abs [f [b] - f [a]] / (b - a))
                  = Abs [f [b] - f [a]] / (b - a) * Abs [x0 - x]).
                { field. lra. }
                rewrite K5 in K3. assumption. }
          destruct J5 as [δ2 [J5 J6]].
          assert (J7 : ∃ δ, 0 < δ /\ δ < δ1 /\ δ < δ2).
          { destruct (Rlt_or_le δ1 δ2) as [K1 | K1].
            - exists (δ1 / 2). split; lra.
            - exists (δ2 / 2). split; lra. }
          destruct J7 as [δ [J7 [J8 J9]]].
          exists δ. split; try lra. intros x0 J10.
          rewrite H5. rewrite H5.
          assert (J11 : f [x0] - f [a] - (f [b] - f [a])
            / (b - a) * (x0 - a) - (f [x] - f [a]
            - (f [b] - f [a]) / (b - a) * (x - a))
            = f[x0] - f[x] - (f [b] - f [a]) / (b - a) * (x0 - x)).
          { field. lra. }
          rewrite J11. clear J11.
          generalize (Abs_minus_le (f[x0] - f[x])
            ((f [b] - f [a]) / (b - a) * (x0 - x))).
          intros J11. assert (J12 : 0 < Abs [x0 - x] < δ1). lra.
          apply J4 in J12. assert (J13 : 0 < Abs [x0 - x] < δ2).
          lra. apply J6 in J13. lra.
    - unfold ContinuousRight. split.
      + apply AxiomII. exists (f[a] - f[a]
          - (f[b] - f[a])/(b - a)*(a - a)).
        rewrite H3. apply AxiomII'. reflexivity.
      + unfold limit_pos. split; auto.
        unfold ContinuousRight in H6. destruct H6 as [I2 I3].
        unfold limit_pos in I3. destruct I3 as [I3 [δ' [I4 [I5 I6]]]].
        exists δ'. split; auto. split.
        * intros x0 J1. apply AxiomII. exists (f[x0] - f[a]
          - (f[b] - f[a])/(b - a)*(x0 - a)).
          rewrite H3. apply AxiomII'. reflexivity.
        * intros ε J1. assert (J2 : ε/2 > 0). lra.
          apply I6 in J2 as J3.
          destruct J3 as [δ1 [J3 J4]].
          assert (J5 : ∃ δ2, 0 < δ2 /\ ∀ x0 : R,a < x0 < a + δ2 ->
            Abs[(f [b] - f [a]) / (b - a) * (x0 - a)] < ε/2).
          { destruct classic with (P := (f [b] - f [a] = 0)) as [K1 | K1].
            - exists 1. split; try lra. intros x0 K2.
              rewrite K1. unfold Rdiv. rewrite Rmult_0_l. rewrite Rmult_0_l.
              rewrite Abs_ge; try lra.
            - exists ((ε / 2 * ((b - a) / Abs [f [b] - f [a]] ))).
              split.
              + apply Rmult_lt_0_compat; auto.
                apply Rdiv_lt_0_compat; try lra.
                apply Abs_not_eq_0; auto.
              + intros x0 K2. rewrite Abs_mult. rewrite Abs_div; try lra.
                rewrite (Abs_gt (b - a)); try lra.
                destruct K2 as [K2 K3].
                assert (K4 : 0 < Abs [f [b] - f [a]] / (b - a)).
                { apply Rdiv_lt_0_compat; try lra.
                  apply Abs_not_eq_0; auto. }
                assert (K6 : x0 - a < ε / 2 * ((b - a)
                  / Abs [f [b] - f [a]])). lra.
                apply Rmult_lt_compat_r with
                  (r := Abs [f [b] - f [a]] / (b - a)) in K6; auto.
                assert (K5 : ε / 2 * ((b - a) / Abs [f [b] - f [a]]) *
                  (Abs [f [b] - f [a]] / (b - a)) = ε / 2).
                { apply Abs_not_eq_0 in K1. field; split; lra. }
                rewrite K5 in K6. clear K5.
                rewrite (Abs_gt (x0 - a)); lra. }
          destruct J5 as [δ2 [J5 J6]].
          assert (J7 : ∃ δ, 0 < δ /\ δ < δ1 /\ δ < δ2).
          { destruct (Rlt_or_le δ1 δ2) as [K1 | K1].
            - exists (δ1 / 2). split; lra.
            - exists (δ2 / 2). split; lra. }
          destruct J7 as [δ [J7 [J8 J9]]].
          exists δ. split; try lra. intros x0 J10.
          rewrite H5. rewrite H5.
          assert (J11 : f [x0] - f [a] - (f [b] - f [a])
            / (b - a) * (x0 - a) - (f [a] - f [a]
            - (f [b] - f [a]) / (b - a) * (a - a))
            = f[x0] - f[a] - (f [b] - f [a]) / (b - a) * (x0 - a)).
          { field. lra. }
          rewrite J11. clear J11.
          generalize (Abs_minus_le (f[x0] - f[a])
            ((f [b] - f [a]) / (b - a) * (x0 - a))).
          intros J11. assert (J12 : a < x0 < a + δ1). lra.
          apply J4 in J12. assert (J13 : a < x0 < a + δ2).
          lra. apply J6 in J13. lra.
    - unfold ContinuousLeft. split.
      + apply AxiomII. exists (f[b] - f[a]
          - (f[b] - f[a])/(b - a)*(b - a)).
        rewrite H3. apply AxiomII'. reflexivity.
      + unfold limit_neg. split; auto.
        unfold ContinuousLeft in H7. destruct H7 as [I2 I3].
        unfold limit_neg in I3. destruct I3 as [I3 [δ' [I4 [I5 I6]]]].
        exists δ'. split; auto. split.
        * intros x0 J1. apply AxiomII. exists (f[x0] - f[a]
          - (f[b] - f[a])/(b - a)*(x0 - a)).
          rewrite H3. apply AxiomII'. reflexivity.
        * intros ε J1. assert (J2 : ε/2 > 0). lra.
          apply I6 in J2 as J3.
          destruct J3 as [δ1 [J3 J4]].
          assert (J5 : ∃ δ2, 0 < δ2 /\ ∀ x0, b - δ2 < x0 < b ->
            Abs[(f [b] - f [a]) / (b - a) * (x0 - b)] < ε/2).
          { destruct classic with (P := (f [b] - f [a] = 0)) as [K1 | K1].
            - exists 1. split; try lra. intros x0 K2.
              rewrite K1. unfold Rdiv. rewrite Rmult_0_l. rewrite Rmult_0_l.
              rewrite Abs_ge; try lra.
            - exists ((ε / 2 * ((b - a) / Abs [f [b] - f [a]] ))).
              split.
              + apply Rmult_lt_0_compat; auto.
                apply Rdiv_lt_0_compat; try lra.
                apply Abs_not_eq_0; auto.
              + intros x0 K2. rewrite Abs_mult. rewrite Abs_div; try lra.
                rewrite (Abs_gt (b - a)); try lra.
                destruct K2 as [K2 K3].
                assert (K4 : 0 < Abs [f [b] - f [a]] / (b - a)).
                { apply Rdiv_lt_0_compat; try lra.
                  apply Abs_not_eq_0; auto. }
                assert (K6 : b - x0 < ε / 2 * ((b - a)
                  / Abs [f [b] - f [a]])). lra.
                apply Rmult_lt_compat_r with
                  (r := Abs [f [b] - f [a]] / (b - a)) in K6; auto.
                assert (K5 : ε / 2 * ((b - a) / Abs [f [b] - f [a]]) *
                  (Abs [f [b] - f [a]] / (b - a)) = ε / 2).
                { apply Abs_not_eq_0 in K1. field; split; lra. }
                rewrite K5 in K6. clear K5.
                rewrite (Abs_lt (x0 - b)); lra. }
          destruct J5 as [δ2 [J5 J6]].
          assert (J7 : ∃ δ, 0 < δ /\ δ < δ1 /\ δ < δ2).
          { destruct (Rlt_or_le δ1 δ2) as [K1 | K1].
            - exists (δ1 / 2). split; lra.
            - exists (δ2 / 2). split; lra. }
          destruct J7 as [δ [J7 [J8 J9]]].
          exists δ. split; try lra. intros x0 J10.
          rewrite H5. rewrite H5.
          assert (J11 : f [x0] - f [a] - (f [b] - f [a])
            / (b - a) * (x0 - a) - (f [b] - f [a]
            - (f [b] - f [a]) / (b - a) * (b - a))
            = f[x0] - f[b] - (f [b] - f [a]) / (b - a) * (x0 - b)).
          { field. lra. }
          rewrite J11. clear J11.
          generalize (Abs_minus_le (f[x0] - f[b])
            ((f [b] - f [a]) / (b - a) * (x0 - b))).
          intros J11. assert (J12 : b - δ1 < x0 < b). lra.
          apply J4 in J12. assert (J13 : b - δ2 < x0 < b).
          lra. apply J6 in J13. lra. }
  assert (H9 : ∀ x, a < x < b -> derivable F x).
  { intros x I1. apply H2 in I1 as I2.
    destruct I2 as [y' [I2 [[δ' [I3 I4]] I5]]].
    exists (y' - (f [b] - f [a]) / (b - a)).
    split; auto. split.
    - exists δ'. split; auto. intros x0 J1.
      apply AxiomII. rewrite H3.
      exists (f [x0] - f [a] - (f [b] - f [a]) / (b - a) * (x0 - a)).
      apply AxiomII'. reflexivity.
    - unfold limit. destruct I5 as [I5 [δ0' [I6 [I7 I8]]]].
      split.
      + unfold Function. intros x0 y0 z0 J1 J2.
        applyAxiomII' J1; applyAxiomII' J2.
        rewrite J2. assumption.
      + exists δ0'. split; auto. split.
        * intros x0 J1. apply AxiomII.
          exists ((F [x0] - F [x]) / (x0 - x)).
          apply AxiomII'. reflexivity.
        * intros ε J1. apply I8 in J1 as J2.
          destruct J2 as [δ [J2 J3]]. exists δ. split; auto.
          intros x0 J4. apply J3 in J4 as J5.
          assert (J6 : {` λ x0 y, y =
            (f [x0] - f [x]) / (x0 - x) `} [x0]
            = (f [x0] - f [x]) / (x0 - x)).
          { apply f_x.
            - intros x1 y1 z1 K1 K2.
              applyAxiomII' K1; applyAxiomII' K2.
              rewrite K2. assumption.
            - apply AxiomII'. reflexivity. }
          rewrite J6 in J5. clear J6.
          assert (J6 : {` λ x1 y, y = (F [x1] - F [x])
            / (x1 - x) `} [x0] = (F [x0] - F [x]) / (x0 - x)).
          { apply f_x.
            - intros x1 y1 z1 K1 K2.
              applyAxiomII' K1; applyAxiomII' K2.
              rewrite K2. assumption.
            - apply AxiomII'. reflexivity. }
          rewrite J6. clear J6.
          rewrite H5. rewrite H5.
          assert (J6 : (f [x0] - f [a] - (f [b] - f [a])
            / (b - a) * (x0 - a) - (f [x] - f [a]
            - (f [b] - f [a]) / (b - a) * (x - a))) /
            (x0 - x) - (y' - (f [b] - f [a]) / (b - a))
            = (f [x0] - f [x]) / (x0 - x) - y').
          { field. destruct J4 as [J4 K1]. split; try lra.
            intro K2. rewrite K2 in J4.
            rewrite Abs_ge in J4; lra. }
          rewrite J6. clear J6. assumption. }
  assert (H10 : F[a] = F[b]).
  { rewrite H5; rewrite H5. field. lra. }
  generalize (Theorem6_1 F a b H0 H8 H9 H10).
  intros [ξ [H11 H12]]. exists ξ. split; auto.
  apply H2 in H11 as H13. destruct H13 as [f' H13].
  assert (H14 : derivative F ξ (f' - (f [b] - f [a]) / (b - a))).
  { split; auto. split.
    - exists 1. split; try lra. intros x0 I1.
      rewrite H3. apply AxiomII.
      exists (f[x0] - f[a] - (f[b] - f[a]) / (b - a) * (x0 - a)).
      apply AxiomII'. reflexivity.
    - unfold limit. destruct H13 as [H13 [[δ' [I1 I2]] I3]].
      destruct I3 as [I3 [δ0' [I4 [I5 I6]]]]. split.
      + intros x1 y1 z1 J1 J2. applyAxiomII' J1; applyAxiomII' J2.
        rewrite J2. assumption.
      + exists δ0'. repeat split; auto.
        * intros x0 J1. apply AxiomII.
          exists ((F[x0] - F[ξ]) / (x0 - ξ)).
          apply AxiomII'. reflexivity.
        * intros ε J1. apply I6 in J1 as J2.
          destruct J2 as [δ [J2 J3]].
          exists δ. split; auto.
          intros x J4. apply J3 in J4 as J5.
          assert (J6 : {` λ x y, y = (f[x] - f[ξ]) / (x - ξ) `} [x]
            = (f[x] - f[ξ]) / (x - ξ)).
          { apply f_x.
            - intros x1 y1 z1 K1 K2.
              applyAxiomII' K1; applyAxiomII' K2.
              rewrite K2. assumption.
            - apply AxiomII'. reflexivity. }
          rewrite J6 in J5. clear J6.
          assert (J6 : {` λ x y, y = (F[x] - F[ξ]) / (x - ξ) `} [x]
            = (F[x] - F[ξ]) / (x - ξ)).
          { apply f_x.
            - intros x1 y1 z1 K1 K2.
              applyAxiomII' K1; applyAxiomII' K2.
              rewrite K2. assumption.
            - apply AxiomII'. reflexivity. }
          rewrite J6. clear J6.
          assert (J6 : (F [x] - F [ξ]) / (x - ξ) -
            (f' - (f [b] - f [a]) / (b - a))
            = (f [x] - f [ξ]) / (x - ξ) - f').
          { rewrite H5. rewrite H5. field.
            destruct J4 as [J4 K1]. apply Abs_not_eq_0 in J4.
            split; lra. }
          rewrite J6. assumption. }
  generalize (derivativeUnique F ξ 0 (f' - (f [b] - f [a]) / (b - a))
    H12 H14). intro H15.
  assert (H16 : f' = (f [b] - f [a]) / (b - a)). lra.
  rewrite <- H16. assumption.
Qed.

End A6_1.

Export A6_1.


Require Export base_mods max_min.

Fixpoint rev_seq start length : list nat :=
  match length with
  | 0 => nil
  | S n => cons (start + n) (rev_seq start n)
  end.

Lemma rev_seq_nil : forall m n,
  rev_seq n m = nil -> m = 0.
Proof. induction m; intros; auto. simpl in *. discriminate. Qed.

Inductive decr_strict : list nat -> Prop :=
| decr_strict_nil : decr_strict nil
| decr_strict_cons n ln: (max_l ln) < n -> decr_strict ln -> decr_strict (n :: ln).

Lemma max_l_rev_seq : forall m n,
  max_l (rev_seq n (S m)) = (n + m).
Proof.
  induction m; intros n; simpl in *. lia.
  rewrite IHm. lia.
Qed.

Lemma min_l_rev_seq : forall m n,
  min_l (rev_seq n (S m)) = n.
Proof.
  induction m; intros n. simpl. lia.
  simpl. case_eq (rev_seq n m). intros H.
    apply rev_seq_nil in H. subst. lia.
  intros a la Ha. rewrite <- Ha. simpl in IHm.
  specialize (IHm n). rewrite Ha in *.
  rewrite <- Ha in *. rewrite IHm. lia.
Qed.

Lemma decr_strict_rev_seq : forall m n,
  decr_strict (rev_seq (S n) m).
Proof.
  induction m; intros n. simpl. constructor.
  simpl. constructor; auto. simpl.
  destruct m. simpl. lia.
  rewrite max_l_rev_seq. lia.
Qed.


(* This file contains basic lemmas about lists for this project. *)

Require Import List Arith.
Import List ListNotations.

Lemma combine_map (A B : Type) (f : A -> B) g (v1 v2 : list A) :
(forall a a0, (f a, f a0) = g (a, a0)) ->
combine (map f v1) (map f v2) = (map g (combine v1 v2)).
Proof. intros.
revert v2; induction v1; destruct v2; simpl; auto; f_equal; auto.
Qed.

Lemma rev_empty (A: Type) : @rev A [] = []. simpl; auto. Qed.

Lemma combine_nil_r (A : Type) (l1 l2: list A) :
  length l1 = length l2 ->
  combine l1 [] = combine l1 l2 -> l2 = [].
Proof. intros.
rewrite combine_nil in H0. symmetry in H0.
apply length_zero_iff_nil in H0.
      rewrite combine_length in H0.
  rewrite H in H0; clear H. rewrite Nat.min_id in H0.
apply length_zero_iff_nil; auto.
Qed.

Lemma combine_nil_l (A : Type) (l1 l2: list A) :
  length l1 = length l2 ->
  combine l1 [] = combine l1 l2 -> l1 = [].
Proof. intros.
rewrite combine_nil in H0. symmetry in H0.
apply length_zero_iff_nil in H0.
      rewrite combine_length in H0. symmetry in H.
  rewrite H in H0; clear H. rewrite Nat.min_id in H0.
apply length_zero_iff_nil; auto.
Qed.

Lemma combine_app (A : Type) a1 a2 : forall (l1 l2 : list A),
  length l1 = length l2 -> combine l1 l2 ++ [(a1,a2)] = combine (l1 ++ [a1]) (l2 ++ [a2]).
Proof.
induction l1.
{ intros. pose proof combine_nil_r A [] l2 H eq_refl; subst; simpl; auto. }
intros. destruct l2.
{ pose proof combine_nil_l A (a :: l1) [] H eq_refl as H0; inversion H0. }
assert (Hlen: length l1 = length l2) by auto.
specialize (IHl1 l2 Hlen).
simpl; rewrite IHl1; simpl; auto.
Qed.

Lemma combine_rev (A : Type) (l1 l2: list A) :
length l1 = length l2 ->
combine (rev l1) (rev l2) = rev (combine l1 l2).
Proof.
revert l1.
induction l2.
{ intros. rewrite !combine_nil; simpl; auto. }
intros. destruct l1.
{ simpl. auto. }
assert (Hlen: length l1 = length l2).
  simpl in H. auto.
specialize (IHl2 l1 Hlen).
simpl. rewrite <- IHl2.
rewrite <- combine_app; auto.
rewrite !rev_length; auto.
Qed.

Lemma combine_single A v1 v2 (a : A * A) :
  length v1 = length v2 ->
  combine v1 v2 = [a] -> v1 = [fst a] /\ v2 = [snd a].
Proof.
intros. pose proof combine_split v1 v2 H.
rewrite H0 in H1. destruct a.
simpl in H1. inversion H1; simpl; split; auto.
Qed.

From Coq Require Import ZArith Reals Psatz.
From Coquelicot Require Import Coquelicot.

Lemma length_not_empty {A} l :
l <> [] ->
(1 <= @length A l)%nat.
Proof.
intros.
destruct l; simpl;
 try simpl (length (a :: l)); try lia.
destruct H; auto.
Qed.

Lemma length_not_empty' {A} l :
l <> [] ->
(1 <= INR (@length A l))%R.
Proof.
intros.
replace 1%R with (INR 1) by (simpl; auto).
eapply le_INR.
apply length_not_empty; auto.
Qed.

Lemma length_not_empty_nat {A} l :
l <> [] ->
(1 <= (@length A l))%nat.
Proof.
intros.
apply INR_le.
apply length_not_empty';auto.
Qed.

Lemma length_not_empty_lt {A} l :
l <> [] ->
(0 < INR (@length A l))%R.
Proof.
intros.
destruct l.
destruct H; auto.
simpl (length (a:: l)).
rewrite <- Nat.add_1_r.
rewrite plus_INR.
apply Rcomplements.Rlt_minus_l.
field_simplify.
simpl.
eapply Rlt_le_trans with 0;  try nra.
apply pos_INR.
Qed.

Lemma length_not_empty_nat' {A} l :
l <> [] ->
(0 <= (@length A l))%nat.
Proof.
intros.
apply INR_le.
apply Rlt_le.
apply length_not_empty_lt;auto.
Qed.

Lemma fold_left_Rplus_Rplus:
 forall al b c, fold_left Rplus al (b+c) = c + fold_left Rplus al b.
Proof.
intros.
rewrite ! fold_symmetric by (intros; lra).
induction al; simpl; intros; lra.
Qed.

Lemma fold_left_Rplus_0:
 forall al b , fold_left Rplus al b = b + fold_left Rplus al 0.
Proof.
intros.
rewrite ! fold_symmetric by (intros; lra).
induction al; simpl; intros; lra.
Qed.

Lemma length_split {A : Type} (l : list (A * A)) :
length (fst (List.split l)) = length (snd (List.split l)).
Proof.
induction l; [simpl; auto | ].
destruct a; simpl; destruct (List.split l); simpl.
simpl in IHl; lia.
Qed.

Lemma combine_split {A : Type} (l : list (A * A)) :
combine (fst (List.split l)) (snd (List.split l)) = l.
Proof.
induction l; [simpl; auto | ].
destruct a; simpl; destruct (List.split l); simpl.
simpl in IHl; rewrite IHl; auto.
Qed.


From Hammer Require Import Hammer Reconstr.
Require Import Coq.ZArith.ZArith.
Open Scope Z.

Set Hammer Eprover.
Set Hammer Vampire.
Set Hammer Z3.
Set Hammer CVC4.
Lemma addition_commute : forall n m, n + m = m + n.
Proof.
  hammer.
Qed.

Lemma max_of_three : forall n m p, max n (max m p) = max (max n m) p.
  hammer.
Qed.

Fixpoint even (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | (S (S n')) => even n'
  end.

Lemma even_256 : even 256 = true.
  hammer.
Qed.

Inductive Evenn : nat -> Prop :=
| Bcase : Evenn O
| Ccase n : Evenn n -> Evenn (S (S n)).

Lemma even_ind : Evenn 10.
  hammer.
Qed.

Lemma connect_even_Even :
  forall n, Evenn n <-> even n = true.
Proof.
  (* Hammer is not able to solve this goal *)
  split; intros.
  induction H; scrush.
  generalize dependent n.
  refine (fix Fn n :=
            match n with
            | O => fun H => _
            | S O => fun H => _
            | S (S n') => fun H => _
            end).
  constructor.
  inversion H.
  cbn in H.
  constructor 2. apply Fn.
  auto.
Qed.

Lemma nat_even_odd :
  forall (n : nat), Nat.Odd n \/ Nat.Even n.
Proof.
  hammer.
Qed.

Lemma lem_pow : forall n : nat, (3 * 3 ^ n)%nat = (3 ^ (n + 1))%nat.
  hammer.
Qed.

Lemma lem_lst_1 : forall (A : Type) (l l' : list A), List.NoDup (l ++ l') -> List.NoDup l.
Proof.
  (* The hammer can't do induction. If induction is necessary to carry out the
  proof, then one needs to start the induction manually. *)
  induction l'.
  hammer. Undo.
  Reconstr.reasy (@Coq.Lists.List.app_nil_end) Reconstr.Empty.
  hammer. Undo.
  Reconstr.reasy (@Coq.Lists.List.NoDup_remove_1) Reconstr.Empty.
Qed.

Lemma NoDup_remove_1
     : forall (A : Type) (a : A) (l' l : list A),
       List.NoDup (l ++ a :: l') ->
       ~ List.In a (l ++ l') /\ List.NoDup (l ++ l') /\ List.NoDup l.
Proof.
  Reconstr.rcrush (@Coq.Lists.List.NoDup_remove, @lem_lst_1) Reconstr.Empty.
Qed.


From Coq Require Import Arith  Logic.Epsilon  Ensembles.
From hydras Require Export Schutte_basics  Ordering_Functions
     PartialFun  Countable  MoreEpsilonIota.
Set Implicit Arguments.
Require Export STDPP_compat.

(** * Definitions *)

(**  **  addition, multiplication by a positive integer *)

(* begin snippet additionDef *)

Definition plus alpha := ord (ge alpha).
Infix "+"  := plus : schutte_scope.

(* end snippet additionDef *)

(** returns [alpha * (S n)]
*)

(* begin snippet multFin *)

Fixpoint mult_Sn (alpha:Ord)(n:nat){struct n} :Ord :=
 match n with 0 => alpha
            | S p => mult_Sn alpha p + alpha
 end.

Definition mult_fin_r alpha n :=
  match n with
      0 => zero
    | S p => mult_Sn alpha p
  end.

Infix "*" := mult_fin_r : schutte_scope.

(* end snippet multFin *)

(** * Proofs, proofs, proofs
*)

Lemma Unbounded_ge (alpha : Ord)  :   Unbounded (ge alpha).
Proof with auto with schutte.
  red. intros   x ; tricho alpha x H3.
 -  exists (succ x);split ...
    right;  apply lt_trans with x; trivial ...
 -  subst alpha; exists (succ x) ; split ...
    red;red ...
 - exists (succ alpha); split.
  +  red;red ...
  +  apply lt_trans with alpha ...
Qed.

Lemma ge_o_segment (alpha : Ord) :
 the_ordering_segment (ge alpha) = ordinal.
Proof.
  intros;apply segment_unbounded.
  - pattern  (the_ordering_segment (ge alpha)); apply iota_ind.
    +  generalize  (ordering_segment_ex_unique (ge alpha));
         intros. destruct  H.
       destruct H.
       exists x; split;auto.
    +  destruct 1;eapply ordering_function_seg;eauto.
  -     generalize
          (ordering_unbounded_unbounded
             (A:=the_ordering_segment (ge alpha))
             (B:=ge alpha)
             (f:=plus alpha));  intros H.
        apply H.
        unfold plus; intros;  apply ord_ok.
        apply Unbounded_ge;auto.
Qed.

Lemma plus_ordering (alpha : Ord) :
  ordering_function (plus alpha)
                    ordinal
                    (ge alpha).
Proof.
 unfold plus;  generalize (@ord_ok (ge alpha));
    rewrite  ge_o_segment;auto.
Qed.

(* begin snippet plusElim:: no-out  *)
Lemma plus_elim (alpha : Ord) :
  forall P : (Ord->Ord)->Prop,
    (forall f: Ord->Ord,
        ordering_function f ordinal (ge alpha)-> P f) ->
    P (plus alpha).
Proof.
 intros  P H0; now apply H0, plus_ordering.
Qed.
(* end snippet plusElim *)

Lemma normal_plus_alpha (alpha : Ord) :
  normal (plus alpha) (ge alpha).
Proof.
 unfold plus;pattern (ord (ge alpha)).
 unfold ord, some;apply epsilon_ind.
 -  rewrite ge_o_segment; trivial.
   +  exists (plus alpha);apply (plus_ordering alpha); auto.
-  intros a H0; rewrite ge_o_segment in H0; trivial.
   split; trivial.
   apply Th_13_5_2; trivial.
+   intros M H1 H2 H3;  destruct H2; apply le_trans with x;auto.
       *  specialize (H1 _ H);  apply H1.
       *  apply sup_upper_bound;auto.
Qed.

(** ** Basic properties of addition
 *)

(* begin snippet alphaPlusZero *)

Lemma alpha_plus_zero (alpha: Ord):   alpha + zero = alpha. (* .no-out *)
Proof. (* .no-out *)
  pattern  (plus alpha); apply plus_elim;eauto.
  (* ... *)
  (* end snippet alphaPlusZero *)

  intros f H0 ; case (ordering_function_least_least H0).
  intros H1 H3; case (H3 alpha);auto.
  -  red;red; auto with schutte.
  -  intro H4; case H1.
     +  symmetry;tauto.
     +  intro; case (@lt_irrefl alpha);auto.
        apply lt_trans with (f zero);auto.
Qed.

Remark ge_zero : (ge zero : Ensemble Ord) = ordinal.
Proof with eauto with schutte.
  apply Extensionality_Ensembles.
  split.
   +  red; split.
   + unfold ge ...
Qed.

(* begin snippet bunchOfLemmas *)

(*| .. coq:: no-out |*)
Lemma zero_plus_alpha (alpha : Ord): zero + alpha = alpha.
(*||*) (*| .. coq:: none |*)
Proof with auto with schutte.
  pattern (plus zero);  apply plus_elim ...
  intros f H0;
    assert (H1:ordering_function (fun o => o) ordinal ordinal).
 {  (repeat split) ...
     -  eauto with schutte.
 }
 rewrite ge_zero in H0.
 generalize (ordering_function_unicity H0 H1); destruct 1.
 apply H2; split.
Qed.
(*||*)

Lemma le_plus_l (alpha beta : Ord) : alpha <= alpha + beta. (* .no-out *)
(*||*) (*| .. coq:: none |*)
Proof.
  pattern alpha at 1;  rewrite  <- alpha_plus_zero;auto.
  pattern (plus alpha);apply plus_elim;auto.
  intros;eapply ordering_function_mono_weak;eauto with schutte.
Qed.
(*||*)

Lemma le_plus_r (alpha beta : Ord) :  beta <= alpha + beta. (* .no-out *)
(*||*) (*| .. coq:: none |*)
Proof.
 pattern (plus alpha);  apply plus_elim;auto.
 intros; eapply ordering_le.
 + apply H.
 + split.
Qed.
(*||*)

Lemma plus_mono_r (alpha beta gamma : Ord) :
  beta < gamma -> alpha + beta < alpha + gamma. (* .no-out *)
(*||*) (*| .. coq:: none |*)
Proof.
 intro  H; pattern (plus alpha); apply plus_elim;auto.
 intros; eapply ordering_function_mono;eauto with schutte.
Qed.
(*||*)

Lemma plus_of_succ (alpha beta : Ord) :
  alpha + (succ beta) = succ (alpha + beta). (* .no-out *)
(*||*) (*| .. coq:: none |*)
Proof with trivial.
 pattern (plus alpha); apply plus_elim ...
 intros plus_alpha Hp;
   assert (H1 :plus_alpha beta < plus_alpha (succ beta)).
 {  eapply ordering_function_mono.
    apply Hp.
    split.
    split.
    apply lt_succ; auto.
 }
 generalize (@lt_succ_le (plus_alpha  beta) (plus_alpha  (succ beta))).
 intros H2.
 generalize (H2 H1);  intro H5; case (le_disj H5) ; auto.
 intro H6;case Hp;intros H H3 H4 H7.
 case (H4 (succ (plus_alpha beta))).
 -  red; apply le_trans with (plus_alpha  beta).
   +  generalize (H beta );  unfold In,  ge.
      intro H9; apply H3. split.
   +  right; apply lt_succ.
 -  intros x [Hx Ex].  absurd ( beta < x /\ x < succ beta).
    + intro H8; decompose [and] H8;clear H8.
      assert (H8: succ beta <= x) by (apply lt_succ_le; eauto with schutte).
      case (@lt_irrefl (succ beta)).
      eapply le_lt_trans. apply H8. assumption.
    +  split.
   *  eapply ordering_function_monoR. apply Hp.
      split.
      assumption.
      rewrite Ex.  auto with schutte.
   *  rewrite <- Ex in H6; eapply ordering_function_monoR.
      apply Hp.
      assumption.
      split.
      assumption.
Qed.
(*||*)

(* end snippet bunchOfLemmas *)

Lemma plus_mono_r_weak (alpha beta gamma : Ord) :
  beta <= gamma -> alpha + beta <= alpha + gamma.
Proof.
  intros  H;  case (le_disj H).
 - intros; subst gamma; auto with schutte.
 - right;  apply plus_mono_r;auto.
Qed.

Lemma plus_reg_r (alpha beta gamma : Ord) :
  alpha + beta = alpha + gamma  ->  beta = gamma.
Proof with trivial.
 intros  H;   tricho beta gamma H0 ...
 -  case (@lt_irrefl (alpha+beta)).
    pattern (alpha+beta) at 2; rewrite H; apply plus_mono_r ...
 -  case (@lt_irrefl (alpha+beta)).
    pattern (alpha+beta) at 1; rewrite H; apply plus_mono_r ...
Qed.

Lemma succ_is_plus_1 alpha :  succ alpha = alpha + 1.
Proof.
   rewrite  <- alpha_plus_zero  at 1; change (F 1) with (succ zero).
   rewrite   plus_of_succ;   now repeat rewrite alpha_plus_zero.
Qed.

Lemma alpha_plus_sup (alpha : Ord) (A : Ensemble Ord) :
    Inhabited _ A ->
    countable A ->
    alpha + |_| A = |_| (image A (plus alpha)).
Proof.
 intros  H0 H1 ;  generalize (@normal_plus_alpha alpha ).
 intros [H [H2 [H3 H4]]];  rewrite  H4; auto.
 split.
Qed.

Lemma plus_limit (alpha beta : Ord)
  : is_limit beta ->
    alpha + beta =  |_| (image (members beta) (plus alpha)).
Proof.
 intros H ; generalize (is_limit_sup_members H);intro e.
 generalize (@normal_plus_alpha alpha ); intro H2.
 pattern beta at 1;rewrite e; destruct H2 as [H0 [H1 [H2 H3]]].
 rewrite <- H3;auto.
 -  red;split.
 - case H. exists zero.
   red; auto with schutte.
   generalize (zero_le  beta).
   intro H6; case (le_disj H6).
   +  intro; subst beta; now destruct H4.
   + intros; now red.
 - apply countable_members; auto.
Qed.

Lemma plus_FF : forall i j, F (i + j) = F i + F j.
Proof.
 induction i.
 -  simpl.
     intros;rewrite zero_plus_alpha;auto with schutte.
 -  simpl; induction j.
    +  simpl.
       rewrite alpha_plus_zero;auto with schutte.
       now rewrite <- (plus_n_O i).
    +  rewrite IHi.
       replace (F (S j)) with (succ (F j)).
       * rewrite plus_of_succ, plus_of_succ, <- IHi, IHj; auto with schutte.
       * now simpl.
Qed.

Lemma one_plus_omega :  1 + omega = omega.
Proof.
 rewrite plus_limit; auto with schutte.
 -  apply le_antisym; auto with schutte.
  +    unfold omega_limit;  apply sup_mono;auto with schutte.
   *   apply Ordering_Functions.R1 with ordinal (ge (F 1)).
       apply plus_ordering.
       apply    countable_members;auto with schutte.
       red; split.
   *      intros x [a [H1 H2]].
          red in H1; case (@lt_omega_finite _  H1).
          intros n e; exists (F (S n)).
          subst x; split;auto with schutte.
          exists (S n); trivial.
          subst a. split;auto.
        subst a. left;  now rewrite <- plus_FF .
  + unfold omega_limit; apply sup_mono.
  *    apply seq_range_countable; auto with schutte.
  *  simpl; auto with schutte.
     apply Ordering_Functions.R1 with ordinal (ge (succ zero)).
     apply plus_ordering; auto with schutte.
     apply countable_members; auto with schutte.
     red; split.
  *  intros x [x0 [_ Hx]]; subst x.
     exists (F (S x0));split;auto with schutte.
     exists (F x0);split;auto with schutte.
     red;  red;  apply finite_lt_omega.
     rewrite <- plus_FF; trivial.
 - apply is_limit_omega.
Qed.

Lemma minus_exists (alpha beta : Ord) :
  alpha <= beta ->
  exists gamma, alpha + gamma = beta.
Proof.
 intro H; pattern (plus alpha); apply plus_elim;auto.
 intros f H2; case H2;intros H3 H4 H5 H6.
 case (H5 beta H).  intros;exists x;auto.
 now destruct H0.
Qed.

Section proof_of_associativity.
  Variables alpha beta : Ord.

  Lemma plus_assoc1 (gamma : Ord) :
    alpha + beta <= alpha + (beta + gamma) .
  Proof.
    intros;apply plus_mono_r_weak;auto.
    -  apply le_plus_l; auto.
  Qed.

  Lemma plus_assoc2 (gamma : Ord) :
    alpha + beta <= gamma ->
    exists khi,  gamma = alpha + (beta + khi).
  Proof.
    intros  H0; assert (H1 : alpha <= gamma).
    {  apply le_trans with (alpha + beta);auto.
       apply le_plus_l; auto.
    }  case (minus_exists H1); intros z Hz .
    assert (H2 :beta <= z).
    {  tricho beta z HH.
       -  right;auto.
       -  left;auto.
       -  case (@lt_irrefl gamma).
          pattern gamma at 1; rewrite <- Hz.
          apply lt_le_trans with (alpha + beta);auto.
          + apply plus_mono_r;auto.
    }
    case (minus_exists H2);intros u Hu.
    exists u;auto.
    rewrite Hu;auto.
  Qed.

  Let f_alpha_beta := plus (alpha + beta).

  Let g_alpha_beta gamma := alpha + (beta + gamma).

  Remark of_g : ordering_function g_alpha_beta ordinal (ge (alpha+beta)).
  Proof.
    repeat split.
    - intros;red; red; unfold g_alpha_beta; now apply plus_assoc1.
    -   intros b H;
          case (plus_assoc2  H). intros x H'x;  exists x.
        unfold g_alpha_beta;split.
        split.
        symmetry; assumption.
    -  unfold g_alpha_beta;intros.
       + apply plus_mono_r;auto with schutte.
         apply plus_mono_r;auto with schutte.
  Qed.

  Lemma of_u : fun_equiv f_alpha_beta g_alpha_beta ordinal ordinal.
  Proof.
    eapply ordering_function_unicity.
    - unfold f_alpha_beta; apply plus_ordering.
    - apply of_g.
  Qed.

  Lemma plus_assoc3 (gamma : Ord) :
    f_alpha_beta  gamma =  g_alpha_beta gamma.
  Proof.
    case of_u; intros H0 H1; apply H1.
    split.
  Qed.

  Lemma plus_assoc' (gamma : Ord) :
    alpha + (beta + gamma) = (alpha + beta) + gamma.
  Proof.
    intros; generalize plus_assoc3; unfold f_alpha_beta, g_alpha_beta.
    intros;symmetry;apply H.
  Qed.

End proof_of_associativity.

(* begin snippet plusAssoc *)
#[global] Instance plus_assoc: Assoc eq plus.
(* end snippet plusAssoc *)
Proof.
  intros ? ? ?; apply plus_assoc'; auto.
Qed.

Lemma one_plus_infinite (alpha : Ord) :
  omega <= alpha ->  1 + alpha = alpha.
Proof.
 intros  H.
 generalize (minus_exists H); intros [gamma e];  subst alpha .
 rewrite plus_assoc. now rewrite one_plus_omega.
Qed.

(* begin snippet finitePlusInfinite *)

Lemma finite_plus_infinite (n : nat) (alpha : Ord) :
  omega <= alpha -> n + alpha = alpha. (* .no-out *)
(*| .. coq:: none |*)
Proof.
 induction n.
 - simpl; intros;rewrite zero_plus_alpha;trivial.
 -  intros; simpl; replace (succ (F n)) with (F 1 + F n).
    + rewrite <- plus_assoc.
      rewrite IHn.
      * apply one_plus_infinite; assumption.
      * assumption.
  + now   rewrite <- plus_FF.
Qed.
(*||*)
(* end snippet finitePlusInfinite *)

Example L_3_plus_omega : 3 + omega = omega.
Proof.
 apply finite_plus_infinite, le_refl.
Qed.

Lemma plus_mono_weak_l : forall alpha beta gamma,
                          alpha <= beta -> alpha + gamma <= beta + gamma.
Proof.
 intros alpha beta gamma  H0;
 assert (H1 : ordinal alpha) by ( eauto with schutte).
 assert (H2 :ordinal beta) by ( eauto with schutte).
 case (minus_exists H0); intros  khi  ekhi;  subst beta.
 rewrite <- plus_assoc.
 apply plus_mono_r_weak.
 apply le_plus_r.
Qed.

Lemma plus_mono_bi : forall alpha beta gamma delta,
                        alpha <= gamma ->
                        beta < delta ->
                        alpha + beta < gamma + delta.
Proof.
 intros alpha beta gamma delta H H0; apply le_lt_trans with (gamma+beta).
 now apply plus_mono_weak_l.
 now apply plus_mono_r.
Qed.

Lemma mult_fin_r_one : forall n, (F 1) * S n = F (S n).
 Proof.
  induction n.
  -   trivial.
  -   simpl in *; rewrite IHn; rewrite plus_of_succ.
      rewrite alpha_plus_zero;auto with schutte.
 Qed.

Lemma mult_fin_r_mono : forall alpha beta , alpha < beta ->
   forall n,  alpha * S n <  beta * S n.
Proof.
 induction n; simpl; [assumption|].
 apply plus_mono_bi; [ right; assumption | assumption].
Qed.

Lemma le_a_mult_Sn_a : forall alpha n, ordinal alpha ->
                                       alpha <= alpha * S n.
Proof.
 intros alpha n H;  case n.
 -  simpl;auto with schutte.
 -  intros;simpl;apply le_plus_r;auto with schutte.
Qed.

Lemma mult_Sn_mono2 : forall a, zero < a ->
                         forall n p, (n < p)%nat -> a * S n <  a * S p.
Proof with auto with schutte.
  intros a Ha; induction 1.
  - simpl; intros; pattern ( mult_Sn a n) at 1;
      rewrite <- alpha_plus_zero ...
    +   apply plus_mono_r ...
  -  simpl;apply lt_trans with (mult_Sn a m);auto.
     pattern (mult_Sn a m) at 1; rewrite <- alpha_plus_zero.
     apply plus_mono_r ...
Qed.

Lemma mult_Sn_mono3 : forall alpha, zero < alpha ->
                         forall n p, (n < p)%nat -> alpha * S n + alpha
                                                    <=  alpha * S p.
Proof with auto with schutte.
 intros a Ha; induction 1 .
 - simpl; apply eq_le ...
 - simpl; apply plus_mono_weak_l.
   apply lt_le; apply  mult_Sn_mono2 ...
Qed.


Require Export Coq.Program.Tactics.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Arith.Arith_base.
Require Export Coq.Relations.Relations.
Require Export Coq.Lists.List.

Import EqNotations.
Import ListNotations.

(***
 *** Ordered Types = Types with a PreOrder
 ***)

Record OType : Type :=
  {
    ot_Type :> Type;
    ot_R : relation ot_Type;
    ot_PreOrder :> PreOrder ot_R
  }.

Instance OType_Reflexive (A:OType) : Reflexive (ot_R A).
Proof.
  destruct A; auto with typeclass_instances.
Qed.

Instance OType_Transitive (A:OType) : Transitive (ot_R A).
Proof.
  destruct A; auto with typeclass_instances.
Qed.

(* The equivalence relation for an OrderedType *)
Definition ot_equiv (A:OType) : relation A :=
  fun x y => ot_R A x y /\ ot_R A y x.

Instance ot_equiv_Equivalence A : Equivalence (ot_equiv A).
Proof.
  constructor; intro; intros.
  { split; reflexivity. }
  { destruct H; split; assumption. }
  { destruct H; destruct H0; split; transitivity y; assumption. }
Qed.

(***
 *** Commonly-Used Ordered Types
 ***)

(* The ordered type of propositions *)
Program Definition OTProp : OType :=
  {|
    ot_Type := Prop;
    ot_R := Basics.impl;
  |}.
Next Obligation.
  constructor; auto with typeclass_instances.
Qed.

(* The discrete ordered type, where things are only related to themselves *)
Program Definition OTdiscrete (A:Type) : OType :=
  {|
    ot_Type := A;
    ot_R := eq;
  |}.

(* The only ordered type over unit is the discrete one *)
Definition OTunit : OType := OTdiscrete unit.

(* The ordered type of natural numbers using <= *)
Program Definition OTnat : OType :=
  {|
    ot_Type := nat;
    ot_R := le;
  |}.

(* Flip the ordering of an OType *)
Program Definition OTflip (A:OType) : OType :=
  {|
    ot_Type := ot_Type A;
    ot_R := fun x y => ot_R A y x
  |}.
Next Obligation.
  constructor.
  { intro x. reflexivity. }
  { intros x y z; transitivity y; assumption. }
Qed.

(* The pointwise relation on pairs *)
Definition pairR {A B} (RA:relation A) (RB:relation B) : relation (A*B) :=
  fun p1 p2 => RA (fst p1) (fst p2) /\ RB (snd p1) (snd p2).

Instance PreOrder_pairR A B RA RB
         `(PreOrder A RA) `(PreOrder B RB) : PreOrder (pairR RA RB).
Proof.
  constructor.
  { intro p; split; reflexivity. }
  { intros p1 p2 p3 R12 R23; destruct R12; destruct R23; split.
    - transitivity (fst p2); assumption.
    - transitivity (snd p2); assumption. }
Qed.

(* The non-dependent product ordered type, where pairs are related pointwise *)
Definition OTpair (A B:OType) : OType :=
  {|
    ot_Type := ot_Type A * ot_Type B;
    ot_R := pairR (ot_R A) (ot_R B);
    ot_PreOrder := PreOrder_pairR A B _ _ (ot_PreOrder A) (ot_PreOrder B)
  |}.

(* The sort-of pointwise relation on sum types *)
Inductive sumR {A B} (RA:relation A) (RB:relation B) : A+B -> A+B -> Prop :=
| sumR_inl a1 a2 : RA a1 a2 -> sumR RA RB (inl a1) (inl a2)
| sumR_inr b1 b2 : RB b1 b2 -> sumR RA RB (inr b1) (inr b2).

Instance PreOrder_sumR A B RA RB
         `(PreOrder A RA) `(PreOrder B RB) : PreOrder (sumR RA RB).
Proof.
  constructor.
  { intro s; destruct s; constructor; reflexivity. }
  { intros s1 s2 s3 R12 R23. destruct R12; inversion R23.
    - constructor; transitivity a2; assumption.
    - constructor; transitivity b2; assumption. }
Qed.

(*
Definition sumR {A B} (RA:relation A) (RB:relation B) : relation (A+B) :=
  fun sum1 sum2 =>
    match sum1, sum2 with
    | inl x, inl y => RA x y
    | inl x, inr y => False
    | inr x, inl y => False
    | inr x, inr y => RB x y
    end.

Instance PreOrder_sumR A B RA RB
         `(PreOrder A RA) `(PreOrder B RB) : PreOrder (sumR RA RB).
Proof.
  constructor.
  { intro s; destruct s; simpl; reflexivity. }
  { intros s1 s2 s3 R12 R23.
    destruct s1; destruct s2; destruct s3;
      try (elimtype False; assumption); simpl.
    - transitivity a0; assumption.
    - transitivity b0; assumption. }
Qed.
*)

(* The non-dependent sum ordered type, where objects are only related if they
are both "left"s or both "right"s *)
Definition OTsum (A B : OType) : OType :=
  {|
    ot_Type := ot_Type A + ot_Type B;
    ot_R := sumR (ot_R A) (ot_R B);
    ot_PreOrder := PreOrder_sumR _ _ _ _ (ot_PreOrder A) (ot_PreOrder B)
  |}.

(* NOTE: the following definition requires everything above to be polymorphic *)
(* NOTE: The definition we choose for OTType is actually deep: instead of
requiring ot_Type A = ot_Type B, we could just require a coercion function from
ot_Type A to ot_Type B, which would yield something more like HoTT... though
maybe it wouldn't work unless we assumed the HoTT axiom? As it is, we might need
UIP to hold if we want to use the definition given here... *)
(*
Program Definition OTType : OType :=
  {|
    ot_Type := OType;
    ot_R := (fun A B =>
               exists (e:ot_Type A = ot_Type B),
                 forall (x y:A),
                   ot_R A x y ->
                   ot_R B (rew [fun A => A] e in x)
                        (rew [fun A => A] e in y));
  |}.
*)

(***
 *** The Ordered Type for Functions
 ***)

(* The type of continuous, i.e. Proper, functions between ordered types *)
Record Pfun (A B:OType) :=
  {
    pfun_app : ot_Type A -> ot_Type B;
    pfun_Proper :> Proper (ot_R A ==> ot_R B) pfun_app
  }.

Arguments pfun_app [_ _] _ _.
Arguments pfun_Proper [_ _] _ _ _ _.

(* Infix "@" := pfun_app (at level 50). *)

(* The non-dependent function ordered type *)
Definition OTarrow_R (A B : OType) : relation (Pfun A B) :=
  fun f g =>
    forall a1 a2, ot_R A a1 a2 -> ot_R B (pfun_app f a1) (pfun_app g a2).

Program Definition OTarrow (A B:OType) : OType :=
  {|
    ot_Type := Pfun A B;
    ot_R := OTarrow_R A B;
  |}.
Next Obligation.
  constructor.
  { intros f; apply (pfun_Proper f). }
  { intros f g h Rfg Rgh a1 a2 Ra. transitivity (pfun_app g a1).
    - apply (Rfg a1 a1). reflexivity.
    - apply Rgh; assumption. }
Qed.

(* Curry a Pfun *)
Program Definition pfun_curry {A B C} (pfun : Pfun (OTpair A B) C)
  : Pfun A (OTarrow B C) :=
  {| pfun_app :=
       fun a =>
         {| pfun_app := fun b => pfun_app pfun (a,b);
            pfun_Proper := _ |};
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros b1 b2 Rb. apply pfun_Proper.
  split; [ reflexivity | assumption ].
Qed.
Next Obligation.
Proof.
  intros a1 a2 Ra b1 b2 Rb; simpl.
  apply pfun_Proper; split; assumption.
Qed.

(* Uncrry a Pfun *)
Program Definition pfun_uncurry {A B C} (pfun : Pfun A (OTarrow B C))
  : Pfun (OTpair A B) C :=
  {| pfun_app :=
       fun ab => pfun_app (pfun_app pfun (fst ab)) (snd ab);
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros ab1 ab2 Rab. destruct Rab as [ Ra Rb ].
  exact (pfun_Proper pfun (fst ab1) (fst ab2) Ra (snd ab1) (snd ab2) Rb).
Qed.

(* Currying and uncurrying of pfuns form an adjunction *)
(* FIXME: figure out the simplest way of stating this adjunction *)

(* OTarrow is right adjoint to OTpair, meaning that (OTarrow (OTpair A B) C) is
isomorphic to (OTarrow A (OTarrow B C)). The following is the first part of this
isomorphism, mapping left-to-right. *)

(* FIXME: could also do a forall type, but need the second type argument, B, to
itself be proper, i.e., to be an element of OTarrow A OType. Would also need a
dependent version of OTContext, below. *)

(* pfun_app is always Proper *)
Instance Proper_pfun_app A B :
  Proper (ot_R (OTarrow A B) ==> ot_R A ==> ot_R B) (@pfun_app A B).
Proof.
  intros f1 f2 Rf a1 a2 Ra. apply Rf; assumption.
Qed.

(* pfun_app is always Proper w.r.t. ot_equiv *)
Instance Proper_pfun_app_equiv A B :
  Proper (ot_equiv (OTarrow A B) ==> ot_equiv A ==> ot_equiv B) (@pfun_app A B).
Proof.
  intros f1 f2 Rf a1 a2 Ra; destruct Rf; destruct Ra.
  split; apply Proper_pfun_app; assumption.
Qed.

(***
 *** Ordered Type Functions
 ***)

(*
Class OTypeF (TF: forall `(A:OType), Type) : Type :=
  otypef_app : forall `(A:OType), OType (TF A).

Arguments otypef_app [TF] _ [T] A _ _.

Instance OType_OTypeF_app `(F:OTypeF) `(A:OType) : OType (TF _ A) := otypef_app _ A.

Class ValidOTypeF `(F:OTypeF) : Prop :=
  {
    otypef_app_PreOrder :>
      forall `(A:OType) {_:ValidOType A}, PreOrder (ot_R (otypef_app F A))
  }.

Instance ValidOType_OTypeF_app `(ValidOTypeF) `(ValidOType) :
  ValidOType (otypef_app F A).
Proof.
  constructor. typeclasses eauto.
Qed.
*)

(***
 *** Finding and Instantiating Ordered Types
 ***)

(* States that A is the default OType for type AU. We expect that AU = ot_Type
A, though the below only implies that A is isomorphic to AU w.r.t. RU. *)
Class OTForType (A:OType) {AU} (RU:relation AU) : Type :=
  {
    ot_lift_iso : AU -> A;
    ot_lift_iso_Proper : Proper (RU ==> ot_R A) ot_lift_iso;
    ot_unlift_iso : A -> AU;
    ot_unlift_iso_Proper : Proper (ot_R A ==> RU) ot_unlift_iso;
    ot_for_type_PreOrder :> PreOrder RU;
    ot_lift_unlift_iso : forall x, ot_unlift_iso (ot_lift_iso x) = x;
    ot_unlift_lift_iso : forall x, ot_lift_iso (ot_unlift_iso x) = x;
  }.

Instance OTForType_refl (A:OType) : OTForType A (ot_R A) :=
  {
    ot_lift_iso := fun a => a;
    ot_lift_iso_Proper := fun a1 a2 Ra => Ra;
    ot_unlift_iso := fun a => a;
    ot_unlift_iso_Proper := fun a1 a2 Ra => Ra;
    ot_for_type_PreOrder := ot_PreOrder A;
    ot_unlift_lift_iso := fun a => eq_refl;
    ot_lift_unlift_iso := fun a => eq_refl;
  }.

(* Hint to use OTForType_refl if AU unifies with (ot_Type A), even if it is not
syntactically equal to (ot_Type A) *)
Hint Extern 1 (OTForType _ _) => apply OTForType_refl : typeclass_instances.

(* The default OType for Prop is OTProp *)
Instance OTForType_OTProp : OTForType OTProp Basics.impl := OTForType_refl _.

(* The default OType for a pair is OTpair of the defaults for the two types *)
Program Instance OTForType_pair A AU RAU B BU RBU
        (otA:@OTForType A AU RAU) (otB:@OTForType B BU RBU) :
  OTForType (OTpair A B) (pairR RAU RBU) :=
    {|
      ot_lift_iso :=
        fun p => (ot_lift_iso (fst p), ot_lift_iso (snd p));
      ot_unlift_iso := fun p => (ot_unlift_iso (fst p), ot_unlift_iso (snd p));
    |}.
Next Obligation.
  intros p1 p2 Rp; destruct Rp.
  split; simpl; apply ot_lift_iso_Proper; assumption.
Qed.
Next Obligation.
  intros p1 p2 Rp; destruct Rp.
  split; simpl; apply ot_unlift_iso_Proper; assumption.
Qed.
Next Obligation.
  repeat rewrite ot_lift_unlift_iso. reflexivity.
Qed.
Next Obligation.
  repeat rewrite ot_unlift_lift_iso. reflexivity.
Qed.

(* The default OType for a sum is OTsum of the defaults for the two types *)
Program Instance OTForType_sum A AU RAU B BU RBU
        (otA:@OTForType A AU RAU) (otB:@OTForType B BU RBU) :
  OTForType (OTsum A B) (sumR RAU RBU) :=
    {|
      ot_lift_iso :=
        fun s =>
          match s with
          | inl a => inl (ot_lift_iso a)
          | inr b => inr (ot_lift_iso b)
          end;
      ot_unlift_iso :=
        fun s =>
          match s with
          | inl a => inl (ot_unlift_iso a)
          | inr b => inr (ot_unlift_iso b)
          end;
    |}.
Next Obligation.
  intros s1 s2 Rs.
  destruct Rs; constructor; apply ot_lift_iso_Proper; assumption.
Qed.
Next Obligation.
  intros s1 s2 Rs.
  destruct Rs; constructor; apply ot_unlift_iso_Proper; assumption.
Qed.
Next Obligation.
  destruct x; rewrite ot_lift_unlift_iso; reflexivity.
Qed.
Next Obligation.
  destruct x; rewrite ot_unlift_lift_iso; reflexivity.
Qed.

(* States that A is a valid OType for the Proper elements of AU *)
Class OTForRel (A:OType) {AU} (RU:relation AU) : Type :=
  {
    ot_lift : forall a, Proper RU a -> A;
    ot_lift_Proper :
      forall a1 a2 prp1 prp2,
        RU a1 a2 -> ot_R A (ot_lift a1 prp1) (ot_lift a2 prp2);
    ot_unlift : A -> AU;
    ot_unlift_Proper : Proper (ot_R A ==> RU) ot_unlift;
    ot_lift_unlift_R : forall a prp, RU a (ot_unlift (ot_lift a prp));

    ot_unlift_lift :
      forall a prp, ot_equiv A (ot_lift (ot_unlift a) prp) a;

    (* NOTE: the case for RU is more complex since it may not be transitive *)
    ot_lift_unlift1 :
      forall a' a prp, RU a' a <-> RU a' (ot_unlift (ot_lift a prp));
    ot_lift_unlift2 :
      forall a' a prp, RU a a' <-> RU (ot_unlift (ot_lift a prp)) a';
  }.

Arguments OTForRel A {AU%type} RU%signature.

(*
Program Instance OTForRel_refl (A:OType) : OTForRel A (ot_R A) :=
  {
    ot_lift := fun a _ => a;
    ot_lift_Proper := _;
    ot_unlift := fun a => a;
  }.
*)

(* If A is the default OType for AU and RU, then it is a valid OType for them *)
Program Instance OTForRel_OTForType A AU RU
        (_:@OTForType A AU RU) : OTForRel A RU | 3 :=
  {|
    ot_lift := fun a _ => ot_lift_iso a;
    ot_unlift := ot_unlift_iso;
  |}.
Next Obligation.
  apply ot_lift_iso_Proper. assumption.
Qed.
Next Obligation.
  intros a1 a2 Ra; apply ot_unlift_iso_Proper; assumption.
Qed.
Next Obligation.
  rewrite ot_lift_unlift_iso. reflexivity.
Qed.
Next Obligation.
  rewrite ot_unlift_lift_iso. reflexivity.
Qed.
Next Obligation.
  rewrite ot_lift_unlift_iso. reflexivity.
Qed.
Next Obligation.
  rewrite ot_lift_unlift_iso. reflexivity.
Qed.

Program Instance OTForRel_fun (A B:OType) AU RAU BU RBU
        (otA:@OTForType A AU RAU) (otB:@OTForRel B BU RBU) :
  OTForRel (OTarrow A B) (RAU ==> RBU) :=
  {|
    ot_lift := fun f prp =>
                 {| pfun_app :=
                      fun a =>
                        ot_lift (OTForRel:=otB) (f (ot_unlift_iso a))
                                (prp _ _ (reflexivity _))|};
    ot_lift_Proper := _;
    ot_unlift := fun pfun a => ot_unlift (pfun_app pfun (ot_lift_iso a));
  |}.
Next Obligation.
  intros a1 a2 Ra. apply ot_lift_Proper. apply prp.
  apply ot_unlift_iso_Proper. assumption.
Qed.
Next Obligation.
  intros x1 x2 Rx. apply ot_lift_Proper. apply H.
  apply ot_unlift_iso_Proper. assumption.
Qed.
Next Obligation.
  intros f1 f2 Rf a1 a2 Ra. apply ot_unlift_Proper.
  apply Rf. apply ot_lift_iso_Proper. assumption.
Qed.
Next Obligation.
  intros a1 a2 Ra. apply ot_lift_unlift1. rewrite ot_lift_unlift_iso.
  apply prp. assumption.
Qed.
Next Obligation.
  split; intros a1 a2 Ra; simpl.
  { transitivity (pfun_app a (ot_lift_iso (ot_unlift_iso a1)));
      [ apply (proj1 (ot_unlift_lift _ _))
      | rewrite ot_unlift_lift_iso; apply pfun_Proper; assumption ]. }
  { transitivity (pfun_app a (ot_lift_iso (ot_unlift_iso a2)));
      [ rewrite ot_unlift_lift_iso; apply pfun_Proper; assumption
      | apply (proj2 (ot_unlift_lift _ _)) ]. }
Qed.
Next Obligation.
  split; intros Ra' a1 a2 Ra.
  { apply ot_lift_unlift1. rewrite ot_lift_unlift_iso. apply Ra'; assumption. }
  { rewrite <- (ot_lift_unlift_iso a2).
    refine (proj2 (ot_lift_unlift1 (a' a1) _ _) (Ra' _ _ _)); assumption. }
Qed.
Next Obligation.
  split; intros Ra' a1 a2 Ra.
  { apply ot_lift_unlift2. rewrite ot_lift_unlift_iso. apply Ra'; assumption. }
  { rewrite <- (ot_lift_unlift_iso a1).
    refine (proj2 (ot_lift_unlift2 (a' a2) _ _) (Ra' _ _ _)). assumption. }
Qed.

(* Tactic to prove OTForRel goals *)
Ltac prove_OTForRel :=
  lazymatch goal with
  | |- @OTForRel ?A (forall x:?AU, ?BU) ?RU =>
    refine (OTForRel_fun _ _ _ _ _ _ _ _)
  | |- @OTForRel (OTarrow ?A ?B) _ _ =>
    apply OTForRel_fun
  | |- @OTForRel _ _ _ => apply OTForRel_OTForType; try apply OTForType_refl
  end.

(*
Ltac prove_OTForRel :=
  lazymatch goal with
  | |- @OTForRel (OTarrow ?A ?B) (forall x:?AU, ?BU) _ =>
    let RBU := fresh "RBU" in
    evar (RBU: forall (x:AU), relation BU);
    assert (forall x, @OTForRel A BU (?RBU x)); [ intro x | ];
    unfold RBU; clear RBU
  | |- @OTForRel _ _ _ => apply OTForRel_OTForType
  end.
*)

(* Hint to use the prove_OTForRel tactic; we need this because often the
relation part is an evar, so will not match any of the instances above *)
Hint Extern 2 (@OTForRel _ _ _) => prove_OTForRel : typeclass_instances.

(***
 *** Building Ordered Terms
 ***)

Class OTHasType (A:OType) {AU} (RU:relation AU) (x y:AU) : Prop :=
  {
    ot_has_type : RU x y
  }.

Arguments OTHasType A {AU%type} RU%signature x y.

Instance OTHasType_app (A:OType) AU RAU (B:OType) BU RBU
         (fl fr:AU -> BU) argl argr
         (otef:OTHasType (OTarrow A B) (RAU ==> RBU) fl fr)
         (otea:OTHasType A RAU argl argr) :
  OTHasType B RBU (fl argl) (fr argr) | 3.
Proof.
  constructor.
  apply (ot_has_type (OTHasType:=otef)).
  apply ot_has_type.
Qed.

Instance OTHasType_pfun_app (A B:OType) (fl fr:OTarrow A B) argl argr
         (otef:OTHasType (OTarrow A B) (ot_R (OTarrow A B)) fl fr)
         (otea:OTHasType A (ot_R A) argl argr)
 : OTHasType B (ot_R B) (pfun_app fl argl) (pfun_app fr argr) | 2.
Proof.
  constructor.
  apply (ot_has_type (OTHasType:=otef)).
  apply (ot_has_type (OTHasType:=otea)).
Qed.

(* NOTE: We only want this to apply to terms that are syntactically lambdas, so
we use an Extern hint, below. *)
Definition OTHasType_lambda (A B:OType) AU RAU BU RBU
         (fl fr:AU -> BU)
         (pf: forall xl xr (pf:OTHasType A RAU xl xr),
             OTHasType B RBU (fl xl) (fr xr)) :
  OTHasType (OTarrow A B) (RAU ==> RBU) fl fr.
Proof.
  constructor.
  intros xl xr Rx; apply pf; constructor; assumption.
Qed.

(*
Ltac OTHasType_tac :=
  lazymatch goal with
  | |- OTHasType _ _ (fun x => ?f) (fun y => ?g) =>
    eapply (OTHasType_lambda _ _ _ _ (fun x => f) (fun y => g))
  | |- OTHasType _ _ (pfun_app ?f ?x) (pfun_app ?g ?y) =>
    apply (OTHasType_pfun_app _ _ f g x y)
  | |- OTHasType _ _ (?f ?x) (?g ?y) =>
    eapply (OTHasType_app _ _ _ _ _ _ f g x y)
  end.

Hint Extern 4 (OTHasType _ _ _ _) => OTHasType_tac : typeclass_instances.
*)

(* Hint to apply OTHasType_lambda on lambdas *)
Ltac try_OTHasType_lambda :=
  lazymatch goal with
  | |- @OTHasType _ _ _ (fun x => ?f) (fun y => ?g) =>
    eapply (OTHasType_lambda _ _ _ _ _ _ (fun x => f) (fun y => g))
  end.

Hint Extern 2 (@OTHasType _ _ _ (fun _ => _) (fun _ => _)) =>
try_OTHasType_lambda : typeclass_instances.

(* NOTE: this is not an instance because it is not syntax-driven, like our other
rules for OTHasType. Instead, this definition is used as a helper to build
other instances of OTHasType. *)
Definition OTHasType_Proper `{OTForRel} (x:AU) :
  Proper RU x -> OTHasType A RU x x.
  intros; constructor; assumption.
Defined.

Instance OTHasType_refl (A:OType) (x:A) : OTHasType A (ot_R A) x x.
Proof.
  apply OTHasType_Proper. unfold Proper. reflexivity.
Defined.

(*
Instance OTHasType_refl_rel {T} (A:relation T) {vA:ValidOType A} (x:T)
  : OTHasType A A x x := OTHasType_refl A x.
*)

Program Definition mkOTerm (A:OType) {AU RU}
        {otfr:OTForRel A RU} (x:AU) {ht:@OTHasType A AU RU x x} : ot_Type A :=
  ot_lift (OTForRel:=otfr) x ot_has_type.

Arguments mkOTerm A {AU%type RU%signature} {otfr} x {ht}.

Instance OTHasType_mkOTerm A AU RU x y otr htx hty (ht:@OTHasType A AU RU x y)
  : OTHasType A (ot_R A) (@mkOTerm A AU RU otr x htx) (@mkOTerm A AU RU otr y hty).
Proof.
  constructor. apply (ot_lift_Proper x y). apply ot_has_type.
Qed.

(***
 *** OT Typing Rules for Common Operations
 ***)

(*
Instance OTHasType_Proper A AU R (x:AU)
           {ote:OTForRel A R} {prp:Proper R x} :
  OTHasType A R x x.
  constructor; assumption.
Qed.

Instance Proper_fst A B : Proper (ot_R (OTpair A B) ==> ot_R A) fst.
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_snd A B : Proper (ot_R (OTpair A B) ==> ot_R B) snd.
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_pair A B : Proper (ot_R A ==> ot_R B ==> ot_R (OTpair A B)) pair.
Proof.
  intros a1 a2 Ra b1 b2 Rb; split; assumption.
Qed.
*)

Instance OTHasType_fst A B :
  OTHasType (OTarrow (OTpair A B) A) (pairR (ot_R A) (ot_R B) ==> ot_R A) fst fst.
Proof.
  apply OTHasType_Proper.
  intros p1 p2 Rp; destruct Rp; assumption.
Defined.

(*
Hint Extern 0 (@OTHasType _ _ fst fst) =>
apply OTHasType_fst : typeclass_instances.
*)

Instance OTHasType_snd A B :
  OTHasType (OTarrow (OTpair A B) B) (ot_R (OTpair A B) ==> ot_R B) snd snd.
Proof.
  apply OTHasType_Proper.
  intros p1 p2 Rp; destruct Rp; assumption.
Defined.

(*
Hint Extern 0 (@OTHasType _ _ snd snd) =>
eapply OTHasType_snd : typeclass_instances.
 *)

Instance OTHasType_pair A B :
  OTHasType (OTarrow A (OTarrow B (OTpair A B)))
            (ot_R A ==> ot_R B ==> ot_R (OTpair A B)) pair pair.
Proof.
  apply OTHasType_Proper.
  intros a1 a2 Ra b1 b2 Rb; split; assumption.
Defined.

(*
Hint Extern 0 (OTHasType _ _ pair pair) =>
apply OTHasType_pair : typeclass_instances.
 *)

(***
 *** Notations for Ordered Types
 ***)

Notation "A '-o>' B" :=
  (OTarrow A B) (right associativity, at level 99).
Notation "A '*o*' B" :=
  (OTpair A B) (left associativity, at level 40).
Notation "A '+o+' B" :=
  (OTsum A B) (left associativity, at level 50).
Notation "'~o~' A" :=
  (OTflip A) (right associativity, at level 35).

Notation "x <o= y" :=
  (ot_R _ x y) (no associativity, at level 70).
Notation "x =o= y" :=
  (ot_equiv _ x y) (no associativity, at level 70).

Notation "x @o@ y" :=
  (pfun_app x y) (left associativity, at level 20).

(*
  Notation "F @t@ A" :=
    (otypef_app F A) (left associativity, at level 20).
 *)

Definition ofst {A B} : A *o* B -o> A := mkOTerm _ fst.
Definition osnd {A B} : A *o* B -o> B := mkOTerm _ snd.
Definition opair {A B} : A -o> B -o> A *o* B := mkOTerm _ pair.

Notation "( x ,o, y )" :=
  (opair @o@ x @o@ y)
    (no associativity, at level 0).

(***
 *** Automation for Ordered Terms
 ***)

Create HintDb OT.

(* Split ot_equiv equalities into the left and right cases *)
Definition prove_ot_equiv A (x y : ot_Type A)
           (pf1: x <o= y) (pf2 : y <o= x) : x =o= y :=
  conj pf1 pf2.

Hint Resolve prove_ot_equiv : OT.

(* Extensionality for ot_R *)
Definition ot_arrow_ext (A B:OType) (f1 f2 : A -o> B)
           (pf:forall x y, x <o= y -> f1 @o@ x <o= f2 @o@ y) : f1 <o= f2 := pf.

Hint Resolve ot_arrow_ext : OT.

(* Application commutes with ot_lift *)
(* FIXME: don't use this! *)
(*
Definition ot_lift_apply (A B:OType) AU RAU BU RBU
      (otfA:@OTForType A AU RAU) (otfB:@OTForRel B BU RBU)
      (f:AU -> BU) prp arg :
  ot_lift (OTForRel:=OTForRel_fun A B AU RAU BU RBU otfA otfB) f prp @o@ arg
  = ot_lift (OTForRel:=otfB) (f (ot_unlift_iso arg)) (prp _ _ (reflexivity _))
  := eq_refl.
*)

(* ot_unlift_iso for OTForType_refl is just the identity *)
(* NOTE: also don't use this directly *)
(*
Lemma ot_unlift_iso_OTForType_refl_id (A:OType) x :
  ot_unlift_iso (OTForType:=OTForType_refl A) x = x.
  reflexivity.
Qed.
*)

(* Tactic to simplify ot_unlift_iso x to just x *)
(*
Ltac simpl_ot_unlift_iso :=
  lazymatch goal with
  | |- context ctx [@ot_unlift_iso _ _ _ (OTForType_refl ?A) ?x] =>
    let new_goal := context ctx [x] in
    change new_goal
  end.
 *)

(* Tactic to simplify mkOTerm x to just x *)
(*
Definition simpl_mkOTerm_refl A x ht :
  mkOTerm (otfr:=OTForRel_OTForType _ _ _ (OTForType_refl A)) A x (ht:=ht) = x
  := eq_refl.
*)

Ltac simpl_mkOTerm_refl :=
  lazymatch goal with
  | |- context ctx [@mkOTerm
                      _ _ _
                      (OTForRel_OTForType _ _ _ (OTForType_refl _)) _ ?x _] =>
    let new_goal := context ctx [x] in
    change new_goal
  end.

(* Application commutes with mkOTerm *)
(* NOTE: Don't use this directly; it is just here to inform the change tactic
used in prove_OT, below *)
(*
Definition mkOTerm_apply (A B:OType) AU RAU BU RBU
      (otfA:@OTForType A AU RAU) (otfB:@OTForRel B BU RBU)
      (f:AU -> BU) ht arg :
  mkOTerm (A -o> B) (otfr:=OTForRel_fun A B AU RAU BU RBU otfA otfB)
          f (ht:=ht) @o@ arg
  =
  mkOTerm B (otfr:=otfB)
          (ht:=
             {| ot_has_type :=
                  (ot_has_type (OTHasType:=ht)) _ _ (reflexivity _) |})
          (f (ot_unlift_iso arg))
  := eq_refl.
 *)

(* Tactic to simplify mkOTerm f @o@ x to f (ot_unlift_iso x) *)
Ltac simpl_mkOTerm_apply :=
  lazymatch goal with
  | |- context
         ctx
         [@mkOTerm
            _ _ _
            (OTForRel_fun ?A ?B ?AU ?RAU ?BU ?RBU (OTForType_refl _) ?otfB) ?f ?ht
         @o@ ?arg] =>
    let new_goal :=
        context
          ctx
          [mkOTerm B (otfr:=otfB)
                   (ht:=
                      {| ot_has_type :=
                           (ot_has_type (OTHasType:=ht)) _ _ (reflexivity _) |})
                   (f arg)]
    in change new_goal; cbv beta
(*
  | |- context
         ctx
         [@mkOTerm
            _ _ _
            (OTForRel_fun ?A ?B ?AU ?RAU ?BU ?RBU ?otfA ?otfB) ?f ?ht
         @o@ ?arg] =>
    let new_goal :=
        context
          ctx
          [mkOTerm B (otfr:=otfB)
                   (ht:=
                      {| ot_has_type :=
                           (ot_has_type (OTHasType:=ht)) _ _ (reflexivity _) |})
                   (f (ot_unlift_iso arg))]
    in change new_goal; cbv beta
*)
  end.

(* Add the above rules to the OT rewrite set *)
(* Hint Rewrite @mkOTerm_apply @ot_unlift_iso_OTForType_refl_id : OT. *)

(* Tactic to apply rewrites in the OT rewrite set *)
Ltac rewrite_OT := rewrite_strat (topdown (hints OT)).

(* General tactic to try to prove theorems about ordered terms *)
Ltac prove_OT :=
  repeat first [simpl_mkOTerm_refl | simpl_mkOTerm_apply];
  try rewrite_OT;
  lazymatch goal with
  | |- ot_equiv _ _ _ => split
  | |- _ => idtac
  end.
  (* repeat (apply ot_arrow_ext; intros). *)

(***
 *** Examples of Ordered Terms
 ***)

Module OTExamples.

Definition ex1 := mkOTerm (OTProp -o> OTProp) (fun p => p).
Eval compute in (ot_unlift ex1 : Prop -> Prop).

Definition ex2 {A} := mkOTerm (A -o> A) (fun p => p).
Eval simpl in (fun A:OType => ot_unlift (@ex2 A) : A -> A).

Definition ex2' {A} := mkOTerm (A -o> A -o> A) (fun p1 p2 => p1).
Eval simpl in (fun A:OType => ot_unlift (@ex2' A) : A -> A -> A).

(* FIXME HERE: ex3 does not work without type annotations on fun vars! I think
the problem is that the inferred types of the fun vars are evars that depend on
all the previous vars, so it looks like a dependent forall type and OTForRel_fun
does not apply. *)
Definition ex3 {A} :=
  mkOTerm (A -o> A -o> A -o> A -o> A) (fun p1 p2 p3 p4 => p1).
Eval simpl in (fun A:OType => ot_unlift (@ex3 A) : A -> A -> A -> A -> A).

Definition ex4 {A B} : (A *o* B -o> A) := mkOTerm _ (fun p => fst p).
Eval simpl in (fun (A B:OType) => ot_unlift ex4 : A * B -> A).

Definition ex5 {A B} : A *o* B -o> B *o* A :=
  mkOTerm _ (fun p => (snd p, fst p)).
Eval simpl in (fun (A B:OType) => ot_unlift ex5 : A *o* B -> B *o* A).

(*
Definition ex6 {A B C} : A *o* B *o* C -o> C *o* A :=
  mkOTerm _ (fun triple => (snd triple, fst (fst triple))).
 *)

Definition ex6 {A B C} : A *o* B *o* C -o> C *o* A :=
  mkOTerm _ (fun triple => (osnd @o@ triple , ofst @o@ (ofst @o@ triple))).

Definition ex7 {A B C} : (A *o* B -o> C) -o> C -o> A -o> B -o> C :=
  mkOTerm ((A *o* B -o> C) -o> C -o> A -o> B -o> C)
          (fun (f:A *o* B -o> C) (c:C) a b => f @o@ (a ,o, b)).

End OTExamples.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Category.
Local Open Scope morphism_scope.

(** A composable chain in a category from a to b is a single arrow from a to b
or an arrow from a to some c provided that there is a composable chain from c
to b.

Composable chains are used in defining images of functors.
*)
Inductive Composable_Chain (C : Category) (a b : C) : Type :=
| Single : (a --> b) → Composable_Chain C a b
| Chain : ∀ (c : Obj),
    (a --> c) → Composable_Chain C c b → Composable_Chain C a b.

Arguments Single {_ _ _} _.
Arguments Chain {_ _ _ _} _ _.

(**
A forall quantifier ofr arrows on a composable chain. Forall ch P is provable if
P x is provable for all arrows x on the composable chain ch.
*)
Fixpoint Forall_Links {C : Category} {a b : C} (ch : Composable_Chain C a b)
         (P : ∀ {x y : Obj}, (x --> y) → Prop) : Prop :=
  match ch with
    | Single f => P f
    | Chain f ch' => P f ∧ Forall_Links ch' (@P)
  end.

(**
Computes the composition of a composable chain.
*)
Fixpoint Compose_of {C : Category} {a b : C} (ch : Composable_Chain C a b)
         {struct ch} : a --> b :=
  match ch with
    | Single f => f
    | Chain f ch' => (Compose_of ch') ∘ f
  end.

(**
Composes two composable chains (chain-composition).
*)
Fixpoint Chain_Compose {C : Category} {a b c : C} (ch1 : Composable_Chain C a b)
         (ch2 : Composable_Chain C b c) : Composable_Chain C a c :=
  match ch1 with
    | Single f => Chain f ch2
    | Chain f ch' => Chain f (Chain_Compose ch' ch2)
  end.

(**
It doesn't matter if we first chain-compose two composable chains and then get
the compostion of the resutlting chain or if we first compose individual chains
and then composte the two resulting arrows.
*)
Theorem Compose_of_Chain_Compose (C : Category) (a b c : C)
        (ch1 : Composable_Chain C a b) (ch2 : Composable_Chain C b c)
  : ((Compose_of ch2) ∘ (Compose_of ch1))%morphism =
    Compose_of (Chain_Compose ch1 ch2).
Proof.
  induction ch1; auto.
  simpl.
  rewrite <- assoc.
  rewrite IHch1; trivial.
Qed.

(**
If a property holds for all arrows of two chains, then the same property holds
for all arrows in their chain-composition.
*)
Theorem Forall_Links_Chain_Compose (C : Category) (a b c : C)
        (ch1 : Composable_Chain C a b) (ch2 : Composable_Chain C b c)
        (P : ∀ (x y : Obj), (x --> y) → Prop) :
  Forall_Links ch1 P → Forall_Links ch2 P → Forall_Links (Chain_Compose ch1 ch2) P.
Proof.
  intros H1 H2.
  induction ch1.
  simpl in *; auto.
  destruct H1 as [H11 H12].
  simpl in *; split; auto.
Qed.