Set Implicit Arguments.

Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import LibTactics.

Require Import Program.
Require Import List.
Require Import SimpleTypes.
Require Import Occurs.
Require Import Subst.
Require Import Omega.

Section hoare_state_monad.

Variable st : Set.

Definition Pre : Type := st -> Prop.

Definition Post (a : Type) : Type := st -> a -> st -> Prop.

Program Definition HoareState  (B : Set) (pre : Pre) (a : Type) (post : Post a) : Type :=
  forall i : sig (fun t : st => pre t), sig (fun anonymous : sum (prod a st) B =>
                                       match anonymous with
                                       | inl (x, f) => post (proj1_sig i) x f
                                       | inr _ => True
                                       end).

Definition top : Pre := fun st => True.

Program Definition ret {B : Set} (a : Type) : forall x,
    @HoareState B top a (fun i y f => i = f /\ y = x) := fun x s => exist _ (inl (x, s)) _.

Program Definition bind : forall a b P1 P2 Q1 Q2 B,
    (@HoareState B P1 a Q1) -> (forall (x : a), @HoareState B (P2 x) b (Q2 x)) ->
    @HoareState B (fun s1 => P1 s1 /\ forall x s2, Q1 s1 x s2 -> P2 x s2)
                b
                (fun s1 y s3 => exists x, exists s2, Q1 s1 x s2 /\ Q2 x s2 y s3) :=
  fun B a b P1 P2 Q1 Q2 c1 c2 s1 => match c1 s1 as y with
                                 | inl (x, s2) => c2 x s2
                                 | inr R => _
                                 end.
Next Obligation.
  eapply p.
  cbv in Heq_y.
  destruct c1.
  destruct x0.
  - simpl in y.
    destruct p0.
    inversion Heq_y.
    subst.
    auto.
  - simpl in y.
    inversion Heq_y.
Defined.
Next Obligation.
  destruct (c2 x).
  destruct x0.
  cbv in Heq_y.
  simpl in *.
  destruct p0.
  exists x s2.
  split;
    auto.
  destruct c1.
  destruct x0.
  destruct p0.
  simpl in *.
  inversion Heq_y.
  subst.
  auto.
  inversion Heq_y.
  simpl in *.
  auto.
Defined.
Next Obligation.
  simpl in *.
  inversion Heq_y.
  exists (@inr (a * st) Q2 R).
  auto.
Defined.

Program Definition failT {B : Set} (b : B) (A : Type) : @HoareState B top A (fun _ _ _ => True) := fun s => exist _ (inr b) _.

Program Definition get' {B : Set} : @HoareState B top st (fun i x f => i = f /\ x = i) := fun s => exist _ (inl (s, s)) _.

Program Definition put' {B : Set} (x : st) : @HoareState B top unit (fun _ _ f => f = x) := fun  _ => exist _ (inl (tt, x)) _.

End hoare_state_monad.

Infix ">>=" := bind (right associativity, at level 71).

Notation "x <- m ; p" := (m >>= fun x => p)
    (at level 68, right associativity,
     format "'[' x  <-  '[' m ']' ; '//' '[' p ']' ']'").

(** * Failures of W *)

Inductive UnifyFailure : ty -> ty -> Set :=
| occ_fail  : forall v t, occurs v t -> UnifyFailure (var v) t
| occ_fail'  : forall v t, occurs v t -> UnifyFailure t (var v)
| diff_cons : forall n n', n <> n' -> UnifyFailure (con n) (con n')
| con_arrow   : forall n l r, UnifyFailure (con n) (arrow l r)
| arrow_con   : forall n l r, UnifyFailure (arrow l r) (con n)
| arrow_left  : forall l l' r r', UnifyFailure l l' -> UnifyFailure (arrow l r) (arrow l' r')
| arrow_right  : forall l l' r r' s, UnifyFailure (apply_subst s r) (apply_subst s r') ->
                                UnifyFailure (arrow l r) (arrow l' r') .

Hint Constructors UnifyFailure:core.

Inductive SubstFailure : Set :=
| substFail : SubstFailure.

Hint Constructors SubstFailure:core.

Inductive MissingVar : id ->  Set :=
| missingVar : forall i, MissingVar i.

Hint Constructors MissingVar:core.

Inductive InferFailure : Set :=
| SubstFailure' : SubstFailure -> InferFailure
| UnifyFailure' : forall t1 t2, UnifyFailure t1 t2 -> InferFailure
| MissingVar' : forall i, MissingVar i -> InferFailure.

Hint Constructors InferFailure:core.

Unset Implicit Arguments.

(** * Instance of Hoare Exception-Sate Monad *)
Definition Infer := @HoareState id InferFailure.
Definition get := @get' id InferFailure.
Definition put := @put' id InferFailure.


(* begin hide *)
From Coq Require Import
     Arith.PeanoNat
     Logic.FunctionalExtensionality
     Lists.List
     Lia.

From Heapster2 Require Import
     Utils.

Import ListNotations.
(* end hide *)

(** * Memory model *)
(** ** Addresses *)
(** We use a block-offset address model. *)
Definition addr : Set := nat * nat.

(** Equality on addresses. *)
Definition eqb (a b : addr) : bool :=
  Nat.eqb (fst a) (fst b) && Nat.eqb (snd a) (snd b).

Lemma eqb_spec : forall x y, Bool.reflect (x = y) (eqb x y).
Proof.
  intros [x1 x2] [y1 y2]. destruct (eqb (x1, x2) (y1, y2)) eqn:?; constructor.
  - unfold eqb in Heqb. simpl in Heqb. symmetry in Heqb. apply Bool.andb_true_eq in Heqb.
    destruct Heqb. symmetry in H, H0.
    apply (Bool.reflect_iff _ _ (Nat.eqb_spec _ _)) in H.
    apply (Bool.reflect_iff _ _ (Nat.eqb_spec _ _)) in H0. subst. auto.
  - unfold eqb in Heqb. simpl in Heqb. apply Bool.andb_false_iff in Heqb.
    destruct Heqb.
    + intro. inversion H0. subst. rewrite Nat.eqb_refl in H. inversion H.
    + intro. inversion H0. subst. rewrite Nat.eqb_refl in H. inversion H.
Qed.

Lemma addr_dec : forall (a b : addr), {a = b} + {a <> b}.
Proof.
  intros [a1 a2] [b1 b2].
  destruct (Nat.eq_dec a1 b1); destruct (Nat.eq_dec a2 b2); subst; auto.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
Qed.

Lemma addr_neq_cases (b b' o o' : nat) :
  (b, o) <> (b', o') -> b <> b' \/ o <> o'.
Proof.
  intros.
  destruct (Nat.eq_dec b b'); destruct (Nat.eq_dec o o'); subst; auto.
Qed.

(** ** Memory definition *)
Inductive Value :=
| VNum : nat -> Value
| VPtr : addr -> Value.

Definition mem_block := nat -> option Value.

Variant logical_block :=
| LBlock (size : nat) (bytes : mem_block) : logical_block.

Definition memory := list (option logical_block).

(** ** Memory operations *)
(** Whether the block of [ptr] is allocated and is the offset of [ptr] within bounds. *)
Definition allocated (m : memory) (ptr : addr) : bool :=
  match nth_error m (fst ptr) with
  | Some (Some (LBlock size _)) => snd ptr <? size
  | _ => false
  end.

(** Read [m] at memory location [ptr]. [ptr] must be a valid location and allocated. *)
Definition read (m : memory) (ptr : addr) : option Value :=
  if allocated m ptr
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock _ bytes)) => bytes (snd ptr)
       | _ => None
       end
  else None.

(** Returns the size of the block only if [ptr] has offset 0. *)
(** Note if we used [allocated] here then it doesn't work for size 0 blocks. *)
Definition sizeof (m : memory) (ptr : addr) : option nat :=
  if snd ptr =? 0
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock size _)) => Some size
       | _ => None
       end
  else None.

(** Write [v] into [m] at address [ptr]. *)
Definition write (m : memory) (ptr : addr) (v : Value) : option memory :=
  if allocated m ptr
  then match nth_error m (fst ptr) with
       | Some (Some (LBlock size bytes)) =>
         Some (replace_list_index
                 m
                 (fst ptr)
                 (Some (LBlock size (fun o => if o =? snd ptr
                                           then Some v
                                           else bytes o))))
       | _ => None
       end
  else None.

(** Properties about memory operations *)
Lemma allocated_ptr_block m b o :
  allocated m (b, o) = true ->
  b < length m.
Proof.
  unfold allocated. simpl. intros.
  apply nth_error_Some. intro. rewrite H0 in H. inversion H.
Qed.

Lemma allocated_ptr_offset m b o size bytes :
  allocated m (b, o) = true ->
  nth_error m b = Some (Some (LBlock size bytes)) ->
  o < size.
Proof.
  unfold allocated. simpl. intros. rewrite H0 in H.
  rewrite <- (Bool.reflect_iff _ _ (Nat.ltb_spec0 _ _)) in H. auto.
Qed.

Lemma read_success_write m ptr v v' :
  read m ptr = Some v ->
  exists m', write m ptr v' = Some m'.
Proof.
  unfold read, write. intros.
  destruct (allocated m ptr), (nth_error m (fst ptr));
    try destruct o; try solve [inversion H].
  destruct l. eexists. reflexivity.
Qed.

Lemma write_success_read_eq m m' ptr v :
  write m ptr v = Some m' ->
  read m' ptr = Some v.
Proof.
  unfold read, write. intros.
  destruct (allocated m ptr) eqn:?, (nth_error m (fst ptr)) eqn:?;
           try destruct o; try solve [inversion H].
  destruct l. inversion H. clear H H1 m'. unfold allocated in *.
  rewrite nth_error_replace_list_index_eq.
  rewrite Heqo in Heqb. clear Heqo. rewrite Heqb. rewrite Nat.eqb_refl; auto.
Qed.

