Require Import Reals Psatz Omega.
From discprob.measure Require Export measures.
Export Hierarchy.
Open Scope R_scope.

Record outer_measure (A: Type)  :=
  { outer_measure_fun :> (A → Prop) → R;
    outer_measure_mono : Proper (@le_prop A ==> Rle) outer_measure_fun;
    outer_measure_empty : outer_measure_fun ∅ = 0;
    outer_measure_subadditivity : ∀ U: nat → (A → Prop),
        ex_series (λ n, outer_measure_fun (U n)) →
        outer_measure_fun (unionF U) <= Series (λ n, outer_measure_fun (U n))
  }.

Arguments outer_measure_empty {_} _.
Arguments outer_measure_subadditivity {_}.

Global Instance outer_measure_proper {A: Type} (μ: outer_measure A) :
  Proper (@eq_prop A ==> eq) (@outer_measure_fun _ μ).
Proof.
  intros U U' Heq.
  apply Rle_antisym; apply outer_measure_mono; rewrite Heq; done.
Qed.

Definition outer_measurable {A} (μ: outer_measure A) (U: A → Prop) :=
  ∀ V, μ V = μ (V ∩ U) + μ (V ∩ (compl U)).

Global Instance outer_measurable_proper {A: Type} (μ: outer_measure A) :
  Proper (@eq_prop A ==> iff) (@outer_measurable _ μ).
Proof.
  intros U V Heq.
  rewrite /outer_measurable; split.
  - intros ??. rewrite -Heq. eauto.
  - intros ??. rewrite Heq. eauto.
Qed.

Hint Resolve outer_measure_empty.

