(* Julien Narboux *)
(* Formalization of *)
(* Tarski's axiomatic *)

Require Export Ch06_out_lines.

Unset Regular Subst Tactic.

Definition is_midpoint := fun M A B => Bet A M B /\ Cong A M M B.

Lemma l7_2 : forall M A B, is_midpoint M A B -> is_midpoint M B A.
Proof with Tarski.
unfold is_midpoint.
intros.
intuition.
Qed.

Lemma l7_3 : forall M A, is_midpoint M A A -> M=A.
Proof with Tarski.
unfold is_midpoint.
intros.
intuition.
eTarski.
Qed.

Lemma l7_3_2 : forall A, is_midpoint A A A.
Proof with Tarski.
unfold is_midpoint.
intros.
intuition.
Qed.

Hint Resolve l7_2 l7_3 l7_3_2 : Midpoint.

Ltac Midpoint := eauto with Midpoint.

Lemma symmetric_point_construction : forall A P,
 exists P', is_midpoint P A P'.
Proof with Tarski.
unfold is_midpoint.
intros.
assert (exists E : Point, Bet A P E /\ Cong P E A P)...
DecompExAnd H E.
exists E.
intuition.
Qed.

Hint Resolve symmetric_point_construction : Midpoint.

Lemma symmetric_point_unicity : forall A P P1 P2,
  is_midpoint P A P1 -> is_midpoint P A P2 -> P1=P2.
Proof with Tarski.
unfold is_midpoint.
intros.
intuition.
cases_equality A P.

treat_equalities...

eapply construction_unicity; try apply H0...
esTarski.
Qed.

Lemma l7_9 : forall P Q A X,
  is_midpoint A P X -> is_midpoint A Q X -> P=Q.
Proof with Tarski.
unfold is_midpoint.
intros;intuition.

cases_equality A X.
treat_equalities...
eapply (construction_unicity X A X A P Q);Between;sTarski.
Qed.

Lemma l7_13 : forall A P Q P' Q',
  is_midpoint A P' P -> is_midpoint A Q' Q ->
  Cong P Q P' Q'.
Proof with sTarski.
intros.
cases_equality P A.
unfold is_midpoint in *.
intuition.
(* *)
treat_equalities...
(* *)
assert (exists X, Bet P' P X /\ Cong P X Q A)...
DecompExAnd H2 X.
assert (exists X', Bet X P' X' /\ Cong P' X' Q A)...
DecompExAnd H2 X'.
assert (exists Y, Bet Q' Q Y /\ Cong Q Y P A)...
DecompExAnd H2 Y.
assert (exists Y', Bet Y Q' Y' /\ Cong Q' Y' P A)...
DecompExAnd H2 Y'.
(* *)
unfold is_midpoint in *;intuition.
(* *)
assert (Cong A X Y A).
apply (l2_11 A P X Y Q A);Between...
(* *)
assert (Cong A Y' X' A).
apply (l2_11 A Q' Y' X' P' A);Between.
eapply cong_transitivity.
apply cong_commutativity.
apply H12.
sTarski.
eapply cong_transitivity;eauto...
(* *)
assert (Cong A Y A Y').
apply (l2_11 A Q Y A Q' Y');Between;eauto...
eapply cong_transitivity;eauto...
(* *)
assert (FSC X A X' Y' Y' A Y X).
unfold FSC;repeat split.
unfold Col;left;Between.
eapply cong_transitivity with (C:=Y) (D:=A)...
4:eapply cong_transitivity with (C:=Y) (D:=A)...
2:eapply cong_transitivity with (C:=Y') (D:=A)...
2:Tarski.
(* *)
eapply (l2_11 X A X' Y' A Y);Between.
eapply cong_transitivity with (C:=Y) (D:=A)...
eapply cong_transitivity with (C:=Y') (D:=A)...
(* *)
assert (X<>A).
unfold not;intro.
treat_equalities...
(* *)
assert (Cong X' Y' Y X).
eapply l4_16.
apply H15.
auto.
(* *)
assert (IFSC Y Q A X Y' Q' A X').
unfold IFSC,FSC in *;intuition;Between...
eapply cong_transitivity with (C:=Y') (D:=A)...
(* *)
assert (Cong Q X Q' X').
eapply l4_2.
apply H18.
(* *)
assert (IFSC X P A Q X' P' A Q').
unfold IFSC,FSC in *;intuition;Between...
(* *)
eapply l4_2.
apply H20.
Qed.

(** Symmetry preserves Bet. *)

Lemma l7_15 : forall P Q R P' Q' R' A,
 is_midpoint A P P' -> is_midpoint A Q Q' -> is_midpoint A R R' ->
 Bet P Q R -> Bet P' Q' R'.
Proof with Midpoint.
intros.
eapply l4_6.
apply H2.
unfold Cong_3.
repeat split;eapply l7_13...
Qed.

(** Symmetry preserves Cong. *)

Lemma l7_16 : forall P Q R S P' Q' R' S' A,
   is_midpoint A P P' -> is_midpoint A Q Q' ->
   is_midpoint A R R' -> is_midpoint A S S' ->
  Cong P Q R S  -> Cong P' Q' R' S'.
Proof with Midpoint.
intros.
assert (Cong P Q P' Q').
eapply l7_13...
assert (Cong R S R' S').
eapply l7_13...
eapply cong_transitivity with (C:=P) (D:=Q);sTarski.
eapply cong_transitivity with (C:=R) (D:=S);sTarski.
Qed.

(** Symmetry preserves midpoint *)

Lemma symmetry_preserves_midpoint :
   forall A B C D E F Z,
 is_midpoint Z A D -> is_midpoint Z B E -> is_midpoint Z C F ->
 is_midpoint B A C -> is_midpoint E D F.
Proof.
intros.
unfold is_midpoint in H2.
unfold is_midpoint.
split.
eapply l7_15;eauto.
intuition.
eapply l7_16;eauto.
intuition.
Qed.

Hint Resolve symmetry_preserves_midpoint : Midpoint.

Lemma l7_17 : forall P P' A B,
   is_midpoint A P P' -> is_midpoint B P P' -> A=B.
Proof with Midpoint.
intros.
assert (Cong P B P' B).
eapply l7_13...
assert (exists B', is_midpoint A B B')...
DecompEx H2 B'.
assert (Cong P' B P B').
eapply l7_13.
apply H.
Midpoint.
(* *)
assert (Cong P B P B').
eTarski.
assert (Cong P B P' B').
eapply l7_13.
apply l7_2.
apply H.
Midpoint.
(* *)
assert (Cong P' B P' B').
eTarski.
(* *)
assert (Bet P B P').
unfold is_midpoint in *;intuition.
assert (B=B').
eapply l4_19.
apply H7.
sTarski.
sTarski.
treat_equalities.
eapply l7_3...
Qed.

Lemma l7_20 : forall M A B,
  Col A M B -> Cong M A M B -> A=B \/ is_midpoint M A B.
Proof with Tarski.
unfold is_midpoint.
intros.
unfold Col in *;intuition.
(* *)
assert (Cong A B B B).
eapply l4_3.
apply between_symmetry;apply H.
2:apply cong_commutativity;apply H0.
Tarski.
Tarski.
treat_equalities.
left;auto.
(* *)
assert (Cong B A A A).
eapply l4_3.
apply H.
2:apply cong_commutativity;apply cong_symmetry;apply H0.
Tarski.
Tarski.
treat_equalities.
left;auto.
Qed.

Lemma l7_21 : forall A B C D P,
  ~ Col A B C -> B<>D -> Cong A B C D -> Cong B C D A ->
     Col A P C -> Col B P D -> is_midpoint P A C /\ is_midpoint P B D.
Proof with Tarski.
intros.
assert (exists P', Cong_3 B D P D B P').
apply l4_14;Col...
DecompEx H5 P'.
assert (Col D B P').
eapply l4_13;try apply H6;Col...
assert (FSC B D P A D B P' C).
unfold FSC;intuition...
assert (FSC B D P C D B P' A).
unfold FSC;intuition...
assert (Cong P A P' C).
eapply l4_16; try apply H7...
assert (Cong P C P' A).
eapply l4_16; try apply H8...
assert (Cong_3 A P C C P' A).
unfold Cong_3;intuition...
assert (Col C P' A).
eapply l4_13;try apply H11...
assert (P=P').
unfold FSC in *;intuition.
eapply (l6_21 A C B D);Col...
treat_equalities.
assert (C = A \/ is_midpoint P C A).
eapply l7_20;Col...
assert (B = D \/ is_midpoint P B D).
eapply l7_20;Col...
unfold FSC,Cong_3 in *.
intuition;sTarski...
intuition.
unfold is_midpoint,FSC,Cong_3 in *;intuition.
treat_equalities.
clear H13 H21 H26 H2 H4 H5 H6.
unfold Col in H.
intuition.
assert (Bet C C B)...
intuition.
Qed.

Lemma l7_22_aux : forall A1 A2 B1 B2 C M1 M2,
   Bet A1 C A2 -> Bet B1 C B2 ->
   Cong C A1 C B1 -> Cong C A2 C B2 ->
   is_midpoint M1 A1 B1 -> is_midpoint M2 A2 B2 -> le C A1 C A2 ->
   Bet M1 C M2.
Proof with Tarski.
intros.
cases_equality A2 C.
treat_equalities.
assert (M2=A2).
apply l7_3...
treat_equalities.
Tarski.
assert (exists A, is_midpoint C A2 A).
eapply symmetric_point_construction.
DecompEx H7 A.
assert (exists B, is_midpoint C B2 B).
eapply symmetric_point_construction.
DecompEx H7 B.
assert (exists M, is_midpoint C M2 M).
eapply symmetric_point_construction.
DecompEx H7 M.
assert (is_midpoint M A B).
unfold is_midpoint.
split.
eapply l7_15.
apply H8.
apply H10.
apply H9.
unfold is_midpoint in H4;intuition...
eapply l7_16.
apply H8.
apply H10.
apply H10.
apply H9.
unfold is_midpoint in *;intuition...
assert (le C A1 C A).
eapply l5_6.
split.
apply H5.
split...
unfold is_midpoint in H8;intuition.
assert (Bet C A1 A).
cases_equality A1 C.
subst;Tarski.
eapply l6_13_1.
2:auto.
unfold out;repeat split;auto.
unfold not;intro;treat_equalities.
assert (A=A1).
eapply le_zero.
apply H11.
treat_equalities.
assert (M1=A).
Midpoint.
treat_equalities.
auto.
unfold is_midpoint in H8.
decompose [and] H8;clear H8.
eapply l5_2.
3:apply H13.
auto.
Between.
assert (le C B1 C B).
eapply l5_6.
split.
apply H11.
split...
eapply cong_transitivity with (C:=C)  (D:=A2).
unfold is_midpoint in H8;intuition.
eapply cong_transitivity with (C:=C)  (D:=B2).
unfold is_midpoint in H8;intuition.
unfold is_midpoint in H9;intuition.
assert (Bet C B1 B).
cases_equality B1 C.
subst;Tarski.
eapply l6_13_1.
2:auto.
unfold out;repeat split;auto.
unfold not;intro;treat_equalities.
assert (B=B1).
eapply le_zero.
apply H13.
treat_equalities.
assert (M1=B).
Midpoint.
treat_equalities.
auto.
unfold is_midpoint in H9.
decompose [and] H9;clear H9.
eapply l5_2.
3:apply H15.
2:Between.
unfold not;intro.
treat_equalities.
auto.
assert (exists Q, Bet M Q C /\ Bet A1 Q B1).
eapply l3_17.
apply between_symmetry.
apply H12.
Between.
unfold is_midpoint in H7;intuition.
DecompExAnd H15 Q.
assert (Bet Q C M2).
unfold is_midpoint in H10;intuition;Between.
cut (Q=M1).
intro.
subst M1;auto.
assert (IFSC A A1 C M B B1 C M).
unfold IFSC;unfold is_midpoint in *;intuition.
eapply cong_transitivity with (C:=C)  (D:=A2).
unfold is_midpoint in H8;intuition.
eapply cong_transitivity with (C:=C)  (D:=B2).
unfold is_midpoint in H8;intuition.
unfold is_midpoint in H9;intuition.
assert (Cong A1 M B1 M).
eapply l4_2;eauto.
assert (Cong Q A1 Q B1).
cases_equality M C.
treat_equalities.
sTarski.
eapply l4_17.
apply H20.
Col.
sTarski.
sTarski.
assert (is_midpoint Q A1 B1).
unfold is_midpoint;intuition.
eapply l7_17;eauto.
Qed.

Lemma l7_22  : forall A1 A2 B1 B2 C M1 M2,
   Bet A1 C A2 -> Bet B1 C B2 ->
   Cong C A1 C B1 -> Cong C A2 C B2 ->
   is_midpoint M1 A1 B1 -> is_midpoint M2 A2 B2 ->
   Bet M1 C M2.
Proof.
intros.
assert (le C A1 C A2 \/ le C A2 C A1).
eapply le_cases.
elim H5;intro.
eapply (l7_22_aux A1 A2 B1 B2 C M1 M2);auto.
apply between_symmetry.
eapply (l7_22_aux A2 A1 B2 B1 C M2 M1);try assumption;Between.
Qed.

Lemma l7_25 : forall A B C, Cong C A C B -> exists X, is_midpoint X A B.
Proof with Tarski.
intros.
cases_col A B C.
assert (A = B \/ is_midpoint C A B).
apply l7_20...
Col.
intuition.
exists A;subst B;Midpoint.
exists C...
assert (exists P, Bet C A P /\ A<>P)...
DecompExAnd H1 P.
assert (exists Q, Bet C B Q /\ Cong B Q A P)...
DecompExAnd H1 Q.
assert (exists R, Bet A R Q /\ Bet B R P).
eapply inner_pasch;Between.
DecompExAnd H1 R.
assert (exists X, Bet A X B /\ Bet R X C).
eapply inner_pasch;Between.
DecompExAnd H1 X.
exists X.
unfold is_midpoint.
split;auto.
apply cong_left_commutativity.
cut (Cong R A R B).
intro.
eapply l4_17.
3:apply H1.
3:apply H.
unfold not;intro.
treat_equalities.
assert (Col A B R);Col.
Col.
assert (C<>A).
unfold not;intro.
treat_equalities.
unfold Col in H0.
intuition.
assert (OFSC C A P B C B Q A).
unfold OFSC,Cong_3;intuition.
assert (Cong P B Q A).
eapply five_segments_with_def.
apply H2.
apply H1.
assert (exists R', Bet A R' Q /\ Cong_3 B R P A R' Q).
eapply l4_5...
sTarski.
DecompExAnd H12 R'.
assert (IFSC B R P A A R' Q B).
unfold IFSC,Cong_3 in*;intuition.
assert (IFSC B R P Q A R' Q P).
unfold IFSC,Cong_3 in*;intuition.
assert (Cong R A R' B).
eapply l4_2;eauto.
assert (Cong R Q R' P).
eapply l4_2;eauto.
assert (Cong_3 A R Q B R' P).
unfold Cong_3;intuition.
assert (Col B R' P).
eapply l4_13.
2:apply H18.
Col.
cut (R=R').
intro.
subst R'.
sTarski.
assert (B<>P).
unfold not;intro;treat_equalities...
assert (A<>Q).
unfold not;intro;treat_equalities...
assert (B<>Q).
unfold not;intro;treat_equalities...
eapply (l6_21 A Q B P R R' );Col.
unfold not;intro.
assert (B<>R).
unfold not;intro.
unfold OFSC,IFSC,Cong_3 in *.
decompose [and] H2;clear H2.
decompose [and] H15;clear H15.
decompose [and] H12;clear H12.
decompose [and] H13;clear H13.
decompose [and] H18;clear H18.
treat_equalities...
assert (Col B C A).
eapply col_transitivity_1.
apply H22.
Col.
Col.
assert (Col A B C).
Col.
auto.
assert (Col A R B).
eapply col_transitivity_1.
apply H21.
Col.
Col.
assert (Col B P A).
eapply col_transitivity_1.
apply H24.
Col.
Col.
assert (Col A B C).
eapply col_transitivity_1.
apply H4.
Col.
Col.
auto.
Qed.


Require Import Omega.
Require Import Program.Basics.
Require Import Logic.FunctionalExtensionality.
Require Import prelims.
Require Import repeater.
Require Import increasing_expanding.
Require Import inverse.
Require Import countdown.
Require Import applications.

(*
==========================================================================
*************** SECTION 7: THE INVERSE ACKERMANN FUNCTION ****************
==========================================================================
 *)

(*
 * This section contains the most important application of countdown,
 * the Inverse Ackermann function.
 *
 * We first define an inverse tower for the Ackermann hierarchy,
 * then write a theorem proving its correctness.
 *
 * Then we define a structurally terminating definition for the inverse
 * Ackermann function, and prove its correctness using the above theorem.
 *
 * We digress briefly to discuss the two-parameter inverse Ackermann
 * function, which some authors prefer.
 *
 * Finally, we state and prove the correctness of the time-bound improvement,
 * on the single-argument inverse Ackermann, which runs in linear time.
 *)

(* ****** INVERSE ACKERMANN HIERARCHY ****** *)

Fixpoint alpha m x :=
  match m with
  | 0 => x - 1
  | S m' => countdown_to (alpha m') 1 (alpha m' x)
  end.

Theorem alpha_correct :
  forall m, contract_strict_above 1 (alpha m) /\
            upp_inv_rel (alpha m) (ackermann m).
Proof.
  induction m.
  1: split; [split; intro; simpl; omega | intros n x; simpl; omega].
  destruct IHm as [IHm0 IHm1]. split.
  - simpl. split; intro n;
             rewrite countdown_antirecursion by apply IHm0;
             apply (countdown_contract_strict 1 _ 1) in IHm0;
             destruct IHm0 as [IHm00 IHm01]; trivial.
    + specialize (IHm00 n); omega.
    + specialize (IHm01 n); omega.
  - intros n x. simpl. rewrite repeater_from_repeat.
    rewrite <- repeat_S_comm.
    apply (upp_inv_repeat (S n) _ _) in IHm1.
    rewrite <- (IHm1 1 x), repeat_S_comm.
    now apply countdown_repeat.
Qed.

(* ****** INVERTABILITY OF ACKERMANN FUNCTION ****** *)

(* Repeatability *)
Lemma ack_repeatable : forall i, repeatable_from 0 (ackermann i).
Proof.
  induction i; split; try split;
    intro n; try intro m; simpl; try omega;
      apply (repeatable_monotone 0 1 _) in IHi; try omega;
        repeat rewrite repeater_from_repeat;
        repeat rewrite <- repeat_S_comm;
        repeat rewrite <- repeater_from_repeat;
        apply (repeater_repeatable _ 0 _) in IHi; try omega;
          destruct IHi as [IHi0 IHi1];
          [intro; apply IHi0; omega | |];
          apply (Nat.le_trans _ (S (S n)) _); try apply IHi1; omega.
Qed.

(*
 * Ackermann at level 1. It is useful for two purposes:
 *  (1) Computes alpha 1 below, which is used in hard-coding the second level
 *      for linear runtime.
 *  (2) Serves to prove base case for "ack_incr_by_lvl"
 *)
Lemma ack_1 : forall n, ackermann 1 n = (S (S n)).
Proof.
  induction n; [|rewrite ackermann_recursion; rewrite IHn]; trivial.
Qed.

(* Alpha at level 1. Used in hard-coding the second level for linear runtime *)
Lemma alpha_1 : alpha 1 = (fun n => n - 2).
Proof.
  assert (upp_inv_rel (alpha 1) (ackermann 1)) as H
      by apply alpha_correct.
  assert (upp_inv_rel (fun n => n - 2) (ackermann 1)) as H'
      by (intros n m; rewrite ack_1; omega).
  rewrite upp_inv_unique in H
      by (intros n m; repeat rewrite ack_1; omega).
  rewrite upp_inv_unique in H'
      by (intros n m; repeat rewrite ack_1; omega).
  now rewrite H'.
Qed.

(*
 * The two results below show that the diagonal Ackermann function is increasing,
 * and therefore has a proper upper inverse.
 * We need them to compute the inverse
 * value for the inv_ack correctness proof later.
 *)

(* Strict Increasing With Level *)
Lemma ack_incr_by_lvl : forall n, increasing (fun i => ackermann i n).
Proof.
  intro n. rewrite incr_S. intro i. generalize dependent n.
  induction i; intro n. 1: rewrite ack_1; simpl; omega.
  remember (S i) as p. destruct n. 1: simpl;
  apply ack_repeatable; omega.
  rewrite ackermann_recursion. apply ack_repeatable.
  assert (Hi := IHi).
  rewrite Heqp in IHi. specialize (IHi (S n)).
  rewrite ackermann_recursion in IHi.
  rewrite <- incr_twoways in IHi by apply ack_repeatable.
  apply (Nat.lt_trans _ (ackermann (S i) n) _); trivial.
  clear IHi. induction n; [now simpl|].
  repeat rewrite ackermann_recursion.
  apply (Nat.lt_trans _ (ackermann i (ackermann (S p) n)) _).
  1: apply ack_repeatable; assumption. apply Hi.
Qed.

(* Diagonal Strict Increasing *)
Lemma diag_ack_incr : increasing (fun n => ackermann n n).
Proof.
  intros n m Hnm.
  apply (Nat.lt_trans _ (ackermann n m) _);
    [apply ack_repeatable | apply ack_incr_by_lvl]; assumption.
Qed.

(* Small helper lemma - alpha decreases by level *)
Lemma alpha_decr_by_lvl : forall i n, alpha (S i) n <= alpha i n.
Proof.
  intros i n.
  destruct (alpha_correct i) as [_ Hi].
  destruct (alpha_correct (S i)) as [_ HSi].
  rewrite (HSi (alpha i n) n).
  apply (Nat.le_trans _ (ackermann i (alpha i n)) _).
  - rewrite <- (Hi (alpha i n) n). trivial.
  - assert (H := ack_incr_by_lvl (alpha i n) i (S i)). omega.
Qed.

(* ****** INVERSE ACKERMANN FUNCTION ****** *)

Fixpoint inv_ack_wkr (f : nat -> nat) (n k b : nat) : nat :=
  match b with
  | 0    => k
  | S b' => if (n <=? k) then k
              else let g := (countdown_to f 1) in
                   inv_ack_wkr (compose g f) (g n) (S k) b'
  end.

(*
 * IMPORTANT:
 * A new computational definition of inverse Ackermann, runtime O(n^2)
 *)
Definition inv_ack n := inv_ack_wkr (alpha 0) (alpha 0 n) 0 n.

(* Proof of Correctness of the above: *)
(* First, an intermediate lemma about inv_ack_wkr *)
Lemma inv_ack_wkr_intermediate :
  forall i n b,
    i < alpha i n -> i < b ->
    inv_ack_wkr (alpha 0) (alpha 0 n) 0 b =
    inv_ack_wkr (alpha (S i)) (alpha (S i) n) (S i) (b - (S i)).
Proof.
  intros i n b. rewrite <- Nat.leb_gt.
  generalize dependent b. generalize dependent n.
  induction i.
  - simpl. intros n b Hn Hb. unfold inv_ack_wkr.
    destruct b; try omega. unfold compose. rewrite Hn.
    replace (S b - 1) with b by omega. trivial.
  - intros n b Hn Hb. rewrite IHi; [| |omega].
    + remember (S i) as p.
      replace (alpha (S p)) with
        (compose (countdown_to (alpha p) 1) (alpha p)) by trivial.
      unfold inv_ack_wkr.
      remember (b - p) as c. destruct c; try omega.
      rewrite Hn. replace (b - S p) with c by omega.
      trivial.
    + rewrite Nat.leb_gt. rewrite Nat.leb_gt in Hn.
      apply (Nat.lt_le_trans _ (alpha (S i) n) _);
        [omega|apply alpha_decr_by_lvl].
Qed.

(* Proof that inv_ack correctly calculates the inverse of the
   diagonal Ackermann-Peter function *)
Theorem inv_ack_correct :
  upp_inv_rel inv_ack (fun k => ackermann k k).
Proof.
  rewrite upp_inv_unique by apply diag_ack_incr.
  assert (forall n N : nat,
             upp_inv (fun k : nat => ackermann k k) N <= n
             <-> alpha n N <= n) as H.
  { intros n N.
    rewrite (upp_inv_correct (fun k : nat => ackermann k k)
                                diag_ack_incr n N).
    destruct (alpha_correct n) as [_ Hm]. symmetry. apply Hm. }
  apply functional_extensionality. intro n.
  remember (upp_inv (fun k : nat => ackermann k k) n) as m.
  unfold inv_ack. assert (H0 := H). destruct m.
  - specialize (H 0 n). rewrite <- Heqm in H.
    assert (n <= 1) as Hn by (simpl in H; omega).
    destruct n; simpl; trivial; destruct n; simpl; trivial; omega.
  - specialize (H m n). rewrite <- Heqm in H.
    assert (m < alpha m n) as Hn by omega.
    assert (S m < n) as Hmn.
    { destruct (alpha_correct m) as [_ Hm]. rewrite <- not_le in Hn.
      rewrite (Hm m n) in Hn. rewrite <- not_le. intro.
      assert (ackermann m m <= m) by omega.
      destruct (ack_repeatable m) as [_ Hackm].
      destruct Hackm as [_ Hackm]. specialize (Hackm m). omega. }
    rewrite (inv_ack_wkr_intermediate m n n Hn). 2: omega.
    assert (alpha (S m) n <=? (S m) = true).
      { rewrite Nat.leb_le. specialize (H0 (S m) n).
        rewrite <- Heqm in H0. omega. }
    unfold inv_ack_wkr.
    remember (n - S m) as p. destruct p; [omega|].
    rewrite H1. trivial.
Qed.

(* ********* DIGRESSION: TWO PARAMETER INVERSE ACKERMANN ************* *)

(* Two parameter Inverse Ackerman worker function *)
Fixpoint two_params_inv_ack_wkr (f : nat -> nat) (n k b : nat) : nat :=
  match b with
  | 0    => 0
  | S b' => if (n <=? k) then 0
              else let g := (countdown_to f 1) in
                   S (two_params_inv_ack_wkr (compose g f) (g n) k b')
  end.

(* Two parameters Inverse Ackermann function *)
Definition two_params_inv_ack (m n : nat) : nat :=
  let f := (fun x => x - 2) in
    let n' := (Nat.log2_up n) in
      1 + two_params_inv_ack_wkr f (f n') (m / n) n'.

(* Correctness proofs begin here *)
(* First, a lemma about the worker function's inner working *)
Lemma two_params_inv_ack_wkr_intermediate :
    forall i n k b, k < alpha i n -> i <= b ->
      two_params_inv_ack_wkr (alpha 1) (alpha 1 n) k b =
        i + two_params_inv_ack_wkr (alpha (S i)) (alpha (S i) n) k (b - i).
Proof.
  induction i; intros n k b Hin Hib.
  1: rewrite Nat.add_0_l; f_equal; omega.
  rewrite IHi.
  2: apply (Nat.lt_le_trans _ (alpha (S i) n) _ Hin),
              alpha_decr_by_lvl.
  2: omega.
  unfold two_params_inv_ack_wkr at 1.
  replace (b - i) with (S (b - (S i))) by omega.
  rewrite <- Nat.leb_gt in Hin. rewrite Hin.
  fold two_params_inv_ack_wkr.
  rewrite <- Nat.add_succ_comm. trivial.
Qed.

(* Correctness theorem for two_params_inv_ack *)
Theorem two_params_inv_ack_correct :
    forall m n, two_params_inv_ack m n =
      1 + upp_inv (fun x => ackermann (S x) (m / n)) (Nat.log2_up n).
Proof.
  intros m n. unfold two_params_inv_ack.
  remember (Nat.log2_up n) as b. remember (m / n) as a.
  replace (b - 2) with (alpha 1 b) by (rewrite alpha_1; trivial).
  rewrite <- alpha_1. f_equal. clear Heqb Heqa m n.
  remember (fun x => two_params_inv_ack_wkr
                       (alpha 1) (alpha 1 x) a x) as f.
  replace (two_params_inv_ack_wkr (alpha 1) (alpha 1 b) a b)
              with (f b) by (rewrite Heqf; trivial).
  remember (fun x => ackermann (S x) a) as F.
  assert (increasing F) as HF.
  { intros x y. rewrite HeqF. rewrite Nat.succ_lt_mono.
    apply ack_incr_by_lvl. }
  remember (upp_inv F b) as p. destruct p.
  - assert (alpha 1 b <= a) as Hab.
    { destruct (alpha_correct 1) as [_ H]. rewrite (H a b).
      replace (ackermann 1 a) with (F 0) by (rewrite HeqF; trivial).
      rewrite <- (upp_inv_correct F HF 0 b). omega. }
    rewrite Heqf. rewrite <- Nat.leb_le in Hab.
    unfold two_params_inv_ack_wkr. destruct b;
      [|rewrite Hab]; trivial.
  - assert (~ b <= F p) as Hp by
          (rewrite <- (upp_inv_correct F HF p b); omega).
    rewrite HeqF in Hp. destruct (alpha_correct (S p)) as [_ H].
    rewrite <- (H a b), <- Nat.lt_nge in Hp. rewrite Heqf.
    rewrite (two_params_inv_ack_wkr_intermediate (S p) _ _ _ Hp).

    + unfold two_params_inv_ack_wkr. destruct (b - S p); [omega|].
      replace (ackermann (S p) a) with (F p)
          by (rewrite HeqF; trivial).
      replace (alpha (S (S p)) b <=? a) with true; [omega|].
      symmetry. rewrite Nat.leb_le.
      destruct (alpha_correct (S (S p))) as [_ H1]. rewrite (H1 a b).
      replace (ackermann (S (S p)) a) with (F (S p))
          by (rewrite HeqF; trivial).
      rewrite <- (upp_inv_correct F HF (S p) b). omega.
    + rewrite Nat.lt_nge, (H a b), <- Nat.lt_nge in Hp.
      apply (Nat.le_trans _ (ackermann (S p) a) _); [|omega].
      clear Heqp Hp H. induction (S p) as [|k]; [omega|].
      rewrite Nat.le_succ_l.
      apply (Nat.le_lt_trans _ (ackermann k a) _ IHk).
      apply ack_incr_by_lvl. omega.
Qed.

(* ***** LINEAR-TIME INVERSE ACKERMANN BY HARD-CODING SECOND LEVEL ***** *)

(* IMPORTANT: A new computational definition for inverse Ackerman *)
(* We hardcode the second 'alpha' level for runtime O(n). *)
Definition inv_ack_linear n :=
  match n with
  | 0 | 1 => 0
  | _     => let f := (fun x => x - 2) in inv_ack_wkr f (f n) 1 (n - 1)
  end.

(* Correctness proof *)
Theorem inv_ack_linear_correct : inv_ack_linear = inv_ack.
Proof.
  apply functional_extensionality. intro n.
  unfold inv_ack, inv_ack_linear.
  destruct n; try destruct n; trivial.
  rewrite (inv_ack_wkr_intermediate 0 _ _) by (simpl; omega).
  rewrite alpha_1; trivial.
Qed.

(* Please see inv_ack_test.v for a demonstration of the time bound. *)


Require Import CoqStock.Invs.
Require Import CoqStock.List.
Require Import CoqStock.Listerine.

Require Import Brzozowski.Alphabet.
Require Import Brzozowski.ConcatLang.
Require Import Brzozowski.Language.
Require Import Brzozowski.Setoid.

(*
This module shows off different possible definitions of star_lang and how they are all equivalent
to the defintion we use in Language.v, namely `star_lang`.
The 4 varieties include switching these options on and off:

  - allowing empty prefixes in `mk_star_more`
  - using an existence statement

Where the definition of the `star_lang` we use in Language.v:

  - does not allow empty prefixes in `mk_star_more`
  - prefers using forall over existence

The reason for preferring forall over existence in this case is that,
the definitions that use an existence statement (e.g. the existence statement
that is part of `concat_lang` and `concat_ex_prefix_not_empty_lang`) require you to
prove your own induction principle, because Coq is not smart enough to figure it
out by itself. The definitions that allow empty prefixes make induction more
difficult if the regular expression matches the empty string.

Therefore, the easiest definition is the one that does not have an existence
statement and that does not allow empty prefixes, so we will use that as our main definition.

Below, we define all these definitions and prove their equivalence. As part of
the proofs, we prove a stronger induction principle for the two definitions that
use an existence statement.

For reference here follows our main definition of `star_lang`

Inductive star_lang (R: lang): lang :=
  | mk_star_zero : star_lang R []
  | mk_star_more : forall (s p q: str),
      p ++ q = s ->
      p <> [] ->
      p \in R ->
      q \in (star_lang R) ->
      s \in star_lang R.

The other definitions are:
  - star_lang_ex_empty
  - star_lang_empty
  - star_lang_ex
*)

(*
  star_lang_ex_empty is the original definition of star_lang:
  - Uses existence
  - Allows empty prefixes in mk_star_more
  It contains more recursion, since it allows R to match the empty string.
  The definition allowing empty prefixes and using the existence statement is hidden in `concat_lang_ex`.
  This is the most difficult definition to use in Coq, but arguably the closest to the mathematical definition:
    *Star*. $P^{*} = \cup_{0}^{\infty} P^n$ , where $P^2 = P.P$, etc.
    and $P^0 = \epsilon$, the set consisting of the string of zero length.
*)
Inductive star_lang_ex_empty (R: lang): lang :=
  | mk_star_zero_ex_empty : forall (s: str),
    s = [] -> star_lang_ex_empty R s
  | mk_star_more_ex_empty : forall (s: str),
    s \in (concat_lang_ex R (star_lang_ex_empty R)) ->
    star_lang_ex_empty R s.

(* star_lang_empty is a middle ground:
  - Does not use existence
  - Allows empty prefixes
*)
Inductive star_lang_empty (R: lang): lang :=
  | mk_star_zero_empty : forall (s: str),
      s = [] -> star_lang_empty R s
  | mk_star_more_empty : forall (s p q: str),
      p ++ q = s ->
      p \in R ->
      q \in (star_lang_empty R) ->
      s \in star_lang_empty R.

(* concat_ex_prefix_not_empty_lang is a helper for star_lang_ex
   It uses existence to define concat and
   the prefix language is not allowed to match the empty string
*)
Inductive concat_ex_prefix_not_empty_lang (P Q: lang): lang :=
  | mk_concat_prefix_is_not_empty: forall (s: str),
    (exists
      (p: str)
      (a: alphabet)
      (q: str)
      (pqs: (a :: p) ++ q = s),
      (a :: p) \in P /\
      q \in Q
    ) ->
    concat_ex_prefix_not_empty_lang P Q s
.

(* star_lang_ex is another middle ground:
  - Uses existence that is hidden in concat_ex_prefix_not_empty_lang
  - Does not allow empty prefixes in mk_star_more, which is also hidden in concat_ex_prefix_not_empty_lang
*)
Inductive star_lang_ex (R: lang): lang :=
  | mk_star_zero_ex : forall (s: str),
      s = [] -> star_lang_ex R s
  | mk_star_more_ex : forall (s: str),
      s \in (concat_ex_prefix_not_empty_lang R (star_lang_ex R)) ->
      star_lang_ex R s.

(* The Propositions below shows how each of the 4 definitions are equivalent to star_lang. *)

Proposition star_lang_empty_equivalent (R: lang):
  star_lang R {<->} star_lang_empty R.
Proof.
  split.
  - intro Hmatch.
    induction Hmatch.
    + subst. now constructor.
    + eapply (mk_star_more_empty R s); try (exact H); try assumption.
  - intro Hmatch.
    induction Hmatch as [| s p q Hp_match Hq_match IH].
    + subst. now constructor.
    + destruct p.
      * (* If the prefix is empty, the induction hypothesis is exactly what we want. *)
        subst.
        cbn.
        assumption.
      * (* Otherwise, we only have to apply the constructor and use the IH. *)
        apply (mk_star_more R s (a :: p) q); try assumption.
        trivial.
        listerine.
Qed.

Local Proposition star_lang_ex_ind_better:
 forall (R : lang) (P : str -> Prop),
   (* base case *)
   P [] ->
   (* induction step *)
   (forall s: str, (exists (p q: str),
                  p ++ q = s /\
                  p <> [] /\
                  p \in R /\
                  q \in star_lang_ex R /\
                  P q) ->
              P s) ->
   (* conclusion *)
   forall s: str, star_lang_ex R s -> P s.
Proof.
intros R P Hbase Hstep s0 Hs_match0.
refine (
    (fix f s (Hs_match: star_lang_ex R s) {struct Hs_match}: P s  :=
       _) s0 Hs_match0
).
destruct Hs_match.
- subst.
  exact Hbase.
- specialize Hstep with s.
  destruct H as [s [p [a [q [Hconcat [Hp_match Hq_match]]]]]].
  pose (f q Hq_match) as IH.
  apply Hstep.
  exists (a :: p).
  exists q.
  repeat split; try assumption.
  listerine.
Qed.

Proposition star_lang_ex_equivalent (R: lang):
    star_lang R {<->} star_lang_ex R.
Proof.
split.
- intro Hmatch.
  induction Hmatch.
  + subst. now constructor.
  + eapply (mk_star_more_ex R s); try (exact H).
    constructor.
    destruct p.
    * contradiction.
    * exists p.
      exists a.
      exists q.
      exists H.
      split; assumption.
- intro Hmatch.
  apply (star_lang_ex_ind_better R (star_lang R)).
  + now constructor.
  + intros.
    destruct H as [p [q [Hconcat [ Hnon_empty [ Hp_match [Hq_match IH]]]]]].
    constructor 2 with (p := p) (q := q); assumption.
  + assumption.
Qed.

Local Proposition star_lang_ex_empty_ind_better:
 forall (R : lang) (P : str -> Prop),
   (* base case *)
   P [] ->
   (* induction step *)
   (forall s: str, (exists (p q: str),
                  p ++ q = s /\
                  p \in R /\
                  q \in star_lang_ex_empty R /\
                  P q) ->
              P s) ->
   (* conclusion *)
   forall s: str, star_lang_ex_empty R s -> P s.
Proof.
intros R P Hbase Hstep s0 Hs_match0.
refine (
    (fix f s (Hs_match: star_lang_ex_empty R s) {struct Hs_match}: P s  :=
       _) s0 Hs_match0
).
destruct Hs_match.
- subst.
  exact Hbase.
- specialize Hstep with s.
  destruct H as [s [p [q [Hconcat [Hp_match Hq_match]]]]].
  pose (f q Hq_match) as IH.
  apply Hstep.
  exists p.
  exists q.
  repeat split; try assumption.
Qed.

Proposition star_lang_ex_empty_equivalent (R: lang):
    star_lang R {<->} star_lang_ex_empty R.
Proof.
  split.
  - intro Hmatch.
    induction Hmatch.
    + subst. now constructor.
    + eapply (mk_star_more_ex_empty R s); try (exact H).
      constructor.
      destruct p.
      * contradiction.
      * exists (a :: p).
        exists q.
        exists H.
        split; assumption.
  - intro Hmatch.
    apply (star_lang_ex_empty_ind_better R (star_lang R)).
    + now constructor.
    + intros.
      destruct H as [p [q [Hconcat [ Hp_match [Hq_match IH]]]]].
      destruct p.
      * subst. cbn. assumption.
      * constructor 2 with (p := (a :: p)) (q := q); try assumption.
        listerine.
    + assumption.
Qed.

Proposition decompose_star_lang (R: lang):
  forall (s: str),
    s \in star_lang R
  <->
  (
    s = []
  \/
    (exists
      (p: str)
      (a: alphabet)
      (q: str)
      (splits: (a :: p) ++ q = s),
      (a :: p) \in R
    /\
      q \in (star_lang R)
    )
  ).
Proof.
intros.
rewrite star_lang_ex_equivalent.
split; intros.
- invs H.
  + auto.
  + right.
    invs H0.
    destruct H as [p [a [q [splits [inr instarr]]]]].
    exists p, a, q, splits.
    rewrite <- star_lang_ex_equivalent in instarr.
    auto.
- invs H.
  + constructor. reflexivity.
  + destruct H0 as [p [a [q [splits [inr instarr]]]]].
    apply mk_star_more_ex.
    constructor.
    exists p, a, q, splits.
    rewrite star_lang_ex_equivalent in instarr.
    auto.
Qed.


Section Stream.

  Context {A : Set}.

  CoInductive stream : Set :=
  | Nil : stream
  | Cons : A -> stream -> stream.

  Definition helper (s : stream) : stream :=
    match s with
    | Nil => Nil
    | Cons h t => Cons h t
    end.

  Lemma helper_eq
        (s : stream) :
        s = helper s.
  Proof. destruct s; reflexivity. Qed.

  CoInductive equal_streams : stream -> stream -> Prop :=
  | eqsNil  :                    equal_streams Nil Nil
  | eqsCons : forall h1 h2 t1 t2 (EQH : h1 = h2)
                                 (EQT : equal_streams t1 t2),
                                 equal_streams (Cons h1 t1) (Cons h2 t2).

  Lemma equal_streams_symmetry
        (s1 s2 : stream)
        (EQS : equal_streams s1 s2) :
        equal_streams s2 s1.
  Proof.
    revert EQS. revert s1 s2.
    cofix CIH. intros. inversion EQS; subst.
    { constructor. }
    { constructor. reflexivity. auto. }
  Qed.

  Inductive in_stream : A -> stream -> Prop :=
  | inHead : forall x t,  in_stream x (Cons x t)
  | inTail : forall x h t (IN : in_stream x t),
                          in_stream x (Cons h t).

  Hint Constructors in_stream.

  Lemma in_equal_streams
        (s1 s2 : stream)
        (EQS : equal_streams s1 s2)
        (x : A)
        (X_IN : in_stream x s1) :
        in_stream x s2.
  Proof.
    revert EQS. revert s2.
    induction X_IN; intros; inversion_clear EQS; subst.
    { constructor. }
    { constructor. eapply IHX_IN. assumption. }
  Qed.

  Inductive finite : stream -> Prop :=
  | fNil  :            finite Nil
  | fCons : forall h t (FIN : finite t),
                       finite (Cons h t).

  Hint Constructors finite.

  CoInductive interleave : stream -> stream -> stream -> Prop :=
  | interNil  : forall s s'     (EQS : equal_streams s s'),
                                interleave Nil s s'
  | interCons : forall h t s rs (INTER : interleave s t rs),
                                interleave (Cons h t) s (Cons h rs).

  Lemma interleave_in_1
        (s1 s2 s : stream)
        (INTER : interleave s1 s2 s)
        (x : A)
        (X_IN : in_stream x s) :
        in_stream x s1 \/ in_stream x s2.
  Proof.
    revert INTER. revert s1 s2. induction X_IN; intros.
    { inversion INTER.
      { right. inversion EQS. subst. constructor. }
      { left. constructor. } }
    { inversion INTER; subst.
      { right. inversion EQS; subst. constructor.
        apply equal_streams_symmetry in EQT.
        eapply in_equal_streams; eauto. }
      { specialize (IHX_IN _ _ INTER0). destruct IHX_IN.
        { auto. }
        { left. constructor. auto. } } }
  Qed.

  Lemma interleave_in_2
        (s1 s2 s : stream)
        (INTER : interleave s1 s2 s)
        (x : A)
        (X_IN_12 : in_stream x s1 \/ in_stream x s2) :
        in_stream x s.
  Proof.
    destruct X_IN_12.
    { revert INTER. revert s2 s. induction H.
      { intros. inversion_clear INTER; subst. constructor. }
      { intros. inversion_clear INTER; subst. constructor.
        inversion_clear INTER0; subst.
        { eapply in_equal_streams; eauto. }
        { constructor. eauto. } } }
    { revert INTER. revert s1 s. induction H.
      { intros. inversion INTER; subst.
        { eapply in_equal_streams; eauto. }
        { constructor. inversion INTER0; subst. auto. } }
      { intros. inversion INTER; subst.
        { eapply in_equal_streams; eauto. }
        { inversion INTER0; subst. constructor. constructor. eapply IHin_stream. eauto. } } }
  Qed.

  Lemma interleave_in
        (s1 s2 s : stream)
        (INTER : interleave s1 s2 s)
        (x : A) :
        in_stream x s <-> in_stream x s1 \/ in_stream x s2.
  Proof.
    intros. split.
    { apply interleave_in_1. auto. }
    { apply interleave_in_2. auto. }
  Qed.

  Lemma equal_streams_finite
        (s1 s2 : stream)
        (EQS : equal_streams s1 s2)
        (FIN_1 : finite s1) :
        finite s2.
  Proof.
    revert EQS. revert s2.
    induction FIN_1; intros; inversion EQS; subst; auto.
  Qed.

  Lemma interleave_finite_1
        (s s1 s2 : stream)
        (INTER : interleave s1 s2 s)
        (FIN : finite s) :
        finite s1 /\ finite s2.
  Proof.
    revert INTER. revert s1 s2. induction FIN.
    { intros. inversion INTER; subst. inversion EQS. auto. }
    { intros. inversion INTER; subst.
      { inversion EQS; subst. split; auto. constructor.
        apply equal_streams_symmetry in EQT. eapply equal_streams_finite; eauto. }
      { apply IHFIN in INTER0. destruct INTER0. auto. } }
  Qed.

  Lemma interleave_finite_2
        (s s1 s2 : stream)
        (INTER : interleave s1 s2 s)
        (FIN_1 : finite s1)
        (FIN_2 : finite s2) :
        finite s.
  Proof.
    revert INTER FIN_2. revert s s2. induction FIN_1.
    { intros. inversion INTER. eapply equal_streams_finite; eauto. }
    { intros. inversion INTER; subst. constructor. inversion INTER0; subst.
      { eapply equal_streams_finite; eauto. }
      { inversion FIN_2; subst. constructor. eapply IHFIN_1; eauto. } }
  Qed.

  Lemma interleave_finite
        (s1 s2 s : stream)
        (INTER : interleave s1 s2 s) :
        finite s <-> finite s1 /\ finite s2.
  Proof.
    intros. split.
    { intro. eapply interleave_finite_1; eauto. }
    { intro. destruct H. eapply interleave_finite_2; eauto. }
  Qed.

End Stream.

Section Test.

  CoFixpoint nats (n : nat) : stream := Cons n (nats (S n)).

  Definition true_false : stream := Cons true (Cons false Nil).

  Lemma true_false_fin : finite true_false.
  Proof.
    repeat constructor.
  Qed.

  Lemma nats_not_fin
        (n : nat) :
        ~ finite (nats n).
  Proof.
    intro C. remember (nats n).
    revert Heqs. revert n.
    induction C.
    { intros. rewrite helper_eq in Heqs. simpl in Heqs. inversion Heqs. }
    { intros. apply IHC with (S n). rewrite helper_eq in Heqs. simpl in Heqs.
      inversion Heqs. reflexivity. }
  Qed.

  Lemma nats_contain_all_nats
        (n : nat) :
        in_stream n (nats 0).
  Proof.
    induction n.
    { rewrite helper_eq. constructor. }
    { remember (nats 0). remember 0. clear Heqn0.
      revert Heqs. revert n0. induction IHn.
      { intros. rewrite helper_eq in Heqs. inversion Heqs.
        constructor. rewrite helper_eq. constructor. }
      { intros. constructor. rewrite helper_eq in Heqs.
        inversion Heqs; subst. eapply IHIHn. reflexivity. } }
  Qed.

End Test.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Local Open Scope string_scope.

Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A :=
  (fun _ => v).

Definition t_update {A} (m : total_map A) (x : string) (v : A) :=
  fun x' => if x =? x' then v else m x'.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Notation "x '!->' v ';' m" := (t_update m x v)
  (at level 100, v at next level, right associativity).

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
    (_ !-> v) x = v.
Proof. intros. reflexivity. Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) (x : string) (v : A),
    (x !-> v ; m) x = v.
Proof. intros. unfold t_update. rewrite eqb_refl. reflexivity. Qed.

Lemma t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
    x1 <> x2 ->
    (x1 !-> v; m) x2 = m x2.
Proof. intros. unfold t_update. destruct (x1 =? x2) eqn:Heqb.
  - apply eqb_eq in Heqb as Heq. apply H in Heq as Hcon. destruct Hcon.
  - reflexivity.
Qed.

Theorem t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
    (x !-> v2; x !-> v1; m) = (x !-> v2; m).
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality.
  intros.
  destruct (x =? x0) eqn:Heqb.
  - reflexivity.
  - reflexivity.
Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
    (x !-> m x; m) = m.
Proof.
  intros.
  apply functional_extensionality.
  intros.
  unfold t_update.
  destruct (x =? x0) eqn:Heqb.
  - apply eqb_eq in Heqb as Heq.
    subst.
    reflexivity.
  - reflexivity.
Qed.

Theorem t_update_permute : forall (A : Type) (m : total_map A) v1 v2 x1 x2,
    x2 <> x1 ->
    (x1 !-> v1; x2 !-> v2; m) = (x2 !-> v2; x1 !-> v1; m).
Proof.
  intros.
  unfold t_update.
  apply functional_extensionality.
  intros.
  destruct (x1 =? x) eqn:Heqb1; destruct (x2 =? x) eqn:Heqb2.
  - apply eqb_eq in Heqb1 as Heq1.
    apply eqb_eq in Heqb2 as Heq2.
    symmetry in Heq1.
    remember (eq_trans Heq2 Heq1).
    clear Heqe.
    apply H in e.
    destruct e.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Definition partial_map (A : Type) := total_map (option A).

Definition empty {A : Type} : partial_map A :=
  t_empty None.

Definition update {A : Type} (m : partial_map A) (x : string) (v : A) :=
  (x !-> Some v; m).

Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (update empty x v)
  (at level 100).

Lemma apply_empty : forall (A : Type) (x : string),
    @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
    (x |-> v ; m) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Lemma update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
    x2 <> x1->
    (x2 |-> v ; m) x1 = m x1.
Proof.
  intros A m x1 x2 v H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H.
Qed.

Theorem update_shadow :  forall (A : Type) (m : partial_map A) x v1 v2,
    (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof.
  intros A m x v1 v2. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
    m x = Some v ->
    (x |-> v ; m) = m.
Proof.
  intros A m x v H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A) x1 x2 v1 v2,
    x2 <> x1 ->
    (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof.
  intros A m x1 x2 v1 v2. unfold update.
  apply t_update_permute.
Qed.

Definition inclusion {A : Type} (m m' : partial_map A) :=
  forall x v, m x = Some v -> m' x = Some v.

Lemma inclusion_update : forall (A : Type) (m m' : partial_map A) (x : string) (vx : A),
    inclusion m m' ->
    inclusion (x |-> vx ; m) (x |-> vx ; m').
Proof.
  unfold inclusion.
  intros A m m' x vx H.
  intros y vy.
  destruct (x =? y) eqn:Heqb.
  - apply eqb_eq in Heqb as Heq.
    rewrite Heq.
    rewrite update_eq. rewrite update_eq. intro H1. apply H1.
  - apply eqb_neq in Heqb as Hneq.
    rewrite update_neq. rewrite update_neq.
    + apply H.
    + apply Hneq.
    + apply Hneq.
Qed.

Lemma inclusion_empty : forall (A : Type) (m : partial_map A),
    inclusion empty m.
Proof.
  intros.
  unfold inclusion.
  intros.
  inversion H.
Qed.

Lemma inclusion_refl : forall (A : Type) (m : partial_map A),
    inclusion m m.
Proof.
  intros.
  unfold inclusion.
  intros.
  assumption.
Qed.


(** Homework Assignment 6#
#
##Interactive Computer Theorem
Proving#
#
CS294-9, Fall 2006#
#
UC Berkeley *)

Require Import Arith Bool List.

Definition var := nat.
Definition lit := (bool * var)%type.

Definition clause := list lit.
Definition formula := list clause.

Definition asgn := var -> bool.

Definition satLit (l : lit) (a : asgn) :=
  a (snd l) = fst l.

Fixpoint satClause (cl : clause) (a : asgn) {struct cl} : Prop :=
  match cl with
    | nil => False
    | l :: cl' => satLit l a \/ satClause cl' a
  end.

Fixpoint satFormula (fm : formula) (a : asgn) {struct fm} : Prop :=
  match fm with
    | nil => True
    | cl :: fm' => satClause cl a /\ satFormula fm' a
  end.

Definition bool_eq_dec : forall (x y : bool), {x = y} + {x <> y}.
  decide equality.
Defined.

Lemma contradictory_assignment : forall s l cl a,
  s <> fst l
  -> satLit l a
  -> satLit (s, snd l) a
  -> satClause cl a.
  intros.
  red in H0, H1.
  simpl in H1.
  subst.
  tauto.
Qed.

Hint Resolve contradictory_assignment.

Definition upd (a : asgn) (l : lit) : asgn :=
  fun v : var =>
    if eq_nat_dec v (snd l)
      then fst l
      else a v.

Lemma satLit_upd_eq : forall l a,
  satLit l (upd a l).
  unfold satLit, upd; simpl; intros.
  destruct (eq_nat_dec (snd l) (snd l)); tauto.
Qed.

Hint Resolve satLit_upd_eq.

Lemma satLit_upd_neq : forall v l s a,
  v <> snd l
  -> satLit (s, v) (upd a l)
  -> satLit (s, v) a.
  unfold satLit, upd; simpl; intros.
  destruct (eq_nat_dec v (snd l)); tauto.
Qed.

Hint Resolve satLit_upd_neq.

Lemma satLit_upd_neq2 : forall v l s a,
  v <> snd l
  -> satLit (s, v) a
  -> satLit (s, v) (upd a l).
  unfold satLit, upd; simpl; intros.
  destruct (eq_nat_dec v (snd l)); tauto.
Qed.

Hint Resolve satLit_upd_neq2.

Lemma satLit_contra : forall s l a cl,
  s <> fst l
  -> satLit (s, snd l) (upd a l)
  -> satClause cl a.
  unfold satLit, upd; simpl; intros.
  destruct (eq_nat_dec (snd l) (snd l)); intuition.
  assert False; intuition.
Qed.

Hint Resolve satLit_contra.

Ltac magic_solver := simpl; intros; subst; intuition eauto; firstorder;
  match goal with
    | [ H1 : satLit ?l ?a, H2 : satClause ?cl ?a |- _ ] =>
      assert (satClause cl (upd a l)); firstorder
  end.

Definition setClause : forall (cl : clause) (l : lit),
  {cl' : clause |
    forall a, satClause cl (upd a l) <-> satClause cl' a}
  + {forall a, satLit l a -> satClause cl a}.
  refine (fix setClause (cl : clause) (l : lit) {struct cl}
    : {cl' : clause |
      forall a, satClause cl (upd a l) <-> satClause cl' a}
    + {forall a, satLit l a -> satClause cl a} :=
    match cl return {cl' : clause |
      forall a, satClause cl (upd a l) <-> satClause cl' a}
    + {forall a, satLit l a -> satClause cl a} with
      | nil => inleft _ (exist _ nil _)
      | (s, v) :: cl' =>
	if eq_nat_dec v (snd l)
	  then if bool_eq_dec s (fst l)
	    then inright _ _
	    else match setClause cl' l with
		   | inleft (exist cl'' _) => inleft _ (exist _ cl'' _)
		   | inright _ => inright _ _
		 end
	  else match setClause cl' l with
		 | inleft (exist cl'' _) => inleft _ (exist _ ((s, v) :: cl'') _)
		 | inright _ => inright _ _
	       end
    end); clear setClause; magic_solver.
Defined.

Definition setClauseSimple (cl : clause) (l : lit) :=
  match setClause cl l with
    | inleft (exist cl' _) => Some cl'
    | inright _ => None
  end.

Eval compute in setClauseSimple nil (true, 0).
Eval compute in setClauseSimple ((true, 0) :: nil) (true, 0).
Eval compute in setClauseSimple ((true, 0) :: nil) (false, 0).
Eval compute in setClauseSimple ((true, 0) :: nil) (true, 1).
Eval compute in setClauseSimple ((true, 0) :: nil) (false, 1).
Eval compute in setClauseSimple ((true, 0) :: (true, 1) :: nil) (true, 1).
Eval compute in setClauseSimple ((true, 0) :: (true, 1) :: nil) (false, 1).
Eval compute in setClauseSimple ((true, 0) :: (false, 1) :: nil) (true, 1).
Eval compute in setClauseSimple ((true, 0) :: (false, 1) :: nil) (false, 1).

Definition isNil : forall (A : Set) (ls : list A), {ls = nil} + {True}.
  destruct ls; eauto.
Defined.
Implicit Arguments isNil [A].

Lemma satLit_idem_lit : forall l a l',
  satLit l a
  -> satLit l' a
  -> satLit l' (upd a l).
  unfold satLit, upd; simpl; intros.
  destruct (eq_nat_dec (snd l') (snd l)); congruence.
Qed.

Hint Resolve satLit_idem_lit.

Lemma satLit_idem_clause : forall l a cl,
  satLit l a
  -> satClause cl a
  -> satClause cl (upd a l).
  induction cl; simpl; intuition.
Qed.

Hint Resolve satLit_idem_clause.

Lemma satLit_idem_formula : forall l a fm,
  satLit l a
  -> satFormula fm a
  -> satFormula fm (upd a l).
  induction fm; simpl; intuition.
Qed.

Hint Resolve satLit_idem_formula.

Definition setFormula : forall (fm : formula) (l : lit),
  {fm' : formula |
    forall a, satFormula fm (upd a l) <-> satFormula fm' a}
  + {forall a, satLit l a -> ~satFormula fm a}.
  refine (fix setFormula (fm : formula) (l : lit) {struct fm}
    : {fm' : formula |
      forall a, satFormula fm (upd a l) <-> satFormula fm' a}
    + {forall a, satLit l a -> ~satFormula fm a} :=
    match fm return {fm' : formula |
      forall a, satFormula fm (upd a l) <-> satFormula fm' a}
    + {forall a, satLit l a -> ~satFormula fm a} with
      | nil => inleft _ (exist _ nil _)
      | cl :: fm' =>
	match setClause cl l with
	  | inleft (exist cl' _) =>
	    if isNil cl'
	      then inright _ _
	      else match setFormula fm' l with
		     | inleft (exist fm'' _) => inleft _ (exist _ (cl' :: fm'') _)
		     | inright _ => inright _ _
		   end
	  | inright _ =>
	    match setFormula fm' l with
	      | inleft (exist fm'' _) => inleft _ (exist _ fm'' _)
	      | inright _ => inright _ _
	    end
	end
    end); clear setFormula; magic_solver.
Defined.

Definition setFormulaSimple (fm : formula) (l : lit) :=
  match setFormula fm l with
    | inleft (exist fm' _) => Some fm'
    | inright _ => None
  end.

Eval compute in setFormulaSimple nil (true, 0).
Eval compute in setFormulaSimple (((true, 0) :: nil) :: nil) (true, 0).
Eval compute in setFormulaSimple (((false, 0) :: nil) :: nil) (true, 0).
Eval compute in setFormulaSimple (((false, 1) :: nil) :: nil) (true, 0).
Eval compute in setFormulaSimple (((false, 1) :: (true, 0) :: nil) :: nil) (true, 0).
Eval compute in setFormulaSimple (((false, 1) :: (false, 0) :: nil) :: nil) (true, 0).

Hint Extern 1 False => discriminate.

Hint Extern 1 False =>
  match goal with
    | [ H : In _ (_ :: _) |- _ ] => inversion H; clear H; subst
  end.

Definition findUnitClause : forall (fm : formula),
  {l : lit | In (l :: nil) fm}
  + {forall l, ~In (l :: nil) fm}.
  refine (fix findUnitClause (fm : formula)
    : {l : lit | In (l :: nil) fm}
    + {forall l, ~In (l :: nil) fm} :=
    match fm return {l : lit | In (l :: nil) fm}
      + {forall l, ~In (l :: nil) fm} with
      | nil => inright _ _
      | (l :: nil) :: _ => inleft _ (exist _ l _)
      | _ :: fm' =>
	match findUnitClause fm' with
	  | inleft (exist l _) => inleft _ (exist _ l _)
	  | inright _ => inright _ _
	end
    end); clear findUnitClause; magic_solver.
Defined.

Lemma unitClauseTrue : forall l a fm,
  In (l :: nil) fm
  -> satFormula fm a
  -> satLit l a.
  induction fm; intuition.
  inversion H.
  inversion H; subst; simpl in H0; intuition.
Qed.

Hint Resolve unitClauseTrue.

Definition unitPropagate : forall (fm : formula), option (sigS (fun fm' : formula =>
  {l : lit |
    (forall a, satFormula fm a -> satLit l a)
    /\ forall a, satFormula fm (upd a l) <-> satFormula fm' a})
+ {forall a, ~satFormula fm a}).
  intro fm.
  refine (match findUnitClause fm with
	    | inleft (exist l _) =>
	      match setFormula fm l with
		| inleft (exist fm' _) =>
		  Some (inleft _ (existS (fun fm' : formula =>
		    {l : lit |
		      (forall a, satFormula fm a -> satLit l a)
		      /\ forall a, satFormula fm (upd a l) <-> satFormula fm' a})
		  fm' (exist _ l _)))
		| inright _ => Some (inright _ _)
	      end
	    | inright _ => None
	  end); magic_solver.
Defined.

Definition unitPropagateSimple (fm : formula) :=
  match unitPropagate fm with
    | None => None
    | Some (inleft (existS fm' (exist l _))) => Some (Some (fm', l))
    | Some (inright _) => Some None
  end.

Eval compute in unitPropagateSimple nil.
Eval compute in unitPropagateSimple (((true, 0) :: nil) :: nil).
Eval compute in unitPropagateSimple (((true, 0) :: nil) :: ((false, 0) :: nil) :: nil).
Eval compute in unitPropagateSimple (((true, 0) :: nil) :: ((false, 1) :: nil) :: nil).
Eval compute in unitPropagateSimple (((true, 0) :: nil) :: ((false, 0) :: (false, 1) :: nil) :: nil).
Eval compute in unitPropagateSimple (((false, 0) :: (false, 1) :: nil) :: ((true, 0) :: nil) :: nil).

Definition chooseSplit (fm : formula) :=
  match fm with
    | ((l :: _) :: _) => l
    | _ => (true, 0)
  end.

Definition negate (l : lit) := (negb (fst l), snd l).

Hint Unfold satFormula.

Lemma satLit_dec : forall l a,
  {satLit l a} + {satLit (negate l) a}.
  destruct l.
  unfold satLit; simpl; intro.
  destruct b; destruct (a v); simpl; auto.
Qed.

Definition alist := list lit.

Fixpoint interp_alist (al : alist) : asgn :=
  match al with
    | nil => fun _ => true
    | l :: al' => upd (interp_alist al') l
  end.

Definition boundedSat (bound : nat) (fm : formula)
  : option ({al : alist | satFormula fm (interp_alist al)}
    + {forall a, ~satFormula fm a}).
  refine (fix boundedSat (bound : nat) (fm : formula) {struct bound}
    : option ({al : alist | satFormula fm (interp_alist al)}
      + {forall a, ~satFormula fm a}) :=
    match bound with
      | O => None
      | S bound' =>
	if isNil fm
	  then Some (inleft _ (exist _ nil _))
	  else match unitPropagate fm with
		 | Some (inleft (existS fm' (exist l _))) =>
		   match boundedSat bound' fm' with
		     | None => None
		     | Some (inleft (exist al _)) => Some (inleft _ (exist _ (l :: al) _))
		     | Some (inright _) => Some (inright _ _)
		   end
		 | Some (inright _) => Some (inright _ _)
		 | None =>
		   let l := chooseSplit fm in
		     match setFormula fm l with
		       | inleft (exist fm' _) =>
			 match boundedSat bound' fm' with
			   | None => None
			   | Some (inleft (exist al _)) => Some (inleft _ (exist _ (l :: al) _))
			   | Some (inright _) =>
			     match setFormula fm (negate l) with
			       | inleft (exist fm' _) =>
				 match boundedSat bound' fm' with
				   | None => None
				   | Some (inleft (exist al _)) => Some (inleft _ (exist _ (negate l :: al) _))
				   | Some (inright _) => Some (inright _ _)
				 end
			       | inright _ => Some (inright _ _)
			     end
			 end
		       | inright _ =>
			 match setFormula fm (negate l) with
			   | inleft (exist fm' _) =>
			     match boundedSat bound' fm' with
			       | None => None
			       | Some (inleft (exist al _)) => Some (inleft _ (exist _ (negate l :: al) _))
			       | Some (inright _) => Some (inright _ _)
			     end
			   | inright _ => Some (inright _ _)
			 end
		     end
	       end
    end); simpl; intros; subst; intuition; try generalize dependent (interp_alist al).
  firstorder.
  firstorder.
  firstorder.
  firstorder.
  assert (satFormula fm (upd a0 l)); firstorder.
  assert (satFormula fm (upd a0 l)); firstorder.
  firstorder.
  firstorder.
  firstorder.
  firstorder.
  firstorder.
  firstorder.
  firstorder.
  firstorder.
  firstorder.
  firstorder.
  destruct (satLit_dec l a);
    [assert (satFormula fm (upd a l))
      | assert (satFormula fm (upd a (negate l)))]; firstorder.
  destruct (satLit_dec l a);
    [assert (satFormula fm (upd a l))
      | assert (satFormula fm (upd a (negate l)))]; firstorder.
  destruct (satLit_dec l a);
    [assert (satFormula fm (upd a l))
      | assert (satFormula fm (upd a (negate l)))]; firstorder.
  destruct (satLit_dec l a);
    [assert (satFormula fm (upd a l))
      | assert (satFormula fm (upd a (negate l)))]; firstorder.
  destruct (satLit_dec l a); intuition eauto;
    assert (satFormula fm (upd a l)); firstorder.
  destruct (satLit_dec l a); intuition eauto;
    assert (satFormula fm (upd a l)); firstorder.
  firstorder.
  firstorder.
  destruct (satLit_dec l a); intuition eauto;
    assert (satFormula fm (upd a (negate l))); firstorder.
  destruct (satLit_dec l a); intuition eauto;
    assert (satFormula fm (upd a (negate l))); firstorder.
  destruct (satLit_dec l a);
    [assert (satFormula fm (upd a l))
      | assert (satFormula fm (upd a (negate l)))]; firstorder.
Defined.

Definition boundedSatSimple (bound : nat) (fm : formula) :=
  match boundedSat bound fm with
    | None => None
    | Some (inleft (exist a _)) => Some (Some a)
    | Some (inright _) => Some None
  end.

Eval compute in boundedSatSimple 100 nil.
Eval compute in boundedSatSimple 100 (((true, 0) :: nil) :: nil).
Eval compute in boundedSatSimple 100 (((true, 0) :: nil) :: ((false, 0) :: nil) :: nil).
Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((true, 1) :: nil) :: nil).
Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((true, 1) :: (false, 0) :: nil) :: nil).
Eval compute in boundedSatSimple 100 (((true, 0) :: (false, 1) :: nil) :: ((false, 0) :: (false, 0) :: nil) :: ((true, 1) :: nil) :: nil).
Eval compute in boundedSatSimple 100 (((false, 0) :: (true, 1) :: nil) :: ((false, 1) :: (true, 0) :: nil) :: nil).

Recursive Extraction boundedSat.


Require Import BaseLists.

(**** Filter *)

Section Filter.
  Variable X : Type.
  Implicit Types (x y: X) (A B C: list X) (p q: X -> bool).

  Fixpoint filter p A : list X :=
    match A with
    | nil => nil
    | x::A' => if p x then x :: filter p A' else filter p A'
    end.

  Lemma in_filter_iff x p A :
    x el filter p A <-> x el A /\ p x.
  Proof.
    induction A as [|y A]; cbn.
    - tauto.
    - destruct (p y) eqn:E; cbn;
      rewrite IHA; intuition; subst; auto.
  Qed.

  Lemma filter_incl p A :
    filter p A <<= A.
  Proof.
    intros x D. apply in_filter_iff in D. apply D.
  Qed.

  Lemma filter_mono p A B :
    A <<= B -> filter p A <<= filter p B.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_id p A :
    (forall x, x el A -> p x) -> filter p A = A.
  Proof.
    intros D.
    induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:E.
      + f_equal; auto.
      + exfalso. apply bool_Prop_false in E. auto.
  Qed.

  Lemma filter_app p A B :
    filter p (A ++ B) = filter p A ++ filter p B.
  Proof.
    induction A as [|y A]; cbn.
    - reflexivity.
    - rewrite IHA. destruct (p y); reflexivity.
  Qed.

  Lemma filter_fst p x A :
    p x -> filter p (x::A) = x::filter p A.
  Proof.
    cbn. destruct (p x); auto.
  Qed.

  Lemma filter_fst' p x A :
    ~ p x -> filter p (x::A) = filter p A.
  Proof.
    cbn. destruct (p x); auto.
  Qed.

  Lemma filter_pq_mono p q A :
    (forall x, x el A -> p x -> q x) -> filter p A <<= filter q A.
  Proof.
    intros D x E. apply in_filter_iff in E as [E E'].
    apply in_filter_iff. auto.
  Qed.

  Lemma filter_pq_eq p q A :
    (forall x, x el A -> p x = q x) -> filter p A = filter q A.
  Proof.
    intros C; induction A as [|x A]; cbn.
    - reflexivity.
    - destruct (p x) eqn:D, (q x) eqn:E.
      + f_equal. auto.
      + exfalso. enough (p x = q x) by congruence. auto.
      + exfalso. enough (p x = q x) by congruence. auto.
      + auto.
  Qed.

  Lemma filter_and p q A :
    filter p (filter q A) = filter (fun x => p x && q x) A.
  Proof.
    induction A as [|x A]; cbn. reflexivity.
    destruct (p x) eqn:E, (q x); cbn;
      try rewrite E; now rewrite IHA.
  Qed.

  Lemma filter_comm p q A :
    filter p (filter q A) = filter q (filter p A).
  Proof.
    rewrite !filter_and. apply filter_pq_eq.
    intros x _. now destruct (p x), (q x).
  Qed.

End Filter.


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

Require Import Rbase.
Require Import Rfunctions.
Require Import Ranalysis1.
Require Import Rtopology.
Local Open Scope R_scope.

(* The Mean Value Theorem *)
Theorem MVT :
  forall (f g:R -> R) (a b:R) (pr1:forall c:R, a < c < b -> derivable_pt f c)
    (pr2:forall c:R, a < c < b -> derivable_pt g c),
    a < b ->
    (forall c:R, a <= c <= b -> continuity_pt f c) ->
    (forall c:R, a <= c <= b -> continuity_pt g c) ->
    exists c : R,
      (exists P : a < c < b,
        (g b - g a) * derive_pt f c (pr1 c P) =
        (f b - f a) * derive_pt g c (pr2 c P)).
Proof.
  intros; assert (H2 := Rlt_le _ _ H).
  set (h := fun y:R => (g b - g a) * f y - (f b - f a) * g y).
  cut (forall c:R, a < c < b -> derivable_pt h c).
  intro X; cut (forall c:R, a <= c <= b -> continuity_pt h c).
  intro; assert (H4 := continuity_ab_maj h a b H2 H3).
  assert (H5 := continuity_ab_min h a b H2 H3).
  elim H4; intros Mx H6.
  elim H5; intros mx H7.
  cut (h a = h b).
  intro; set (M := h Mx); set (m := h mx).
  cut
    (forall (c:R) (P:a < c < b),
      derive_pt h c (X c P) =
      (g b - g a) * derive_pt f c (pr1 c P) -
      (f b - f a) * derive_pt g c (pr2 c P)).
  intro; case (Req_dec (h a) M); intro.
  case (Req_dec (h a) m); intro.
  cut (forall c:R, a <= c <= b -> h c = M).
  intro; cut (a < (a + b) / 2 < b).
(*** h constant ***)
  intro; exists ((a + b) / 2).
  exists H13.
  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_constant2 with a b.
  elim H13; intros; assumption.
  elim H13; intros; assumption.
  intros; rewrite (H12 ((a + b) / 2)).
  apply H12; split; left; assumption.
  elim H13; intros; split; left; assumption.
  split.
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite double; apply Rplus_lt_compat_l; apply H.
  discrR.
  apply Rmult_lt_reg_l with 2.
  prove_sup0.
  unfold Rdiv; rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc;
    rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite Rplus_comm; rewrite double;
    apply Rplus_lt_compat_l; apply H.
  discrR.
  intros; elim H6; intros H13 _.
  elim H7; intros H14 _.
  apply Rle_antisym.
  apply H13; apply H12.
  rewrite H10 in H11; rewrite H11; apply H14; apply H12.
  cut (a < mx < b).
(*** h admet un minimum global sur [a,b] ***)
  intro; exists mx.
  exists H12.
  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_minimum with a b.
  elim H12; intros; assumption.
  elim H12; intros; assumption.
  intros; elim H7; intros.
  apply H15; split; left; assumption.
  elim H7; intros _ H12; elim H12; intros; split.
  inversion H13.
  apply H15.
  rewrite H15 in H11; elim H11; reflexivity.
  inversion H14.
  apply H15.
  rewrite H8 in H11; rewrite <- H15 in H11; elim H11; reflexivity.
  cut (a < Mx < b).
(*** h admet un maximum global sur [a,b] ***)
  intro; exists Mx.
  exists H11.
  apply Rminus_diag_uniq; rewrite <- H9; apply deriv_maximum with a b.
  elim H11; intros; assumption.
  elim H11; intros; assumption.
  intros; elim H6; intros; apply H14.
  split; left; assumption.
  elim H6; intros _ H11; elim H11; intros; split.
  inversion H12.
  apply H14.
  rewrite H14 in H10; elim H10; reflexivity.
  inversion H13.
  apply H14.
  rewrite H8 in H10; rewrite <- H14 in H10; elim H10; reflexivity.
  intros; unfold h;
    replace
    (derive_pt (fun y:R => (g b - g a) * f y - (f b - f a) * g y) c (X c P))
    with
      (derive_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F) c
        (derivable_pt_minus _ _ _
          (derivable_pt_mult _ _ _ (derivable_pt_const (g b - g a) c) (pr1 c P))
          (derivable_pt_mult _ _ _ (derivable_pt_const (f b - f a) c) (pr2 c P))));
      [ idtac | apply pr_nu ].
  rewrite derive_pt_minus; do 2 rewrite derive_pt_mult;
    do 2 rewrite derive_pt_const; do 2 rewrite Rmult_0_l;
      do 2 rewrite Rplus_0_l; reflexivity.
  unfold h; ring.
  intros; unfold h;
    change
      (continuity_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
        c).
  apply continuity_pt_minus; apply continuity_pt_mult.
  apply derivable_continuous_pt; apply derivable_const.
  apply H0; apply H3.
  apply derivable_continuous_pt; apply derivable_const.
  apply H1; apply H3.
  intros;
    change
      (derivable_pt ((fct_cte (g b - g a) * f)%F - (fct_cte (f b - f a) * g)%F)
        c).
  apply derivable_pt_minus; apply derivable_pt_mult.
  apply derivable_pt_const.
  apply (pr1 _ H3).
  apply derivable_pt_const.
  apply (pr2 _ H3).
Qed.

(* Corollaries ... *)
Lemma MVT_cor1 :
  forall (f:R -> R) (a b:R) (pr:derivable f),
    a < b ->
    exists c : R, f b - f a = derive_pt f c (pr c) * (b - a) /\ a < c < b.
Proof.
  intros f a b pr H; cut (forall c:R, a < c < b -> derivable_pt f c);
    [ intro X | intros; apply pr ].
  cut (forall c:R, a < c < b -> derivable_pt id c);
    [ intro X0 | intros; apply derivable_pt_id ].
  cut (forall c:R, a <= c <= b -> continuity_pt f c);
    [ intro | intros; apply derivable_continuous_pt; apply pr ].
  cut (forall c:R, a <= c <= b -> continuity_pt id c);
    [ intro | intros; apply derivable_continuous_pt; apply derivable_id ].
  assert (H2 := MVT f id a b X X0 H H0 H1).
  destruct H2 as (c & P & H4).
  exists c; split.
  cut (derive_pt id c (X0 c P) = derive_pt id c (derivable_pt_id c));
    [ intro H5 | apply pr_nu ].
  rewrite H5 in H4; rewrite (derive_pt_id c) in H4; rewrite Rmult_1_r in H4;
    rewrite <- H4; replace (derive_pt f c (X c P)) with (derive_pt f c (pr c));
      [ idtac | apply pr_nu ]; apply Rmult_comm.
  apply P.
Qed.

Theorem MVT_cor2 :
  forall (f f':R -> R) (a b:R),
    a < b ->
    (forall c:R, a <= c <= b -> derivable_pt_lim f c (f' c)) ->
    exists c : R, f b - f a = f' c * (b - a) /\ a < c < b.
Proof.
  intros f f' a b H H0; cut (forall c:R, a <= c <= b -> derivable_pt f c).
  intro X; cut (forall c:R, a < c < b -> derivable_pt f c).
  intro X0; cut (forall c:R, a <= c <= b -> continuity_pt f c).
  intro; cut (forall c:R, a <= c <= b -> derivable_pt id c).
  intro X1; cut (forall c:R, a < c < b -> derivable_pt id c).
  intro X2; cut (forall c:R, a <= c <= b -> continuity_pt id c).
  intro; elim (MVT f id a b X0 X2 H H1 H2); intros x (P,H3).
  exists x; split.
  cut (derive_pt id x (X2 x P) = 1).
  cut (derive_pt f x (X0 x P) = f' x).
  intros; rewrite H4 in H3; rewrite H5 in H3; unfold id in H3;
    rewrite Rmult_1_r in H3; rewrite Rmult_comm; symmetry ;
      assumption.
  apply derive_pt_eq_0; apply H0; elim P; intros; split; left; assumption.
  apply derive_pt_eq_0; apply derivable_pt_lim_id.
  assumption.
  intros; apply derivable_continuous_pt; apply X1; assumption.
  intros; apply derivable_pt_id.
  intros; apply derivable_pt_id.
  intros; apply derivable_continuous_pt; apply X; assumption.
  intros; elim H1; intros; apply X; split; left; assumption.
  intros; unfold derivable_pt; exists (f' c); apply H0;
    apply H1.
Qed.

Lemma MVT_cor3 :
  forall (f f':R -> R) (a b:R),
    a < b ->
    (forall x:R, a <= x -> x <= b -> derivable_pt_lim f x (f' x)) ->
    exists c : R, a <= c /\ c <= b /\ f b = f a + f' c * (b - a).
Proof.
  intros f f' a b H H0;
    assert (H1 :  exists c : R, f b - f a = f' c * (b - a) /\ a < c < b);
      [ apply MVT_cor2; [ apply H | intros; elim H1; intros; apply (H0 _ H2 H3) ]
        | elim H1; intros; exists x; elim H2; intros; elim H4; intros; split;
          [ left; assumption | split; [ left; assumption | rewrite <- H3; ring ] ] ].
Qed.

Lemma Rolle :
  forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
    (forall x:R, a <= x <= b -> continuity_pt f x) ->
    a < b ->
    f a = f b ->
    exists c : R, (exists P : a < c < b, derive_pt f c (pr c P) = 0).
Proof.
  intros; assert (H2 : forall x:R, a < x < b -> derivable_pt id x).
  intros; apply derivable_pt_id.
  assert (H3 := MVT f id a b pr H2 H0 H);
    assert (H4 : forall x:R, a <= x <= b -> continuity_pt id x).
  intros; apply derivable_continuous; apply derivable_id.
  destruct (H3 H4) as (c & P & H6). exists c; exists P; rewrite H1 in H6.
  unfold id in H6; unfold Rminus in H6; rewrite Rplus_opp_r in H6.
  rewrite Rmult_0_l in H6; apply Rmult_eq_reg_l with (b - a);
    [ rewrite Rmult_0_r; apply H6
      | apply Rminus_eq_contra; red; intro H7; rewrite H7 in H0;
        elim (Rlt_irrefl _ H0) ].
Qed.

(**********)
Lemma nonneg_derivative_1 :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, 0 <= derive_pt f x (pr x)) -> increasing f.
Proof.
  intros.
  unfold increasing.
  intros.
  destruct (total_order_T x y) as [[H1| ->]|H1].
  apply Rplus_le_reg_l with (- f x).
  rewrite Rplus_opp_l; rewrite Rplus_comm.
  pose proof (MVT_cor1 f _ _ pr H1) as (c & H3 & H4).
  unfold Rminus in H3.
  rewrite H3.
  apply Rmult_le_pos.
  apply H.
  apply Rplus_le_reg_l with x.
  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
  right; reflexivity.
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H0 H1)).
Qed.

(**********)
Lemma nonpos_derivative_0 :
  forall (f:R -> R) (pr:derivable f),
    decreasing f -> forall x:R, derive_pt f x (pr x) <= 0.
Proof.
  intros f pr H x; assert (H0 := H); unfold decreasing in H0;
    generalize (derivable_derive f x (pr x)); intro; elim H1;
      intros l H2.
  rewrite H2; case (Rtotal_order l 0); intro.
  left; assumption.
  elim H3; intro.
  right; assumption.
  generalize (derive_pt_eq_1 f x l (pr x) H2); intros; cut (0 < l / 2).
  intro; elim (H5 (l / 2) H6); intros delta H7;
    cut (delta / 2 <> 0 /\ 0 < delta / 2 /\ Rabs (delta / 2) < delta).
  intro; decompose [and] H8; intros; generalize (H7 (delta / 2) H9 H12);
    cut ((f (x + delta / 2) - f x) / (delta / 2) <= 0).
  intro; cut (0 < - ((f (x + delta / 2) - f x) / (delta / 2) - l)).
  intro; unfold Rabs;
    case (Rcase_abs ((f (x + delta / 2) - f x) / (delta / 2) - l)) as [Hlt|Hge].
  intros;
    generalize
      (Rplus_lt_compat_r (- l) (- ((f (x + delta / 2) - f x) / (delta / 2) - l))
        (l / 2) H14); unfold Rminus.
  replace (l / 2 + - l) with (- (l / 2)).
  replace (- ((f (x + delta / 2) + - f x) / (delta / 2) + - l) + - l) with
  (- ((f (x + delta / 2) + - f x) / (delta / 2))).
  intro.
  generalize
    (Ropp_lt_gt_contravar (- ((f (x + delta / 2) + - f x) / (delta / 2)))
      (- (l / 2)) H15).
  repeat rewrite Ropp_involutive.
  intro.
  generalize
    (Rlt_trans 0 (l / 2) ((f (x + delta / 2) - f x) / (delta / 2)) H6 H16);
    intro.
  elim
    (Rlt_irrefl 0
      (Rlt_le_trans 0 ((f (x + delta / 2) - f x) / (delta / 2)) 0 H17 H10)).
  ring.
  pattern l at 3; rewrite double_var.
  ring.
  intros.
  generalize
    (Ropp_ge_le_contravar ((f (x + delta / 2) - f x) / (delta / 2) - l) _ Hge).
  rewrite Ropp_0.
  intro.
  elim
    (Rlt_irrefl 0
      (Rlt_le_trans 0 (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) 0 H13
        H15)).
  replace (- ((f (x + delta / 2) - f x) / (delta / 2) - l)) with
  ((f x - f (x + delta / 2)) / (delta / 2) + l).
  unfold Rminus.
  apply Rplus_le_lt_0_compat.
  unfold Rdiv; apply Rmult_le_pos.
  cut (x <= x + delta * / 2).
  intro; generalize (H0 x (x + delta * / 2) H13); intro;
    generalize
      (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H14);
      rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
  pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
    left; assumption.
  left; apply Rinv_0_lt_compat; assumption.
  assumption.
  rewrite Ropp_minus_distr.
  unfold Rminus.
  rewrite (Rplus_comm l).
  unfold Rdiv.
  rewrite <- Ropp_mult_distr_l_reverse.
  rewrite Ropp_plus_distr.
  rewrite Ropp_involutive.
  rewrite (Rplus_comm (f x)).
  reflexivity.
  replace ((f (x + delta / 2) - f x) / (delta / 2)) with
  (- ((f x - f (x + delta / 2)) / (delta / 2))).
  rewrite <- Ropp_0.
  apply Ropp_ge_le_contravar.
  apply Rle_ge.
  unfold Rdiv; apply Rmult_le_pos.
  cut (x <= x + delta * / 2).
  intro; generalize (H0 x (x + delta * / 2) H10); intro.
  generalize
    (Rplus_le_compat_l (- f (x + delta / 2)) (f (x + delta / 2)) (f x) H13);
    rewrite Rplus_opp_l; rewrite Rplus_comm; intro; assumption.
  pattern x at 1; rewrite <- (Rplus_0_r x); apply Rplus_le_compat_l;
    left; assumption.
  left; apply Rinv_0_lt_compat; assumption.
  unfold Rdiv; rewrite <- Ropp_mult_distr_l_reverse.
  rewrite Ropp_minus_distr.
  reflexivity.
  split.
  unfold Rdiv; apply prod_neq_R0.
  generalize (cond_pos delta); intro; red; intro H9; rewrite H9 in H8;
    elim (Rlt_irrefl 0 H8).
  apply Rinv_neq_0_compat; discrR.
  split.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ apply (cond_pos delta) | apply Rinv_0_lt_compat; prove_sup0 ].
  rewrite Rabs_right.
  unfold Rdiv; apply Rmult_lt_reg_l with 2.
  prove_sup0.
  rewrite <- (Rmult_comm (/ 2)); rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite double; pattern (pos delta) at 1;
    rewrite <- Rplus_0_r.
  apply Rplus_lt_compat_l; apply (cond_pos delta).
  discrR.
  apply Rle_ge; unfold Rdiv; left; apply Rmult_lt_0_compat.
  apply (cond_pos delta).
  apply Rinv_0_lt_compat; prove_sup0.
  unfold Rdiv; apply Rmult_lt_0_compat;
    [ apply H4 | apply Rinv_0_lt_compat; prove_sup0 ].
Qed.

(**********)
Lemma increasing_decreasing_opp :
  forall f:R -> R, increasing f -> decreasing (- f)%F.
Proof.
  unfold increasing, decreasing, opp_fct; intros; generalize (H x y H0);
    intro; apply Ropp_ge_le_contravar; apply Rle_ge; assumption.
Qed.

(**********)
Lemma nonpos_derivative_1 :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, derive_pt f x (pr x) <= 0) -> decreasing f.
Proof.
  intros.
  cut (forall h:R, - - f h = f h).
  intro.
  generalize (increasing_decreasing_opp (- f)%F).
  unfold decreasing.
  unfold opp_fct.
  intros.
  rewrite <- (H0 x); rewrite <- (H0 y).
  apply H1.
  cut (forall x:R, 0 <= derive_pt (- f) x (derivable_opp f pr x)).
  intros.
  replace (fun x:R => - f x) with (- f)%F; [ idtac | reflexivity ].
  apply (nonneg_derivative_1 (- f)%F (derivable_opp f pr) H3).
  intro.
  assert (H3 := derive_pt_opp f x0 (pr x0)).
  cut
    (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
      derive_pt (- f) x0 (derivable_opp f pr x0)).
  intro.
  rewrite <- H4.
  rewrite H3.
  rewrite <- Ropp_0; apply Ropp_ge_le_contravar; apply Rle_ge; apply (H x0).
  apply pr_nu.
  assumption.
  intro; ring.
Qed.

(**********)
Lemma positive_derivative :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, 0 < derive_pt f x (pr x)) -> strict_increasing f.
Proof.
  intros.
  unfold strict_increasing.
  intros.
  apply Rplus_lt_reg_l with (- f x).
  rewrite Rplus_opp_l; rewrite Rplus_comm.
  assert (H1 := MVT_cor1 f _ _ pr H0).
  elim H1; intros.
  elim H2; intros.
  unfold Rminus in H3.
  rewrite H3.
  apply Rmult_lt_0_compat.
  apply H.
  apply Rplus_lt_reg_l with x.
  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
Qed.

(**********)
Lemma strictincreasing_strictdecreasing_opp :
  forall f:R -> R, strict_increasing f -> strict_decreasing (- f)%F.
Proof.
  unfold strict_increasing, strict_decreasing, opp_fct; intros;
    generalize (H x y H0); intro; apply Ropp_lt_gt_contravar;
      assumption.
Qed.

(**********)
Lemma negative_derivative :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, derive_pt f x (pr x) < 0) -> strict_decreasing f.
Proof.
  intros.
  cut (forall h:R, - - f h = f h).
  intros.
  generalize (strictincreasing_strictdecreasing_opp (- f)%F).
  unfold strict_decreasing, opp_fct.
  intros.
  rewrite <- (H0 x).
  rewrite <- (H0 y).
  apply H1; [ idtac | assumption ].
  cut (forall x:R, 0 < derive_pt (- f) x (derivable_opp f pr x)).
  intros; eapply positive_derivative; apply H3.
  intro.
  assert (H3 := derive_pt_opp f x0 (pr x0)).
  cut
    (derive_pt (- f) x0 (derivable_pt_opp f x0 (pr x0)) =
      derive_pt (- f) x0 (derivable_opp f pr x0)).
  intro.
  rewrite <- H4; rewrite H3.
  rewrite <- Ropp_0; apply Ropp_lt_gt_contravar; apply (H x0).
  apply pr_nu.
  intro; ring.
Qed.

(**********)
Lemma null_derivative_0 :
  forall (f:R -> R) (pr:derivable f),
    constant f -> forall x:R, derive_pt f x (pr x) = 0.
Proof.
  intros.
  unfold constant in H.
  apply derive_pt_eq_0.
  intros; exists (mkposreal 1 Rlt_0_1); simpl; intros.
  rewrite (H x (x + h)); unfold Rminus; unfold Rdiv;
    rewrite Rplus_opp_r; rewrite Rmult_0_l; rewrite Rplus_opp_r;
      rewrite Rabs_R0; assumption.
Qed.

(**********)
Lemma increasing_decreasing :
  forall f:R -> R, increasing f -> decreasing f -> constant f.
Proof.
  unfold increasing, decreasing, constant; intros;
    case (Rtotal_order x y); intro.
  generalize (Rlt_le x y H1); intro;
    apply (Rle_antisym (f x) (f y) (H x y H2) (H0 x y H2)).
  elim H1; intro.
  rewrite H2; reflexivity.
  generalize (Rlt_le y x H2); intro; symmetry ;
    apply (Rle_antisym (f y) (f x) (H y x H3) (H0 y x H3)).
Qed.

(**********)
Lemma null_derivative_1 :
  forall (f:R -> R) (pr:derivable f),
    (forall x:R, derive_pt f x (pr x) = 0) -> constant f.
Proof.
  intros.
  cut (forall x:R, derive_pt f x (pr x) <= 0).
  cut (forall x:R, 0 <= derive_pt f x (pr x)).
  intros.
  assert (H2 := nonneg_derivative_1 f pr H0).
  assert (H3 := nonpos_derivative_1 f pr H1).
  apply increasing_decreasing; assumption.
  intro; right; symmetry ; apply (H x).
  intro; right; apply (H x).
Qed.

(**********)
Lemma derive_increasing_interv_ax :
  forall (a b:R) (f:R -> R) (pr:derivable f),
    a < b ->
    ((forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) ->
      forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y) /\
    ((forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) ->
      forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y).
Proof.
  intros.
  split; intros.
  apply Rplus_lt_reg_l with (- f x).
  rewrite Rplus_opp_l; rewrite Rplus_comm.
  assert (H4 := MVT_cor1 f _ _ pr H3).
  elim H4; intros.
  elim H5; intros.
  unfold Rminus in H6.
  rewrite H6.
  apply Rmult_lt_0_compat.
  apply H0.
  elim H7; intros.
  split.
  elim H1; intros.
  apply Rle_lt_trans with x; assumption.
  elim H2; intros.
  apply Rlt_le_trans with y; assumption.
  apply Rplus_lt_reg_l with x.
  rewrite Rplus_0_r; replace (x + (y + - x)) with y; [ assumption | ring ].
  apply Rplus_le_reg_l with (- f x).
  rewrite Rplus_opp_l; rewrite Rplus_comm.
  assert (H4 := MVT_cor1 f _ _ pr H3).
  elim H4; intros.
  elim H5; intros.
  unfold Rminus in H6.
  rewrite H6.
  apply Rmult_le_pos.
  apply H0.
  elim H7; intros.
  split.
  elim H1; intros.
  apply Rle_lt_trans with x; assumption.
  elim H2; intros.
  apply Rlt_le_trans with y; assumption.
  apply Rplus_le_reg_l with x.
  rewrite Rplus_0_r; replace (x + (y + - x)) with y;
    [ left; assumption | ring ].
Qed.

(**********)
Lemma derive_increasing_interv :
  forall (a b:R) (f:R -> R) (pr:derivable f),
    a < b ->
    (forall t:R, a < t < b -> 0 < derive_pt f t (pr t)) ->
    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x < f y.
Proof.
  intros.
  generalize (derive_increasing_interv_ax a b f pr H); intro.
  elim H4; intros H5 _; apply (H5 H0 x y H1 H2 H3).
Qed.

(**********)
Lemma derive_increasing_interv_var :
  forall (a b:R) (f:R -> R) (pr:derivable f),
    a < b ->
    (forall t:R, a < t < b -> 0 <= derive_pt f t (pr t)) ->
    forall x y:R, a <= x <= b -> a <= y <= b -> x < y -> f x <= f y.
Proof.
  intros a b f pr H H0 x y H1 H2 H3;
    generalize (derive_increasing_interv_ax a b f pr H);
      intro; elim H4; intros _ H5; apply (H5 H0 x y H1 H2 H3).
Qed.

(**********)
(**********)
Theorem IAF :
  forall (f:R -> R) (a b k:R) (pr:derivable f),
    a <= b ->
    (forall c:R, a <= c <= b -> derive_pt f c (pr c) <= k) ->
    f b - f a <= k * (b - a).
Proof.
  intros.
  destruct (total_order_T a b) as [[H1| -> ]|H1].
  pose proof (MVT_cor1 f _ _ pr H1) as (c & -> & H4).
  do 2 rewrite <- (Rmult_comm (b - a)).
  apply Rmult_le_compat_l.
  apply Rplus_le_reg_l with a; rewrite Rplus_0_r.
  replace (a + (b - a)) with b; [ assumption | ring ].
  apply H0.
  elim H4; intros.
  split; left; assumption.
  unfold Rminus; do 2 rewrite Rplus_opp_r.
  rewrite Rmult_0_r; right; reflexivity.
  elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H H1)).
Qed.

Lemma IAF_var :
  forall (f g:R -> R) (a b:R) (pr1:derivable f) (pr2:derivable g),
    a <= b ->
    (forall c:R, a <= c <= b -> derive_pt g c (pr2 c) <= derive_pt f c (pr1 c)) ->
    g b - g a <= f b - f a.
Proof.
  intros.
  cut (derivable (g - f)).
  intro X.
  cut (forall c:R, a <= c <= b -> derive_pt (g - f) c (X c) <= 0).
  intro.
  assert (H2 := IAF (g - f)%F a b 0 X H H1).
  rewrite Rmult_0_l in H2; unfold minus_fct in H2.
  apply Rplus_le_reg_l with (- f b + f a).
  replace (- f b + f a + (f b - f a)) with 0; [ idtac | ring ].
  replace (- f b + f a + (g b - g a)) with (g b - f b - (g a - f a));
  [ apply H2 | ring ].
  intros.
  cut
    (derive_pt (g - f) c (X c) =
      derive_pt (g - f) c (derivable_pt_minus _ _ _ (pr2 c) (pr1 c))).
  intro.
  rewrite H2.
  rewrite derive_pt_minus.
  apply Rplus_le_reg_l with (derive_pt f c (pr1 c)).
  rewrite Rplus_0_r.
  replace
  (derive_pt f c (pr1 c) + (derive_pt g c (pr2 c) - derive_pt f c (pr1 c)))
    with (derive_pt g c (pr2 c)); [ idtac | ring ].
  apply H0; assumption.
  apply pr_nu.
  apply derivable_minus; assumption.
Qed.

(* If f has a null derivative in ]a,b[ and is continue in [a,b], *)
(* then f is constant on [a,b] *)
Lemma null_derivative_loc :
  forall (f:R -> R) (a b:R) (pr:forall x:R, a < x < b -> derivable_pt f x),
    (forall x:R, a <= x <= b -> continuity_pt f x) ->
    (forall (x:R) (P:a < x < b), derive_pt f x (pr x P) = 0) ->
    constant_D_eq f (fun x:R => a <= x <= b) (f a).
Proof.
  intros; unfold constant_D_eq; intros; destruct (total_order_T a b) as [[Hlt|Heq]|Hgt].
  assert (H2 : forall y:R, a < y < x -> derivable_pt id y).
  intros; apply derivable_pt_id.
  assert (H3 : forall y:R, a <= y <= x -> continuity_pt id y).
  intros; apply derivable_continuous; apply derivable_id.
  assert (H4 : forall y:R, a < y < x -> derivable_pt f y).
  intros; apply pr; elim H4; intros; split.
  assumption.
  elim H1; intros; apply Rlt_le_trans with x; assumption.
  assert (H5 : forall y:R, a <= y <= x -> continuity_pt f y).
  intros; apply H; elim H5; intros; split.
  assumption.
  elim H1; intros; apply Rle_trans with x; assumption.
  elim H1; clear H1; intros; elim H1; clear H1; intro.
  assert (H7 := MVT f id a x H4 H2 H1 H5 H3).
  destruct H7 as (c & P & H9).
  assert (H10 : a < c < b).
  split.
  apply P.
  apply Rlt_le_trans with x; [apply P|assumption].
  assert (H11 : derive_pt f c (H4 c P) = 0).
  replace (derive_pt f c (H4 c P)) with (derive_pt f c (pr c H10));
  [ apply H0 | apply pr_nu ].
  assert (H12 : derive_pt id c (H2 c P) = 1).
  apply derive_pt_eq_0; apply derivable_pt_lim_id.
  rewrite H11 in H9; rewrite H12 in H9; rewrite Rmult_0_r in H9;
    rewrite Rmult_1_r in H9; apply Rminus_diag_uniq; symmetry ;
      assumption.
  rewrite H1; reflexivity.
  assert (H2 : x = a).
  rewrite <- Heq in H1; elim H1; intros; apply Rle_antisym; assumption.
  rewrite H2; reflexivity.
  elim H1; intros;
    elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ (Rle_trans _ _ _ H2 H3) Hgt)).
Qed.

(* Unicity of the antiderivative *)
Lemma antiderivative_Ucte :
  forall (f g1 g2:R -> R) (a b:R),
    antiderivative f g1 a b ->
    antiderivative f g2 a b ->
    exists c : R, (forall x:R, a <= x <= b -> g1 x = g2 x + c).
Proof.
  unfold antiderivative; intros; elim H; clear H; intros; elim H0;
    clear H0; intros H0 _; exists (g1 a - g2 a); intros;
      assert (H3 : forall x:R, a <= x <= b -> derivable_pt g1 x).
  intros; unfold derivable_pt; exists (f x0); elim (H x0 H3);
    intros; eapply derive_pt_eq_1; symmetry ;
      apply H4.
  assert (H4 : forall x:R, a <= x <= b -> derivable_pt g2 x).
  intros; unfold derivable_pt; exists (f x0);
    elim (H0 x0 H4); intros; eapply derive_pt_eq_1; symmetry ;
      apply H5.
  assert (H5 : forall x:R, a < x < b -> derivable_pt (g1 - g2) x).
  intros; elim H5; intros; apply derivable_pt_minus;
    [ apply H3; split; left; assumption | apply H4; split; left; assumption ].
  assert (H6 : forall x:R, a <= x <= b -> continuity_pt (g1 - g2) x).
  intros; apply derivable_continuous_pt; apply derivable_pt_minus;
    [ apply H3 | apply H4 ]; assumption.
  assert (H7 : forall (x:R) (P:a < x < b), derive_pt (g1 - g2) x (H5 x P) = 0).
  intros; elim P; intros; apply derive_pt_eq_0; replace 0 with (f x0 - f x0);
    [ idtac | ring ].
  assert (H9 : a <= x0 <= b).
  split; left; assumption.
  apply derivable_pt_lim_minus; [ elim (H _ H9) | elim (H0 _ H9) ]; intros;
    eapply derive_pt_eq_1; symmetry ; apply H10.
  assert (H8 := null_derivative_loc (g1 - g2)%F a b H5 H6 H7);
    unfold constant_D_eq in H8; assert (H9 := H8 _ H2);
      unfold minus_fct in H9; rewrite <- H9; ring.
Qed.

(* A variant of MVT using absolute values. *)
Lemma MVT_abs :
  forall (f f' : R -> R) (a b : R),
  (forall c : R, Rmin a b <= c <= Rmax a b ->
      derivable_pt_lim f c (f' c)) ->
  exists c : R, Rabs (f b - f a) = Rabs (f' c) * Rabs (b - a) /\
             Rmin a b <= c <= Rmax a b.
Proof.
intros f f' a b.
destruct (Rle_dec a b) as [aleb | blta].
 destruct (Req_dec a b) as [ab | anb].
  unfold Rminus; intros _; exists a; split.
   now rewrite <- ab, !Rplus_opp_r, Rabs_R0, Rmult_0_r.
  split;[apply Rmin_l | apply Rmax_l].
 rewrite Rmax_right, Rmin_left; auto; intros derv.
 destruct (MVT_cor2 f f' a b) as [c [hc intc]];
  [destruct aleb;[assumption | contradiction] | apply derv | ].
 exists c; rewrite hc, Rabs_mult;split;
  [reflexivity | unfold Rle; tauto].
assert (b < a) by (apply Rnot_le_gt; assumption).
assert (b <= a) by (apply Rlt_le; assumption).
rewrite Rmax_left, Rmin_right; try assumption; intros derv.
destruct (MVT_cor2 f f' b a) as [c [hc intc]];
 [assumption | apply derv | ].
exists c; rewrite <- Rabs_Ropp, Ropp_minus_distr, hc, Rabs_mult.
split;[now rewrite <- (Rabs_Ropp (b - a)), Ropp_minus_distr| unfold Rle; tauto].
Qed.


From solutions Require Export language.

(** * Syntactic types for HeapLang *)
(** The inductive type [ty] defines the syntactic types for HeapLang. We make
use of De Bruijn indices to model type-level binding. *)
Inductive ty :=
  | TVar : nat → ty
  | TUnit : ty
  | TBool : ty
  | TInt : ty
  | TProd : ty → ty → ty
  | TSum : ty → ty → ty
  | TArr : ty → ty → ty
  | TForall : ty → ty
  | TExist : ty → ty
  | TRef : ty → ty
  | TRec : ty → ty.

(** To obtain nice notations when writing types for concrete programs, we define
some Coq notations for types. These notations are put in the notation scope
[ty_scope]. We use the [Bind Scope] command to instruct Coq to parse terms of
type [ty] using the notations in [type_scope]. When the type is not clear from
the context, one can write [τ%ty] to force Coq to parse [τ] using the notations
in [type_scope]. This is set up using the [Delimit Scope] command. *)
Declare Scope ty_scope.
Bind Scope ty_scope with ty.
Delimit Scope ty_scope with ty.
Notation "# x" := (TVar x) : ty_scope.
Notation "()" := TUnit : ty_scope.
Infix "*" := TProd : ty_scope.
Infix "+" := TSum : ty_scope.
Infix "→" := TArr : ty_scope.
Notation "∀: τ" := (TForall τ) (at level 100, τ at level 200) : ty_scope.
Notation "∃: τ" := (TExist τ) (at level 100, τ at level 200) : ty_scope.
Notation "'ref' τ" := (TRef τ) (at level 10, τ at next level, right associativity): ty_scope.
Notation "μ: τ" := (TExist τ) (at level 100, τ at level 200) : ty_scope.

(** * Type-level substitution *)
(** Below we define the function [ty_subst x σ τ], which replaces the De Bruijn
index [x] in the type [τ] by the type [σ]. The definition is standard, and makes
use of the lifting function [ty_lift]. *)
Fixpoint ty_lift (n : nat) (τ : ty) : ty :=
  match τ with
  | TVar y => TVar (if decide (y < n) then y else S y)%nat
  | TUnit => TUnit
  | TBool => TBool
  | TInt => TInt
  | TProd τ1 τ2 => TProd (ty_lift n τ1) (ty_lift n τ2)
  | TSum τ1 τ2 => TSum (ty_lift n τ1) (ty_lift n τ2)
  | TArr τ1 τ2 => TArr (ty_lift n τ1) (ty_lift n τ2)
  | TForall τ => TForall (ty_lift (S n) τ)
  | TExist τ => TExist (ty_lift (S n) τ)
  | TRef τ => TRef (ty_lift n τ)
  | TRec τ => TRec (ty_lift (S n) τ)
  end.

Fixpoint ty_subst (x : nat) (σ : ty) (τ : ty) : ty :=
  match τ with
  | TVar y => if decide (y < x) then TVar y
              else if decide (y = x) then σ else TVar (pred y)
  | TUnit => TUnit
  | TBool => TBool
  | TInt => TInt
  | TProd τ1 τ2 => TProd (ty_subst x σ τ1) (ty_subst x σ τ2)
  | TSum τ1 τ2 => TSum (ty_subst x σ τ1) (ty_subst x σ τ2)
  | TArr τ1 τ2 => TArr (ty_subst x σ τ1) (ty_subst x σ τ2)
  | TForall τ => TForall (ty_subst (S x) (ty_lift 0 σ) τ)
  | TExist τ => TExist (ty_subst (S x) (ty_lift 0 σ) τ)
  | TRef τ => TRef (ty_subst x σ τ)
  | TRec τ => TRec (ty_subst (S x) (ty_lift 0 σ) τ)
  end.


From mathcomp Require Import ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import class_set.
Require Import direct_product_theories.
Require Import correspondence.

Definition FunctionOfMap (U:Type) := U -> U.

Definition Mapping {U:Type} (f:Ensemble (Ensemble (Ensemble U))) (A B: Ensemble U) :=
  f ⊂ A × B /\ forall (x:U), x ∈ A -> exists! y:U, (|x, y|) ∈ f.

Definition MappingWithFunction {U:Type} (f:Ensemble (Ensemble (Ensemble U))) (F:FunctionOfMap U) (A B: Ensemble U) :=
  f = (GraphOfBinaryRelation (fun (x y:U) => y = F x) A B) /\ forall (x:U), x ∈ A -> exists y:U, (|x, y|) ∈ f.

Definition Injection {U:Type} (f:Ensemble (Ensemble (Ensemble U))) :=
  forall (x x' y :U), (|x,y|) ∈ f /\ (|x',y|) ∈ f -> x = x'.

Definition Surjection {U:Type} (f:Ensemble (Ensemble (Ensemble U))) (R:Ensemble U) :=
  forall (y:U), y ∈ R -> exists x:U, (|x,y|) ∈ f.

Definition Bijection {U:Type} (f:Ensemble (Ensemble (Ensemble U))) (R:Ensemble U) :=
  Injection f /\ Surjection f R.

Definition IdentityMapping {U:Type} (f: Ensemble (Ensemble (Ensemble U))) (A: Ensemble U) :=
  MappingWithFunction f (fun x => x) A A.

(* ≔ : Unicode 2254 (COLON EQUAL) *)
(* ⊦ : Unicode 22A6 (ASSERTION) *)
(* ⟼: Unicode:27FC (LONG RIGHTWARDS ARROW FROM BAR) *)

Notation "f ≔ F ⊦ A ⟼ B" := (MappingWithFunction f F A B) (at level 43).

Inductive SetOfAllFunction {U:Type} (A B:Ensemble U) : Ensemble (Ensemble (Ensemble (Ensemble U))) :=
| Definition_of_SetOfAllFunction: forall (f:Ensemble (Ensemble (Ensemble U))), Mapping f A B -> f ∈ SetOfAllFunction A B.

Section FunctionDefinition.

  Variable U:Type.
  Variable F: FunctionOfMap U.
  Variable X Y:Ensemble U.

  (*confirming that MappingWithFunction is satisified with Mapping *)
  Goal forall (f:Ensemble (Ensemble (Ensemble U))),
      f ≔ F ⊦ X ⟼ Y -> Mapping f X Y.
  Proof.
    move => f [Hf HfS].
    split.
    +apply (graph_is_included_in_direct_product Hf).
     move => x Hx.
     move: (HfS x).
     case.
     apply Hx.
     move => y H.
     exists y.
     split.
     apply H.
    +move => y' H'.
     rewrite Hf in H.
     rewrite Hf in H'.
     inversion H.
     inversion H1.
     apply ordered_pair_iff in H0.
     inversion H0.
     inversion H'.
     inversion H7.
     apply ordered_pair_iff in H6.
     inversion H6.
     rewrite H5 in H2.
     rewrite H4 in H2.
     rewrite H11 in H8.
     rewrite H10 in H8.
     rewrite H2 H8.
     reflexivity.
  Qed.

  (*confirming that left-total and uniqueness *)
  Goal forall (f:Ensemble (Ensemble (Ensemble U))),
      (f ≔ F ⊦ X ⟼ Y) -> forall (x:U), x ∈ 𝕯( f ) -> exists! y, {|y|} = f '' {|x|}.
  Proof.
    move => f [Hf HfS] x HxDf.
    inversion HxDf.
    inversion H.
    inversion H1 as [y].
    exists y.
    split.
    apply /Extensionality_Ensembles.
    split => y' H4.
    +apply singleton_eq_iff in H4.
     rewrite H4.
     split.
     exists x.
     split.
     done.
     apply H3.
    +inversion H4 as [y2 [x2 []]].
     rewrite Hf in H6.
     inversion H6 as [x3 y3 []].
     rewrite Hf in H3.
     inversion H3 as [x3' y3' []].
     apply singleton_eq_iff in H5.
     apply ordered_pair_iff in H10.
     inversion H10.
     apply ordered_pair_iff in H13.
     inversion H13.
     rewrite H14 in H8.
     rewrite H5 in H8.
     rewrite H15 in H8.
     rewrite H17 in H11.
     rewrite H16 in H11.
     rewrite H8 H11.
     done.
     -move => y' H4.
      apply Extension in H4.
      inversion H4.
      rewrite -singleton_eq_iff.
      apply (H6 y).
      split.
      --exists x.
        split.
        done.
      --done.
  Qed.

  (* confirming left-total *)
  Goal forall (f:Ensemble (Ensemble (Ensemble U))),
      (f ≔ F ⊦ X ⟼ Y) -> 𝕯( f ) = X.
  Proof.
    move => f [Hf HfS].
    apply /Extensionality_Ensembles.
    -split => x H.
     inversion H as [x0 [x0' [y0']]].
     rewrite Hf in H0.
     inversion H0 as [x1 y1 []].
     rewrite H4 in H3.
     apply ordered_pair_in_direct_product_iff_and in H3.
     inversion H3.
     done.
    -split.
     split.
     move: H.
     apply (HfS x).
  Qed.

  Theorem function_of_mapping_iff_singleton_image:
    forall (f:Ensemble (Ensemble (Ensemble U))) (x y:U),
      x ∈ X /\ y ∈ Y /\ (f ≔ F ⊦ X ⟼ Y) -> {|y|} = f '' {|x|} <-> y = F x.
  Proof.
    move => f x y [HX [HY [Hf HfS]]].
    rewrite /iff.
    split => H.
    apply Extension in H.
    inversion H as [H0 H1].
    move: (H0 y).
    case.
    done.
    move => y' H2.
    inversion H2 as [x' []].
    rewrite Hf in H4.
    inversion H4 as [x0 y0 []].
    apply ordered_pair_iff in H7.
    inversion H7.
    apply singleton_eq_iff in H3.
    rewrite -H3.
    rewrite H8 H9 in H5.
    done.
    apply /Extensionality_Ensembles.
    split => y' H0.
    split.
    exists x.
    split.
    done.
    rewrite Hf.
    split.
    apply singleton_eq_iff in H0.
    rewrite H0.
    split.
    done.
    apply ordered_pair_in_direct_product_iff_and.
    done.
    rewrite Hf in H0.
    inversion H0 as [y0 [x0 []]].
    inversion H2.
    apply singleton_eq_iff in H1.
    inversion H5.
    apply ordered_pair_iff in H4.
    inversion H4.
    rewrite H8 in H6.
    rewrite -H1 in H.
    rewrite H9 in H6.
    rewrite -H in H6.
    apply singleton_eq_iff.
    done.
  Qed.

End FunctionDefinition.

Require Export class_set.
Require Export direct_product_theories.
Require Export correspondence.