Lemma write_success_read_neq m m' ptr v :
  write m ptr v = Some m' ->
  forall ptr', ptr <> ptr' -> read m ptr' = read m' ptr'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H. destruct ptr' as [b' o']. simpl.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  destruct (addr_neq_cases _ _ _ _ H0).
  - unfold allocated. simpl. erewrite nth_error_replace_list_index_neq; eauto.
  - destruct (Nat.eq_dec b b').
    + subst. unfold allocated. simpl. rewrite nth_error_replace_list_index_eq; auto.
      rewrite Heqo0. destruct (o' <? size) eqn:?; auto.
      rewrite <- Nat.eqb_neq in H1. rewrite Nat.eqb_sym. rewrite H1. auto.
    + unfold allocated. simpl. erewrite nth_error_replace_list_index_neq; eauto.
Qed.

Lemma write_success_sizeof m m' ptr v :
  write m ptr v = Some m' ->
  forall ptr', sizeof m ptr' = sizeof m' ptr'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H. destruct ptr' as [b' o']. simpl.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  unfold sizeof. simpl. destruct (o' =? 0) eqn:?; auto.
  destruct (Nat.eq_dec b b').
  - subst. simpl. rewrite nth_error_replace_list_index_eq; auto.
    rewrite Heqo0. auto.
  - erewrite nth_error_replace_list_index_neq; eauto.
Qed.

Lemma write_success_length m m' ptr v :
  write m ptr v = Some m' ->
  length m = length m'.
Proof.
  destruct ptr as [b o].
  unfold write. unfold read. simpl. intros.
  destruct (allocated m (b, o)) eqn:?; try solve [inversion H].
  destruct (nth_error m b) eqn:?; try solve [inversion H].
  destruct o0 eqn:?; try solve [inversion H].
  destruct l. inversion H; subst; clear H.
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  simpl. apply replace_list_index_length; auto.
Qed.

(** ** Helper definitions *)
(** [mem_at ptr v] creates a memory which is only defined at location [ptr]. *)
(** We use this for some sanity checks when we define memory permissions. *)
Definition mem_at (ptr : addr) (v : Value) : memory :=
  repeat None (fst ptr) ++ [Some (LBlock
                                    (snd ptr + 1)
                                    (fun o => if o =? snd ptr
                                           then Some v
                                           else None))].

(** Properties about [mem_at]. *)
Lemma allocated_mem_at ptr v : allocated (mem_at ptr v) ptr = true.
  destruct ptr as [b o]. unfold allocated, mem_at. simpl.
  induction b; simpl; auto. apply Nat.ltb_lt. lia.
Qed.

Lemma nth_error_mem_at ptr v :
  nth_error (mem_at ptr v) (fst ptr) =
  Some (Some (LBlock
                (snd ptr + 1)
                (fun o => if o =? snd ptr
                       then Some v
                       else None))).
Proof.
  destruct ptr as [b o]. simpl. induction b; auto.
Qed.

Lemma read_mem_at ptr v : read (mem_at ptr v) ptr = Some v.
Proof.
  destruct ptr as [b o]. unfold read.
  rewrite allocated_mem_at. rewrite nth_error_mem_at.
  rewrite Nat.eqb_refl. reflexivity.
Qed.

Lemma write_mem_at ptr v v' : write (mem_at ptr v) ptr v' = Some (mem_at ptr v').
Proof.
  destruct ptr as [b o]. unfold write.
  rewrite allocated_mem_at. rewrite nth_error_mem_at. f_equal.
  unfold mem_at. simpl.
  induction b; simpl; try solve [f_equal; auto].
  do 3 f_equal. apply functional_extensionality. intros.
  destruct (x =? o); auto.
Qed.

(** [replace_n] is used later for proving the [Free] rule. *)
Definition replace_n m b size bytes n : memory :=
  replace_list_index
    m b (Some (LBlock size (fun o => if andb (o <? size) (size - n <=? o)
                                  then None else bytes o))).

(** Properties of [replace_n]. *)
Lemma replace_n_0 m b size bytes :
  nth_error m b = Some (Some (LBlock size bytes)) ->
  replace_n m b size bytes 0 = m.
Proof.
  unfold replace_n. intros. f_equal.
  assert (b < length m).
  { apply nth_error_Some. intro. rewrite H in H0. inversion H0. }
  revert H H0. revert b.
  induction m; intros; simpl in *; try lia; auto.
  destruct b; f_equal; [| apply IHm; auto; lia].
  inversion H. rewrite Nat.sub_0_r.
  do 2 f_equal. apply functional_extensionality. intros.
  rewrite Nat.ltb_antisym. rewrite Bool.andb_negb_l. reflexivity.
Qed.

Lemma replace_n_same m b size bytes :
  replace_list_index m b (Some (LBlock (S size) (fun o : nat => if o <? S size then None else bytes o))) =
  replace_n m b (S size) bytes (S size).
Proof.
  unfold replace_n. do 4 f_equal. apply functional_extensionality. intros.
  rewrite Nat.sub_diag. simpl. rewrite Bool.andb_true_r. reflexivity.
Qed.

Lemma read_replace_n_neq ptr' n b len m bytes :
    b <> fst ptr' ->
    b < length m ->
    read m ptr' = read (replace_n m b len bytes n) ptr'.
Proof.
  unfold replace_n, read. intros Hneq Hlt.
  destruct (allocated m ptr') eqn:?.
  2: { unfold allocated in *.
       erewrite <- nth_error_replace_list_index_neq; eauto. rewrite Heqb0; auto. }
  pose proof (allocated_ptr_block _ _ _ Heqb0).
  unfold allocated in *. simpl.
  rewrite <- nth_error_replace_list_index_neq; eauto. rewrite Heqb0; auto.
Qed.

Lemma sizeof_replace_n ptr b m n size bytes :
  nth_error m b = Some (Some (LBlock size bytes)) ->
  b < length m ->
  sizeof m ptr = sizeof (replace_n m b size bytes n) ptr.
Proof.
  simpl. intros Hb Hlt. unfold replace_n, sizeof. destruct (snd ptr =? 0); auto.
  destruct (Nat.eq_dec (fst ptr) b).
  * rewrite e in *. simpl. rewrite nth_error_replace_list_index_eq; auto.
    rewrite Hb. auto.
  * simpl. erewrite <- nth_error_replace_list_index_neq; auto.
Qed.


Require Import
  HoTT.Classes.interfaces.abstract_algebra.

Generalizable Variables A B C.

Open Scope list_scope.

(** Standard notations for lists.
In a special module to avoid conflicts. *)
Module ListNotations.
Notation " [] " := nil : list_scope.
Notation " [ x ] " := (cons x nil) : list_scope.
Notation " [ x ; y ; .. ; z ] " :=  (cons x (cons y .. (cons z nil) ..))
  : list_scope.
End ListNotations.

Import ListNotations.

Fixpoint length {A} (l : list A) := match l with
  | [] => O
  | _ :: l => S (length l)
  end.

Fixpoint fold_left {A B} (f : A -> B -> A) (acc : A) (l : list B) :=
  match l with
  | [] => acc
  | x :: l => fold_left f (f acc x) l
  end.

Fixpoint map {A B} (f : A -> B) (l : list A) :=
  match l with
  | [] => []
  | x :: l => (f x) :: (map f l)
  end.

Fixpoint map2 `(f : A -> B -> C)
  (def_l : list A -> list C) (def_r : list B -> list C)
  l1 l2 :=
  match l1, l2 with
  | [], [] => []
  | [], _ => def_r l2
  | _, [] => def_l l1
  | x :: l1, y :: l2 => (f x y) :: (map2 f def_l def_r l1 l2)
  end.

Lemma map2_cons `(f : A -> B -> C) defl defr x l1 y l2 :
  map2 f defl defr (x::l1) (y::l2) = (f x y) :: map2 f defl defr l1 l2.
Proof.
reflexivity.
Qed.

Lemma map_id `(f : A -> A) (Hf : forall x, f x = x) (l : list A) : map f l = l.
Proof.
induction l as [|x l IHl].
- reflexivity.
- simpl. rewrite Hf,IHl. reflexivity.
Qed.

Global Instance sg_op_app A : SgOp (list A) := @app A.

Global Instance app_assoc A : Associative (@app A).
Proof.
intros l1. induction l1 as [|x l1 IH];intros l2 l3.
- reflexivity.
- simpl;apply ap;apply IH.
Qed.

Fixpoint for_all {A} (P : A -> Type) l : Type :=
  match l with
  | [] => Unit
  | x :: l => P x /\ for_all P l
  end.

Lemma for_all_trivial {A} (P : A -> Type) : (forall x, P x) ->
  forall l, for_all P l.
Proof.
intros HP l;induction l as [|x l IHl];split;auto.
Qed.

Lemma for_all_map {A B} P Q (f : A -> B) (Hf : forall x, P x -> Q (f x))
 : forall l, for_all P l -> for_all Q (map f l).
Proof.
intros l;induction l as [|x l IHl];simpl.
- auto.
- intros [Hx Hl]. split;auto.
Defined.

Lemma for_all_map2 {A B C} P Q R
  `(f : A -> B -> C) (Hf : forall x y, P x -> Q y -> R (f x y))
  def_l (Hdefl : forall l1, for_all P l1 -> for_all R (def_l l1))
  def_r (Hdefr : forall l2, for_all Q l2 -> for_all R (def_r l2))
  : forall l1 l2, for_all P l1 -> for_all Q l2 ->
    for_all R (map2 f def_l def_r l1 l2).
Proof.
intros l1;induction l1 as [|x l1 IHl1].
- simpl. intros [|y l2] _; auto.
- simpl. intros [|y l2] [Hx Hl1];[intros _|intros [Hy Hl2]];simpl;auto.
  apply Hdefl. simpl;auto.
Qed.

Lemma fold_preserves {A B} P Q (f : A -> B -> A)
  (Hf : forall x y, P x -> Q y -> P (f x y))
  : forall acc (Ha : P acc) l (Hl : for_all Q l), P (fold_left f acc l).
Proof.
intros acc Ha l Hl;revert l Hl acc Ha.
intros l;induction l as [|x l IHl].
- intros _ acc Ha. exact Ha.
- simpl. intros [Hx Hl] acc Ha.
  apply IHl;auto.
Qed.

Global Instance for_all_trunc {A} {n} (P : A -> Type) : forall l,
  for_all (fun x => IsTrunc n (P x)) l -> IsTrunc n (for_all P l).
Proof.
intros l;induction l as [|x l IHl];simpl.
- intros _. destruct n;apply _.
- intros [Hx Hl].
  apply IHl in Hl. apply _.
Qed.

(* Copy pasted from the Coq library. *)
Definition tl {A} (l:list A) : list A :=
  match l with
    | [] => nil
    | a :: m => m
  end.

(* Modified copy from the Coq library. *)
(** The "In list" predicate *)
Fixpoint InList {A} (a:A) (l:list A) : Type0 :=
  match l with
    | [] => False
    | b :: m => b = a |_| InList a m
  end.

Fixpoint fold_right {A} {B} (f : B -> A -> A) (x : A) (l : list B) : A :=
  match l with
    | nil => x
    | cons b t => f b (fold_right f x t)
  end.


(* Software Foundations *)
(* Exercice 2 stars,mumble_grumble *)

Inductive mumble: Type :=
|a: mumble
|b: mumble -> nat -> mumble
|c: mumble.

Inductive grumble(X: Type): Type :=
|d: mumble -> grumble X
|e: X -> grumble X.

Check (d _ (b a 5)).
Check (d mumble (b a 5)).
Check (d bool (b a 5)).
Check (e bool true).
Check (e mumble (b c 0)).
Check c.
Check (e bool (b c 0)).


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Max.
Require Import Reals.
Require Import Rintegral.
Require Import Rintegral_usual.
Require Import Rintegral_tactic.
Require Import Lia Lra.
Require Import Rsequence_facts.
Require Import Rsequence_subsequence.
Require Import Rpser.
Require Import RTaylor.
Require Import MyRfunctions.
Require Import Rsequence_tactics.

Local Open Scope R_scope.

Section Wallis.
(** printing ~	~ *)
Local Coercion INR : nat >-> R.

Definition sin_n n := fun x => pow (sin x) n.

Lemma integrable_sin_n : forall n, Riemann_integrable (comp (fun x => pow x n) sin) 0 (PI/2).
Proof.
intro n.
apply RiemannInt_P6.
pose proof PI_RGT_0; lra.
intros x Hx; apply continuity_pt_comp.
  apply continuity_sin.
  apply derivable_continuous; apply derivable_pow.
Qed.

Definition W_even n := ((PI/2)*(fact (2 * n))/(2 ^ (2 * n) * (fact n) ^2 )).
Definition W_odd n := ((2^(2*n) * (fact n) ^2)/(fact (S (2 * n)))).

Lemma Wallis_0 : Rint (sin_n 0)  0 (PI/2) (PI/2).
Proof.
apply Rint_eq_compat with (fct_cte 1).
  trivial.
assert(Hrew : (PI/2) = (1*(PI/2 -0))) by ring.
apply Rint_eq with (1 * (PI / 2 - 0)).
 auto with Rint.
 ring.
Qed.

Lemma Wallis_1 : Rint (sin_n 1)  0 (PI/2) 1.
Proof.
unfold sin_n.
apply Rint_eq_compat with sin.
  auto with *.
assert(Heq : 1 = (cos 0 - cos (PI/2))).
  rewrite cos_PI2, cos_0; ring.
apply Rint_eq with (cos 0 - cos (PI / 2)) ; auto with Rint.
Qed.

(** Recurrence formula *)
Lemma Wallis_formula : forall Wn n,
  Rint (sin_n n) 0 (PI/2) Wn->
    Rint (sin_n (S (S n))) 0 (PI/2) (Wn * (S n)/(S (S n))).
Proof.
intros Wn n H.
pose (RiemannInt (integrable_sin_n (S (S n)))) as W2n.
pose proof (Rint_RiemannInt_link _ _ _ (integrable_sin_n (S (S n)))) as HW2.
assert (W2n = (S n) * (Wn - W2n)) as Heq.
replace (S n * (Wn - W2n)) with
  (comp (fun x => x ^ (S n)) sin (PI/2) *((- cos)%F (PI/2)) - comp (fun x => x ^ (S n)) sin 0 *((- cos)%F 0) - (-(S n) * (Wn - W2n))).
eapply Rint_parts with (f' := fun x => ((S n) * sin x ^ n)* cos x) (g' := sin).
  left; apply PI2_RGT_0.

  intros.
  apply derivable_pt_lim_comp.
    auto with Rcont.
    apply derivable_pt_lim_pow.

  intros.
  replace (sin x) with (- - sin x) by ring.
  auto with Rcont.

  intros.
  apply continuity_pt_mult.
    apply continuity_pt_mult; auto with Rcont.
      apply continuity_pt_const; intros u v; reflexivity.
      reg.
    auto with Rcont.
    auto with Rcont.

  apply Rint_eq_compat with (comp (fun x : R => x ^ S (S n)) sin).
  intros; unfold comp, mult_fct; simpl; ring.
  apply Rint_RiemannInt_link.

  apply Rint_eq_compat with (fun x => (- S n) * (sin x ^ n - sin x ^ (S (S n)))).
  intros.
  unfold mult_fct, opp_fct.
  rewrite Rmult_assoc.
  replace (cos x * - cos x) with (-(1 - (sin x)^2)).
  unfold Rsqr; simpl; ring.
  replace ((sin x) ^ 2) with ((sin x)²) by (unfold Rsqr; ring).
  rewrite <- (cos2 x); unfold Rsqr; ring.
  apply Rint_scalar_mult_compat_l.
  apply Rint_minus; trivial.

  unfold opp_fct, comp;
  rewrite cos_0, cos_PI2, sin_PI2, sin_0;
  simpl; ring.

replace (Wn * S n / S (S n)) with (W2n).
  trivial.
rewrite Rmult_comm.
replace W2n with (/(S (S n)) * (S (S n))* W2n).
replace Wn with ((Wn - W2n) + W2n) by ring.
rewrite Rmult_plus_distr_l.
rewrite <- Heq.
unfold Rdiv.
rewrite Rmult_comm with (r1 := (W2n + S n * W2n)).
rewrite Rmult_assoc.
apply Rmult_eq_compat_l.
simpl; ring.
field.
auto with *.
Qed.

Lemma Wallis_even : forall n, Rint (sin_n (2 * n)) 0 (PI/2) (W_even n).
Proof.
unfold W_even.
induction n.
  simpl; unfold Rsqr; field_simplify; apply Wallis_0.

apply Rint_eq_compat with (sin_n (S (S (2 *  n)))).
  intros; simpl;
  replace (S (n + S (n + 0))) with (S (S (n + (n + 0)))) by auto;
  reflexivity.

replace (PI / 2 * fact (2 * S n) / (2 ^ (2 * S n) * (fact (S n)) ^2)) with
  ((PI / 2 * fact (2 * n) / (2 ^ (2 * n) * (fact n)^2)) * S (2 * n) / (S (S (2 * n)))).
apply Wallis_formula; apply IHn.

replace (2 * S n)%nat with (S (S (2 * n))) by auto with *.
repeat rewrite fact_simpl.
repeat rewrite <- tech_pow_Rmult.
unfold Rsqr.
replace (S (S (2*n))) with (2 * (S n))%nat by auto with *.
repeat rewrite mult_INR.
replace (INR 2) with 2 by trivial; field.

repeat split.
apply not_0_INR; apply fact_neq_0.
auto with *.
apply pow_nonzero; pose proof Rlt_R0_R2; intro; lra.
Qed.

Lemma Wallis_odd : forall n, Rint (sin_n (S (2 * n))) 0 (PI/2) ((2^(2*n) * (fact n) ^2)/(fact (S (2 * n)))).
Proof.
unfold W_odd.
induction n.
  simpl; replace (1 * (1 * (1*1)) / 1) with 1 by field; apply Wallis_1.
apply Rint_eq_compat with (sin_n (S (S (S (2 * n))))).
  intros; simpl.
replace (n + S (n + 0))%nat with (S (n + (n + 0))) by auto;
reflexivity.
replace (2 ^ (2 * S n) * (fact (S n))^2 / fact (S (2 * S n))) with
  ((2 ^ (2 * n) * (fact n)^2 / fact (S (2 * n))) * (S (S (2 * n)))/(S (S (S (2 * n))))).
apply Wallis_formula; apply IHn.

replace (2 * S n)%nat with (S (S (2 * n))) by auto with *.
repeat rewrite fact_simpl.
repeat rewrite <- tech_pow_Rmult.
unfold Rsqr.
replace (S (S (2*n))) with (2 * (S n))%nat by auto with *.
repeat rewrite mult_INR.
replace (INR 2) with 2 by trivial; field.

repeat split;apply not_0_INR; try (auto with * ).
apply fact_neq_0.
Qed.

Lemma Wallis_odd_le_even : forall n, W_odd n <= W_even n.
Proof.
intro n.
apply (Rint_le_compat (sin_n (S (2 * n))) (sin_n (2 * n)) 0 (PI/2)).
  left; apply PI2_RGT_0.

  intros; unfold sin_n.
  replace (sin u ^ (2 * n)) with (1 * sin u ^ (2 * n)) by ring.
  rewrite <- tech_pow_Rmult.
  apply Rmult_le_compat_r.
    apply pow_le.
    apply sin_ge_0; intuition; lra.
    pose proof (SIN_bound u); intuition.

apply Wallis_odd.
apply Wallis_even.
Qed.

Lemma Wallis_even_le_odd : forall n, W_even (S n) <= W_odd n.
Proof.
intro n.
apply (Rint_le_compat (sin_n (2 * (S n))) (sin_n (S (2 * n))) 0 (PI/2)).
  left; apply PI2_RGT_0.

  intros; unfold sin_n.
  replace (2 * (S n))%nat with (S (S (2 * n))) by auto with *.
  replace (sin u ^ (S (2 * n))) with (1 * sin u ^ (S (2 * n))) by ring.
  rewrite <- tech_pow_Rmult.
  apply Rmult_le_compat_r.
    apply pow_le.
    apply sin_ge_0; intuition; lra.
    pose proof (SIN_bound u); intuition.

apply Wallis_even.
apply Wallis_odd.
Qed.

Lemma Wallis_maj : forall n : nat, (2*n/ (S (2 * n))) * (W_even n) <= W_odd n.
Proof.
intro n.
destruct n.

  unfold W_even, W_odd, Rsqr.
  simpl; field_simplify; lra.

   replace 2 with (INR 2) by trivial; rewrite <- mult_INR.
  replace (2 * S n)%nat with (S (S (2 * n))) by auto with *.

  replace (W_odd (S n)) with (INR (S (S (2 * n))) / INR (S (S (S (2 * n)))) * W_odd n).

  apply Rmult_le_compat_l.
  unfold Rdiv.
  repeat apply Rmult_le_pos; auto with *.

  apply Wallis_even_le_odd.

  rewrite Rmult_comm.
  unfold Rdiv.
  rewrite <- Rmult_assoc.
  eapply (Rint_uniqueness _ 0 (PI/2)).
  apply Wallis_formula.
  apply Wallis_odd.
  replace (S (S (2 * n))) with (2 * (S n))%nat by auto with *.
  apply Wallis_odd.
Qed.

Lemma W_even_pos : forall n, 0 < W_even n.
Proof.
intro n.
 unfold W_even, Rsqr, Rdiv.
 repeat apply Rmult_lt_0_compat; try lra.
  now apply Rlt_le_trans with (7 / 8); lra || apply pi2_int.
  now apply INR_fact_lt_0.
  repeat rewrite Rinv_mult_distr ; repeat apply Rmult_lt_0_compat.
   rewrite Rinv_pow.
    apply pow_lt ; lra.
    apply Rgt_not_eq ; lra.
   apply Rinv_0_lt_compat, pow_lt, INR_fact_lt_0.
   apply Rgt_not_eq, pow_lt ; lra.
   apply Rgt_not_eq, pow_lt, INR_fact_lt_0.
Qed.

Lemma Wallis_bound : forall (n : nat),  2*n / (S(2 * n)) <= W_odd n / W_even n <= 1.
Proof.
intro n ; split.
 apply Rle_trans with (2 * n / S (2 * n) * (W_even n / W_even n)).
 right ; field ; split.
 apply Rgt_not_eq ; apply W_even_pos.
 apply not_0_INR ; discriminate.
 unfold Rdiv ; rewrite <- Rmult_assoc ; apply Rmult_le_compat_r.
 left ; apply Rinv_0_lt_compat ; apply W_even_pos.
 apply Wallis_maj.
 rewrite <- Rinv_r with (W_even n).
 unfold Rdiv ; apply Rmult_le_compat_r.
 left ; apply Rinv_0_lt_compat ; apply W_even_pos.
 apply Wallis_odd_le_even.
 apply Rgt_not_eq ; apply W_even_pos.
Qed.

Lemma Wallis_quotient_lim1 : Rseq_cv (fun n => W_odd n / W_even n) 1.
Proof.
apply Rseq_sandwich_theorem
  with (Un := fun (n : nat) => 2 * n / (S (2 * n))) (Wn := fun n => 1).
  apply Rseq_cv_eq_compat with (Un := fun n => 2 * n / (2 * n + 1)).
    intros n.
    rewrite S_INR; rewrite mult_INR; reflexivity.
  apply Rseq_equiv_cv_div.
    apply Rseq_equiv_sym.
    apply Rseq_equiv_plus_little_O_compat_l.
    apply Rseq_equiv_refl.
    apply Rseq_little_O_Rmult_compat_r; [|intro H; lra].
    eapply Rseq_little_O_eq_compat
      with (Un := Rseq_poly 0) (Vn := Rseq_poly 1).
      intros n; unfold Rseq_poly; apply pow_O.
      intros n; unfold Rseq_poly; apply pow_1.
      apply Rseq_poly_little_O; constructor.
    intros n; assert (H := pos_INR n); intros Hc; lra.
  apply Rseq_constant_cv.
  apply Wallis_bound.
Qed.

Lemma Wallis_quotient :
  forall n, W_odd n / W_even n = (2*2 ^ (4*n) * (fact n) ^ 4)/(PI*fact (2 * n) * fact (S (2 * n))).
Proof.
intro n; unfold W_odd, W_even, Rsqr, Rdiv.
replace (2 ^ (4 * n)) with ((2 ^ (2 * n)) * (2 ^ (2 * n))).
field; repeat split.
  apply not_0_INR; apply fact_neq_0.
  apply not_0_INR; apply fact_neq_0.
  apply PI_neq0.
  apply not_0_INR; apply fact_neq_0.
  apply pow_nonzero; intros H; lra.
  replace (4 * n)%nat with (2 * n + 2 * n)%nat by lia.
  rewrite pow_add.
  reflexivity.
Qed.

Lemma Rseq_cv_eq_compat1 : forall Un Vn l,
  {m | forall n, (n >= m)%nat -> Un n = Vn n} ->
    Rseq_cv Un l -> Rseq_cv Vn l.
Proof.
intros Un Vn l Heq Hseq.
intros eps Heps.
destruct Heq as (m, Heq).
destruct (Hseq eps Heps) as (N, Hseq2).
exists (max N m).
intros n Hn.
assert (Hm : (n >= m)%nat). apply le_trans with (max N m) ; intuition.
unfold R_dist in *.
rewrite <- (Heq n) ; intuition;
try (apply Hseq2; intuition; apply le_trans with (max N m) ; intuition).
Qed.

Lemma sqrt_id : forall n : nat, (INR n <> 0)%R -> sqrt (2 * n) / (2 * n) = /sqrt (2 * n).
Proof.
intros n H1.
rewrite <- (sqrt_sqrt (2 * n)) at 2.
field.
intro H. apply H1. apply Rmult_eq_reg_l with 2. rewrite Rmult_0_r. apply sqrt_eq_0 ; intuition.
apply Rmult_le_pos ; intuition. intro ; lra.
apply Rmult_le_pos ; intuition.
Qed.

Lemma Rseq_equiv_eq : forall Un Vn,
  {m | forall n, (n >= m)%nat -> Un n = Vn n} -> Un ~ Vn.
Proof.
intros Un Vn Heq eps Heps.
destruct Heq as (N, Heq).
exists N. intros n HN.
unfold Rseq_constant, Rseq_minus, Rseq_plus.
rewrite (Heq n).
ring_simplify (Vn n - Vn n).
rewrite Rabs_R0. apply Rmult_le_pos.
intuition.
apply Rabs_pos.
assumption.
Qed.

Lemma DL_sqrt_1 : forall Un, Rseq_cv Un 0 -> (fun n => sqrt (1 + Un n) - 1) = o(1).
Proof.
intros Un Un0.
intros eps Heps.
destruct (Un0 eps Heps) as (N, HUn).
assert (H01 : 0 < 1) by lra.
destruct (Un0 1 H01) as (N1, HUn1).
exists (max N N1).
intros n HNmax.
unfold Rseq_constant. rewrite Rabs_R1. rewrite Rmult_1_r.
apply Rle_trans with (Rabs (Un n)).
apply sqrt_var_maj.
unfold R_dist in *. left.
assert (HN : (n >= N1)%nat). apply le_trans with (max N N1) ; intuition.
generalize (HUn1 n HN) ; intros HU1.
rewrite Rminus_0_r in HU1. assumption.
left.
assert (HN : (n >= N)%nat). apply le_trans with (max N N1) ; intuition.
generalize (HUn n HN) ; intros HU1.
unfold R_dist in HU1.
rewrite Rminus_0_r in HU1. assumption.
Qed.

Lemma Rseq_cv_inv_INR : Rseq_cv (fun n => /INR (n + 1)) 0.
Proof.
generalize RinvN_cv. intros useful.
intros eps Heps.
destruct (useful eps Heps) as (N, H).
exists N.
intros n Hn.
generalize (H n Hn). intros H1.
unfold pos in  H1. simpl in H1.
rewrite plus_INR. apply H1.
Qed.

Lemma Rinv_plus : forall a b c : R, c <> 0 -> (a + b) / c = a / c + (b / c).
Proof.
intros a b c d.
field ; apply d.
Qed.

Lemma Rinv_eq_1 : forall a, a <> 0 -> a / a = 1.
Proof.
intros.
field ; assumption.
Qed.

Lemma pow_exp_ln : forall x n, 0 < x -> x ^ n = exp (n * ln x).
Proof.
intros x n H.
induction n.
 simpl. rewrite Rmult_0_l. rewrite exp_0. reflexivity.

 rewrite S_INR. rewrite Rmult_plus_distr_r.
 rewrite <- tech_pow_Rmult. rewrite exp_plus.
 rewrite Rmult_1_l. rewrite exp_ln ; [ | apply H].
 rewrite IHn. ring.
Qed.

Lemma Rseq_equiv_ln : forall Un, Rseq_cv Un 0 -> (fun n => ln (1 + Un n)) ~ Un.
Proof.
intros Un Hu.
destruct (Hu 1) as [M HM]; [lra|].
apply Rseq_equiv_sym.
intros eps Heps.
assert (H1 : 0 < 1) by lra.
destruct (Rpser_little_O_partial_sum _ Un 1 1 H1 Hu ln_plus_cv_radius eps Heps) as [N HN].
exists (Max.max M N); intros n Hn.
unfold Rseq_minus; simpl.
pattern Un at 2; replace (Un n) with (Un n ^ 1) by field.
eapply Rle_trans; [right|apply HN].
  simpl; rewrite ln_plus_taylor_sum.
  rewrite Rabs_minus_sym.
  apply f_equal; field.
  replace (Un n) with (Un n - 0) by field; apply HM.
  eapply le_trans; [apply Max.le_max_l|eassumption].
eapply le_trans; [apply Max.le_max_r|eassumption].
Qed.

Lemma Rseq_cv_inv_INR_0_1 : Rseq_cv (fun n => - / (2 * INR n + 1))%R 0%R.
Proof.
replace 0 with (-0)%R by intuition. apply Rseq_cv_opp_compat.
generalize RinvN_cv. intros useful.
intros eps Heps;
destruct (Rseq_cv_inv_INR eps Heps) as (N, Hun).
exists N. intros n Hn.
generalize (Hun n Hn) ; intros Hun1.
apply Rle_lt_trans with (/INR (n + 1))%R.
 unfold R_dist. rewrite Rminus_0_r. rewrite Rabs_pos_eq.
  apply Rle_Rinv.
   generalize (pos_INR n) ; intros ; rewrite plus_INR ; intuition.
   generalize (pos_INR n) ; intros ; lra.
   rewrite plus_INR. simpl. apply Rplus_le_compat_r. replace (INR n)%R with ((INR n ) * 1)%R by ring. rewrite Rmult_comm. apply Rmult_le_compat.
    intuition.
    apply pos_INR.
    intuition.
    intuition.
 left. apply Rinv_0_lt_compat. generalize (pos_INR n) ; intros ; lra.
unfold R_dist in Hun1. rewrite Rminus_0_r in Hun1. rewrite Rabs_right in Hun1. apply Hun1.
left. apply Rgt_lt. apply Rinv_0_lt_compat. intuition.
Qed.

Lemma Rseq_equiv_continuity : forall Un Vn l f, continuity_pt f l ->
  f l <> 0 -> Rseq_cv Un l -> Rseq_cv Vn l ->
    (fun n : nat => f (Un n)) ~ (fun n : nat => f (Vn n)).
Proof.
intros Un Vn l f Hcont H0 Hun Hvn.
apply Rseq_equiv_trans with (f l).
 apply Rseq_cv_equiv_constant.
  assumption.
  apply Rseq_cv_continuity_compat ; [assumption | reg].

 apply Rseq_equiv_sym.
 apply Rseq_cv_equiv_constant.
  assumption.
  apply Rseq_cv_continuity_compat ; [assumption | reg].
Qed.

Lemma Wallis_quotient_lim2 : forall l,
l <> 0 ->
  (fun n => fact n) ~ (fun n => (n /(exp 1)) ^ n * sqrt n * l) ->
    Rseq_cv (fun n => W_odd n / W_even n) (l^2/(2*PI)).
Proof.
intros l Hneq Hl.
apply Rseq_cv_eq_compat with (fun n => (2*2 ^ (4*n) * (fact n) ^ 4)/(PI*fact (2 * n) * fact (S (2 * n)))).
  intro; rewrite Wallis_quotient; reflexivity.
assert (H2n : (fun n => fact (2 * n)) ~ (fun n => (2 * n / exp 1) ^ (2 * n) * sqrt (2 * n) * l)).
  assert (Hex : is_extractor (mult 2)).
    intros n; lia.
  pose (exist _ _ Hex) as db.
  assert (Hrw1 : extracted db fact == (fun n => fact (2 * n))).
    intros n; reflexivity.
  assert (Hrw2 : extracted db (fun n => (n / exp 1) ^ n * sqrt n * l) == (fun n => (2 * n / exp 1) ^ (2 * n) * sqrt (2 * n) * l)).
    intros n; unfold extracted. simpl.
    repeat rewrite plus_INR; simpl.
    replace (n + (n + 0)) with (2 * n) by field.
    reflexivity.
  eapply Rseq_equiv_eq_compat; [eassumption|eassumption|].
  apply Rseq_equiv_subseq_compat with (Un := fact) (Vn := fun k : nat => (k / exp 1) ^ k * sqrt k * l) (phi := db).
  assumption.
assert (H2n1 : (fun n : nat => fact (S(2*n))) ~ (fun n : nat => (S(2*n) / exp 1) ^ (S(2*n)) * sqrt (S(2*n)) * l)).
  assert (Hex : is_extractor (fun n => S (mult 2 n))).
    intros n; lia.
  pose (exist _ _ Hex) as db.
  apply Rseq_equiv_eq_compat with (extracted db fact) (extracted db (fun n : nat => (n / exp 1) ^ n * sqrt n * l)).
    intro n; unfold db; reflexivity.
    intro n; unfold db; reflexivity.
  apply Rseq_equiv_subseq_compat with (Un := fact) (Vn := fun k : nat => (k / exp 1) ^ k * sqrt k * l)(phi := db).
  assumption.

apply Rseq_equiv_cv_constant.
Local Open Scope Rseq_scope.
apply Rseq_equiv_eq_compat with
  (Un := 2 * (fun n => 2 ^ (4 * n)) * fact * fact * fact * fact *
  / (PI * (fun n => fact (2 * n)) * (fun n => fact (S (2 * n))))) (Vn := (l^2 / (2 * PI))%R).
intro n; unfold Rseq_mult, Rseq_inv, Rdiv, Rseq_constant; ring.
intro; reflexivity.
apply Rseq_equiv_trans with
(2 * (fun n => 2 ^ (4 * n)) * ((fun n : nat => ((n / exp 1) ^ n * sqrt n * l)%R))*((fun n : nat => ((n / exp 1) ^ n * sqrt n * l)%R))*((fun n : nat => ((n / exp 1) ^ n * sqrt n * l)%R))*((fun n : nat => ((n / exp 1) ^ n * sqrt n * l)%R))*
  / (PI * (fun n : nat => ((2 * n / exp 1) ^ (2 * n) * sqrt (2 * n) * l)%R) *  (fun n => (S (2 * n) / exp 1) ^ S (2 * n) * sqrt (S (2 * n)) * l)%R)).

repeat apply Rseq_equiv_mult_compat;
  try apply Rseq_equiv_refl; try assumption.
apply Rseq_equiv_inv_compat.
exists O. intros n Hn.
unfold Rseq_mult, Rseq_constant.
apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ apply PI_neq0 | apply INR_fact_neq_0] | apply INR_fact_neq_0 ].

exists (S O). intros n Hn; unfold Rseq_mult, Rseq_constant.

assert(H : {m | n = S m}). exists (pred n). intuition.
destruct H as (m, Subst).
rewrite Subst.

apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ apply PI_neq0 | apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ (apply pow_nonzero ; unfold Rdiv ; apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ (intro ; lra) | (apply not_0_INR ; intuition) ] | (apply Rinv_neq_0_compat ; generalize (exp_pos 1) ; intros ; intro ; lra)])
| (intro H ; apply sqrt_eq_0 in H ; [ (apply Rmult_integral in H ; destruct H as [H|H] ; [ lra | (generalize H ; apply not_0_INR ; intuition) ])
| apply Rmult_le_pos ; intuition ]) ]
| apply Hneq ] ] | apply Rmult_integral_contrapositive ; split ;
[ apply Rmult_integral_contrapositive ; split ;
[ (apply pow_nonzero ; unfold Rdiv ; apply Rmult_integral_contrapositive ; split ;
[ apply not_0_INR ; intuition | (apply Rinv_neq_0_compat ; generalize (exp_pos 1) ; intros ; intro ; lra) ])
| (intro H ; apply sqrt_eq_0 in H ; [ (apply not_0_INR in H ; intuition )
| apply pos_INR ])
] | apply Hneq ] ].