Section outer_measure_props.
  Context {A: Type}.
  Context (μ : @outer_measure A).

  Lemma outer_measure_nonneg U:
    0 <= μ U.
  Proof.
    rewrite -(outer_measure_empty μ). apply outer_measure_mono. intros x [].
  Qed.

  Hint Resolve outer_measure_nonneg Rle_ge Rge_le.

  Lemma outer_measure_finite_sub_additivity X Y:
    μ (X ∪ Y) <= μ X + μ Y.
  Proof.
    rewrite union_pair_unionF.
    assert (ex_series (λ n : nat, μ match n with
                          | 0%nat => X
                          | 1%nat => Y
                          | S (S _) => empty_set
                          end)).
    { do 2 apply ex_series_incr_1. exists 0. rewrite outer_measure_empty.
      apply is_series_0 => //=. }

    etransitivity; first eapply outer_measure_subadditivity; auto.
    rewrite Series_incr_1 // Series_incr_1; last first.
    { apply ex_series_incr_1; exists 0; rewrite outer_measure_empty; apply is_series_0 => //=. }
    rewrite outer_measure_empty. rewrite Series_0 => //=. nra.
  Qed.

  Lemma outer_measurable_ge U :
    (∀ V, μ V >= μ (V ∩ U) + μ (V ∩ (compl U))) →
    outer_measurable μ U.
  Proof.
    intros Hge V. apply Rle_antisym; last by (apply Rge_le, Hge).
    setoid_rewrite <-outer_measure_finite_sub_additivity.
    right. apply outer_measure_proper.
    rewrite -intersect_union_l union_compl intersect_top. done.
  Qed.

  Lemma null_outer_measurable U:
    μ U = 0 → outer_measurable μ U.
  Proof.
    intros HU. apply outer_measurable_ge => V.
    assert (μ (V ∩ U) = 0) as ->.
    { apply Rle_antisym; auto. rewrite -HU. apply outer_measure_mono.
      firstorder. }
    rewrite Rplus_0_l. apply Rle_ge, outer_measure_mono.
    firstorder.
  Qed.

  Lemma null_compl_outer_measurable U:
    μ (compl U) = 0 → outer_measurable μ U.
  Proof.
    intros HU. apply outer_measurable_ge => V.
    assert (μ (V ∩ (compl U)) = 0) as ->.
    { apply Rle_antisym; auto. rewrite -HU. apply outer_measure_mono.
      firstorder. }
    rewrite Rplus_0_r. apply Rle_ge, outer_measure_mono.
    firstorder.
  Qed.

  Lemma top_outer_measurable:
    outer_measurable μ (λ _, True).
  Proof. apply null_compl_outer_measurable. by rewrite compl_top. Qed.

  Lemma empty_outer_measurable:
    outer_measurable μ ∅.
  Proof. by apply null_outer_measurable. Qed.

  Lemma compl_outer_measurable U:
    outer_measurable μ U → outer_measurable μ (compl U).
  Proof.
    rewrite /outer_measurable => HU V.
    rewrite HU. rewrite compl_involutive Rplus_comm //.
  Qed.

  Lemma union_outer_measurable U1 U2:
    outer_measurable μ U1 → outer_measurable μ U2 → outer_measurable μ (U1 ∪ U2).
  Proof.
    rewrite /outer_measurable => HU1 HU2 V.
    generalize (HU1 (V ∩ (U1 ∪ U2))).
    assert ((V ∩ (U1 ∪ U2)) ∩ U1 ≡ V ∩ U1) as Hsimpl1
           by firstorder.
    assert ((V ∩ (U1 ∪ U2)) ∩ compl U1 ≡
            ((V ∩ (compl U1)) ∩ U2)) as Hsimpl2
        by firstorder.
    rewrite compl_union.
    rewrite Hsimpl1 Hsimpl2 => ->.
    rewrite Rplus_assoc ?assoc.
    rewrite -HU2. apply HU1.
  Qed.

  Lemma intersect_outer_measurable U1 U2:
    outer_measurable μ U1 → outer_measurable μ U2 → outer_measurable μ (U1 ∩ U2).
  Proof.
    intros. rewrite -(compl_involutive (U1 ∩ U2)) compl_intersect.
    by apply compl_outer_measurable, union_outer_measurable; apply compl_outer_measurable.
  Qed.

  Hint Resolve intersect_outer_measurable union_outer_measurable
               top_outer_measurable empty_outer_measurable compl_outer_measurable.

  Lemma disjoint_unionF_outer_measurable_inequality_sum_n Us:
    disjointF Us →
    (∀ i : nat, outer_measurable μ (Us i)) →
    ∀ V n, sum_n (λ i, μ (V ∩ (Us i))) n <= μ V - μ (V ∩ (compl (unionF Us))).
  Proof.
    intros Hdisj Houter.
    assert (Hind: ∀ n, ∀ V, μ V = sum_n (λ i, μ (V ∩ (Us i))) n
                            + μ (V ∩ (λ x, ∀ i, i ≤ n → ¬ Us i x))).
    { induction n => V.
      - rewrite sum_O. rewrite (Houter O V). f_equal.
        apply outer_measure_proper. intros a.
        split.
        * intros [Hv Hcompl]; split; auto => i' Hle. by inversion Hle; subst.
        * intros [Hv Hcompl]; split; auto. by apply Hcompl.
      - rewrite IHn. rewrite sum_Sn /plus//= Rplus_assoc. f_equal.
        rewrite (Houter (S n) (V ∩ (λ x : A, ∀ i : nat, i ≤ n → ¬ Us i x))).
        f_equal; apply outer_measure_proper.
        * rewrite -assoc. apply intersect_proper; first by reflexivity.
          intros x; split; first by firstorder.
          intros Hin; split; auto. intros i Hle.
          eapply disjoint_elim; try eassumption. apply Hdisj. omega.
        * rewrite -assoc. apply intersect_proper; first by reflexivity.
          intros x; split.
          ** intros [Hin1 Hin2] i. inversion 1; subst; eauto.
          ** intros Hin; split; auto. by apply Hin.
    }
    assert (Hind': ∀ n, ∀ V, μ V >= sum_n (λ i, μ (V ∩ (Us i))) n
                            + μ (V ∩ (compl (unionF Us)))).
    { intros. rewrite (Hind n). apply Rle_ge.
      apply Rplus_le_compat; first reflexivity.
      apply outer_measure_mono. apply intersect_mono; first done.
      firstorder.
    }
    intros. specialize (Hind' n V). nra.
  Qed.

  Lemma disjoint_unionF_outer_measurable_inequality Us:
    disjointF Us →
    (∀ i : nat, outer_measurable μ (Us i)) →
    ∀ V, ex_series (λ i : nat, μ (V ∩ Us i)) ∧
         Series (λ i : nat, μ (V ∩ Us i)) <= μ V - μ (V ∩ compl (unionF Us)).
  Proof.
    intros Hdisj Hmeasurable.
    specialize (disjoint_unionF_outer_measurable_inequality_sum_n Us Hdisj Hmeasurable) => Hind''.
    intros V.
    eapply (ex_series_non_neg_le_const (λ i, μ (V ∩ Us i))) in Hind'' as (Hex&?); auto.
  Qed.

  Lemma disjoint_unionF_outer_measurable Us:
    disjointF Us →
    (∀ i : nat, outer_measurable μ (Us i)) →
    outer_measurable μ (unionF Us).
  Proof.
    intros Hdisj Hmeasurable.
    apply outer_measurable_ge => V.
    edestruct (disjoint_unionF_outer_measurable_inequality Us) as (Hex&?); eauto.
    specialize (outer_measure_subadditivity μ (λ i, V ∩ Us i) Hex); eauto.
    intros Hle. rewrite intersect_unionF_l. nra.
  Qed.

  Lemma unionF_outer_measurable Us:
    (∀ i : nat, outer_measurable μ (Us i)) →
    outer_measurable μ (unionF Us).
  Proof.
    intros Hmeasure.
    rewrite diff_below_unionF.
    apply disjoint_unionF_outer_measurable.
    - apply diff_below_disjoint.
    - apply diff_below_measurable'.
      * auto.
      * apply outer_measurable_proper.
      * apply empty_outer_measurable.
      * apply compl_outer_measurable.
      * apply intersect_outer_measurable.
  Qed.

  Definition outer_measure_sigma : sigma_algebra A.
    refine {| sigma_sets := outer_measurable μ |}.
    - apply top_outer_measurable.
    - apply compl_outer_measurable.
    - apply unionF_outer_measurable.
  Defined.

  Lemma outer_measurable_additivity Us:
    (∀ i, outer_measurable μ (Us i)) →
    disjointF Us →
    is_series (λ n, μ (Us n)) (μ (unionF Us)).
  Proof.
    intros Hmeasur Hdisj.
    assert (Hsimpl1: ∀ i, (unionF Us ∩ Us i) ≡ Us i).
    {
      intros i x; split.
      * intros (?&H); done.
      * intros; split; auto. exists i; auto.
    }
    assert (Hsimpl2: (unionF Us ∩ compl (unionF Us)) ≡ ∅).
    {
      intros x; split; firstorder.
    }
    cut (ex_series (λ i, μ (Us i)) ∧ (Series (λ i, μ (Us i)) = (μ (unionF Us)))).
    { intros (?&<-). by apply Series_correct. }
    specialize (disjoint_unionF_outer_measurable_inequality Us Hdisj Hmeasur (unionF Us)).
    intros (Hex&Hseries). split; auto.
    - eapply ex_series_ext; try eassumption.
      intros n. apply outer_measure_proper, Hsimpl1.
    - rewrite Hsimpl2 outer_measure_empty Rminus_0_r in Hseries * => Hseries.
      apply Rle_antisym.
      * etransitivity; last eapply Hseries.
        right. apply Series_ext => n. by rewrite Hsimpl1.
      * apply outer_measure_subadditivity.
        eapply ex_series_ext; try eassumption.
        intros n. apply outer_measure_proper, Hsimpl1.
  Qed.

  Definition outer_measure_measure {F: measurable_space A} :
    eq_sigma F (outer_measure_sigma) →
    measure A.
  Proof.
    intros Heq.
    refine {| measure_fun := μ |}.
    - abstract (auto).
    - apply outer_measure_empty.
    - abstract (intros; apply outer_measurable_additivity; auto; try (intros; by eapply Heq)).
  Defined.

End outer_measure_props.

Definition full_measure_is_outer {A: Type} {F: measurable_space A} (μ: measure A)
          (Hfull: eq_prop F (λ _, True)) : outer_measure A.
Proof.
  refine {| outer_measure_fun := measure_fun _ μ |}.
  - abstract (intros ?? Hle; apply measure_mono; eauto; try eapply Hfull; done).
  - apply measure_empty.
  - abstract (intros; by apply measure_countable_subadditivity; eauto; intros i; eapply Hfull).
Defined.

Definition outer_pt_measure : outer_measure ().
Proof.
  refine (full_measure_is_outer pt_measure _).
  { rewrite //=. }
Defined.

Lemma outer_pt_measure_sigma_full : ∀ U, outer_measurable (outer_pt_measure) U.
Proof.
  intros U. rewrite /outer_measurable => V //=.
  destruct ClassicalEpsilon.excluded_middle_informative as [HVfull|HVempty].
  {
    destruct (ClassicalEpsilon.excluded_middle_informative (eq_prop U (λ _, True))) as
        [HUfull|HUempty].
    * assert (eq_prop (V ∩ U) (λ _, True)).
      { firstorder. }
      assert (¬ (eq_prop (V ∩ compl U) (λ _, True))).
      { firstorder. exact tt.  }
      do 2 destruct ClassicalEpsilon.excluded_middle_informative; eauto; try nra;
        intuition.
    * assert (¬ (eq_prop (V ∩ U) (λ _, True))).
      { firstorder. }
      assert (eq_prop (compl U) (λ _, True)) as Heq0.
      { intros []; split; auto. intros ? HU. apply HUempty. intros []. split; eauto. }
      assert ((eq_prop (V ∩ compl U) (λ _, True))).
      { rewrite Heq0. firstorder. }
      do 2 destruct ClassicalEpsilon.excluded_middle_informative; eauto; try nra;
        intuition.
  }
  {
    assert (¬ (eq_prop (V ∩ U) (λ _, True))).
    { firstorder. }
    assert (¬ (eq_prop (V ∩ compl U) (λ _, True))).
    { firstorder. }
      do 2 destruct ClassicalEpsilon.excluded_middle_informative; eauto; try nra;
        intuition.
  }
Qed.


(***************************************************************************
* Equivalence of big-step and small-step in call-by-value - Definitions    *
* Arthur Charguéraud, March 2009                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.

(* ********************************************************************** *)
(** ** Grammar of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm.

(* ********************************************************************** *)
(** ** Operation to open up abstractions. *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  end.

Definition open t u := open_rec 0 u t.

Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(* ********************************************************************** *)
(** ** Definition of well-formedness of a term *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1).

(* ********************************************************************** *)
(** ** Definition of the body of an abstraction *)

Definition body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** ** Definition of the small-step semantics *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

Inductive beta : trm -> trm -> Prop :=
  | beta_red : forall t1 t2,
      body t1 ->
      value t2 ->
      beta (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | beta_app1 : forall t1 t1' t2,
      term t2 ->
      beta t1 t1' ->
      beta (trm_app t1 t2) (trm_app t1' t2)
  | beta_app2 : forall t1 t2 t2',
      value t1 ->
      beta t2 t2' ->
      beta (trm_app t1 t2) (trm_app t1 t2').

Inductive beta_star : trm -> trm -> Prop :=
  | beta_star_refl : forall t,
      term t ->
      beta_star t t
  | beta_star_step : forall t2 t1 t3,
      beta t1 t2 ->
      beta_star t2 t3 ->
      beta_star t1 t3.

(* ********************************************************************** *)
(** ** Definition of the big-step semantics *)

Inductive reds : trm -> trm -> Prop :=
  | reds_val : forall t1,
      value t1 ->
      reds t1 t1
  | reds_red : forall t3 v2 v3 t1 t2,
      reds t1 (trm_abs t3) ->
      reds t2 v2 ->
      reds (t3 ^^ v2) v3 ->
      reds (trm_app t1 t2) v3.

(* ********************************************************************** *)
(** ** Definition of the big-step semantics *)

Definition equivalence := forall t v,
  reds t v <-> beta_star t v /\ value v.


Require Import NormTypes.irreleventQuantifiers.
(* A normalizeed type is the image of a type A by a function nf: A ->
   B. nf is not supposed to beinjective so this defines a quotient on
   A. *)
Section Norm.
  Context {A B:Type}.
  Variable nf: A -> B.
  Definition Norm := { b | irr (iexists a, b = nf a) }. (* irrelevant existential proof. *)
  (* Given a:A, its equivalence class is given by (nf a). *)
  Definition class (a:A):Norm := isig_intro _ (nf a) (iex_intro _ a eq_refl).

  Definition extract (x:Norm): B :=
    match x with
    | isig_intro _ res _ => res
    end.

  Definition lift (X:Type) (f:B -> X): Norm -> X := fun a:Norm => f (extract a).

  Definition liftR:= fun (R:B -> B -> Prop) => fun a b:Norm => R (extract a) (extract b).

  (* Lemma facile (P:B -> Prop):     forall b: B, P b -> forall a:A, nf a = b -> lift _ P (class a). *)
  Lemma facile: forall (C:Type) (f:B -> C),
    forall b: B, forall a:Norm, extract a = b -> lift _ f a = f b.
  Proof.
    intros C f b a H.
    unfold lift.
    rewrite H.
    reflexivity.
  Qed.

  Lemma facile2C (C:Type) (f:B -> B -> C):
    forall b b': B, forall a a':Norm, extract a = b ->
                                      extract a' = b'
                                      -> lift _ ((lift _ f a)) a' = f b b'.
  Proof.
    intros b b' a a' H H0.
    erewrite facile.
    2:eassumption.
    erewrite facile.
    2:eassumption.
    reflexivity.
  Qed.

  Lemma facile2 (P:B -> B -> Prop):
    forall b b': B, P b b' -> forall a a':Norm, extract a = b ->
                                                extract a' = b'
                                                -> lift _ ((lift _ P a)) a'.
  Proof.
    intros b b' H a a' H0 H1.
    erewrite facile2C;eauto.
  Qed.

  Definition eqS := (liftR eq).

  Lemma eqS_eq: forall x y, eqS x y -> eq x y.
  Proof.
    intros x y H.
    unfold eqS,liftR in *.
    destruct x;destruct y.
    simpl in *.
    subst.
    reflexivity.
  Qed.

End Norm.


Require Export CatSem.CAT.smon_cats.
Require Export CatSem.CAT.nat_iso.

Require Export CatSem.CAT.cat_SET. (* for the example *)

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section monoidal_cat_def.

Variable obC: Type.
Variable morC: obC -> obC -> Type.

Variable C: Cat_struct morC.

Section Diagram_def.

Notation "a 'X' b" := (build_prod_mor _ _ a b) (at level 44).

Variable tens: Functor (PROD C C) C.
Variable Alpha:
   NISO (CompF (iso C C C) (CompF (Prod_functor (Id C) tens) tens))
                                (CompF (Prod_functor tens (Id C)) tens).

Definition penta_diag := forall z: PROD C (PROD C (PROD C C)),
          let (a, t) := z in
          let (b, r) := t in
          let (c, d) := r in
        Alpha ((a,b),tens(c,d)) ;; Alpha ((tens (a,b),c),d) ==
              #tens  (id a X Alpha ((b,c),d)) ;;
              Alpha ((a,(tens (b,c)),d)) ;;
              #tens (Alpha ((a,b),c) X id d).
(*
Definition penta_diag :=
 forall z: PROD C (PROD C (PROD C C)),
          let (a, t) := z in
          let (b, r) := t in
          let (c, d) := r in
           Alpha ((a, b), tens (c, d)) o Alpha ((tens (a, b), c), d) ==
           Fmor (Functor := tens) (a:= (a, (tens (b, (tens (c, d))))))
                                  (b:= (a, (tens (tens (b, c), d))))
                    (id a , Alpha ((b, c), d)) o
           Alpha ((a, (tens (b, c)), d)) o
           Fmor (Functor := tens) (a := (tens (a, tens (b, c)), d))
                                  (b := (tens (tens (a, b), c), d))
                                (Alpha ((a, b), c), id d).
*)

Variable I: obC.
Variable Lambda: NISO (CompF (eleft C I) tens) (Id C).
Variable Rho: NISO (CompF (eright C I) tens) (Id C).

Definition lam_rho_dia :=
        forall a c: obC,
 Alpha ((a, I), c) ;; #tens ( Rho a X id c ) ==
         #tens ( id a X Lambda c ).
(*
Definition lam_rho_dia  :=
          forall a c: C,
                Alpha ((a, I), c) o
                Fmor (Functor:= tens) (a:= (tens (a, I), c))
                                       (b:= (a, c))
                              (Rho a, id c)
          ==

                Fmor (Functor:= tens) (a:= (a, tens (I, c)))
                                      (b:= (a, c))
                            (id a, Lambda c).
*)

Definition eq_lam_rho:= Lambda I == Rho I.

End Diagram_def.

End monoidal_cat_def.

Section bla.
(* Variable obC:Type.
Variable morC: obC -> obC -> Type. *)

Class mon_cat `{obC:Type, morC:obC -> obC -> Type, C: (Cat_struct obC morC)} := {
  tens : Functor (PROD C C) C;
  I: obC;
  Alpha: NISO (CompF (iso C C C) (CompF (Prod_functor (Id C) tens) tens))
                                (CompF (Prod_functor tens (Id C)) tens);
  Lambda: NISO (CompF (eleft C I) tens) (Id C);
  Rho: NISO (CompF (eright C I) tens) (Id _);
  tens_penta: penta_diag Alpha;
  lam_rho: lam_rho_dia Alpha Lambda Rho;
  eq_l_r: eq_lam_rho Lambda Rho
}.

End bla.

(** this gives a universe inconsistency *)
(**
[
Program Instance CAT_mon_cat : mon_cat (C:=Cat_CAT).
Next Obligation.

Admitted.      (* KAWOOM *)
]
*)

(**  a smon is a mon cat *)
(*
Section smon_imp_mon.

Variable C: Category.

Hypothesis H: smon_cat C.

Let T := @tensor C H.
Let H1 := @tensor_assoc C H.
Let H2 := @eleft_unit C H.
Let H3 := @eright_unit C H.

Program Instance alpha_from_smon :
NT
  (CompF (iso C C C)
     (CompF (Prod_functor (C:=C) (D:=C) (C':=PROD C C) (D':=C) (Id C) tensor)
        tensor))
  (CompF (Prod_functor (C:=PROD C C) (D:=C) (C':=C) (D':=C) tensor (Id C))
     tensor).

Next Obligation.
     unfold Comp_Fobj.  simpl. unfold prod_Fobj.
     destruct c as [[a b] c]. simpl in *|-*.
     unfold eq_Functor1 in H1.
     set (H':= @H1 ((a, b), c)((a, b), c)(id (Cat:= PROD (PROD C C) C) _)).
     simpl in *|-*.
     set (H'':= Equal_hom_src H').
     unfold Comp_Fobj, Prod_functor in H''. simpl in H''.
     unfold prod_Fobj in H''. simpl in H''.
     rewrite H''.
     apply id.
Defined.

Next Obligation.
  Proof. unfold trafo_comm, alpha_from_smon_obligation_1.
         simpl.
         intros c d f.
         destruct c as [[c1 c2] c3].
         destruct d as [[d1 d2] d3].
         destruct f as [[f1 f2] f3].
         simpl in *|-*.
         unfold Comp_Fmor. simpl. unfold prod_Fmor. simpl.
         rewrite <- NTcomm.

(id (tensor (a, tensor (b, c))))).

Program Instance mon_from_smon: mon_cat C := {
  tens := tensor;
  I := e
}.
Next Obligation.
  unfold CompF. simpl.

NISO
  (CompF (iso C C C)
 (CompF (Prod_functor (C:=C) (D:=C) (C':=PROD C C) (D':=C) (Id C) tensor)
        tensor))
  (CompF (Prod_functor (C:=PROD C C) (D:=C) (C':=C) (D':=C) tensor (Id C))
     tensor)

*)

(** SET is a mon cat *)

Section SET_mon_cat.

Definition prod_set (a b:Set) : Set := prod a b.

Program Definition set_prod_functor:
     Functor (PROD SET SET) SET := Build_Functor
  (Fobj := fun x => prod_set (fst x) (snd x))
   (Fmor := fun a b f => fun x => ((fst f) (fst x), (snd f) (snd x))) _ .
Next Obligation.
Proof.
  constructor.

  unfold Proper. red. simpl.
  intros a b x y H x0.
  destruct a as [a1 a2].
  destruct b as [b1 b2].
  destruct x as [x1 x2].
  destruct y as [y1 y2].
  destruct x0 as [w z].
  simpl in *|-*.
  rewrite (proj1 H).
  rewrite (proj2 H).
  auto.

  simpl.
  intros a x;
  destruct x;
  auto.

  simpl.
  auto.
Qed.

Definition I_set := unit.

Program Definition alpha_set :
NT (CompF (iso SET SET SET)
  (CompF (Prod_functor (Id SET) set_prod_functor) set_prod_functor))
   (CompF (Prod_functor set_prod_functor (Id SET)) set_prod_functor):=
Build_NT

(trafo := fun z x => ( (fst x, fst (snd x)), snd (snd x))) _ .
Next Obligation.
Proof.
  constructor.
  intros;
  simpl;
  auto.
Qed.

Program Instance alpha_invertible z : Invertible (alpha_set z) := {
  inverse := fun x =>
           (fst (fst x), (snd (fst x), (snd x)))
}.
Next Obligation.
Proof.
  destruct x as [[x1 x2] x3].
  simpl. auto.
Qed.
Next Obligation.
Proof.
  destruct x as [x1 [x2 x3]];
  simpl. auto.
Qed.

Program Instance alpha_set_NISO : NISO_struct alpha_set.

Definition alpha_SET : NISO (CompF (iso SET SET SET)
  (CompF (Prod_functor (Id SET) set_prod_functor) set_prod_functor))
   (CompF (Prod_functor set_prod_functor (Id SET)) set_prod_functor) :=
   Build_NISO (*niso_struct := *) alpha_set_NISO.

Program Definition lambda_set :
     NT (CompF (eleft SET I_set) set_prod_functor) (Id SET) :=
     Build_NT (trafo := fun z x => snd x) _ .
Next Obligation.
Proof.
  constructor.
  intros.
  simpl.
  auto.
Qed.

Program Instance lambda_invertible z : Invertible (lambda_set z) := {
  inverse := fun x => (tt,x)
}.
Next Obligation.
Proof.
  destruct x as [xa xb].
  simpl in *.
  unfold I_set in xa.
  elim xa.
  auto.
Qed.

Program Instance lambda_set_NISO : NISO_struct lambda_set.

Definition lambda_SET := Build_NISO lambda_set_NISO.

Program Definition rho_set :
     NT (CompF (eright SET I_set) set_prod_functor) (Id SET) :=
     Build_NT (trafo := fun z x => fst x) _ .
Next Obligation.
Proof.
  constructor.
  intros.
  simpl.
  auto.
Qed.

Program Instance rho_invertible z : Invertible (rho_set z) := {
  inverse := fun x => (x,tt)
}.
Next Obligation.
Proof.
  destruct x as [xa xb].
  simpl in *.
  unfold I_set in xa.
  elim xb.
  auto.
Qed.

Program Instance rho_set_NISO : NISO_struct rho_set.

Definition rho_SET := Build_NISO rho_set_NISO.

Program Instance SET_MONOIDAL : mon_cat (C:=SET) := {
  Alpha := alpha_SET;
  Rho := rho_SET;
  Lambda := lambda_SET
}.
Next Obligation.
Proof.
  unfold penta_diag.
  intro z.
  destruct z as [a [b [c d]]].
  simpl.
  intro x.
  destruct x as [xa [xb [xc xd]]].
  simpl in *.
  auto.
Qed.
Next Obligation.
Proof.
  unfold lam_rho_dia.
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  unfold eq_lam_rho.
  simpl.
  intro x;
  destruct x as [xa xb];
  simpl in *.
  unfold I_set in *.
  elim xa.
  elim xb.
  auto.
Qed.

End SET_mon_cat.


(** Imports *)

Require Export UniMath.Foundations.Propositions.

Axiom fill_me : forall {X : UU}, X. (* Remove this line when you are finished. *)

(** * The type of sets i.e. of types of h-level 2 in [UU] *)

Definition hSet : UU := ∑ X : UU, isaset X.
Definition hSetpair (X : UU) (i : isaset X) := tpair isaset X i : hSet.
Definition pr1hSet : hSet -> UU := @pr1 UU (λ X : UU, isaset X).
Coercion pr1hSet: hSet >-> UU.

Definition setproperty (X : hSet) := pr2 X.

(** * Applications of Hedberg's theorem *)

(** Define a map from [bool] to [UU] that maps
    [true] to [unit] (the one-element type) and
    [false] to [empty] (the empty type).
*)
Definition bool_to_type : bool -> UU
  := bool_rect (λ _ : bool, UU) unit empty.

(** Show that there is no path from [true] to [false]. *)
Theorem no_path_from_true_to_false : true != false.
Proof.
  apply fill_me.
Defined.

(** Show that there is no path from [false] to [true]. *)
Theorem no_path_from_false_to_true : false != true.
Proof.
  apply fill_me.
Defined.

(** Construct decidable equality on [bool]. *)
Theorem isdeceqbool : isdeceq bool.
Proof.
  unfold isdeceq. intros x' x. induction x.
  - induction x'.
    + unfold decidable.
      apply fill_me.
    + apply fill_me.
  - induction x'.
    + apply fill_me.
    + apply fill_me.
Defined.

Check isasetifdeceq.

Theorem isaset_bool : isaset bool.
Proof.
  apply fill_me.
Defined.

(** * [nat] is a set *)

(** Define a map from [nat] to [UU] that maps
    [0] to the singleton type and
    [S n] to the empty type for any [n].
*)
Definition nat_to_type : nat -> UU
  := nat_rect _ unit (fun _ _ => empty).

Lemma no_path_from_zero_to_successor (x : nat) : 0 != S x.
Proof.
  apply fill_me.
Defined.

Lemma no_path_from_successor_to_zero (x : nat) : S x != 0.
Proof.
  apply fill_me.
Defined.

(** Define a predecessor function on [nat]:
    [0] is mapped to [0]
    [S m] is mapped to [m]
 *)
Definition predecessor : nat -> nat
  := nat_rect _ 0 (fun m (r : nat) => m).

Lemma invmaponpathsS (n m : nat) : S n = S m -> n = m.
Proof.
  apply fill_me.
Defined.

(** The following constant will be useful for the next lemma. *)
Check @negf.

Lemma noeqinjS (x x' : nat) : x != x' -> S x != S x'.
Proof.
  apply fill_me.
Defined.

Theorem isdeceqnat : isdeceq nat.
Proof.
  apply fill_me.
Defined.

Lemma isasetnat : isaset nat.
Proof.
  apply fill_me.
Defined.

(** * Functions in sets *)

Definition is_injective {X Y : hSet} (f : X -> Y) : UU
  := ∏ (x x': X), f x = f x' -> x = x'.

(* This is a useful lemma for checking that dependent function types are propositions or sets *)
Check impred.

Lemma isaprop_is_injective {X Y : hSet} (f : X -> Y)
  : isaprop (is_injective f).
Proof.
  apply fill_me.
Defined.
(** Question: does the above proof need both X and Y to be sets? *)

(** * The universe is not a set *)
(** The next result requires univalence *)

Require Import UniMath.Foundations.UnivalenceAxiom.

Module universe_is_not_a_set.

  (* We will show that bool has a weak equivalence besides the identity. *)

  Lemma isweq_negb : isweq negb.
  Proof.
    use gradth.
    - exact negb.
    - intro x. induction x; apply idpath.
    - intro x; induction x; apply idpath.
  Defined.

  Definition weq_negb : bool ≃ bool := make_weq negb isweq_negb.

  (* Show that negb is not equal to the identity.
     It suffices, using toforallpaths, to show that they differ on some element. *)
  Check toforallpaths.

  Lemma no_path_weq_negb_idweq : weq_negb != idweq bool.
  Proof.
    apply fill_me.
  Defined.

  (* Using Univalence, we can show that if the universe were a set, then
     negb would have to be equal to the identity. *)

  Definition isaset_UU_gives_path_weq_negb_idweq
    : isaset UU → weq_negb = idweq bool.
  Proof.
    intro H.
    set (H':= H bool bool).
    set (T:= invmaponpathsweq (invweq (make_weq _ (univalenceAxiom bool bool)))).
    apply T.
    apply H'.
  Defined.

  Definition not_isaset_UU : ¬ isaset UU.
  Proof.
    apply fill_me.
  Defined.

End universe_is_not_a_set.

(** * Relations *)

(** ** Definitions *)

Definition hrel (X : UU) : UU := X -> X -> hProp.

Definition isrefl {X : UU} (R : hrel X) : UU
  := ∏ x : X, R x x.
Definition istrans {X : UU} (R : hrel X) : UU := fill_me.
Definition issymm {X : UU} (R : hrel X) : UU := fill_me.

Definition ispreorder {X : UU} (R : hrel X) : UU := istrans R × isrefl R.

Definition iseqrel {X : UU} (R : hrel X) : UU := ispreorder R × issymm R.

Definition iseqrelconstr {X : UU} {R : hrel X}
           (trans0 : istrans R)
           (refl0 : isrefl R)
           (symm0 : issymm R)
  : iseqrel R
  := make_dirprod (make_dirprod trans0 refl0) symm0.

(** ** Eqivalence relations *)

Definition eqrel (X : UU) : UU
  := ∑ R : hrel X, iseqrel R.
Definition eqrelpair {X : UU} (R : hrel X) (is : iseqrel R)
  : eqrel X
  := tpair (λ R : hrel X, iseqrel R) R is.
Definition eqrelconstr {X : UU} (R : hrel X)
           (is1 : istrans R) (is2 : isrefl R) (is3 : issymm R) : eqrel X
  := eqrelpair R (make_dirprod (make_dirprod is1 is2) is3).

Definition pr1eqrel (X : UU) : eqrel X -> (X -> (X -> hProp)) := @pr1 _ _.
Coercion pr1eqrel : eqrel >-> Funclass.

Definition eqreltrans {X : UU} (R : eqrel X) : istrans R := pr1 (pr1 (pr2 R)).
Definition eqrelrefl {X : UU} (R : eqrel X) : isrefl R := pr2 (pr1 (pr2 R)).
Definition eqrelsymm {X : UU} (R : eqrel X) : issymm R := pr2 (pr2 R).

(** * The type of subtypes of a given type *)

Definition hsubtype (X : UU) : UU := X -> hProp.

(** The carrier of a subtype *)
Definition carrier {X : UU} (A : hsubtype X) : UU := ∑ x : X, A x.

Check isasethProp.
Check (impred 2).

Lemma isasethsubtype (X : UU) : isaset (hsubtype X).
Proof.
  apply fill_me.
Defined.

(** ** A subtype with paths between any two elements is an [hProp]. *)

Lemma isapropsubtype {X : UU} (A : hsubtype X)
      (is : ∏ (x1 x2 : X), A x1 -> A x2 -> x1 = x2)
  : isaprop (carrier A).
Proof.
  apply invproofirrelevance.
  intros x x'.
  assert (X0 : isincl (@pr1 _ A)).
  {
    apply isinclpr1.
    intro x0.
    apply (pr2 (A x0)).
  }
  apply (invmaponpathsincl (@pr1 _ A) X0).
  induction x as [ x0 is0 ].
  induction x' as [ x0' is0' ].
  simpl.
  apply (is x0 x0' is0 is0').
Defined.

(** ** Equivalence classes with respect to a given relation *)

Definition iseqclass {X : UU} (R : hrel X) (A : hsubtype X) : UU
  :=
    ∥ carrier A ∥ (* is non-empty *)
      ×
      ((∏ x1 x2 : X, R x1 x2 -> A x1 -> A x2)
         ×
         (∏ x1 x2 : X, A x1 -> A x2 -> R x1 x2)).

Definition iseqclassconstr {X : UU} (R : hrel X) {A : hsubtype X}
           (ax0 : ishinh (carrier A))
           (ax1 : ∏ x1 x2 : X, R x1 x2 -> A x1 -> A x2)
           (ax2 : ∏ x1 x2 : X, A x1 ->  A x2 -> R x1 x2)
  : iseqclass R A
  := make_dirprod ax0 (make_dirprod ax1 ax2).

Definition eqax0 {X : UU} {R : hrel X} {A : hsubtype X}
  : iseqclass R A -> ishinh (carrier A)
  := λ is : iseqclass R A, pr1 is.
Definition eqax1 {X : UU} {R : hrel X} {A : hsubtype X}
  : iseqclass R A -> ∏ x1 x2 : X, R x1 x2 -> A x1 -> A x2
  := λ is : iseqclass R A, pr1 (pr2 is).
Definition eqax2 {X : UU} {R : hrel X} {A : hsubtype X}
  : iseqclass R A -> ∏ x1 x2 : X, A x1 -> A x2 -> R x1 x2
  := λ is : iseqclass R A, pr2 (pr2 is).

Lemma isapropiseqclass {X : UU} (R : hrel X) (A : hsubtype X)
  : isaprop (iseqclass R A).
Proof.
  apply isofhleveldirprod.
  - apply propproperty.
  - apply fill_me.
Defined.

(** ** Setquotient defined in terms of equivalence classes *)

Definition setquot {X : UU} (R : hrel X) : UU
  := ∑ A : hsubtype X, iseqclass R A.

Definition setquotpair {X : UU} (R : hrel X) (A : hsubtype X)
           (is : iseqclass R A)
  : setquot R
  := A ,, is.

Definition pr1setquot {X : UU} (R : hrel X)
  : setquot R -> hsubtype X
  := @pr1 _ (λ A : _, iseqclass R A).
Coercion pr1setquot : setquot >-> hsubtype.

Lemma isinclpr1setquot {X : UU} (R : hrel X) : isincl (pr1setquot R).
Proof.
  apply isinclpr1.
  intro x0.
  apply isapropiseqclass.
Defined.

Definition setquottouu0 {X : UU} (R : hrel X) (a : setquot R)
  := carrier (pr1 a).
Coercion setquottouu0 : setquot >-> UU.

Theorem isasetsetquot {X : UU} (R : hrel X) : isaset (setquot R).
Proof.
  apply (isasetsubset (@pr1 _ _) (isasethsubtype X)).
  apply isinclpr1setquot.
Defined.

Theorem setquotpr {X : UU} (R : eqrel X) : X -> setquot R.
Proof.
  intro x.
  set (rax := eqrelrefl R).
  set (sax := eqrelsymm R).
  set (tax := eqreltrans R).
  apply (tpair _ (λ x0 : X, R x x0)).
  split.
  - exact (hinhpr (tpair _ x (rax x))).
  - split; intros x1 x2 X1 X2.
    + exact fill_me.
    + exact fill_me.
Defined.

Lemma setquotl0 {X : UU} (R : eqrel X) (c : setquot R) (x : c) :
  setquotpr R (pr1 x) = c.
Proof.
  Set Printing Coercions.
  apply (invmaponpathsincl _ (isinclpr1setquot R)).
  Unset Printing Coercions.
  apply funextsec; intro x0.
  apply hPropUnivalence; intro r.
  - exact fill_me.
  - exact fill_me.
Defined.

Theorem issurjsetquotpr {X : UU} (R : eqrel X) : issurjective (setquotpr R).
Proof.
  unfold issurjective.
  intro c. apply (@hinhuniv (carrier c)).
  - intro x. apply hinhpr.
    use tpair.
    + exact (pr1 x).
    + apply setquotl0.
  - apply (eqax0 (pr2 c)).
Defined.

Lemma iscompsetquotpr {X : UU} (R : eqrel X) (x x' : X)
  : R x x' -> setquotpr R x = setquotpr R x'.
Proof.
  intro r.
  Set Printing Coercions.
  apply (invmaponpathsincl _ (isinclpr1setquot R)).
  Unset Printing Coercions.
  simpl. apply funextsec.
  intro x0. apply hPropUnivalence.
  - intro r0. exact fill_me.
  - intro x0'. exact fill_me.
Defined.

(** *** Universal property of [seqtquot R] for functions to sets satisfying compatibility condition [iscomprelfun] *)

Definition iscomprelfun {X Y : UU} (R : hrel X) (f : X -> Y) : UU
  := ∏ x x' : X, R x x' -> f x = f x'.

Lemma isapropimeqclass {X : UU} (R : hrel X) (Y : hSet) (f : X -> Y)
      (is : iscomprelfun R f) (c : setquot R) :
  isaprop (image (λ x : c, f (pr1 x))).
Proof.
  apply isapropsubtype.
  intros y1 y2. simpl.
  apply (@hinhuniv2 _ _ (make_hProp (y1 = y2) (pr2 Y y1 y2))).
  intros x1 x2. simpl.
  destruct c as [ A iseq ].
  destruct x1 as [ x1 is1 ]. destruct x2 as [ x2 is2 ].
  destruct x1 as [ x1 is1' ]. destruct x2 as [ x2 is2' ].
  simpl in is1. simpl in is2. simpl in is1'. simpl in is2'.
  assert (r : R x1 x2) by apply (eqax2 iseq _ _ is1' is2').
  apply ( !is1 @  (is _ _ r) @ is2).
Defined.

Definition setquotuniv {X : UU} (R : hrel X) (Y : hSet) (f : X -> Y)
        (is : iscomprelfun R f) (c : setquot R) : Y.
Proof.
  apply (pr1image (λ x : c, f (pr1 x))).
  apply (@squash_to_prop (carrier c)).
  - apply (eqax0 (pr2 c)).
  - apply isapropimeqclass. apply is.
  - unfold carrier. apply prtoimage.
Defined.

(** Note : the axioms rax, sax and trans are not used in the proof of
  setquotuniv. If we consider a relation which is not an equivalence relation
  then setquot will still be the set of subsets which are equivalence classes.
  Now however such subsets need not to cover all of the type. In fact their set
  can be empty. Nevertheless setquotuniv will apply. *)

Theorem setquotunivcomm {X : UU} (R : eqrel X) (Y : hSet) (f : X -> Y)
        (is : iscomprelfun R f) :
  ∏ x : X, setquotuniv R Y f is (setquotpr R x) = f x.
Proof.
  intros.
  apply idpath.
Defined.

Lemma setquotpr_eq_eqrel {X : UU} (R : eqrel X) (x x' : X)
  : setquotpr R x = setquotpr R x' → R x x'.
Proof.
  intro e.
  set (e' := maponpaths (pr1setquot R) e). simpl in e'.
  set (e'' := maponpaths (λ f : _, f x') e'). simpl in e''.
  rewrite e''.
  apply eqrelrefl.
Defined.

Theorem weqpathsinsetquot {X : UU} (R : eqrel X) (x x' : X) :
  R x x' ≃ setquotpr R x = setquotpr R x'.
Proof.
  intros.
  exists (iscompsetquotpr R x x').
  apply isweqimplimpl.
  - intro e.
    set (e' := maponpaths (pr1setquot R) e). simpl in e'.
    set (e'' := maponpaths (λ f : _, f x') e'). simpl in e''.
    rewrite e''.
    apply eqrelrefl.
  - apply propproperty.
  - apply isasetsetquot.
Defined.

(* End of file *)


From Equations Require Import Equations.
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype ssrnat ssrint ssralg ssrnum order seq path.
From favssr Require Import prelude bintree bst adt.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import Order.POrderTheory.
Import Order.TotalTheory.
Open Scope order_scope.

Section Intro.
Context {A : Type}.

Definition tree_ht A := tree (A * nat).

Definition ht (t : tree_ht A) : nat :=
  if t is Node _ (_, n) _ then n else 0.

Definition node (l : tree_ht A) (a : A) (r : tree_ht A) : tree_ht A :=
  Node l (a, maxn (ht l) (ht r) + 1) r.

Fixpoint avl (t : tree_ht A) : bool :=
  if t is Node l (_, n) r
    then [&& `|height l - height r| <= 1%N, n == maxn (height l) (height r) + 1, avl l & avl r]
    else true.

Lemma avl_ind (P : tree_ht A -> Prop) :
  P (Leaf (A*nat)) ->
  (forall l a r,
   `|height l - height r| <= 1%N ->
   avl l -> avl r ->
   P l -> P r ->
   P (Node l (a,maxn (height l) (height r) + 1) r)) ->
  forall t, avl t -> P t.
Proof.
move=>Pl Pn; elim=>//= l IHl [a n] r IHr /and4P [D /eqP -> Hcl Hcr].
by apply: Pn=>//; [apply: IHl| apply: IHr].
Qed.

Lemma ht_height (t : tree_ht A) : avl t -> ht t = height t.
Proof. by case: t=>//=l [a x] r /and4P [_ /eqP E _ _]. Qed.

Lemma ne_hplus2 (t1 t2 : tree_ht A) : non_empty_if (ht t1 == ht t2 + 2) t1.
Proof.
case: eqP; last by move=>_; apply: Def.
case: t1=>/=; first by rewrite addn2.
by move=>l [a n] r _; apply: Nd.
Qed.

Lemma ne_hgt (t1 t2 : tree_ht A) : non_empty_if (ht t2 < ht t1)%N t1.
Proof.
case: ltnP; last by move=>_; apply: Def.
by case: t1=>//= l [a n] r _; apply: Nd.
Qed.

End Intro.

Arguments avl_ind [A P].

(* TODO: move to prelude? *)
(* distance helpers *)

Lemma dist_leq (a b c : nat) :
  (`|a - b| <= c -> (a <= b <= a + c) || (b <= a <= b + c))%N.
Proof.
case/orP: (leq_total a b)=>/[dup] Hab =>[/distnEr|/distnEl] ->;
rewrite Hab leq_subLR=>->//=.
by rewrite orbT.
Qed.

Corollary dist_leqL (a b c : nat) :
  (`|a - b| <= c -> a <= b -> b <= a + c)%N.
Proof.
move/dist_leq; rewrite (leqNgt b a) ltn_neqAle.
move/[swap]=>->; rewrite andbT /=; case/orP=>//.
by case/andP=>/negbNE/eqP->.
Qed.

Corollary dist_leqR (a b c : nat) :
  (`|a - b| <= c -> b <= a -> a <= b + c)%N.
Proof.
move/dist_leq; rewrite (leqNgt a b) ltn_neqAle.
move/[swap]=>->; rewrite andbT /=; case/orP=>//.
by case/andP=>/negbNE/eqP->.
Qed.

Lemma distn_Dl n m : `|(n + m) - n| = m.
Proof.
have/distnEl->: (n <= n + m)%N by apply: leq_addr.
by rewrite -addnBAC // subnn.
Qed.

Corollary distn_Dr (n m : nat) : `|n - (n + m)| = m.
Proof. by rewrite distnC; apply: distn_Dl. Qed.

Lemma leq_dist n m p :
  (n <= m + p -> m <= n + p -> `|n - m| <= p)%N.
Proof.
move=>Hn Hm.
by case/orP: (leq_total n m)=>[/distnEr|/distnEl]->; rewrite leq_subLR.
Qed.

Section LogarithmicHeight.
Context {A : Type}.

Equations? fib (n: nat) : nat by wf n lt :=
fib 0 => 0;
fib 1 => 1;
fib (n.+2) => fib (n + 1) + fib n.
Proof. by apply: ssrnat.ltP; rewrite addn1. Qed.

Lemma fib_monotone : {homo fib : x y / (x <= y)%N}.
Proof.
apply: (homo_leq leqnn leq_trans)=>n.
funelim (fib n); simp fib=>//.
by apply: leq_add.
Qed.

Lemma avl_fib (t : tree_ht A) : avl t -> (fib (height t + 2) <= size1_tree t)%N.
Proof.
elim/avl_ind=>{t}//=l _ r H Hal Har Hl Hr.
case: (leqP (height l) (height r))=>Hlr; rewrite addn2; simp fib.
- rewrite addnC; apply: leq_add; last by rewrite -addnA.
  apply/leq_trans/Hl/fib_monotone; rewrite (_ : 2 = 1 + 1) // addnA leq_add2r.
  by apply: dist_leqL.
apply: leq_add; first by rewrite -addnA.
apply/leq_trans/Hr/fib_monotone; rewrite (_ : 2 = 1 + 1) // addnA leq_add2r.
by apply: dist_leqR=>//; apply: ltnW.
Qed.

Import Order.TTheory GRing.Theory Num.Theory.
Open Scope ring_scope.

Variable C : numClosedFieldType.
Definition phi : C := (1 + sqrtC 5%:R) / 2%:R.

Lemma phi_sq : phi ^+ 2 = phi + 1.
Proof.
rewrite /phi expr_div_n sqrrD expr1n sqrtCK mul1r addrAC expr2.
rewrite -(natrD _ 1) (_ : (1+5=(2+1)*2)%N) // natrM -(mulr_natr (sqrtC 5%:R)).
rewrite -mulrDl -mulf_div divff; last by rewrite pnatr_eq0.
rewrite mulr1 natrD -addrA [in LHS]mulrDl divff; last by rewrite pnatr_eq0.
by rewrite addrC.
Qed.

Lemma fib_bound n : phi ^+ n <= (fib (n + 2)) %:R.
Proof.
funelim (fib n); simp fib=>//.
- rewrite add0n; simp fib=>//; rewrite addn0 expr1 addn1 /phi.
  rewrite -(@ler_pmul2r _ 2%:R) // mulfVK; last by rewrite pnatr_eq0.
  rewrite -natrM (_ : (2*2 = 1+3)%N) // natrD mulr1n ler_add2l.
  rewrite -(@ler_pexpn2r _ 2) //; first last.
  - by rewrite nnegrE.
  - by rewrite nnegrE sqrtC_ge0; apply: ler0n.
  by rewrite sqrtCK expr2 -natrM ler_nat.
rewrite -addn2 (addn2 (n + 2)); simp fib.
rewrite exprD phi_sq mulrDr mulr1 natrD.
by apply: ler_add=>//; move: H; rewrite exprD expr1 -!addnA.
Qed.

Corollary height_bound (t : tree_ht A) : avl t -> phi ^+ (height t) <= (size1_tree t)%:R.
Proof.
move/avl_fib=>H; apply: le_trans; first by apply: fib_bound.
by rewrite ler_nat.
Qed.

(* ssrnum doesn't have general logarithms *)
(* they exist in mathcomp-analysis but it doesn't look worth it *)

(* Corollary height_bound_ln t : avl t -> height t <= (1 / ln phi) * ln (size_tree1 t). *)

End LogarithmicHeight.

Section SetImplementation.
Context {disp : unit} {T : orderType disp}.

(* rebalancing *)

Definition balL {A} (ab : tree_ht A) (u : A) (c : tree_ht A) : tree_ht A :=
  match ne_hplus2 ab c with
  | Nd a (v, _) b _ _ =>
      match ne_hgt b a with
      | Nd b1 (w, _) b2 _ _ => node (node a v b1) w (node b2 u c)
      | Def _            => node a v (node b u c)
      end
  | Def _ => node ab u c
  end.

Definition balR {A} (a : tree_ht A) (u : A) (bc : tree_ht A) : tree_ht A :=
  match ne_hplus2 bc a with
  | Nd b (v, _) c _ _ =>
      match ne_hgt b c with
      | Nd b1 (w, _) b2 _ _ => node (node a u b1) w (node b2 v c)
      | Def _            => node (node a u b) v c
      end
  | Def _ => node a u bc
  end.

(* h bal = h c + 3 only when h a = h b = h c + 1 *)
Lemma height_balL {A} (l : tree_ht A) a r :
  avl l -> avl r -> height l = height r + 2 ->
  (height (balL l a r) == height r + 2) || (height (balL l a r) == height r + 3).
Proof.
move=>Hl Hr E; rewrite /balL.
case (ne_hplus2 l r)=>[al [vl xl] bl|] /=; last by rewrite !ht_height // E eq_refl.
move=>El _; move/eqP: E; rewrite {l}El /= in Hl *;
rewrite {1}(_ : 2 = 1+1) // {1}addnA eqn_add2r => /eqP E.
case/and4P: Hl=>Habl _ Hal Hbl.
case (ne_hgt bl al)=>[bl1 [wl nl] bl2|] /=; rewrite !ht_height //; last first.
- rewrite -leqNgt=>/[dup] Hbal /maxn_idPr.
  rewrite maxnC => Em; rewrite {}Em in E; rewrite E -addn_maxl maxnCA maxnn.
  move: (dist_leqR Habl Hbal)=>/[dup] {}Habl; rewrite E leq_add2r=>/maxn_idPl ->.
  rewrite leq_eqVlt {2}addn1 ltnS E in Habl.
  case/orP: Habl; first by rewrite eqn_add2r =>/eqP->; rewrite -addnA eq_refl.
  move=>Habl; have /eqP->: height bl == height al by rewrite eqn_leq Hbal E.
  by rewrite E -2!addnA eq_refl orbT.
move/[swap]/[dup] => Habl' /ltnW {Hal Hbl} /(dist_leqL Habl) {Habl}.
rewrite leq_eqVlt {2}addn1 ltnS leqNgt {}Habl' orbF =>Ehbl Ebl.
rewrite {bl}Ebl /= in Ehbl E *; move: Ehbl.
rewrite eqn_add2r=>/eqP Ehal; rewrite -{}Ehal in E *; rewrite -addn_maxl.
set h1 := height bl1 in E *; set h2 := height bl2 in E *.
have {E}<-: maxn h1 h2 = height r.
- by move: E; rewrite maxn_addr !addn1 =>/succn_inj.
by rewrite (maxnAC h1 h2 h1) maxnn (maxnCA h2 h1 h2) !maxnn -addnA eq_refl.
Qed.

Lemma height_balR {A} (l : tree_ht A) a r :
  avl l -> avl r -> height r = height l + 2 ->
  (height (balR l a r) == height l + 2) || (height (balR l a r) == height l + 3).
Proof.
move=>Hl Hr E; rewrite /balR.
case (ne_hplus2 r l)=>[br [vr xr] cr|] /=; last by rewrite !ht_height // E eq_refl.
move=>Er; move/eqP: E; rewrite {r}Er /= in Hr *;
rewrite {1}(_ : 2 = 1+1) // {1}addnA eqn_add2r => /eqP E _.
case/and4P: Hr=>Hbcr _ Hbr Hcr.
case (ne_hgt br cr)=>[br1 [wr nr] br2|] /=; rewrite !ht_height //; last first.
- rewrite -leqNgt=>/[dup] Hcbr /maxn_idPr Em; rewrite {}Em in E.
  rewrite E -addn_maxl maxnAC maxnn.
  move: (dist_leqL Hbcr Hcbr)=>/[dup] {Hbcr}Hcbr'; rewrite E leq_add2r=>/maxn_idPr->.
  rewrite leq_eqVlt {2}addn1 ltnS E in Hcbr'.
  case/orP: Hcbr'; first by rewrite eqn_add2r =>/eqP->; rewrite -addnA eq_refl.
  move=>Hlbr; have /eqP->: height br == height cr by rewrite eqn_leq Hcbr E.
  by rewrite E -2!addnA eq_refl orbT.
move/[swap]/[dup] => Hcbr' /ltnW {Hbr Hcr} /(dist_leqR Hbcr) {Hbcr}.
rewrite leq_eqVlt {2}addn1 ltnS leqNgt {}Hcbr' orbF=>Ehbr Ebr.
rewrite {br}Ebr /= in Ehbr E *; move: Ehbr.
rewrite eqn_add2r=>/eqP Ehcr; rewrite -{}Ehcr in E *; rewrite -addn_maxl.
set h1 := height br1 in E *; set h2 := height br2 in E *.
have {E}<-: maxn h1 h2 = height l.
- by move: E; rewrite maxn_addl !addn1 =>/succn_inj.
by rewrite (maxnAC h1 h2 h1) maxnn (maxnCA h2 h1 h2) !maxnn -addnA eq_refl.
Qed.

Lemma height_balL2 {A} (l : tree_ht A) a r :
  avl l -> avl r -> height l != height r + 2 ->
  height (balL l a r) = maxn (height l) (height r) + 1.
Proof.
move=>Hl Hr E; rewrite /balL.
case (ne_hplus2 l r)=>[al [vl _] bl _|_] //=.
by rewrite !ht_height //; move/negbTE: E=>->.
Qed.

Lemma height_balR2 {A} (l : tree_ht A) a r :
  avl l -> avl r -> height r != height l + 2 ->
  height (balR l a r) = maxn (height l) (height r) + 1.
Proof.
move=>Hl Hr E; rewrite /balR.
case (ne_hplus2 r l)=>[al [vl _] bl _|_] //=.
by rewrite !ht_height //; move/negbTE: E=>->.
Qed.

Lemma avl_balL {A} (l : tree_ht A) a r :
  avl l -> avl r -> (height r - 1 <= height l <= height r + 2)%N ->
  avl (balL l a r).
Proof.
move=>Hl Hr I; rewrite /balL.
case (ne_hplus2 l r)=>[al [vl xl] bl|] /=; last first.
- rewrite Hl Hr !ht_height // eq_refl /= andbT => N.
  case/andP: I; rewrite leq_subLR addnC=>Hrl.
  rewrite leq_eqVlt; move/negbTE: N=>->/=; rewrite (_ : 2= 1+1) // addnA addn1 ltnS.
  rewrite leq_eqVlt; case/orP; first by move/eqP=>->; rewrite addn1 distSn.
  by rewrite addn1 ltnS => /distnEr ->; rewrite leEnat leq_subLR.
rewrite !ht_height // => {I}El; rewrite {l}El /= in Hl *.
rewrite (_ : 2= 1+1) // addnA eqn_add2r => /eqP E.
case/and4P: Hl=>Habl _ Hal Hbl.
case (ne_hgt bl al)=>[bl1 [wl nl] bl2|] /=; last first.
- rewrite !ht_height // !eq_refl Hr Hal Hbl /= andbT.
  rewrite -leqNgt =>/[dup] Hbal /maxn_idPr; rewrite maxnC =>Em; rewrite {}Em in E.
  move: (dist_leqR Habl Hbal); rewrite E leq_add2r=>/[dup] {}Habl /maxn_idPl->.
  by rewrite distnDr distnC andbb (distnEl Habl) leEnat leq_subLR -E.
rewrite ht_height // ht_height // => /[swap]/[dup] Habl' /ltnW /(dist_leqL Habl) {Habl}.
rewrite leq_eqVlt {2}addn1 ltnS leqNgt {}Habl' orbF =>Ehbl Ebl.
rewrite {bl}Ebl /= in Hbl Ehbl E *; case/and4P: Hbl=>D12 _ Hbl1 Hbl2.
rewrite !ht_height // !eq_refl {}Hal {}Hbl1 {}Hbl2 {}Hr -!andbA /= andbT distnDr.
move: Ehbl; rewrite eqn_add2r=>/eqP Ehal; rewrite -{}Ehal in E *.
set h1 := height bl1 in D12 E *; set h2 := height bl2 in D12 E *.
have {E}<-: maxn h1 h2 = height r.
- by move: E; rewrite maxn_addr !addn1 =>/succn_inj.
rewrite (maxnAC h1 h2 h1) maxnn (maxnCA h2 h1 h2) maxnn distnn /=.
by rewrite /maxn; case: ifP=>_; rewrite distnn distnC ?andbT.
Qed.

Lemma avl_balR {A} (l : tree_ht A) a r :
  avl l -> avl r -> (height l - 1 <= height r <= height l + 2)%N ->
  avl (balR l a r).
Proof.
move=>Hl Hr I; rewrite /balR.
case (ne_hplus2 r l)=>[br [vr xr] cr|] /=; last first.
- rewrite Hl Hr !ht_height // eq_refl /= andbT => N.
  case/andP: I; rewrite leq_subLR addnC=>Hrl.
  rewrite leq_eqVlt; move/negbTE: N=>->/=; rewrite (_ : 2= 1+1) // addnA addn1 ltnS.
  rewrite leq_eqVlt; case/orP; first by move/eqP=>->; rewrite addn1 distnS.
  by rewrite addn1 ltnS => /distnEl ->; rewrite leEnat leq_subLR.
rewrite !ht_height // => {I}Er; rewrite {r}Er /= in Hr *.
rewrite (_ : 2= 1+1) // addnA eqn_add2r => /eqP E.
case/and4P: Hr=>Hbcr _ Hbr Hcr.
case (ne_hgt br cr)=>[br1 [wr nr] br2|] /=; last first.
- rewrite !ht_height // !eq_refl Hl Hbr Hcr /= !andbT.
  rewrite -leqNgt =>/[dup] Hcbr /maxn_idPr Em; rewrite {}Em in E.
  move: (dist_leqL Hbcr Hcbr); rewrite E leq_add2r=>/[dup] {}Hbcr /maxn_idPr->.
  by rewrite distnDr distnC andbb (distnEr Hbcr) leEnat leq_subLR -E.
rewrite ht_height // ht_height // => /[swap]/[dup] Hcbr /ltnW /(dist_leqR Hbcr) {Hbcr}.
rewrite leq_eqVlt {2}addn1 ltnS leqNgt {}Hcbr orbF =>Ehbr Ebr.
rewrite {br}Ebr /= in Hbr Ehbr E *; case/and4P: Hbr=>D12 _ Hbr1 Hbr2.
rewrite !ht_height // !eq_refl {}Hl {}Hbr1 {}Hbr2 {}Hcr -!andbA /= andbT distnDr.
move: Ehbr; rewrite eqn_add2r=>/eqP Ehcr; rewrite -{}Ehcr in E *.
set h1 := height br1 in D12 E *; set h2 := height br2 in D12 E *.
have {E}<-: maxn h1 h2 = height l.
- by move: E; rewrite maxn_addl !addn1 =>/succn_inj.
rewrite (maxnAC h1 h2 h1) maxnn (maxnCA h2 h1 h2) maxnn distnn /=.
by rewrite /maxn; case: ifP=>_; rewrite distnn distnC ?andbT.
Qed.

(* insertion *)

Fixpoint insert (x : T) (t : tree_ht T) : tree_ht T :=
  if t is Node l (a,n) r then
    match cmp x a with
    | LT => balL (insert x l) a r
    | EQ => Node l (a,n) r
    | GT => balR l a (insert x r)
    end
    else Node leaf (x,1%N) leaf.

Theorem avl_insert x t :
  avl t ->
  avl (insert x t) && ((height (insert x t) == height t) || (height (insert x t) == height t + 1)).
Proof.
elim/avl_ind=>//=l a r H Hal Har /andP [Hail IHl] /andP [Hair IHr].
case: (cmp x a)=>/=.
- apply/andP; split.
  - apply: avl_balL=>//; rewrite leq_subLR addnC.
    case/dist_leq/orP: H=>/andP [H1 H2]; case/orP: IHl=>/eqP->.
    - by rewrite H2 /=; apply/(leq_trans H1)/leq_addr.
    - apply/andP; split; first by apply/(leq_trans H2)/leq_addr.
      by rewrite (_ : 2= 1+1) // addnA leq_add2r; apply/(leq_trans H1)/leq_addr.
    - apply/andP; split; first by apply/(leq_trans H1)/leq_addr.
      by rewrite (_ : 2= 1+1) // addnA; apply/(leq_trans H2)/leq_addr.
    apply/andP; split; first by rewrite -addnA; apply/(leq_trans H1)/leq_addr.
    by rewrite (_ : 2= 1+1) // addnA leq_add2r.
  case/boolP: (height (insert x l) == height r + 2)=>Hil; last first.
  - move: (height_balL2 a Hail Har Hil)=>->.
    case/orP: IHl=>/eqP->; first by rewrite eq_refl.
    case/dist_leq/orP: H=>/andP [H1 H2].
    - move/maxn_idPl: (H2)=>->; move/maxn_idPr: (H1)=>->; rewrite !eqn_add2r.
      move: H2; rewrite leq_eqVlt; case/orP; first by move/eqP=>->; rewrite eq_refl.
      rewrite addn1 ltnS => Hrl; suff: height l == height r by move=>->; rewrite orbT.
      by rewrite eqn_leq H1 Hrl.
    have/maxn_idPl->: (height r <= height l + 1)%N by apply/(leq_trans H1)/leq_addr.
    by move/maxn_idPl: H1=>->; rewrite eq_refl orbT.
  rewrite (eqP Hil) in IHl; case/orP: IHl.
  - by move=>/eqP Ehl; move: H; rewrite -{}Ehl distn_Dl.
  rewrite (_: 2= 1+1) // addnA eqn_add2r =>/eqP<-; rewrite maxn_addl.
  by case/orP: (height_balL a Hail Har (eqP Hil))=>/eqP->; rewrite -!addnA eq_refl ?orbT.
- by rewrite H Hal Har eq_refl.
apply/andP; split.
- apply: avl_balR=>//; rewrite leq_subLR addnC.
  case/dist_leq/orP: H=>/andP [H1 H2]; case/orP: IHr=>/eqP->.
  - apply/andP; split; first by apply/(leq_trans H1)/leq_addr.
    by rewrite (_ : 2= 1+1) // addnA; apply/(leq_trans H2)/leq_addr.
  - apply/andP; split; first by rewrite -addnA; apply/(leq_trans H1)/leq_addr.
    by rewrite (_ : 2= 1+1) // addnA leq_add2r.
  - by rewrite H2 /=; apply/(leq_trans H1)/leq_addr.
  apply/andP; split; first by apply/(leq_trans H2)/leq_addr.
  by rewrite (_ : 2= 1+1) // addnA leq_add2r; apply/(leq_trans H1)/leq_addr.
case/boolP: (height (insert x r) == height l + 2)=>Hir; last first.
- move: (height_balR2 a Hal Hair Hir)=>->.
  case/orP: IHr=>/eqP->; first by rewrite eq_refl.
  case/dist_leq/orP: H=>/andP [H1 H2].
  - have/maxn_idPr->: (height l <= height r + 1)%N by apply/(leq_trans H1)/leq_addr.
    by move/maxn_idPr: H1=>->; rewrite eq_refl orbT.
  move/maxn_idPr: (H2)=>->; move/maxn_idPl: (H1)=>->; rewrite !eqn_add2r.
  move: H2; rewrite leq_eqVlt; case/orP; first by move/eqP=>->; rewrite eq_refl.
  rewrite addn1 ltnS => Hrl; suff: height r == height l by move=>->; rewrite orbT.
  by rewrite eqn_leq H1 Hrl.
rewrite (eqP Hir) in IHr; case/orP: IHr.
- by move=>/eqP Ehr; move: H; rewrite -{}Ehr distn_Dr.
rewrite (_: 2= 1+1) // addnA eqn_add2r =>/eqP<-; rewrite maxn_addr.
by case/orP: (height_balR a Hal Hair (eqP Hir))=>/eqP->; rewrite -!addnA eq_refl ?orbT.
Qed.

(* deletion by replacing *)

Fixpoint split_max (l : tree_ht T) (a : T) (r : tree_ht T) : (tree_ht T * T) :=
   if r is Node lr (ar, _) rr then
       let: (r', a') := split_max lr ar rr in
       (balL l a r', a')
     else (l, a).

Fixpoint delete (x : T) (t : tree_ht T) : tree_ht T :=
  if t is Node l (a, _) r then
    match cmp x a with
    | LT => balR (delete x l) a r
    | EQ => if l is Node ll (al, _) rl then
                let: (l', a') := split_max ll al rl in
                balR l' a' r
              else r
    | GT => balL l a (delete x r)
    end
  else leaf.

Lemma avl_split_max l a r t x :
  split_max l a r = (t, x) ->
  `|height l - height r| <= 1%N -> avl l -> avl r ->
  avl t && ((height t == maxn (height l) (height r)) || (height t == maxn (height l) (height r) + 1)).
Proof.
elim: r l a t=>/=[|lr _ [ar nr] rr IHr] l a t; first by case=><- _; rewrite maxn0 eq_refl /= => _ ->.
case Hsm: (split_max lr ar rr)=>[r' a'][<- E]; rewrite {}E in Hsm.
move=>E Hl /and4P [Hr Er Hlr Hrr]; case/andP: (IHr _ _ _ Hsm Hr Hlr Hrr)=>Hr' E'.
apply/andP; split.
- apply: avl_balL=>//; rewrite leq_subLR.
  case/orP: E'=>/eqP E'; rewrite -{}E' in E; case/dist_leq/orP: E=>/andP [H1 H2].
  - rewrite leq_add2r in H2; apply/andP; split; first by apply: (leq_trans H2); apply: leq_addl.
    by rewrite (_: 2= 1+1) // addnA; apply: (leq_trans H1); apply: leq_addr.
  - rewrite -addnA in H2; rewrite H2 andbT.
    apply: leq_trans; first by apply: (leq_addr 1).
    by apply: (leq_trans H1); apply: leq_addl.
  - by rewrite addnC H2 /=; apply: (leq_trans H1); apply: leq_addr.
  apply/andP; split; first by apply: (leq_trans H1); apply: leq_addl.
  by rewrite (_: 2= 1+1) // addnA; apply: (leq_trans H2); apply: leq_addr.
case/boolP: (height l == height r' + 2)=>Hlr'; last first.
- move: (height_balL2 a Hl Hr' Hlr')=>->.
  case/orP: E'=>/eqP E'; last by rewrite -E' eq_refl orbT.
  rewrite -{}E' in E *.
  case/dist_leq/orP: E=>/andP [H1 H2].
  - rewrite leq_add2r in H2.
    move/maxn_idPr: (H1)=>->; move/maxn_idPl: (H2)=>->; rewrite !eqn_add2r.
    move: H1; rewrite leq_eqVlt; case/orP; first by move/eqP=>->; rewrite eq_refl orbT.
    rewrite addn1 ltnS => H1; suff: height l == height r' by move=>->.
    by rewrite eqn_leq H1 H2.
  move: H2; rewrite -addnA leq_eqVlt; move/negbTE: Hlr'=>-> /=; rewrite addnA addn1 ltnS => H2.
  have /eqP->: height l == height r' + 1 by rewrite eqn_leq H1 H2.
  by rewrite maxnn maxn_addl eq_refl orbT.
case/orP: E'=>/eqP<-; rewrite (eqP Hlr') addn_maxl;
case/orP: (height_balL a Hl Hr' (eqP Hlr'))=>/eqP->;
set n := height r'; apply/orP.
- by left; rewrite eq_sym; apply/eqP/maxn_idPl; rewrite (_: 2= 1+1) // addnA; apply: leq_addr.
- by right; rewrite eq_sym -addnA; apply/eqP/maxn_idPl; rewrite -addnA [X in (_ <= X)%N]addnA; apply: leq_addr.
- by left; rewrite eq_sym; apply/eqP/maxn_idPl; apply: leq_addr.
by right; rewrite eq_sym -addnA; apply/eqP/maxn_idPl; rewrite (addnC 2 1%N) addnA; apply: leq_addr.
Qed.

Theorem avl_delete x t :
  avl t ->
  avl (delete x t) && ((height t == height (delete x t)) || (height t == height (delete x t) + 1)).
Proof.
elim/avl_ind=>//=l a r H Hal Har /andP [Hail IHl] /andP [Hair IHr].
case: (cmp x a)=>/=.
- apply/andP; split.
  - apply: avl_balR=>//; rewrite leq_subLR addnC.
    case/dist_leq/orP: H=>/andP [H1 H2]; case/orP: IHl=>/eqP E'.
    - rewrite -E'; apply/andP; split; first by apply/(leq_trans H1)/leq_addr.
      by rewrite (_ : 2= 1+1) // addnA; apply/(leq_trans H2)/leq_addr.
    - apply/andP; split; last by rewrite (_ : 2= 1+1) // addnA -E'.
      by rewrite -(leq_add2r 1) -E' -addnA; apply/(leq_trans H1)/leq_addr.
    - by rewrite -E' H2 /=; apply/(leq_trans H1)/leq_addr.
    apply/andP; split; last by rewrite (_ : 2= 1+1) // addnA -E'; apply/(leq_trans H1)/leq_addr.
    by rewrite -(leq_add2r 1) -E'; apply/(leq_trans H2)/leq_addr.
  case/boolP: (height r == height (delete x l) + 2)=>Hil; last first.
  - move: (height_balR2 a Hail Har Hil)=>->.
    rewrite !addn_maxl; case/orP: IHl=>/eqP<-; first by rewrite eq_refl.
    rewrite -!addn_maxl.
    case/dist_leq/orP: H=>/andP [H1 H2].
    - have/maxn_idPr->: (height l <= height r + 1)%N by apply/(leq_trans H1)/leq_addr.
      by move/maxn_idPr: H1=>->; rewrite eq_refl.
    move/maxn_idPl: (H1)=>->; move/maxn_idPr: (H2)=>->; rewrite !eqn_add2r.
    move: H2; rewrite leq_eqVlt; case/orP; first by move/eqP=>->; rewrite eq_refl orbT.
    rewrite addn1 ltnS => Hlr; suff: height l == height r by move=>->.
    by rewrite eqn_leq H1 Hlr.
  case/orP: (height_balR a Hail Har (eqP Hil))=>/eqP->;
  case/orP: IHl=>/eqP ->; rewrite (eqP Hil);
  set d := height (delete x l); apply/orP.
  - by right; rewrite eqn_add2r maxn_addr eq_refl.
  - by right; rewrite eqn_add2r; apply/eqP/maxn_idPr; rewrite (_ : 2= 1+1) // addnA; apply: leq_addr.
  - by left; rewrite (_ : 3= 2+1) // addnA eqn_add2r maxn_addr eq_refl.
  by left; rewrite (_ : 3= 2+1) // addnA eqn_add2r; apply/eqP/maxn_idPr; rewrite (_ : 2= 1+1) // addnA; apply: leq_addr.
- case: {Hail IHl}l H Hal=>/=; first by rewrite Har max0n eq_refl orbT.
  move=>ll [al nl] rl H /and4P [Hl El Hall Harl].
  case Hsm: (split_max ll al rl)=>[l' a'].
  case/andP: (avl_split_max Hsm Hl Hall Harl)=>Hal' Hl'.
  apply/andP; split.
  - apply: avl_balR=>//; rewrite leq_subLR addnC.
    case/dist_leq/orP: H=>/andP [H1 H2]; case/orP: Hl'=>/eqP E';
    rewrite -{}E' in H1 H2.
    - rewrite -addnA in H2; rewrite H2 andbT.
      by rewrite -(leq_add2r 1); apply/(leq_trans H1); rewrite -addnA; apply: leq_addr.
    - apply/andP; split; first by apply/(leq_trans H1)/leq_addr.
      by rewrite (_ : 2= 1+1) // addnA; apply/(leq_trans H2)/leq_addr.
    - apply/andP; split; last by rewrite (_ : 2= 1+1) // addnA; apply/(leq_trans H1)/leq_addr.
      by rewrite -(leq_add2r 1); apply/(leq_trans H2)/leq_addr.
    by rewrite H2 /=; apply/(leq_trans H1)/leq_addr.
  case/boolP: (height r == height l' + 2)=>Hrl'; last first.
  - move: (height_balR2 a' Hal' Har Hrl')=>->.
    case/orP: Hl'=>/eqP E'; rewrite -{}E' in H *; last by rewrite eq_refl.
    case/dist_leq/orP: H=>/andP [H1 H2].
    - have/maxn_idPr->: (height l' <= height r)%N by apply/leq_trans/H1/leq_addr.
      by move/maxn_idPr: H1=>->; rewrite eq_refl.
    move/maxn_idPl: (H1)=>->.
    rewrite leq_add2r in H2; move/maxn_idPr: (H2)=>->; rewrite !eqn_add2r.
    move: H1; rewrite leq_eqVlt; case/orP; first by move/eqP=>->; rewrite eq_refl.
    rewrite addn1 ltnS => {}Hrl'; suff: height l' == height r by move=>->; rewrite orbT.
    by rewrite eqn_leq H2 Hrl'.
  case/orP: Hl'=>/eqP E'; rewrite -{}E' (eqP Hrl') in H *; last by move: H; rewrite distn_Dr.
  case/orP: (height_balR a' Hal' Har (eqP Hrl'))=>/eqP->; apply/orP.
  - right; rewrite eqn_add2r; apply/eqP/maxn_idPr; rewrite (_ : 2= 1+1) // addnA; apply: leq_addr.
  by left; rewrite (_ : 3= 2+1) // addnA eqn_add2r; apply/eqP/maxn_idPr; rewrite (_ : 2= 1+1) // addnA; apply: leq_addr.
apply/andP; split.
- apply: avl_balL=>//; rewrite leq_subLR addnC.
  case/dist_leq/orP: H=>/andP [H1 H2]; case/orP: IHr=>/eqP E'.
  - by rewrite -E' H2 /=; apply/(leq_trans H1)/leq_addr.
  - apply/andP; split; last by rewrite (_ : 2= 1+1) // addnA -E'; apply/(leq_trans H1)/leq_addr.
    by rewrite -(leq_add2r 1) -E'; apply/(leq_trans H2)/leq_addr.
  - rewrite -E'; apply/andP; split; first by apply/(leq_trans H1)/leq_addr.
    by rewrite (_ : 2= 1+1) // addnA; apply/(leq_trans H2)/leq_addr.
  apply/andP; split; last by rewrite (_ : 2= 1+1) // addnA -E' H2.
  by rewrite -(leq_add2r 1) -E' -addnA; apply/(leq_trans H1)/leq_addr.
case/boolP: (height l == height (delete x r) + 2)=>Hlr; last first.
- move: (height_balL2 a Hal Hair Hlr)=>->.
  rewrite !addn_maxl; case/orP: IHr=>/eqP<-; first by rewrite eq_refl.
  rewrite -!addn_maxl.
  case/dist_leq/orP: H=>/andP [H1 H2].
  - move/maxn_idPr: (H1)=>->; move/maxn_idPl: (H2)=>->; rewrite !eqn_add2r.
    move: H2; rewrite leq_eqVlt; case/orP; first by move/eqP=>->; rewrite eq_refl orbT.
    rewrite addn1 ltnS => {}Hlr; suff: height r == height l by move=>->.
    by rewrite eqn_leq H1 Hlr.
  have/maxn_idPl->: (height r <= height l + 1)%N by apply/(leq_trans H1)/leq_addr.
  by move/maxn_idPl: H1=>->; rewrite eq_refl.
case/orP: (height_balL a Hal Hair (eqP Hlr))=>/eqP->;
case/orP: IHr=>/eqP ->; rewrite (eqP Hlr);
set d := height (delete x r); apply/orP.
- by right; rewrite eqn_add2r maxn_addl eq_refl.
- by right; rewrite eqn_add2r; apply/eqP/maxn_idPl; rewrite (_ : 2= 1+1) // addnA; apply: leq_addr.
- by left; rewrite (_ : 3= 2+1) // addnA eqn_add2r maxn_addl eq_refl.
by left; rewrite (_ : 3= 2+1) // addnA eqn_add2r; apply/eqP/maxn_idPl; rewrite (_ : 2= 1+1) // addnA; apply: leq_addr.
Qed.

(* correctness via sorted lists *)

Lemma inorder_balL {A} (l : tree_ht A) a r :
  inorder_a (balL l a r) = inorder_a l ++ a :: inorder_a r.
Proof.
rewrite /balL.
case (ne_hplus2 l r)=>// al [vl _] bl {l}->/= _.
case (ne_hgt bl al)=>[bl1 [wl nl] bl2|] /=; last by rewrite -catA.
by move=>{bl}->/= _; rewrite -!catA !cat_cons -catA.
Qed.

Lemma inorder_balR {A} (l : tree_ht A) a r :
  inorder_a (balR l a r) = inorder_a l ++ a :: inorder_a r.
Proof.
rewrite /balR.
case (ne_hplus2 r l)=>// br [vr _] cr {r}->/= _.
case (ne_hgt br cr)=>[br1 [wr nr] br2|] /=; last by rewrite -catA.
by move=>{br}->/= _; rewrite -!catA !cat_cons.
Qed.

Lemma inorder_split_max l a r t x :
  split_max l a r = (t, x) ->
  inorder_a t ++ [:: x] = inorder_a l ++ a :: inorder_a r.
Proof.
elim: r l a t=>/= [|lr _ [ar nr] rr IHr] l a t; first by case=>->->.
case Hsm: (split_max lr ar rr)=>[r' a'][<- Hx] /=; rewrite {}Hx in Hsm.
by rewrite inorder_balL -(IHr _ _ _ Hsm) -catA.
Qed.

Theorem inorder_insert x t :
  bst_list_a t ->
  inorder_a (insert x t) = ins_list x (inorder_a t).
Proof.
rewrite /bst_list_a; elim: t=>//=l IHl [a n] r IHr.
rewrite sorted_cat_cons_cat=>/andP [H1 H2].
rewrite inslist_sorted_cat_cons_cat //.
case: cmpE=>Hx /=.
- case: ltgtP Hx=>//_ _; rewrite -cat1s in H2.
  by rewrite inorder_balR IHr // (cat_sorted2 H2).
- by rewrite Hx ltxx eq_refl.
by rewrite inorder_balL IHl // (cat_sorted2 H1).
Qed.

Theorem inorder_delete x t :
  bst_list_a t ->
  inorder_a (delete x t) = del_list x (inorder_a t).
Proof.
rewrite /bst_list_a /=; elim: t=>//=l IHl [a c] r IHr /[dup] H.
rewrite sorted_cat_cons_cat=>/andP [H1 H2].
rewrite dellist_sorted_cat_cons_cat //.
case: cmpE=>Hxa /=.
- case: ltgtP Hxa=>//_ _; rewrite -cat1s in H2.
  by rewrite inorder_balL IHr // (cat_sorted2 H2).
- rewrite Hxa eq_refl.
  case: {H H1 IHl}l=>//= ll [al nl] rl.
  case Hsm: (split_max ll al rl)=>[a' r'] /=.
  move: (inorder_split_max Hsm)=>Esm.
  by rewrite inorder_balR -Esm -catA.
by rewrite inorder_balR IHl // (cat_sorted2 H1).
Qed.

(* corollaries *)

Definition invariant (t : tree_ht T) := bst_list_a t && avl t.

Corollary invariant_empty : invariant leaf.
Proof. by []. Qed.

Corollary invariant_insert x t :
  invariant t -> invariant (insert x t).
Proof.
rewrite /invariant /bst_list_a => /andP [H1 H2].
apply/andP; split; last by case/andP: (avl_insert x H2).
by rewrite inorder_insert //; apply: ins_list_sorted.
Qed.

Corollary inorder_insert_list x t :
  invariant t ->
  inorder_a (insert x t) =i [predU1 x & inorder_a t].
Proof.
rewrite /invariant /bst_list_a => /andP [H1 _].
by rewrite inorder_insert //; apply: inorder_ins_list_pred.
Qed.

Corollary invariant_delete x t :
  invariant t -> invariant (delete x t).
Proof.
rewrite /invariant /bst_list_a => /andP [H1 H2].
apply/andP; split; last by case/andP: (avl_delete x H2).
by rewrite inorder_delete //; apply: del_list_sorted.
Qed.

Corollary inorder_delete_list x t :
  invariant t ->
  inorder_a (delete x t) =i [predD1 inorder_a t & x].
Proof.
rewrite /invariant /bst_list_a => /andP [H1 H2].
by rewrite inorder_delete //; apply: inorder_del_list_pred.
Qed.

Corollary inv_isin_list t :
  invariant t ->
  isin_a t =i inorder_a t.
Proof. by rewrite /invariant => /andP [H1 _]; apply: inorder_isin_list_a. Qed.

Definition SetAVL :=
  @ASetM.make _ (tree_ht T)
    leaf insert delete isin_a
    (pred_of_seq \o inorder_a) invariant
    invariant_empty inorder_a_empty_pred
    invariant_insert inorder_insert_list
    invariant_delete inorder_delete_list
    inv_isin_list.

End SetImplementation.

Section Exercises.

(* Exercise 9.1 *)

Lemma height_bound' {A} (t : tree_ht A) :
  avl t ->
  (2^ (height t)./2 <= size1_tree t)%N.
Proof.
Admitted.

(* Exercise 9.2 *)

Equations? fibt (n : nat) : tree unit by wf n lt :=
fibt 0 => Leaf _;
fibt 1 => Node (Leaf _) tt (Leaf _);
fibt (n.+2) => Node (fibt (n + 1)) tt (fibt n).
Proof. by apply: ssrnat.ltP; rewrite addn1. Qed.

Fixpoint avl0 {A} (t : tree A) : bool :=
  if t is Node l _ r
    then [&& `|height l - height r| <= 1%N, avl0 l & avl0 r]
    else true.

Lemma avl0_fibt n : avl0 (fibt n).
Proof.
Admitted.

Lemma fibt_size n : size1_tree (fibt n) = fib (n + 2).
Proof.
Admitted.

Lemma fibt_minimal {A} (t : tree_ht A) :
  avl t ->
  (size1_tree (fibt (height t)) <= size1_tree t)%N.
Proof.
Admitted.

(* Exercise 9.3 *)

Lemma acomplete_avl {A} (t : tree A) : acomplete t -> avl0 t.
Proof.
Admitted.

(* Exercise 9.4 *)
Variable (m : nat) (mnz : (0 < m)%N).

(* height-balanced tree *)

(* IMPLEMENT *)

(* Exercise 9.5 *)

Definition avl_of_list {A} (xs : seq A) : tree_ht A := leaf (* FIXME *).

(* order preservation *)

Theorem inorder_aol {A} (xs : seq A) : inorder_a (avl_of_list xs) = xs.
Proof.
Admitted.

(* AVL invariant *)

Theorem avl_aol {S : eqType} (xs : seq S) : avl (avl_of_list xs).
Proof.
Admitted.

End Exercises.

Section Optimization.
Context {disp : unit} {T : orderType disp}.

Variant bal := Lh | Bal | Rh.

Definition eqbal (b1 b2 : bal) :=
  match b1, b2 with
  | Lh, Lh => true
  | Bal, Bal => true
  | Rh, Rh => true
  | _, _ => false
  end.

Lemma eqbalP : Equality.axiom eqbal.
Proof. by move; case; case; constructor. Qed.

Canonical bal_eqMixin := EqMixin eqbalP.
Canonical bal_eqType := Eval hnf in EqType bal bal_eqMixin.

Definition tree_bal A := tree (A * bal).

Definition bal_inv (x : nat) (b : bal) (y : nat) : bool :=
  match b with
  | Lh => x == y + 1
  | Bal => y == x
  | Rh => y == x + 1
  end.

Fixpoint avl_b {A} (t : tree_bal A) : bool :=
  if t is Node l (_, b) r then
    [&& bal_inv (height l) b (height r), avl_b l & avl_b r]
    else true.

Lemma avl_b_ind {A} (P : tree_bal A -> Prop) :
  P (Leaf (A*bal)) ->
  (forall l a b r,
   bal_inv (height l) b (height r) ->
   avl_b l -> avl_b r ->
   P l -> P r ->
   P (Node l (a,b) r)) ->
  forall t, avl_b t -> P t.
Proof.
move=>Pl Pn; elim=>//= l IHl [a n] r IHr /and3P [H Hal Har].
by apply: Pn=>//; [apply: IHl| apply: IHr].
Qed.

Arguments avl_b_ind [A P].

Definition is_bal {A} (t : tree_bal A) : bool :=
  if t is Node _ (_, b) _ then b == Bal else false.

Definition incr {A} (t t' : tree_bal A) : bool :=
  ~~ is_node t || (is_bal t && ~~ is_bal t').

(* since we don't have height~balance factor link available in the computational code, *)
(* we add unused cases for pattern-matches *)

Definition rot2 {A} (a : tree_bal A) (x : A) (b : tree_bal A) (z : A) (c : tree_bal A) : tree_bal A :=
  match b with
  | Node b1 (y, bb) b2 =>
    let bb1 := if bb == Rh then Lh else Bal in
    let bb2 := if bb == Lh then Rh else Bal in
    Node (Node a (x, bb1) b1) (y, Bal) (Node b2 (z, bb2) c)
  | Leaf => leaf
  end.

(* TODO split out internal matches and formulate helper lemmas in their terms *)

Definition balL_b {A} (ab : tree_bal A) (z : A) (bb : bal) (c : tree_bal A) : tree_bal A :=
  match bb with
  | Lh => match ab with
          | Node a (x, Lh) b => Node a (x, Bal) (Node b (z, Bal) c)
          | Node a (x, Bal) b => Node a (x, Rh) (Node b (z, Lh) c)
          | Node a (x, Rh) b => rot2 a x b z c
          | Leaf => leaf
          end
  | Bal => Node ab (z, Lh) c
  | Rh => Node ab (z, Bal) c
  end.

Definition balR_b {A} (a : tree_bal A) (x : A) (bb : bal) (bc : tree_bal A) : tree_bal A :=
  match bb with
  | Lh => Node a (x, Bal) bc
  | Bal => Node a (x, Rh) bc
  | Rh => match bc with
          | Node b (z, Lh) c => rot2 a x b z c
          | Node b (z, Bal) c => Node (Node a (x, Rh) b) (z, Lh) c
          | Node b (z, Rh) c => Node (Node a (x, Bal) b) (z, Bal) c
          | Leaf => leaf
          end
  end.

Fixpoint insert_b (x : T) (t : tree_bal T) : tree_bal T :=
  if t is Node l (a, b) r
    then match cmp x a with
         | LT => let l' := insert_b x l in
                 if incr l l' then balL_b l' a b r else Node l' (a, b) r
         | EQ => Node l (a, b) r
         | GT => let r' := insert_b x r in
                 if incr r r' then balR_b l a b r' else Node l (a, b) r'
         end
    else Node leaf (x, Bal) leaf.

Definition decr {A} (t t' : tree_bal A) : bool :=
  is_node t && (~~ is_node t' || ((~~ is_bal t) && is_bal t')).

Fixpoint split_max_b {A} (l : tree_bal A) (a : A) (ba : bal) (r : tree_bal A) : tree_bal A * A :=
  if r is Node lr (ar, br) rr
    then let: (r', a') := split_max_b lr ar br rr in
         let t' := if decr r r' then balL_b l a ba r' else Node l (a, ba) r' in
         (t', a')
    else (l, a).

Fixpoint delete_b (x : T) (t : tree_bal T) : tree_bal T :=
  if t is Node l (a, ba) r
    then match cmp x a with
         | LT => let l' := delete_b x l in
                 if decr l l' then balR_b l' a ba r else Node l' (a, ba) r
         | EQ => if l is Node ll (al, bl) rl then
                   let: (l', a') := split_max_b ll al bl rl in
                   if decr l l' then balR_b l' a' ba r
                                else Node l' (a', ba) r
                   else r
         | GT => let r' := delete_b x r in
                 if decr r r' then balL_b l a ba r' else Node l (a, ba) r'
         end
    else leaf.

Lemma avl_insert_b x t :
  avl_b t ->
  avl_b (insert_b x t) && (height (insert_b x t) == height t + incr t (insert_b x t)).
Proof.
elim/avl_b_ind=>//= l a b r E Hl Hr /andP [Hal Hhl] /andP [Har Hhr].
case: (cmp x a)=>/=.
- (* x < a *)
  case: ifP=>/=; last first.
  - move=>Hi; case: b E=>/=; move/eqP: Hhl=>->/eqP->;
    by rewrite Hi !addn0 Hal Hr !eq_refl.
  (* incr l insert *)
  move=>Hi; rewrite Hi in Hhl.
  case: b E=>/eqP E /=.
  - (* b = Lh *)
    case E': (insert_b x l) Hi => [|li [ai bi] ri]/=.
    - (* insert = Leaf, impossible *)
      by move: Hhl; rewrite E' addn0 E addn1.
    (* insert = Node *)
    move: Hal Hhl; rewrite {}E' E /= maxn_addl addn0; case: bi=>/=.
    - (* bi = Lh *)
      case/and3P=>/eqP->->->/=.
      by rewrite maxn_addl !eqn_add2r=>/eqP<-; rewrite !maxnn Hr !eq_refl.
    - (* bi = Bal *)
      case: {Hl}l E; rewrite /incr /=; first by rewrite addn1.
      by move=>????; rewrite andbF.
    (* bi = Rh *)
    case/and3P; case: ri=>/=; first by rewrite addn1; move/eqP.
    move=>lri [ari bri] rri /=; rewrite eqn_add2r /bal_inv =>/eqP <- ->.
    case: bri=>/= /and3P [/eqP->->->] /=.
    - (* bri = Lh *)
      rewrite -!addn_maxl maxn_addl -addn_maxl maxn_addr !eqn_add2r =>/eqP <-.
      by rewrite maxn_addr !maxnn Hr !eq_refl.
    - (* bri = Bal *)
      by rewrite !maxnn maxn_addr !eqn_add2r=>/eqP<-; rewrite !maxnn Hr !eq_refl.
    (* bri = Rh *)
    by rewrite !maxn_addr maxn_addl !eqn_add2r=>/eqP<-; rewrite !maxnn Hr !eq_refl.
  - (* b = Bal *)
    by rewrite Hal Hr; move/eqP: Hhl=>->; rewrite E maxnn maxn_addl !eq_refl.
  (* b = Rh *)
  by rewrite Hal Hr; move/eqP: Hhl=>->; rewrite E maxnn addn0 maxn_addr !eq_refl.
- (* x == a *)
  by rewrite Hl Hr /= andbT; case: b E=>/= /eqP->; rewrite addn0 !eq_refl.
(* x > a *)
case: ifP=>/=; last first.
- move=>Hi; case: b E=>/=; move/eqP: Hhr=>->/eqP->;
  by rewrite Hi !addn0 Har Hl !eq_refl.
(* incr r insert *)
move=>Hi; case: b E=>/eqP E /=.
- (* b = Lh *)
  by rewrite Har Hl; move/eqP: Hhr=>->; rewrite Hi E maxnn addn0 maxn_addl !eq_refl.
- (* b = Bal *)
  by rewrite Har Hl; move/eqP: Hhr=>->; rewrite Hi E maxnn maxn_addr !eq_refl.
(* b = Rh *)
case E': (insert_b x r)=> [|li [ai bi] ri]/=.
- (* insert = Leaf, impossible *)
  move: Hhr; rewrite E' /=; case: (incr _ _)=>/= /eqP; first by rewrite addn1.
  by rewrite addn0 E addn1.
(* insert = Node *)
move: Hi Har Hhr; rewrite {}E' E=>/=.
rewrite maxn_addr addn0; case: bi=>/=.
- (* bi = Lh *)
  move=>->; case/and3P; case: li=>/=; first by rewrite addn1; move/eqP.
  move=>lli [ali bli] rli /=; rewrite eqn_add2r /bal_inv =>/eqP <- /[swap] ->.
  case: bli=>/= /and3P [/eqP->->->] /=.
  - (* bli = Lh *)
    by rewrite !maxn_addl maxn_addr -addn_maxl !eqn_add2r =>/eqP=><-; rewrite !maxnn Hl !eq_refl.
  - (* bli = Bal *)
    by rewrite !maxnn maxn_addl !eqn_add2r =>/eqP<-; rewrite !maxnn Hl !eq_refl.
  (* bli = Rh *)
  rewrite maxn_addl maxn_addr -!addn_maxl !eqn_add2r=>/eqP<-.
  by rewrite maxn_addl !maxnn Hl !eq_refl.
- (* bi = Bal, impossible *)
  case: {Hr}r E; rewrite /incr /=; first by rewrite addn1.
  by move=>????; rewrite andbF.
(* bi = Rh *)
move=>->; case/and3P=>/eqP->->->/=.
by rewrite !eqn_add2r maxn_addr eqn_add2r=>/eqP<-; rewrite !maxnn Hl !eq_refl.
Qed.

Lemma avl_balL_b_decr {A} (l : tree_bal A) a b r t :
  avl_b l -> avl_b r -> bal_inv (height l) b (height r + 1) ->
  avl_b (balL_b l a b r) && (maxn (height l) (height r + 1) + 1 == height (balL_b l a b r) +
                                                                   decr (Node l (a, b) t) (balL_b l a b r)).
Proof.
move=>Hl Hr; case: b=>/=.
- case: l Hl=>/=; first by move=>_ /eqP; rewrite addn1.
  move=>ll [al bl] rl /and3P [Hbl Hall Harl].
  rewrite eqn_add2r => /[dup] H' /eqP ->; rewrite -addn_maxl maxn_addl.
  case: bl Hbl=>/=; move: (H')=>/[swap]/eqP->.
  - rewrite maxn_addl !eqn_add2r=>/eqP->.
    by rewrite !maxnn !eq_refl Hall Harl Hr.
  - rewrite maxnn addn0 !eqn_add2r=>/eqP->.
    by rewrite -addn_maxl maxn_addl maxn_addr !eq_refl Hall Harl Hr.
  rewrite maxn_addr eqn_add2r =>/eqP H''.
  case: rl Harl H'=>/=.
  - by move=>_; rewrite maxn0 H'' -{1}(addn0 (height _)) eqn_add2l.
  move=>lrl [arl brl] rrl=>/= /and3P [Hlrl -> ->].
  case: brl Hlrl=>/=.
  - move/eqP->; rewrite maxn_addl H''.
    case: (ltngtP (height r) (height rrl + 1 + 1))=>_;
      try by rewrite -{1}(addn0 (height _)) eqn_add2l.
    by rewrite eqn_add2r=>/eqP<-; rewrite maxn_addr !maxnn !eq_refl Hall Hr.
  - move/eqP->; rewrite maxnn H''.
    case: (ltngtP (height r) (height lrl + 1))=>_;
      try by rewrite -{1}(addn0 (height _)) eqn_add2l.
    by rewrite eqn_add2r=>/eqP->; rewrite !maxnn !eq_refl Hall Hr.
  move/eqP->; rewrite maxn_addr H''.
  case: (ltngtP (height r) (height lrl + 1 + 1))=>_;
    try by rewrite -{1}(addn0 (height _)) eqn_add2l.
  by rewrite eqn_add2r=>/eqP<-; rewrite maxn_addl !maxnn !eq_refl Hall Hr.
- by move/eqP <-; rewrite maxn_addl maxnn addn0 !eq_refl Hl Hr.
by rewrite eqn_add2r=>/eqP->; rewrite maxn_addr maxnn !eq_refl Hl Hr.
Qed.

Lemma avl_split_max_b {A} (l : tree_bal A) a b r t x :
  split_max_b l a b r = (t, x) ->
  bal_inv (height l) b (height r) -> avl_b l -> avl_b r ->
  avl_b t && (maxn (height l) (height r) + 1 == height t + decr (Node l (a,b) r) t).
Proof.
elim: r l a b t=>/= [|lr _ [ar br] rr IHr] l a b t.
- case=><- _; rewrite maxn0 => H /[dup] E -> _ /=.
  case: b H=>/=; rewrite /decr /=.
  - rewrite add0n=>/[dup] H /eqP ->; rewrite eqn_add2l eq_sym eqb1.
    case: l E H=>//= l [z b] r.
    rewrite -{2}(add0n 1%N) eqn_add2r; case: b=>//=; case/and3P=>/eqP->_ _.
    - by rewrite maxn_addl addn1=>/eqP.
    by rewrite maxn_addr addn1=>/eqP.
  - by rewrite eq_sym=>/heightE->.
  by rewrite addn1=>/eqP.
case Hsm: (split_max_b lr ar br rr)=>[r' a']; case=><- E; rewrite {}E in Hsm.
move=>H Hl /and3P [Hbr Hlr Hrr].
case/andP: (IHr _ _ _ _ Hsm Hbr Hlr Hrr)=>Har' Hh.
case: ifP=>/= Hd; rewrite Hd /= in Hh.
- rewrite /bal_inv /= in H; rewrite (eqP Hh) in H *.
  by apply: avl_balL_b_decr.
by case: b H=>/=; rewrite (eqP Hh) addn0=>/eqP->; rewrite addn0 !eq_refl Hl Har'.
Qed.

Lemma avl_delete_b x t :
  avl_b t ->
  avl_b (delete_b x t) && (height t == height (delete_b x t) + decr t (delete_b x t)).
Proof.
elim/avl_b_ind=>//=l a b r E Hl Hr /andP [Hal Hhl] /andP [Har Hhr].
case: (cmp x a)=>/=.
- (* x < a *)
  case: ifP=>/=; last first.
  - by move=>Hi; case: b E=>/=; move/eqP: Hhl=>->;
    rewrite Hi !addn0=>/eqP->; rewrite Hal Hr !eq_refl.
  (* decr l delete *)
  move=>Hi; rewrite Hi /= in Hhl; case: b E=>E /=.
  - (* b = Lh *)
    rewrite Hal Hr; move: Hhl; rewrite (eqP E) eqn_add2r=>/eqP<-.
    by rewrite maxnn maxn_addl !eq_refl.
  - (* b = Bal *)
    rewrite Hal Hr; move: Hhl; rewrite (eqP E) maxnn =>/eqP->.
    by rewrite maxn_addr addn0 !eq_refl.
  (* b = Rh *)
  case: {Har Hhr}r Hr E=>/=; first by rewrite addn1.
  move=>lr [ar br] rr /=; case/and3P; case: br=>/=.
  - case: lr=>/=; first by rewrite addn1=>/eqP.
    move=>llr [alr blr] rlr /=; rewrite eqn_add2r=>Hrr; case: blr=>/=.
    - rewrite -(eqP Hrr); case/and3P =>/eqP-> Hallr Harlr Harr; move/eqP: Hhl=>->.
      rewrite !maxn_addl !eqn_add2r=>/eqP <-.
      by rewrite !maxn_addr !maxnn !eq_refl Hal Hallr Harlr Harr.
    - rewrite -(eqP Hrr); case/and3P=>/eqP-> Hallr Harlr Harr; move/eqP: Hhl=>->.
      rewrite maxn_addl !maxnn !eqn_add2r=>/eqP <-.
      by rewrite maxn_addr !maxnn !eq_refl Hal Hallr Harlr Harr.
    rewrite -(eqP Hrr); case/and3P =>/eqP-> Hallr Harlr Harr; move/eqP: Hhl=>->.
    rewrite !maxn_addl !maxn_addr !eqn_add2r=>/eqP <-.
    by rewrite !maxn_addr !maxn_addl !maxnn !eq_refl Hal Hallr Harlr Harr.
  - move/eqP=>-> Halr Harr; rewrite (eqP Hhl) maxnn !eqn_add2r =>/eqP->.
    by rewrite !maxn_addr maxn_addl addn0 !eq_refl Hal Halr Harr.
  move/eqP=>-> Halr Harr; rewrite (eqP Hhl) maxn_addr !eqn_add2r =>/eqP <-.
  by rewrite !maxnn maxn_addr !eq_refl Hal Halr Harr.
- (* x == a *)
  case: {Hal Hhl} l Hl E=>/=.
  - move=>_; case: b=>/=; rewrite /decr /=.
    - by rewrite addn1 => /eqP.
    - by move/heightE=>->.
    rewrite add0n max0n Hr => H /=; rewrite eqn_add2l.
    case: {Har Hhr}r Hr H=>//=lr [ar br] rr /=.
    rewrite -{2}(add0n 1%N) eqn_add2r; case: br=>//=; case/and3P=>/eqP=>->_ _.
    - by rewrite maxn_addl addn1=>/eqP.
    by rewrite maxn_addr addn1=>/eqP.
  move=>ll [al bl] rl=>/and3P [Hb Hall Harl] Hbl.
  case Hsm: (split_max_b ll al bl rl)=>[l' a'].
  case/andP: (avl_split_max_b Hsm Hb Hall Harl)=>Hal'; case: ifP=>/= Hd.
  - rewrite eqn_add2r => /eqP E'; move: Hbl; rewrite E'; case: b=>/=.
    - by rewrite eqn_add2r=>/eqP->; rewrite maxn_addl maxnn !eq_refl Hal' Hr.
    - by move/eqP=>->; rewrite maxn_addr maxnn addn0 !eq_refl Hal' Hr.
    case: {Har Hhr}r Hr=>/=; first by rewrite addn1=>/eqP.
    move=>lr [ar br] rr; rewrite eqn_add2r=>/and3P [H'' Halr Harr] E''.
    case: br H'' =>/=.
    - case: lr Halr E''=>/=; first by move=>_ _; rewrite addn1=>/eqP.
      move=>llr [alr blr] rlr; case: blr=>/= /and3P [/eqP-> Hallr Harlr].
      - rewrite maxn_addl !eqn_add2r=>/[swap]/eqP<-.
        rewrite maxn_addl eqn_add2r=>/eqP<-.
        by rewrite !maxn_addr !maxnn !eq_refl Hal' Hallr Harlr Harr.
      - rewrite maxnn !eqn_add2r=>/[swap]/eqP->.
        rewrite maxn_addl maxnn eqn_add2r=>/eqP->.
        by rewrite !maxnn maxn_addr !eq_refl Hal' Hallr Harlr Harr.
      rewrite maxn_addr !eqn_add2r=>/[swap]/eqP<-.
      rewrite maxn_addl eqn_add2r=>/eqP<-.
      by rewrite maxn_addl maxn_addr !maxnn !eq_refl Hal' Hallr Harlr Harr.
    - move: E''=>/[swap]/eqP->; rewrite maxnn=>/eqP->.
      by rewrite !maxn_addr maxn_addl addn0 !eq_refl Hal' Halr Harr.
    move: E''=>/[swap]/eqP->; rewrite maxn_addr !eqn_add2r=>/eqP->.
    by rewrite !maxnn maxn_addr !eq_refl Hal' Halr Harr.
  by rewrite addn0 Hal' Hr; move: Hbl=>/[swap]/eqP->-> /=; case: b=>/=; rewrite addn0.
(* x > a *)
case: ifP=>/=; last first.
- by move=>Hi; case: b E=>/=; move/eqP: Hhr=>->;
  rewrite Hi !addn0=>/eqP->; rewrite Har Hl !eq_refl.
(* decr l delete *)
move=>Hi; rewrite Hi /= in Hhr; case: b E=>E /=.
- (* b = Lh *)
  case: {Hal Hhl}l Hl E=>/=; first by rewrite addn1.
  move=>ll [al bl] rl /=; case/and3P; case: bl=>/=.
  - move/eqP=>-> Hall Harl; rewrite (eqP Hhr) maxn_addl !eqn_add2r =>/eqP <-.
    by rewrite !maxnn maxn_addl !eq_refl Har Hall Harl.
  - move/eqP=>-> Hall Harl; rewrite (eqP Hhr) maxnn !eqn_add2r =>/eqP->.
    by rewrite !maxn_addl maxn_addr addn0 !eq_refl Har Hall Harl.
  case: rl=>/=; first by rewrite addn1=>/eqP.
  move=>lrl [arl brl] rrl /=; rewrite eqn_add2r=>Hll Hall; case: brl=>/=.
  - rewrite -(eqP Hll); case/and3P=>/eqP-> Halrl Harrl.
    rewrite maxn_addl maxn_addr !eqn_add2r; move/eqP: Hhr=>->.
    rewrite !eqn_add2r =>/eqP <-.
    by rewrite !maxn_addr maxn_addl !maxnn !eq_refl Hall Halrl Harrl Har.
  - rewrite -(eqP Hll); case/and3P=>/eqP-> Halrl Harrl.
    rewrite maxnn maxn_addr !eqn_add2r; move/eqP: Hhr=>->.
    rewrite !eqn_add2r =>/eqP <-.
    by rewrite maxn_addl !maxnn !eq_refl Hall Halrl Harrl Har.
  rewrite -(eqP Hll); case/and3P=>/eqP-> Halrl Harrl.
  rewrite !maxn_addr maxn_addl !eqn_add2r; move/eqP: Hhr=>->.
  rewrite !eqn_add2r =>/eqP <-.
  by rewrite maxn_addl !maxnn !eq_refl Hall Halrl Harrl Har.
- (* b = Bal *)
  rewrite Har Hl; move: Hhr; rewrite (eqP E) maxnn =>/eqP->.
  by rewrite maxn_addl addn0 !eq_refl.
(* b = Rh *)
rewrite Har Hl; move: Hhr; rewrite (eqP E) eqn_add2r=>/eqP<-.
by rewrite maxnn maxn_addr !eq_refl.
Qed.

End Optimization.

Section Exercises2.

(* Exercise 9.6 *)

Fixpoint debal {A} (t : tree_bal A) : tree_ht A :=
  if t is Node l (a, _) r
    then Node (debal l) (a, maxn (height l) (height r) + 1) (debal r)
    else leaf.

Lemma avl_b_avl {A} (t : tree_bal A) : avl_b t -> avl (debal t).
Proof.
Admitted.

Fixpoint debal2 {A} (t : tree_bal A) : tree_ht A := leaf. (* FIXME *)

Lemma avl_debal_eq {A} (t : tree_bal A) : avl_b t -> debal2 t = debal t.
Proof.
Admitted.

(* Exercise 9.7 *)

Context {disp : unit} {T : orderType disp}.

Inductive tree4 A := Leaf
                   | Lh4 of (tree4 A) & A & (tree4 A)
                   | Bal4 of (tree4 A) & A & (tree4 A)
                   | Rh4 of (tree4 A) & A & (tree4 A).

(* IMPLEMENT *)

End Exercises2.