apply Rseq_equiv_mult_compat.
apply Rseq_equiv_mult_compat.
apply Rseq_equiv_refl.
assumption.
assumption.
clear Hl H2n H2n1.
apply Rseq_cv_equiv_constant.
unfold Rdiv.
apply Rmult_integral_contrapositive ; split .
 apply pow_nonzero; assumption.
 apply Rinv_neq_0_compat.
 apply Rmult_integral_contrapositive; split.
  intro ; lra.
  apply PI_neq0.
unfold Rseq_constant, Rseq_mult, Rseq_div, Rseq_plus, Rseq_minus, Rseq_inv.
(* Simplification of the expression ! *)
apply Rseq_cv_eq_compat1 with
(fun n:nat => (sqrt (2 * n) / sqrt (S (2 * n))) * (Rsqr l / PI * exp 1) * ((2 * n) / S (2 * n)) ^ (S (2 * n)) * /2)%R.
exists (S O). intros n Hn.
(* need to have n <> 0 *)
assert(H : {m | n = S m}). exists (pred n). intuition.
destruct H as (m, Subst).
(* Solving the simplification equation *)
unfold Rseq_constant.
unfold Rdiv.
ring_simplify.
replace (sqrt n ^ 4) with (n ^ 2) by (rewrite <- (sqrt_sqrt n) at 1 ; [ring | intuition]).
repeat rewrite Rpow_mult_distr.
repeat rewrite <- pow_mult.
repeat rewrite Rinv_mult_distr.
replace (2 ^ (4 * n))%R with (2 ^ (2 * n) * 2 ^ (2 * n))%R by (repeat rewrite pow_mult ;
rewrite <- Rpow_mult_distr ; replace (2 ^ 2 * 2 ^ 2)%R with (2 ^ 4)%R by (unfold pow ; ring) ; ring).
rewrite (mult_comm n 4).
replace (n ^ (4 * n))%R with (n ^ (2 * n) * n ^ (2 * n))%R by
(rewrite <- pow_add ; ring_simplify (2 * n + 2 * n)%nat ; ring).
replace ((/exp 1) ^ (4 * n))%R with ((/exp 1) ^ (2 * n) * (/exp 1) ^ (2 * n))%R by
(rewrite <- pow_add ; ring_simplify (2 * n + 2 * n)%nat ; ring).
repeat rewrite Rinv_pow. rewrite Rinv_involutive.
rewrite <- tech_pow_Rmult with (exp 1) (2 * n)%nat.
rewrite <- (Rinv_pow (exp 1) _).
do 2 rewrite <- tech_pow_Rmult.
replace (/sqrt (2 * n))%R with (sqrt (2 * n) / (2 * n))%R by (apply sqrt_id ; inversion Hn ; [intuition | apply not_0_INR ; intuition]).
unfold Rsqr. unfold Rdiv.
repeat rewrite <- Rinv_pow. field.

(* Solving the "<> 0" equations *)

split. assumption.
split. intro H. apply sqrt_eq_0 in H. apply not_0_INR in H. assumption.
intuition.
intuition.
split. apply pow_nonzero. apply not_0_INR. intuition.
split. apply not_0_INR. intuition.
split. apply pow_nonzero. apply not_0_INR. intuition.
split. apply pow_nonzero. intro. lra.
split. apply PI_neq0.
apply pow_nonzero. intro. generalize (exp_pos 1) ; intros ; lra.
apply not_0_INR. intuition.
intro ; lra.
apply not_0_INR. intuition.
intro. generalize (exp_pos 1) ; intros ; lra.
intro. generalize (exp_pos 1) ; intros ; lra.
apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
apply not_0_INR ; intuition.
apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
apply not_0_INR ; intuition.
intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply not_0_INR ; intuition.
apply pos_INR.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply not_0_INR ; intuition.
apply pos_INR.
apply Hneq.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply Rmult_integral_contrapositive ; split.
intro ; lra.
apply not_0_INR. intuition.
apply Rmult_le_pos. intuition.
intuition.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply Rmult_integral_contrapositive ; split.
intro ; lra.
apply not_0_INR. intuition.
apply Rmult_le_pos. intuition. intuition.
assumption.
apply PI_neq0.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply Rmult_integral_contrapositive ; split.
intro ; lra.
apply not_0_INR. intuition.
apply Rmult_le_pos. intuition. intuition.
assumption.
apply Rmult_integral_contrapositive ; split.
apply PI_neq0.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. intro ; lra.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply Rmult_integral_contrapositive ; split.
intro ; lra.
apply not_0_INR. intuition.
apply Rmult_le_pos. intuition. intuition.
assumption.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply Rmult_integral_contrapositive ; split.
apply pow_nonzero. apply not_0_INR ; intuition.
apply pow_nonzero. apply Rinv_neq_0_compat. intro. generalize (exp_pos 1) ; intros ; lra.
intro H. apply sqrt_eq_0 in H. generalize H. apply not_0_INR. intuition.
apply pos_INR. assumption.
(* End of "<> 0" *)

(* end of simplification *)

eapply Rseq_equiv_cv_compat.
  2: reflexivity.
 symmetry; instantiate (1 := (1 * (Rsqr l / PI * exp 1) * /exp 1 * /2)).
 apply Rseq_equiv_mult_compat ; [ | apply Rseq_equiv_eq ; exists O ; intro ; intuition ].
 apply Rseq_equiv_mult_compat.
  apply Rseq_equiv_mult_compat ; [ | apply Rseq_equiv_eq ; exists O ; intro ; intuition ].
  pose (Un := (fun n => - / (2 * INR n + 1))%R).
  assert (Hcv0 : Rseq_cv Un 0). unfold Un.
   apply Rseq_cv_inv_INR_0_1.
  intros eps Heps.
  destruct (DL_sqrt_1 Un Hcv0 eps Heps) as (N, DL).
  exists N.
  intros n HN. generalize (DL n HN). intros DL1.
  unfold Rseq_constant, Rseq_plus, Rseq_minus, Rseq_mult, Rseq_inv, Un in *.
  rewrite <-sqrt_div ; [ | (apply Rmult_le_pos ; intuition) | intuition ].
  rewrite S_INR. rewrite mult_INR. do 2 rewrite S_INR.
  replace (2 * n)%R with ((2 * n + 1) - 1)%R by ring. rewrite Rplus_0_l.
  unfold Rminus. rewrite Rinv_plus.
   rewrite Rinv_eq_1. unfold Rdiv in *. rewrite Ropp_mult_distr_l_reverse. rewrite Rmult_1_l. rewrite Rabs_minus_sym in DL1. apply DL1.
    generalize (pos_INR n) ; intuition ; lra.
    generalize (pos_INR n) ; intuition ; lra.
 apply Rseq_equiv_trans with (fun n : nat => exp ((2 * n + 1) * ln (1 - /(2 * INR n + 1)))).
 pose (Un := (fun n:nat => - /(2 * (INR n) + 1))%R).
 assert (Hcv0 : Rseq_cv Un 0).
  apply Rseq_cv_inv_INR_0_1.
 apply Rseq_equiv_trans with (fun n : nat => exp ((2 * n + 1) * (- / (2 * n + 1)))).
  apply Rseq_equiv_eq. exists O. intros n Hn.
  field_simplify ((2 * n + 1) * - / (2 * n + 1))%R. unfold Rseq_constant, Rseq_inv.
   rewrite <- exp_Ropp. unfold Rdiv. try rewrite Rinv_1. try rewrite Rmult_1_r. reflexivity.
   generalize (pos_INR n) ; intuition ; lra.
  apply Rseq_equiv_continuity with ((-1)).
   reg.
   generalize (exp_pos (-1)) ; intros l1 H1 ; lra.
   apply Rseq_cv_eq_compat with (-R1).
   intros n. unfold Rseq_constant, Rseq_minus, Rseq_plus, Rseq_opp.
   field. intros H1 ; generalize (pos_INR n) ; intros ; lra.
   change (-1)%R with (-(1%R))%R. intuition.
   eapply Rseq_equiv_cv_compat.
     2: reflexivity.
    symmetry; instantiate (1 := (fun n => (2 * INR n + 1) * - / (2 * INR n + 1))%R).
    apply Rseq_equiv_mult_compat.
     apply Rseq_equiv_refl.
     apply Rseq_equiv_sym. apply Rseq_equiv_ln.
     apply Hcv0.
    apply Rseq_cv_eq_compat with (-R1).
    unfold Rseq_opp, Rseq_constant, Rseq_minus.
    intros n. field. generalize (pos_INR n) ; intuition ; lra.
    change (-1)%R with (-(1%R))%R. intuition.
 apply Rseq_equiv_eq.
 exists 1%nat.
 intros n Hn.
 rewrite pow_exp_ln.
  replace (2 * n)%R with ((2 * n + 1) - 1)%R by ring.
  rewrite S_INR. rewrite mult_INR. repeat rewrite S_INR.
  rewrite Rplus_0_l.
  unfold Rminus. rewrite Rinv_plus. rewrite Rinv_eq_1.
   ring_simplify (2 * n + 1 + -(1) + 1)%R. unfold Rdiv. ring_simplify (1 + -(1) * / ((1 + 1) * n + 1))%R.
   rewrite (Rplus_comm (- / (2 * n + 1)) _). reflexivity.
   generalize (pos_INR n) ; intuition ; lra.
   generalize (pos_INR n) ; intuition ; lra.
   unfold Rdiv. apply Rmult_lt_0_compat. apply Rmult_lt_0_compat ; intuition.
   apply Rinv_0_lt_compat.
   rewrite S_INR. generalize (pos_INR n) ; intuition ; lra.
apply Rseq_cv_eq_compat with (Rsqr l / (2 * PI)).
intro. unfold Rseq_mult, Rseq_plus, Rseq_constant, Rseq_div, Rseq_inv.
field. split.
apply PI_neq0.
intro. generalize (exp_pos 1) ; intros ; lra.
intros eps Heps. exists O. intros n Hn.
unfold R_dist. unfold Rseq_constant, Rseq_div, Rseq_inv, Rseq_mult.
unfold Rdiv, Rsqr. rewrite Rminus_diag_eq.
rewrite Rabs_R0. apply Heps.
ring.
Qed.

End Wallis.


From stdpp Require Export strings.
From stdpp Require Import relations numbers.
From Coq Require Import Ascii.
From stdpp Require Import options.

Class Pretty A := pretty : A → string.
Global Hint Mode Pretty ! : typeclass_instances.

Definition pretty_N_char (x : N) : ascii :=
  match x with
  | 0 => "0" | 1 => "1" | 2 => "2" | 3 => "3" | 4 => "4"
  | 5 => "5" | 6 => "6" | 7 => "7" | 8 => "8" | _ => "9"
  end%char%N.
Lemma pretty_N_char_inj x y :
  (x < 10)%N → (y < 10)%N → pretty_N_char x = pretty_N_char y → x = y.
Proof. compute; intros. by repeat (discriminate || case_match). Qed.

Fixpoint pretty_N_go_help (x : N) (acc : Acc (<)%N x) (s : string) : string :=
  match decide (0 < x)%N with
  | left H => pretty_N_go_help (x `div` 10)%N
     (Acc_inv acc (N.div_lt x 10 H eq_refl))
     (String (pretty_N_char (x `mod` 10)) s)
  | right _ => s
  end.
Definition pretty_N_go (x : N) : string → string :=
  pretty_N_go_help x (wf_guard 32 N.lt_wf_0 x).
Instance pretty_N : Pretty N := λ x,
  if decide (x = 0)%N then "0" else pretty_N_go x "".

Lemma pretty_N_go_0 s : pretty_N_go 0 s = s.
Proof. done. Qed.
Lemma pretty_N_go_help_irrel x acc1 acc2 s :
  pretty_N_go_help x acc1 s = pretty_N_go_help x acc2 s.
Proof.
  revert x acc1 acc2 s; fix FIX 2; intros x [acc1] [acc2] s; simpl.
  destruct (decide (0 < x)%N); auto.
Qed.
Lemma pretty_N_go_step x s :
  (0 < x)%N → pretty_N_go x s
  = pretty_N_go (x `div` 10) (String (pretty_N_char (x `mod` 10)) s).
Proof.
  unfold pretty_N_go; intros; destruct (wf_guard 32 N.lt_wf_0 x).
  destruct (wf_guard _ _). (* this makes coqchk happy. *)
  unfold pretty_N_go_help at 1; fold pretty_N_go_help.
  by destruct (decide (0 < x)%N); auto using pretty_N_go_help_irrel.
Qed.

(** Helper lemma to prove [pretty_N_inj] and [pretty_Z_inj]. *)
Lemma pretty_N_go_ne_0 x s : s ≠ "0" → pretty_N_go x s ≠ "0".
Proof.
  revert s. induction (N.lt_wf_0 x) as [x _ IH]; intros s ?.
  assert (x = 0 ∨ 0 < x < 10 ∨ 10 ≤ x)%N as [->|[[??]|?]] by lia.
  - by rewrite pretty_N_go_0.
  - rewrite pretty_N_go_step by done. apply IH.
    { by apply N.div_lt. }
    assert (x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4 ∨ x = 5 ∨ x = 6
          ∨ x = 7 ∨ x = 8 ∨ x = 9)%N by lia; naive_solver.
  - rewrite 2!pretty_N_go_step by (try apply N.div_str_pos_iff; lia).
    apply IH; [|done].
    trans (x `div` 10)%N; apply N.div_lt; auto using N.div_str_pos with lia.
Qed.
(** Helper lemma to prove [pretty_Z_inj]. *)
Lemma pretty_N_go_ne_dash x s s' : s ≠ "-" +:+ s' → pretty_N_go x s ≠ "-" +:+ s'.
Proof.
  revert s. induction (N.lt_wf_0 x) as [x _ IH]; intros s ?.
  assert (x = 0 ∨ 0 < x)%N as [->|?] by lia.
  - by rewrite pretty_N_go_0.
  - rewrite pretty_N_go_step by done. apply IH.
    { by apply N.div_lt. }
    unfold pretty_N_char. by repeat case_match.
Qed.

Instance pretty_N_inj : Inj (=@{N}) (=) pretty.
Proof.
  cut (∀ x y s s', pretty_N_go x s = pretty_N_go y s' →
    String.length s = String.length s' → x = y ∧ s = s').
  { intros help x y. unfold pretty, pretty_N. intros.
    repeat case_decide; simplify_eq/=; [done|..].
    - by destruct (pretty_N_go_ne_0 y "").
    - by destruct (pretty_N_go_ne_0 x "").
    - by apply (help x y "" ""). }
  assert (∀ x s, ¬String.length (pretty_N_go x s) < String.length s) as help.
  { setoid_rewrite <-Nat.le_ngt.
    intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros s.
    assert (x = 0 ∨ 0 < x)%N as [->|?] by lia; [by rewrite pretty_N_go_0|].
    rewrite pretty_N_go_step by done.
    etrans; [|by eapply IH, N.div_lt]; simpl; lia. }
  intros x; induction (N.lt_wf_0 x) as [x _ IH]; intros y s s'.
  assert ((x = 0 ∨ 0 < x) ∧ (y = 0 ∨ 0 < y))%N as [[->|?] [->|?]] by lia;
    rewrite ?pretty_N_go_0, ?pretty_N_go_step, ?(pretty_N_go_step y) by done.
  { done. }
  { intros -> Hlen. edestruct help; rewrite Hlen; simpl; lia. }
  { intros <- Hlen. edestruct help; rewrite <-Hlen; simpl; lia. }
  intros Hs Hlen.
  apply IH in Hs as [? [= Hchar]];
    [|auto using N.div_lt_upper_bound with lia|simpl; lia].
  split; [|done].
  apply pretty_N_char_inj in Hchar; [|by auto using N.mod_lt..].
  rewrite (N.div_mod x 10), (N.div_mod y 10) by done. lia.
Qed.

Instance pretty_nat : Pretty nat := λ x, pretty (N.of_nat x).
Instance pretty_nat_inj : Inj (=@{nat}) (=) pretty.
Proof. apply _. Qed.

Instance pretty_Z : Pretty Z := λ x,
  match x with
  | Z0 => "0" | Zpos x => pretty (Npos x) | Zneg x => "-" +:+ pretty (Npos x)
  end%string.
Instance pretty_Z_inj : Inj (=@{Z}) (=) pretty.
Proof.
  unfold pretty, pretty_Z.
  intros [|x|x] [|y|y] Hpretty; simplify_eq/=; try done.
  - by destruct (pretty_N_go_ne_0 (N.pos y) "").
  - by destruct (pretty_N_go_ne_0 (N.pos x) "").
  - by edestruct (pretty_N_go_ne_dash (N.pos x) "").
  - by edestruct (pretty_N_go_ne_dash (N.pos y) "").
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU Lesser General Public License for more details.                *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** * Binary trees and some of their properties

- Key definitions: [btree], [inb], [all_leaves], [distinct_leaves],
  [compute_code], [number_of_nodes]
- Initial author: Laurent.Thery@inria.fr (2003)

*)

From Coq Require Export Compare_dec.
From Coq Require Import ArithRing ListDec.
From Huffman Require Export Code ISort Weight UniqueKey.

Set Default Proof Using "Type".

Section Tree.
Variable A : Type.
Variable A_eq_dec : forall a b : A, {a = b} + {a <> b}.
Variable empty : A.

(** Definition of binary trees *)
Inductive btree : Type :=
  | leaf : A -> btree
  | node : btree -> btree -> btree.

(** Predicate that defines belonging *)
Inductive inb : btree -> btree -> Prop :=
  | inleaf : forall t : btree, inb t t
  | innodeL : forall t t1 t2 : btree, inb t t1 -> inb t (node t1 t2)
  | innodeR : forall t t1 t2 : btree, inb t t2 -> inb t (node t1 t2).

#[local] Hint Constructors inb : core.

(** inb is transitive *)
Theorem inb_trans : forall t1 t2 t3, inb t1 t2 -> inb t2 t3 -> inb t1 t3.
Proof.
intros t1 t2 t3 H H1; generalize t1 H; elim H1; clear H H1 t1 t2 t3; auto.
Qed.

(** A tree has at least one leaf  *)
Theorem inb_ex : forall t : btree, exists x, inb (leaf x) t.
Proof.
intros t; elim t; simpl in |- *; auto.
intros a; exists a; auto.
intros b (a, H) b0 H0; exists a; auto.
Qed.

(** Compute the number of nodes of a tree *)
Fixpoint number_of_nodes (b : btree) : nat :=
  match b with
  | leaf _ => 0
  | node b1 b2 => S (number_of_nodes b1 + number_of_nodes b2)
  end.

(** Belonging gives smaller trees *)
Theorem number_of_nodes_inb_le :
 forall t1 t2, inb t1 t2 -> number_of_nodes t1 <= number_of_nodes t2.
Proof.
intros t1 t2 H; elim H; clear H t1 t2; simpl in |- *; auto.
intros t t1 t2 H H0; apply Nat.le_trans with (1 := H0); auto with arith.
intros t t1 t2 H H0; apply Nat.le_trans with (1 := H0); auto with arith.
Qed.

(** Belonging is anisymmetric *)
Theorem inb_antisym : forall t1 t2 : btree, inb t1 t2 -> inb t2 t1 -> t1 = t2.
Proof.
intros t1 t2 H; elim H; auto.
intros t t0 t3 H0 H1 H2.
absurd (number_of_nodes (node t0 t3) <= number_of_nodes t).
rewrite H1; simpl in |- *; auto with arith.
apply inb_trans with (2 := H2); auto.
apply number_of_nodes_inb_le; auto.
intros t t0 t3 H0 H1 H2.
absurd (number_of_nodes (node t0 t3) <= number_of_nodes t).
rewrite H1; simpl in |- *; auto with arith.
apply inb_trans with (2 := H2); auto.
apply number_of_nodes_inb_le; auto.
Qed.

(** equality on trees is decidable  *)
Definition btree_dec : forall a b : btree, {a = b} + {a <> b}.
intros a; elim a.
intros a1 b; case b.
intros b1; case (A_eq_dec a1 b1).
intros e; left; rewrite e; auto.
intros e; right; contradict e; inversion e; auto.
intros b0 b1; right; red in |- *; intros H; discriminate.
intros b H b0 H0 b1; case b1.
intros a0; right; red in |- *; intros H1; discriminate.
intros b2 b3; case (H b2); intros H1.
case (H0 b3); intros H2.
left; rewrite H1; rewrite H2; auto.
right; rewrite H1; contradict H2; inversion H2; auto.
right; contradict H1; inversion H1; auto.
Defined.

(** Belonging is decidable *)
Definition inb_dec : forall a p, {inb a p} + {~ inb a p}.
intros a; elim a; simpl in |- *; auto; clear a.
intros a p; elim p; simpl in |- *; auto; clear p.
intros a1; case (A_eq_dec a a1); intros Ha.
left; rewrite Ha; simpl in |- *; auto.
right; red in |- *; contradict Ha; inversion Ha; auto.
intros b [H| H]; auto.
intros b0 [H1| H1]; auto.
right; red in |- *; intros H2; inversion H2.
case H; auto.
case H1; auto.
intros b H b0 H0 p; elim p; auto.
intros a; right; red in |- *; intros H1; inversion H1.
intros b1 H1 b2 H2.
case H1; intros H3; auto.
case H2; intros H4; auto.
case (btree_dec (node b b0) (node b1 b2)); intros H5.
left; rewrite H5; auto.
right; red in |- *; intros H6; inversion H6; auto.
case H5; rewrite H9; rewrite H10; auto.
Defined.

(** Compute all the leaves of the tree *)
Fixpoint all_leaves (t : btree) : list A :=
  match t with
  | leaf a => a :: []
  | node t1 t2 => all_leaves t1 ++ all_leaves t2
  end.

(** A leaf is in the list of all leaves *)
Theorem all_leaves_in : forall t a, inb (leaf a) t -> In a (all_leaves t).
Proof.
intros t; elim t; simpl in |- *; auto.
intros a a0 H; inversion H; auto.
intros b H b0 H0 a H1; apply in_or_app; inversion H1; auto.
Qed.

(** An element of a list of all leaves is a leaf *)
Theorem all_leaves_inb : forall t a, In a (all_leaves t) -> inb (leaf a) t.
Proof.
intros t; elim t; simpl in |- *; auto.
intros a a0 [H| H]; [ rewrite H | case H ]; auto.
intros b H b0 H0 a H1; case in_app_or with (1 := H1); auto.
Qed.

(** The property for a tree to have distinct leaves  *)
Definition distinct_leaves (t : btree) : Prop :=
  forall t0 t1 t2 : btree,
  inb (node t1 t2) t -> inb t0 t1 -> inb t0 t2 -> False.

(** A leaf tree has distinct leaves  *)
Theorem distinct_leaves_leaf : forall a : A, distinct_leaves (leaf a).
Proof.
intros a; red in |- *.
intros a0 t1 t2 H; inversion H.
Qed.
#[local] Hint Resolve distinct_leaves_leaf : core.

(** An inversion theorem for node *)
Theorem distinct_leaves_l :
 forall t1 t2 : btree, distinct_leaves (node t1 t2) -> distinct_leaves t1.
Proof.
intros t1 t2 H; red in |- *.
intros a t0 t3 H0 H1 H2.
apply (H a t0 t3); auto.
Qed.

(** An inversion theorem for node *)
Theorem distinct_leaves_r :
 forall t1 t2 : btree, distinct_leaves (node t1 t2) -> distinct_leaves t2.
Proof.
intros t1 t2 H; red in |- *.
intros a t0 t3 H0 H1 H2.
apply (H a t0 t3); auto.
Qed.

(** If list of all the leaves of the tree is unique then the tree has distinct leaves *)
Theorem all_leaves_unique :
 forall t, NoDup (all_leaves t) -> distinct_leaves t.
Proof.
intros t; elim t; simpl in |- *; auto.
intros b H b0 H0 H1; red in |- *.
intros t0 t1 t2 H2; inversion H2.
intros H4 H7; case (inb_ex t0); intros a HH.
apply NoDup_app_inv with (a := a) (1 := H1); auto; apply all_leaves_in;
 apply inb_trans with (1 := HH); auto.
apply H; auto; try apply NoDup_app_inv_l with (1 := H1).
apply H0; auto; try apply NoDup_app_inv_r with (1 := H1).
Qed.

(** If the tree has distinct leaves then the list of all the leaves of the tree is unique *)
Theorem all_leaves_NoDup :
 forall t, distinct_leaves t -> NoDup (all_leaves t).
Proof.
intros t; elim t; simpl in |- *; auto using NoDup_cons,NoDup_nil.
intros b H b0 H0 H1; apply NoDup_app; auto.
apply H; apply distinct_leaves_l with (1 := H1).
apply H0; apply distinct_leaves_r with (1 := H1).
intros a H2 H3; case (H1 (leaf a) b b0); auto.
apply all_leaves_inb with (1 := H2).
apply all_leaves_inb with (1 := H3).
Qed.

(** Uniqueleaf is decidable *)
Definition distinct_leaves_dec :
  forall a, {distinct_leaves a} + {~ distinct_leaves a}.
intros a; case (NoDup_dec A_eq_dec (all_leaves a)); intros H.
left; apply all_leaves_unique; auto.
right; contradict H; apply all_leaves_NoDup; auto.
Defined.

(** Compute the code associated with a binary tree *)
Fixpoint compute_code (a : btree) : list (A * list bool) :=
  match a with
  | leaf b => (b, []) :: []
  | node l1 l2 =>
      map
        (fun v : A * list bool =>
         match v with
         | (a1, b1) => (a1, false :: b1)
         end) (compute_code l1) ++
      map
        (fun v : A * list bool =>
         match v with
         | (a1, b1) => (a1, true :: b1)
         end) (compute_code l2)
  end.

(** The computed code is never empty *)
Theorem length_compute_lt_O : forall t, 0 < length (compute_code t).
Proof.
intros t; elim t; simpl in |- *; auto with arith.
intros b H b0 H0; rewrite app_length.
replace 0 with (0 + 0); auto with arith.
apply Nat.add_lt_mono.
generalize H; elim (compute_code b); simpl in |- *; auto with arith.
generalize H0; elim (compute_code b0); simpl in |- *; auto with arith.
Qed.
#[local] Hint Resolve length_compute_lt_O : core.

(** If the computed code has a key it was a leaf of the tree *)
Theorem inCompute_inb :
 forall (t : btree) (a : A) (l : list bool),
 In (a, l) (compute_code t) -> inb (leaf a) t.
Proof.
intros t; elim t; simpl in |- *; auto.
intros a a0 l [H1| H1]; try (case H1; fail).
injection H1; intros H2 H3; rewrite H3; auto.
intros h H h0 H0 a l H1.
case in_app_or with (1 := H1); auto; intros H2.
case (proj1 (in_map_iff _ _ _)) with (1 := H2).
intros (a1, l1) (Hl1, Ha1); auto.
apply innodeL; apply (H a l1).
injection Hl1; intros Hl2 Hl3; rewrite <- Hl3; auto.
case (proj1 (in_map_iff _ _ _)) with (1 := H2).
intros (a1, l1) (Hl1, Ha1); auto.
apply innodeR; apply (H0 a l1).
injection Hl1; intros Hl2 Hl3; rewrite <- Hl3; auto.
Qed.

(** For every leaf in the tree there is an associated key in the code *)
Theorem inb_compute_ex :
 forall a p, inb (leaf a) p -> exists l, In (a, l) (compute_code p).
Proof.
intros a p; elim p; simpl in |- *; auto.
intros a0 H; inversion H.
exists []; auto.
intros p0 H p1 H0 H1; inversion H1.
case H; auto.
intros x Hx; exists (false :: x).
apply in_or_app; left; auto.
change
  (In ((fun v => match v with
                 | (a1, b1) => (a1, false :: b1)
                 end) (a, x))
     (map (fun v => match v with
                    | (a1, b1) => (a1, false :: b1)
                    end) (compute_code p0))) in |- *;
 apply in_map; auto.
case H0; auto.
intros x Hx; exists (true :: x).
apply in_or_app; right; auto.
change
  (In ((fun v => match v with
                 | (a1, b1) => (a1, true :: b1)
                 end) (a, x))
     (map (fun v => match v with
                    | (a1, b1) => (a1, true :: b1)
                    end) (compute_code p1))) in |- *;
 apply in_map; auto.
Qed.

(** The computed code is in the alphabet of its leaves *)
Theorem in_alphabet_compute_code :
 forall m t,
 (forall a : A, In a m -> inb (leaf a) t) -> in_alphabet m (compute_code t).
Proof.
intros m; elim m; simpl in |- *; auto.
intros a l H t H0; cut (inb (leaf a) t); auto; intros H1.
case inb_compute_ex with (1 := H1).
intros l1 Hl1; apply in_alphabet_cons with (ca := l1); auto.
Qed.

(** Two associations in the list with same prefix have same key *)
Theorem btree_unique_prefix1 :
 forall (t : btree) (a1 a2 : A) (lb1 lb2 : list bool),
 In (a1, lb1) (compute_code t) ->
 In (a2, lb2) (compute_code t) -> is_prefix lb1 lb2 -> a1 = a2.
Proof.
intros t; elim t; simpl in |- *.
intros leaf1 a1 a2 lb1 lb2 H1 H2.
case H1; intros H3; [ injection H3 | case H3 ].
case H2; intros H4; [ injection H4 | case H4 ].
intros H H0 H5 H6 H7; apply trans_equal with (2 := H0); auto.
intros t1 Rec1 t2 Rec2 a1 a2 lb1 lb2 H1 H2.
case (in_app_or _ _ _ H1); case (in_app_or _ _ _ H2); clear H1 H2;
 intros H2 H1 H3.
generalize H1 H2; inversion H3.
intros H4; case (proj1 (in_map_iff _ _ _)) with (1 := H4).
intros x; case x; intros x1 x2 (H6, H5); discriminate.
intros H5 H6; apply Rec1 with (lb1 := l1) (lb2 := l2); auto.
case (proj1 (in_map_iff _ _ _)) with (1 := H5).
intros x; case x.
intros a l (H8, H7); injection H8.
intros R1 R2 R3; rewrite <- R1; rewrite <- R3; auto.
case (proj1 (in_map_iff _ _ _)) with (1 := H6).
intros x; case x.
intros a l (H8, H7); injection H8.
intros R1 R2 R3; rewrite <- R1; rewrite <- R3; auto.
generalize H3.
case (proj1 (in_map_iff _ _ _)) with (1 := H1).
intros x; case x; intros aa1 ll1 (H5, H4).
case (proj1 (in_map_iff _ _ _)) with (1 := H2).
intros x1; case x1; intros aa2 ll2 (H7, H6).
inversion H5; inversion H7; intros tH8; inversion tH8.
generalize H3.
case (proj1 (in_map_iff _ _ _)) with (1 := H1).
intros x; case x; intros aa1 ll1 (H5, H4).
case (proj1 (in_map_iff _ _ _)) with (1 := H2).
intros x1; case x1; intros aa2 ll2 (H7, H6).
inversion H5; inversion H7; intros tH8; inversion tH8.
generalize H1 H2; inversion H3.
intros H4; case (proj1 (in_map_iff _ _ _)) with (1 := H4).
intros x; case x; intros x1 x2 (H6, H5); discriminate.
intros H5 H6; apply Rec2 with (lb1 := l1) (lb2 := l2); auto.
case (proj1 (in_map_iff _ _ _)) with (1 := H5).
intros x; case x.
intros a l (H8, H7); injection H8.
intros R1 R2 R3; rewrite <- R1; rewrite <- R3; auto.
case (proj1 (in_map_iff _ _ _)) with (1 := H6).
intros x; case x.
intros a l (H8, H7); injection H8.
intros R1 R2 R3; rewrite <- R1; rewrite <- R3; auto.
Qed.

(** If a tree has distinc leaves its computed tree has unique keys *)
Theorem btree_unique_prefix2 :
 forall t : btree, distinct_leaves t -> unique_key (compute_code t).
Proof.
intros t; elim t; simpl in |- *; auto.
intros b H b0 H0 H1.
apply unique_key_app; auto.
apply unique_key_map; auto.
apply H; apply distinct_leaves_l with (1 := H1); auto.
intros (a1, b1) (a2, b2); simpl in |- *; auto.
apply unique_key_map; auto.
apply H0; apply distinct_leaves_r with (1 := H1); auto.
intros (a1, b1) (a2, b2); simpl in |- *; auto.
intros a b1 c H2 H3.
case (proj1 (in_map_iff _ _ _)) with (1 := H2); auto;
 case (proj1 (in_map_iff _ _ _)) with (1 := H3); auto.
intros (a1, l1) (Hl1, Ha1) (a2, l2) (Hl2, Ha2).
apply (H1 (leaf a) b b0); auto.
injection Hl2; intros HH1 HH2; rewrite <- HH2.
apply inCompute_inb with (1 := Ha2).
injection Hl1; intros HH1 HH2; rewrite <- HH2.
apply inCompute_inb with (1 := Ha1).
Qed.

(** If a tree has distinct leaves its code is prefix *)
Theorem btree_unique_prefix :
 forall t : btree, distinct_leaves t -> unique_prefix (compute_code t).
Proof.
intros t H1; split; try exact (btree_unique_prefix1 t);
 apply btree_unique_prefix2; auto.
Qed.

End Tree.

Arguments leaf [A].
Arguments node [A].
Arguments inb [A].
Arguments all_leaves [A].
Arguments distinct_leaves [A].
Arguments compute_code [A].
Arguments number_of_nodes [A].

#[export] Hint Constructors inb : core.
#[export] Hint Resolve distinct_leaves_leaf : core.
#[export] Hint Resolve length_compute_lt_O : core.