(** ** Refinement of M-types

    M-types can be refined to satisfy the right definitional equalities.
    This idea is from Felix Rech's Bachelor's thesis, and Felix
    Rech also developed together with Luis Scoccola a first formalization
    in UniMath as project work of the UniMath 2017 school. The present
    formalization was obtained as project work of the UniMath 2019 school
    and is heavily inspired by that former formalization.

    Author: Dominik Kirst (@dominik-kirst) and Ralph Matthes (@rmatthes)

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Induction.FunctorCoalgebras_legacy.
Require Import UniMath.CategoryTheory.categories.Type.Core.

Require Import UniMath.Induction.PolynomialFunctors.
Require Import UniMath.Induction.M.Core.
Require Import UniMath.Induction.M.Uniqueness.

(**
    The construction is called a refinement: as input we take any final coalgebra
    for the respective polynomial functor describing an M-type  (hence, with the
    provable coiteration rule), the output is the refined final coalgebra with the
    equational rule of coiteration holding definitionally: Lemma [corec_computation]
    is proved merely by [idpath]. Of course, both coalgebras are equal - provably
    (Lemma [coalgebras_eq]).
*)
Section Refinement.

  Context (A : UU).
  Context (B : A → UU).
  Local Notation F := (polynomial_functor A B).

  Variable M0 : coalgebra F.
  Local Notation carrierM0 := (coalgebra_ob _  M0).
  Local Notation destrM0 := (coalgebra_mor _ M0).

  Variable finalM0 : is_final M0.
  Local Notation corecM0 C := (pr11 (finalM0 C)).

  Local Open Scope cat.
  Local Open Scope functions.

  (* Refinement of the final coalgebra to computable elements *)

  Definition carrierM := ∑ m0 : carrierM0, ∃ C c, corecM0 C c = m0.

  (* Definition of the corecursor *)

  Definition corecM (C : coalgebra F) (c : coalgebra_ob _ C) : carrierM.
  Proof.
    exists (corecM0 C c). apply hinhpr. exists C, c. apply idpath.
  Defined.

  (* Definition of a proposition we factor the computation through *)

  Local Definition P (m0 : carrierM0) :=
    ∑ af : F carrierM, destrM0 m0 = # F pr1 af.

  (** in order to show [P] to be a proposition, a not obviously equivalent
    formulation is given for which it is easy to show [isaprop] *)
  Local Definition P' (m0 : carrierM0) :=
    ∑ ap : ∑ a : A, pr1 (destrM0 m0) = a,
                 ∏ (b : B (pr1 ap)),
                 ∑ mp : ∑ m0' : carrierM0,
                                transportf (λ a, B a  -> carrierM0)
                                           (pr2 ap)
                                           (pr2 (destrM0 m0)) b =
                                m0',
                                ∃ C c, corecM0 C c = pr1 mp.

  (** the easy auxiliary lemma *)
  Local Lemma P'_isaprop m0 :
    isaprop (P' m0).
  Proof.
    apply isofhleveltotal2.
    - apply isofhlevelcontr.
      apply iscontrcoconusfromt.
    - intro ap; induction ap as [a p].
      apply impred; intros b.
      apply isofhleveltotal2.
      + apply isofhlevelcontr.
        apply iscontrcoconusfromt.
      + intro mp; induction mp as [m0' q].
        apply isapropishinh.
  Defined.

  (** the crucial lemma *)
  Local Lemma P_isaprop (m0 : carrierM0) :
    isaprop (P m0).
  Proof.
    use (@isofhlevelweqb _ _ (P' m0) _ (P'_isaprop m0)).
    simple refine (weqcomp (weqtotal2asstor _ _) _).
    simple refine (weqcomp _ (invweq (weqtotal2asstor _ _))).
    apply weqfibtototal; intro a.
    intermediate_weq (
        ∑ f : B a  → carrierM,
              ∑ p : pr1 (destrM0 m0) = a,
                    transportf
                      (λ a, B a -> carrierM0)
                      p
                      (pr2 (destrM0 m0)) =
                    pr1 ∘ f).
    {
      apply weqfibtototal; intro f.
      apply total2_paths_equiv.
    }
    intermediate_weq (∑ p : pr1 (destrM0 m0) = a,
                            ∑ f : B a → carrierM,
                                  transportf
                                    (λ a, B a → carrierM0)
                                    p
                                    (pr2 (destrM0 m0)) =
                                  pr1 ∘ f).
    { apply weqtotal2comm. }
    apply weqfibtototal; intro p.
    intermediate_weq (∑ fg : ∑ f : B a -> carrierM0,
                                   ∏ b, ∃ C c, corecM0 C c = f b,
                        transportf
                          (λ a, B a -> carrierM0)
                          p
                          (pr2 (destrM0 m0)) =
                        pr1 fg).
    { use weqbandf.
      - apply weqfuntototaltototal.
      - cbn.
        intro f.
        apply idweq.
    }
    intermediate_weq (∑ f : B a  → carrierM0,
                            ∑ _ : ∏ b, ∃ C c, corecM0 C c = f b,
                        transportf
                          (λ a, B a  → carrierM0)
                          p
                          (pr2 (destrM0 m0)) =
                        f).
    { apply weqtotal2asstor. }
    intermediate_weq (∑ f : B a → carrierM0,
                            ∑ _ : ∏ b, ∃ C c, corecM0 C c = f b,
                        ∏ b, transportf
                               (λ a, B a → carrierM0)
                               p
                               (pr2 (destrM0 m0)) b =
                             f b).
    { apply weqfibtototal; intro f.
      apply weqfibtototal; intros _.
      apply weqtoforallpaths.
    }
    intermediate_weq (∑ f : B a → carrierM0,
                            ∏ b, ∑ _ : ∃ C c, corecM0 C c = f b,
                        transportf
                          (λ a, B a  → carrierM0)
                          p
                          (pr2 (destrM0 m0)) b =
                        f b).
    { apply weqfibtototal; intro f.
      apply invweq.
      apply weqforalltototal.
    }
    intermediate_weq (∏ b, ∑ m0' : carrierM0,
                                   ∑ _ : ∃ C c, corecM0 C c = m0',
                        transportf
                          (λ a, B a -> carrierM0)
                          p
                          (pr2 (destrM0 m0)) b =
                        m0').
    { apply invweq.
      apply weqforalltototal.
    }
    apply weqonsecfibers; intro b.
    intermediate_weq (∑ m0' : carrierM0,
                              ∑ _ : transportf
                                      (λ a, B a -> carrierM0)
                                      p
                                      (pr2 (destrM0 m0)) b =
                                    m0',
                                    ∃ C c, corecM0 C c = m0').
    {
      apply weqfibtototal; intro m0'.
      apply weqdirprodcomm.
    }
    intermediate_weq (∑ mp : ∑ m0', transportf (λ a, B a → carrierM0) p
                                               (pr2 (destrM0 m0)) b = m0',
                             ∃ C c, corecM0 C c = pr1 mp).
    {
      apply invweq.
      apply weqtotal2asstor.
    }
    use weqbandf.
    - apply weqfibtototal; intro m0'.
      apply idweq.
    - cbn. intro mp.
      apply idweq.
  Defined.

  (* Now the destructor of M can be defined *)

  Local Definition destrM' (m : carrierM) : P (pr1 m).
  Proof.
    induction m as [m0 H]. apply (squash_to_prop H); try apply P_isaprop.
    intros [C [c H1]].
    refine ((# F (corecM C) ∘ (pr2 C)) c,, _). cbn [pr1]. clear H.
    assert (H : is_coalgebra_homo F (corecM0 C)).
    { destruct finalM0 as [[G H] H']. apply H. }
    apply toforallpaths in H.
    apply pathsinv0.
    intermediate_path (destrM0 (corecM0 C c)).
    - apply H.
    - apply maponpaths. assumption.
  Defined.

  Definition destrM (m : carrierM) : F carrierM :=
    pr1 (destrM' m).

  Definition M : coalgebra F :=
    (carrierM,, destrM).

  (* The destructor satisfies the corecursion equation definitionally *)

  Lemma corec_computation C c :
    destrM (corecM C c) = # F (corecM C) (pr2 C c).
  Proof.
    apply idpath.
  Defined.

  (* The two carriers are equal *)

  Lemma eq_corecM0 m0 :
    corecM0 M0 m0 = m0.
  Proof.
    induction finalM0 as [[G H1] H2]. cbn.
    specialize (H2 (coalgebra_homo_id F M0)).
    change (pr1 (G,, H1) m0 = pr1 (coalgebra_homo_id F M0) m0).
    apply (maponpaths (fun X => pr1 X m0)).
    apply pathsinv0.
    assumption.
  Defined.

  Definition injectM0 m0 :
    ∃ C c, corecM0 C c = m0.
  Proof.
    apply hinhpr. exists M0, m0. apply eq_corecM0.
  Defined.

  Lemma carriers_weq :
    carrierM ≃ carrierM0.
  Proof.
    apply (weq_iso pr1 (λ m0, m0,, injectM0 m0)).
    - intros [m H]. cbn. apply maponpaths, ishinh_irrel.
    - intros x. cbn. apply idpath.
  Defined.

  Lemma carriers_eq :
    carrierM = carrierM0.
  Proof.
    apply weqtopaths, carriers_weq.
  Defined. (** needs to be transparent *)

  (* The two coalgebras are equal *)

  Local Lemma eq1 (m0 : carrierM0) :
    transportf (λ X, X → F X) carriers_eq destrM m0
    = transportf (λ X, F X) carriers_eq (destrM (transportf (λ X, X) (!carriers_eq) m0)).
  Proof.
    destruct carriers_eq. apply idpath.
  Defined.

  Local Lemma eq2 (m0 : carrierM0) :
    transportf (λ X, X) (!carriers_eq) m0 = m0,, injectM0 m0.
  Proof.
    apply (transportf_pathsinv0' (idfun UU) carriers_eq).
    unfold carriers_eq. rewrite weqpath_transport. apply idpath.
  Defined.

  Local Lemma eq3 m0 :
    destrM (m0,, injectM0 m0) = pr1 (destrM0 m0),, corecM M0 ∘ pr2 (destrM0 m0).
  Proof.
    apply idpath.
  Defined.

  Lemma coalgebras_eq :
    M = M0.
  Proof.
    use total2_paths_f; try apply carriers_eq.
    apply funextfun. intro m0.
    rewrite eq1. rewrite eq2. rewrite eq3.
    cbn. unfold polynomial_functor_obj.
    rewrite transportf_total2_const.
    use total2_paths_f; try apply idpath.
    cbn. apply funextsec. intros b. rewrite <- helper_A.
    unfold carriers_eq. rewrite weqpath_transport.
    cbn. rewrite eq_corecM0. apply idpath.
  Defined.

  (* Thus M is final *)

  Lemma finalM : is_final M.
  Proof.
    rewrite coalgebras_eq. apply finalM0.
  Defined.

End Refinement.


(* Coq defintions for Sigma-HCOL operator language *)

Require Import Coq.Arith.Arith.
Require Import Coq.Strings.String.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Sorting.Permutation.
Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Import Coq.Arith.PeanoNat.Nat.

Require Import Helix.Tactics.HelixTactics.
Require Import Psatz.
Require Import Coq.micromega.Lia.

Require Import MathClasses.interfaces.canonical_names.
Require Import MathClasses.orders.minmax MathClasses.interfaces.orders.
Require Import MathClasses.implementations.peano_naturals.
Require Import MathClasses.orders.orders.

Require Import MathClasses.interfaces.abstract_algebra.

Require Import Helix.Util.Misc.
Require Import Helix.Util.FinNat.
Require Import Helix.Util.FinNatSet.

Global Open Scope nat_scope.

Unset Transparent Obligations.

(* Index maps (total functions) *)

Record index_map (domain range : nat) :=
  IndexMap
    {
      index_f : nat -> nat;
      index_f_spec : forall x, x<domain -> (index_f x) < range;
    }.

Notation "⟦ f ⟧" := (@index_f _ _ f).
Notation "« f »" := (@index_f_spec _ _ f).

Global Instance index_map_equiv {domain range:nat}:
  Equiv (index_map domain range)
  :=
    fun f g => forall (x:nat) (xd: x<domain), ⟦ f ⟧ x = ⟦ g ⟧ x.

Global Instance index_map_Reflexive
       {i o:nat}:
  Reflexive (@index_map_equiv i o).
Proof.
  crush.
Qed.

Global Instance index_map_Symmetric
       {i o:nat}:
  Symmetric (@index_map_equiv i o).
Proof.
  intros a b E.
  unfold index_map_equiv.
  intros x xc.
  rewrite E.
  reflexivity.
  apply xc.
Qed.

Global Instance index_map_Transitive
       {i o:nat}:
  Transitive (@index_map_equiv i o).
Proof.
  intros a b c Eab Ebc.
  unfold index_map_equiv.
  intros x xc.
  rewrite Eab; auto.
Qed.

Global Instance index_map_Equivalence
       {i o:nat}:
  Equivalence (@index_map_equiv i o).
Proof.
  split.
  apply index_map_Reflexive.
  apply index_map_Symmetric.
  apply index_map_Transitive.
Qed.

Definition index_map_compose
           {i o t: nat}
           (g: index_map t o)
           (f: index_map i t) :
  index_map i o.
Proof.
  refine (IndexMap i o (⟦g⟧ ∘ ⟦f⟧) _).
  intros.
  destruct f, g.
  simpl.
  unfold compose.
  auto.
Defined.

(* Restriction on domain *)
Definition shrink_index_map_domain {d r:nat} (f: index_map (S d) r)
  : index_map d r.
Proof.
  destruct f.
  assert (new_spec : ∀ x : nat, x < d → index_f0 x < r) by auto.
  exact (IndexMap d r index_f0 new_spec).
Defined.

Lemma shrink_non_shrink_eq (d r : nat) (f : index_map (S d) r):
  ⟦ shrink_index_map_domain f ⟧ ≡ ⟦ f ⟧.
Proof.
  unfold shrink_index_map_domain.
  break_match.
  reflexivity.
Qed.

Lemma shrink_index_map_domain_exists_eq {i o : nat}
      (f : index_map (S i) o)
      (j : nat)
      (jc : Peano.lt j (S i))
      (jc1 : Peano.lt j i):
  (@exist nat (fun x : nat => Peano.lt x o)
          (index_f i o (@shrink_index_map_domain i o f) j)
          (index_f_spec i o (@shrink_index_map_domain i o f) j jc1))
    ≡
    (@exist nat (fun x : nat => Peano.lt x o)
            (index_f (S i) o f j)
            (index_f_spec (S i) o f j jc)
    ).
Proof.
  destruct f.
  simpl.
  repeat f_equiv.
  apply le_unique.
Qed.

Definition shrink_index_map_1_range {r:nat} (f: index_map 1 (S r)) (NZ: ⟦ f ⟧ 0 ≢ 0)
  : index_map 1 r.
Proof.
  destruct f.
  simpl in *.

  set (index_f' := compose Nat.pred index_f0).
  assert (new_spec : ∀ x : nat, x < 1 → index_f' x < r).
  {
    intros x xc.
    unfold index_f', compose.
    destruct (index_f0 x) eqn:E.
    -
      destruct x; lia.
    -
      rewrite Nat.pred_succ.
      specialize (index_f_spec0 x xc).
      lia.
  }
  exact (IndexMap 1 r index_f' new_spec).
Defined.

Section InRange.

  Fixpoint in_range  {d r:nat} (f: index_map d r)
           (i:nat)
    : Prop :=
    match d return (index_map d r) -> Prop with
    | O => fun _ => False
    | S d' => fun f' =>
               match Nat.eq_dec (⟦f⟧ d') i with
               | left x => True
               | right x => in_range (shrink_index_map_domain f') i
               end
    end f.

  Global Instance in_range_dec {d r:nat} (f: index_map d r) (i:nat) : Decision (in_range f i).
  Proof.
    unfold Decision.
    induction d.
    crush.
    simpl.
    break_if.
    auto.
    apply IHd.
  Qed.

  Lemma in_range_by_def:
    ∀ (d r : nat) (f : index_map d r) (x : nat) (xc: x < d),
      in_range f (⟦ f ⟧ x).
  Proof.
    intros d r f x xc.

    dependent induction d.
    - crush.
    - simpl.
      break_if.
      + trivial.
      +
        remember (shrink_index_map_domain f) as f0.
        case (Nat.eq_dec x d).
        congruence.
        intros nx.
        assert (F: ⟦ f ⟧ x ≡ ⟦ f0 ⟧ x).
        {
          subst f0.
          unfold shrink_index_map_domain.
          break_match.
          auto.
        }
        rewrite F.
        apply IHd.
        lia.
  Qed.

  Lemma in_range_upper_bound:
    ∀ (d r : nat) (f : index_map d r) (x : nat),
      in_range f x → x < r.
  Proof.
    intros d r f x Rx.
    induction d.
    - crush.
    - destruct (Nat.eq_dec (⟦ f ⟧ d) x).
      + destruct f.
        subst x.
        apply index_f_spec.
        auto.
      + simpl in *.
        remember (shrink_index_map_domain f) as f0.
        apply IHd with (f:=f0).
        break_if.
        * congruence.
        * apply Rx.
  Qed.

  Lemma in_range_shrink_index_map_domain (d r y : nat) (f : index_map (S d) r):
    in_range f y → ⟦ f ⟧ d ≢ y → in_range (shrink_index_map_domain f) y.
  Proof.
    intros R N.
    unfold shrink_index_map_domain.
    break_match.
    simpl in *.
    break_if.
    congruence.
    apply R.
  Qed.

  Lemma in_range_exists
        {d r y: nat}
        (f: index_map d r)
        (yc: y<r)
    :
      in_range f y <-> (∃ x (xc:x<d), ⟦ f ⟧ x ≡ y).
  Proof.
    split.
    - intros H.
      induction d.
      + crush.
      + destruct (Nat.eq_dec (⟦ f ⟧ d) y).
        * assert(dc: d<S d) by lia.
          exists d, dc.
          assumption.
        *
          replace (⟦ f ⟧) with (⟦ shrink_index_map_domain f ⟧).
          assert(S: in_range (shrink_index_map_domain f) y)
            by (apply in_range_shrink_index_map_domain; try assumption).
          specialize (IHd (shrink_index_map_domain f) S).
          elim IHd.
          intros x H0.
          elim H0.
          intros x0 H1.
          assert(xc: x < (Datatypes.S  d)) by lia.
          exists x, xc.
          apply H1.
          apply shrink_non_shrink_eq.
    - intros H.
      elim H; intros x H0; clear H.
      elim H0; intros xc H; clear H0.
      apply in_range_by_def with (f:=f) in xc.
      subst y.
      apply xc.
  Qed.

  Lemma in_range_index_map_compose_left {i o t : nat}
        (f : index_map i t)
        (g : index_map t o)
        (j : nat)
        (jc: j<o):
    in_range (index_map_compose g f) j → in_range g j.
  Proof.
    intros H.
    apply in_range_exists in H; try assumption.
    elim H; intros x0 H0; clear H.
    elim H0; intros xc0 H; clear H0.
    simpl in H.
    unfold compose in H.
    subst j.
    apply in_range_by_def.
    apply index_f_spec, xc0.
  Qed.

End InRange.

Section Jections.

  Definition function_injective
             {A B: Set}
             (f: A->B)
    :=
      forall (x y:A),
        f x ≡ f y → x ≡ y.

  Definition function_surjective
             {A B: Set}
             (f: A->B)
    :=
      forall (y:B), exists (x:A), f x ≡ y.

  Definition function_bijective
             {A B: Set}
             (f: A->B)
    :=
      (function_injective f) /\ (function_surjective f).

  Definition index_map_injective
             {d r: nat}
             (f: index_map d r)
    :=
      forall (x y:nat) (xc: x<d) (yc: y<d),
        ⟦ f ⟧ x ≡ ⟦ f ⟧ y → x ≡ y.

  Definition index_map_surjective
             {d r: nat}
             (f: index_map d r)
    :=
      forall (y:nat) (yc: y<r), exists (x:nat) (xc: x<d), ⟦ f ⟧ x ≡ y.

  Definition index_map_bijective
             {n: nat}
             (f: index_map n n)
    :=
      (index_map_injective f) /\ (index_map_surjective f).

  Lemma index_map_compose_injective
        {i o t: nat}
        (f: index_map t o)
        (g: index_map i t)
        (f_inj: index_map_injective f)
        (g_inj: index_map_injective g)
    :
      index_map_injective (index_map_compose f g).
  Proof.
    unfold index_map_injective in *.
    intros x y xc yc H.
    unfold index_map_compose, compose in H. simpl in H.
    apply g_inj; try assumption.
    apply f_inj in H; try assumption.
    apply (index_f_spec), xc.
    apply (index_f_spec), yc.
  Qed.

  Lemma index_map_surjective_in_range
        {d r: nat}
        (f: index_map d r)
        {S: index_map_surjective f}:
    forall x, x<r -> in_range f x.
  Proof.
    intros x H.
    apply in_range_exists; auto.
  Qed.

  Lemma shrink_index_map_1_range_inj
        {r:nat}
        (f: index_map 1 (S r))
        (NZ: ⟦ f ⟧ 0 ≢ 0):
    index_map_injective f ->
    index_map_injective (shrink_index_map_1_range f NZ).
  Proof.
    intros E.
    unfold index_map_injective.
    intros x y xc yc H.
    apply E; auto.

    unfold shrink_index_map_1_range in *.
    break_match.
    simpl in *.
    unfold compose in H.
    destruct x,y; lia.
  Qed.

End Jections.

Section Inversions.
  Record inverse_index_map {d r: nat} (f: index_map d r)
    :=
      InverseIndexMap {
          inverse_index_f : nat -> nat;
          inverse_index_f_spec: forall x, in_range f x -> ((inverse_index_f x) < d)
        }.

  Fixpoint gen_inverse_index_f {d r: nat} (f: index_map d r)
           (i: nat): nat :=
    let dummy := O in
    match d return (index_map d r) -> nat with
    | O => fun _ => dummy
    | S d' => fun f' =>
                match Nat.eq_dec (⟦f⟧ d') i with
                | left x => d'
                | right x => gen_inverse_index_f (shrink_index_map_domain f') i
                end
    end f.

  Lemma gen_inverse_index_f_spec {d r: nat} (f: index_map d r):
    forall (i: nat), in_range f i -> (gen_inverse_index_f f i) < d.
  Proof.
    intros x R.
    induction d.
    - crush.
    -
      simpl.
      break_if.
      crush.
      rewrite IHd.
      crush.
      unfold in_range in R.
      break_if.
      congruence.
      apply R.
  Qed.

  (* Theoretically, we can only build inverse of injective functions. However this
definition does not enforce this requirement, and the function produced might not be
   true inverse in mathematical sense. To make sure it is, check (index_map_injective f) *)
  Definition build_inverse_index_map
             {d r: nat}
             (f: index_map d r)
    : inverse_index_map f
    := let f' := gen_inverse_index_f f in
       @InverseIndexMap d r f f' (gen_inverse_index_f_spec f).

  Definition inverse_index_map_injective
             {d r: nat} {f: index_map d r}
             (f': inverse_index_map f)
    :=
      let f0 := inverse_index_f f f' in
      forall x y, in_range f x -> in_range f y ->
                  f0 x ≡ f0 y → x ≡ y.

  Definition inverse_index_map_surjective
             {d r: nat} {f: index_map d r}
             (f': inverse_index_map f)
    :=
      let f0 := inverse_index_f f f' in
      forall (y:nat) (yc: y<d), exists x, in_range f x /\ f0 x ≡ y.

  Definition inverse_index_map_bijective
             {d r: nat} {f: index_map d r}
             (f': inverse_index_map f)
    :=
      (inverse_index_map_injective f') /\ (inverse_index_map_surjective f').

  Lemma shrink_index_map_preserves_injectivity:
    ∀ (d r : nat) (f : index_map (S d) r),
      index_map_injective f → index_map_injective (shrink_index_map_domain f).
  Proof.
    intros d r f f_inj.
    unfold index_map_injective.
    intros x y xc yc H.
    apply f_inj; try auto.
    unfold shrink_index_map_domain in *.
    break_match.
    simpl in *.
    assumption.
  Qed.

  (* The following lemma proves that using `buld_inverse_index_map` on
  injective index_map produces true "left inverse" of it *)
  Lemma build_inverse_index_map_is_left_inverse
        {d r: nat}
        (f: index_map d r)
        (f_inj: index_map_injective f):
    let fp := build_inverse_index_map f in
    let f' := inverse_index_f _ fp in
    forall x y (xc:x<d), ⟦ f ⟧ x ≡ y -> f' y ≡ x.
  Proof.
    simpl.
    intros x y xc H.
    induction d.
    - crush.
    - simpl.
      break_if.
      + crush.
      + apply IHd; clear IHd.
        *
          apply shrink_index_map_preserves_injectivity, f_inj.
        *
          destruct (Nat.eq_dec x d).
          congruence.
          lia.
        *
          unfold shrink_index_map_domain.
          break_match.
          simpl in *.
          congruence.
  Qed.

  (* The following lemma proves that using `buld_inverse_index_map` on
  injective index_map produces true "right inverse" of it *)
  Lemma build_inverse_index_map_is_right_inverse
        {d r: nat}
        (f: index_map d r)
        (f_inj: index_map_injective f):
    let fp := build_inverse_index_map f in
    let f' := inverse_index_f _ fp in
    forall x y (rc:in_range f y), f' y ≡ x -> ⟦ f ⟧ x ≡ y.
  Proof.
    simpl.
    intros x y rc H.
    induction d.
    - crush.
    - simpl in *.
      break_if.
      + crush.
      + apply shrink_index_map_preserves_injectivity in f_inj.
        apply IHd in H; try assumption.
        unfold shrink_index_map_domain in *.
        break_match.
        simpl in *.
        congruence.
  Qed.

  Lemma build_inverse_index_map_is_injective:
    ∀ (d r : nat) (f : index_map d r),
      index_map_injective f →
      inverse_index_map_injective (build_inverse_index_map f).
  Proof.
    intros d r f f_inj.
    unfold inverse_index_map_injective.
    intros x y Rx Ry H.
    remember (inverse_index_f f (build_inverse_index_map f) x) as t eqn:H1.
    symmetry in H1.
    symmetry in H.
    apply build_inverse_index_map_is_right_inverse in H; try assumption.
    apply build_inverse_index_map_is_right_inverse in H1; try assumption.
    subst.
    reflexivity.
  Qed.

  Lemma build_inverse_index_map_is_surjective:
    ∀ (d r : nat) (f : index_map d r), index_map_injective f → inverse_index_map_surjective (build_inverse_index_map f).
  Proof.
    intros d r f f_inj.
    unfold inverse_index_map_surjective.
    intros y yc.
    exists (⟦ f ⟧ y).
    split.
    -
      apply in_range_by_def, yc.
    -
      apply build_inverse_index_map_is_left_inverse; try assumption.
      reflexivity.
  Qed.

  Lemma build_inverse_index_map_is_bijective
        {d r: nat}
        (f: index_map d r)
        {f_inj: index_map_injective f}
    : inverse_index_map_bijective (build_inverse_index_map f).
  Proof.
    unfold inverse_index_map_bijective.
    split;
      [apply build_inverse_index_map_is_injective, f_inj |
       apply build_inverse_index_map_is_surjective, f_inj
      ].
  Qed.

  (*
  Program Definition inverse_index_map_compose
          {i o t : nat}
          {f : index_map i t}
          {g : index_map t o}
          (f': inverse_index_map f)
          (g': inverse_index_map g)
    : inverse_index_map (index_map_compose g f)
    :=
      InverseIndexMap _ _ (index_map_compose g f)
                      ((inverse_index_f f f') ∘ (inverse_index_f g g' )) _.
  Next Obligation.
    unfold compose.
  Defined.
   *)

  Lemma gen_inverse_revert:
    ∀ (d r : nat) (f : index_map d r) (v : nat),
      index_map_injective f ->
      in_range f v ->
      ⟦ f ⟧ (gen_inverse_index_f f v) ≡ v.
  Proof.
    intros d r f v f_inj R.
    induction d.
    - crush.
    - simpl.
      + break_if.
        * assumption.
        * simpl in *.
          destruct (Nat.eq_dec (⟦ f ⟧ d) v).
          -- congruence.
          -- simpl in *.
             apply shrink_index_map_preserves_injectivity in f_inj.
             remember (shrink_index_map_domain f) as f0.
             replace (⟦ f ⟧) with (⟦ f0 ⟧).
             apply IHd; try assumption.
             subst f0.
             unfold shrink_index_map_domain.
             break_match.
             reflexivity.
  Qed.

  Lemma composition_of_inverses_to_invese_of_compositions
        (i o t : nat)
        (f : index_map i t)
        (g : index_map t o)
        (f_inj: index_map_injective f)
        (g_inj: index_map_injective g)
        (j : nat)
        (jc:j < o)
        (Rg: in_range g j)
        (R: in_range f (gen_inverse_index_f g j))
        (Rgf: in_range (index_map_compose g f) j)
    :
      gen_inverse_index_f f (gen_inverse_index_f g j) =
      gen_inverse_index_f (index_map_compose g f) j.
  Proof.
    symmetry.
    apply build_inverse_index_map_is_left_inverse.
    - apply index_map_compose_injective.
      apply g_inj.
      apply f_inj.
    -
      apply gen_inverse_index_f_spec, R.
    -
      unfold index_map_compose, compose.
      simpl.
      rewrite 2!gen_inverse_revert; try assumption.
      reflexivity.
  Qed.

  Lemma in_range_index_map_compose_right {i o t : nat}
        (f : index_map i t)
        (g : index_map t o)
        (g_inj: index_map_injective g)
        (j : nat)
        (jc: j < o):
    in_range g j ->
    in_range (index_map_compose g f) j ->
    in_range f (gen_inverse_index_f g j).
  Proof.
    intros Rj Rgf.

    apply in_range_exists in Rj; try assumption.
    elim Rj; intros x0 H0; clear Rj.
    elim H0; intros xc0 Gj; clear H0.

    apply in_range_exists in Rgf; try assumption.
    elim Rgf; intros x1 H1; clear Rgf.
    elim H1; intros xc1 Rgf; clear H1.

    simpl in Rgf. unfold compose in Rgf.
    assert(Fx1: ⟦ f ⟧ x1 = x0).
    {
      apply g_inj.
      apply (@index_f_spec i t f x1 xc1).
      apply xc0.
      subst j.
      apply Rgf.
    }

    apply build_inverse_index_map_is_left_inverse in Gj; try assumption.
    simpl in Gj.
    rewrite Gj.
    rewrite <- Fx1.
    apply in_range_by_def, xc1.
  Qed.

  Lemma in_range_index_map_compose {i o t : nat}
        (f : index_map i t)
        (g : index_map t o)
        (g_inj: index_map_injective g)
        (j : nat)
        (jc: j<o):
    in_range g j → in_range f (gen_inverse_index_f g j)
    → in_range (index_map_compose g f) j.
  Proof.
    intros R0 R1.

    apply in_range_exists in R1.
    elim R1; intros x H0; clear R1.
    elim H0; intros xc R1; clear H0.
    symmetry in R1.
    apply build_inverse_index_map_is_right_inverse in R1; try assumption.
    replace (⟦ g ⟧ (⟦ f ⟧ x)) with (⟦ index_map_compose g f ⟧ x) in R1.
    ++ subst j.
       apply in_range_by_def.
       apply xc.
    ++
      auto.
    ++
      apply in_range_upper_bound in R1.
      apply R1.
  Qed.

End Inversions.

Definition index_map_family (d r n : nat) := FinNat n -> index_map d r.

Section IndexFamilies.

  Definition index_map_family_injective
             {n d r: nat}
             (f: index_map_family d r n)
    :=
      forall (i j: nat) (ic: i<n) (jc: j<n) (x y:nat) (xc: x<d) (yc: y<d),
        ⟦ f (mkFinNat ic) ⟧ x ≡ ⟦ f (mkFinNat jc) ⟧ y → (x ≡ y) /\ (i ≡ j).

  Definition index_map_family_surjective
             {n d r: nat}
             (f: index_map_family d r n)
    :=
      forall (y:nat) (yc: y<r), exists (x j:nat) (xc: x<d) (jc: j<n), ⟦ f (mkFinNat jc) ⟧ x ≡ y.

  Definition index_map_family_bijective
             {n d r}
             (f: index_map_family d r n)
    :=
      (index_map_family_injective f) /\ (index_map_family_surjective f).

  Lemma index_map_family_member_injective
        {d r n: nat}
        {f: index_map_family d r n}:
    index_map_family_injective f -> forall jf, index_map_injective (f jf).
  Proof.
    intros H [j jc].
    unfold index_map_family_injective in H.
    unfold index_map_injective.
    apply H.
  Qed.

  Lemma index_map_family_injective_in_range_once
        {n d r: nat}
        (f: index_map_family d r n)
        (i j: nat)
        {ic jc}
        {y}
        {yc:y<r}
    :
      index_map_family_injective f ->
      in_range  (f (@mkFinNat _ i ic)) y ->
      in_range  (f (@mkFinNat _ j jc)) y -> i ≡ j.
  Proof.
    intros f_inj r0 r1.

    apply in_range_exists in r0; try assumption.
    apply in_range_exists in r1; try assumption.

    elim r0; intros x0; clear r0; intros r0.
    elim r0; intros x0c; clear r0; intros r0.

    elim r1; intros x1; clear r1; intros r1.
    elim r1; intros x1c; clear r1; intros r1.

    rewrite <- r1 in r0; clear r1.

    specialize (f_inj i j ic jc x0 x1 x0c x1c r0).
    destruct f_inj.
    assumption.
  Qed.

End IndexFamilies.

Section Primitive_Functions.

  Program Definition identity_index_map
          (dr: nat) {dp: dr>0}:
    index_map dr dr
    := IndexMap dr dr (id) _.

  Program Definition constant_index_map
          {range: nat}
          (j: nat)
          {jdep: j<range}:
    index_map 1 range
    := IndexMap 1 range (fun _ => j) _.

  Fact add_index_map_spec_conv {d r k: nat}:
    k + d <= r → ∀ x : nat, x < d → x + k < r.
  Proof.
    intros H x H0.
    lia.
  Qed.

  Definition add_index_map
             {domain range: nat}
             (k: nat)
             {kdep: k+domain <= range}:
    index_map domain range
    := IndexMap domain range (fun i => i+k) (add_index_map_spec_conv kdep).

  Program Definition h_index_map
          {domain range: nat}
          (b s: nat)
          {range_bound: forall x, x<domain -> (b+x*s) < range}
    : index_map domain range
    :=
      IndexMap domain range (fun i => b + i*s) _.

  Lemma h_index_map_is_injective
        {domain range: nat}
        (b s: nat)
        {range_bound: forall x, x<domain -> (b+x*s) < range}
        {snzord0: s ≢ 0 \/ domain < 2} (* without this it is not injective! *)
    :
      index_map_injective  (@h_index_map domain range b s range_bound).
  Proof.
    unfold index_map_injective.
    intros x y xc yc H.
    simpl in H.
    nia.
  Qed.

  Lemma in_range_of_h
        {domain range: nat}
        (b s: nat)
        {range_bound: forall x, x<domain -> (b+x*s) < range}
        (y:nat)
        (yc:y<range)
    :
      in_range (@h_index_map domain range b s range_bound) y
      <-> ∃ x (xc:x<domain), b+x*s = y.
  Proof.
    split.
    - intros H.
      rewrite in_range_exists in H.
      auto.
      apply yc.
    -
      intros H.
      apply in_range_exists.
      apply yc.
      apply H.
  Qed.

  Fact h_index_map_compose_range_bound
       {i o t b0 b1 s0 s1: nat}
       (bound0 : forall x : nat, x < o → b0 + x * s0 < t)
       (bound1 : forall x : nat, x < t → b1 + x * s1 < i)
    : forall x : nat, x < o → b1 + b0 * s1 + x * (s0 * s1) < i.
  Proof.
    intros x xc.
    specialize (bound0 x xc).
    specialize (bound1 (b0 + x * s0) bound0).
    clear bound0 xc t.
    repeat ring_simplify.
    replace (b1 + b0 * s1 + x * (s0 * s1)) with
        (b1 + (b0 + x * s0) * s1) by lia.
    auto.
  Qed.

  Lemma h_index_map_compose
        {i o t b0 b1 s0 s1: nat}
        {bound1}
        {bound0}
    :
      @index_map_compose i o t
                         (h_index_map b1 s1 (range_bound:=bound1))
                         (h_index_map b0 s0 (range_bound:=bound0))
      =
      h_index_map (b1 + b0 * s1) (s0 * s1)
                  (range_bound:=h_index_map_compose_range_bound bound0 bound1).
  Proof.
    unfold index_map_compose.
    unfold h_index_map.
    unfold equiv, index_map_equiv, compose.
    simpl.
    clear bound0 bound1.
    intros x xc.
    clear xc i o t.
    unfold equiv, nat_equiv.
    lia.
  Qed.

End Primitive_Functions.

Section PracticalFamilies.

  (* Flattens m-by-n matrix into flat vector of size m*n by column *)
  Program Definition matrixFlattenByColFamily {m n:nat}: index_map_family m (m*n) n
    := fun k => h_index_map (range_bound:=_)  ((proj1_sig k)*m) 1.
  Next Obligation.
    nia.
  Defined.

End PracticalFamilies.

Section Function_Operators.

  Definition tensor_product
             (n N: nat)
             {nz: 0 ≢ n}
             (f: nat -> nat)
             (g: nat -> nat)
             (i: nat): nat
    :=  N * (f (i / n)) + (g (i mod n)).

  Program Definition index_map_tensor_product
          {m n M N: nat}
          {nz: 0 ≢ n}
          (f: index_map m M)
          (g: index_map n N):
    index_map (m*n) (M*N)
    := IndexMap (m*n) (M*N)  (tensor_product n N ⟦f⟧ ⟦g⟧ (nz:=nz))  _.
  Next Obligation.
    destruct f,g.
    unfold tensor_product, div, modulo.
    assert ((fst (divmod x (pred n) 0 (pred n))) < m).
    {
      destruct n.
      congruence. clear nz.
      simpl.
      generalize (divmod_spec x n 0 n).
      destruct divmod as (q,u).
      simpl.
      nia.
    }
    assert (index_f0 (fst (divmod x (pred n) 0 (pred n))) < M) by auto.

    assert ((pred n - snd (divmod x (pred n) 0 (pred n))) < n).
    {
      destruct n.
      congruence. clear nz.
      simpl.
      generalize (divmod_spec x n 0 n).
      destruct divmod as (q,u).
      simpl.
      nia.
    }
    assert (index_f1 (pred n - snd (divmod x (pred n) 0 (pred n))) < N) by auto.
    simpl.
    replace (match n with
             | 0 => n
             | S y' => fst (divmod x y' 0 y')
             end) with (fst (divmod x (pred n) 0 (pred n))).
    replace (match n with
             | 0 => n
             | S y' => y' - snd (divmod x y' 0 y') end) with
    ((pred n) - snd (divmod x (pred n) 0 (pred n))).
    nia.
    break_match; auto.
    break_match; auto.
    congruence.
  Defined.

End Function_Operators.

Declare Scope index_f_scope.
Notation "g ∘ f" := (index_map_compose g f) : index_f_scope.
Notation "x ⊗ y" := (index_map_tensor_product x y) (at level 90) : index_f_scope.

Section Function_Rules.

  Local Open Scope index_f_scope.

  Lemma index_map_rule_39
        {rf0 rf1 dg0 dg1 rg0 rg1:nat}
        {g0: index_map dg0 rg0}
        {g1: index_map dg1 rg1}
        {f0: index_map rg0 rf0}
        {f1: index_map rg1 rf1}
        {ndg1: 0 ≢ dg1}
        {nrg1: 0 ≢ rg1}
        {ls:  (dg0 * dg1) ≡ (rf0 * rf1)}
    :
      (index_map_tensor_product f0 f1 (nz:=nrg1))
        ∘ (index_map_tensor_product g0 g1 (nz:=ndg1))
      =
      index_map_tensor_product
        (f0 ∘ g0)
        (f1 ∘ g1)
        (nz := ndg1).
  Proof.
    destruct f0 as [f0 f0_spec].
    destruct f1 as [f1 f1_spec].
    destruct g0 as [g0 g0_spec].
    destruct g1 as [g1 g1_spec].

    unfold equiv, index_map_equiv.
    intros. simpl.
    unfold compose, tensor_product.

    assert (X: (rg1 * g0 (x / dg1) + g1 (x mod dg1)) / rg1 ≡ g0 (x / dg1)).
    {
      rewrite plus_comm, mult_comm, Nat.div_add by auto.
      + assert(x mod dg1 < dg1). {
          apply modulo_smaller_than_devisor. assumption.
        }
        assert (g1 (x mod dg1) < rg1). {
          apply g1_spec. assumption.
        }
        assert (X0: g1 (x mod dg1) / rg1 ≡ 0). {
          apply Nat.div_small.  assumption.
        }
        rewrite X0.
        auto.
    }
    rewrite_clear X.

    assert (X: (rg1 * g0 (x / dg1) + g1 (x mod dg1)) mod rg1 ≡  g1 (x mod dg1)).
    {
      rewrite plus_comm, mult_comm.
      rewrite Nat.mod_add by auto.
      rewrite Nat.mod_small.
      reflexivity.
      assert (x mod dg1 < dg1).  {
        apply modulo_smaller_than_devisor.
        assumption.
      }
      auto.
    }
    rewrite_clear X.
    reflexivity.
  Qed.

  Program Lemma index_map_rule_40:
    forall n (np: n>0)
           {range_bound_h_0: ∀ x : nat, x < n → 0 + x * 1 < n}
    ,
      @identity_index_map n np = h_index_map 0 1
                                             (range_bound:=range_bound_h_0).
  Proof.
    intros.
    unfold identity_index_map, h_index_map, equiv, index_map_equiv, id.
    intros. simpl.
    symmetry. apply mult_1_r.
  Qed.

  Local Close Scope index_f_scope.

End Function_Rules.

Section IndexMapSets.

  Definition index_map_range_set
             {d r: nat}
             (f: index_map d r): FinNatSet r :=
    fun x => in_range f (proj1_sig x).

  Lemma index_map_range_set_id:
    ∀ (i o : nat) (f : index_map i o) (j : nat) (jc : j < i),
      index_map_range_set f (⟦ f ⟧ j ↾ « f » j jc).
  Proof.
    intros i o f j jc.
    unfold index_map_range_set.
    induction i.
    - inversion jc.
    - simpl.
      break_if.
      auto.
      apply in_range_shrink_index_map_domain.
      apply in_range_by_def.
      lia.
      assumption.
  Qed.

  Lemma h_index_map_range_set_dec
        {domain range: nat}
        (b s: nat)
        {range_bound: forall x, x<domain -> (b+x*s) < range}:
    FinNatSet_dec (index_map_range_set (@h_index_map domain range b s range_bound)).
  Proof.
    unfold FinNatSet_dec.
    intros y.
    unfold index_map_range_set.
    apply Decidable_decision.
    apply in_range_dec.
  Qed.

End IndexMapSets.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Nil : lst |Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (append (rev x) y) (qreva x y).
Proof.
   induction x.
   - reflexivity.
   - intros. simpl. lfind. Admitted.


From Coq Require Import Lists.List.
Require Import RBT.Verif.RBtree_Type.
Require Import RBT.Verif.RBtree_Definition.

Section Section_Half_Tree.

Context {rbt:RBtree_setting}.
Existing Instance rbt.

Definition Half_tree : Type := (bool * color * Key * Value * Tag * RBtree ).

(*Some simple Properties*)
  Definition fst_false (l :  Half_tree) : Prop :=
  match l with
  |(false, co, k, v, t, r) => True
  |(true, co, k, v, t, r) => False
  end.
  Definition fst_black (h : list Half_tree) : Prop :=
  match hd_error h with
  |None => True
  |Some (b, c, k ,v, t, r) => c = Black
  end.
  Definition fst_black' (h : list Half_tree):Prop := fst_black h /\ ~ h =nil.
  Fixpoint last_black (l : list Half_tree) : Prop :=
  match l with
  | nil  => False
  | a :: nil => match a with
           | (_, c, _, _ , _ ,_ ) => c = Black
           end
  |_ :: l' => last_black l'
  end.
  (*性质P: 半树tag为default*)
  Definition P : Half_tree -> Prop :=  fun x =>  snd ( fst x) = default.

  Fixpoint accumulate_tag_for_ht (l : list Half_tree) : Tag :=
  match l with
  | nil => default
  |( pb, pc, p, pv, pt, brother) :: l' =>
    Optt (accumulate_tag_for_ht l') pt
  end.
  Lemma accumulate_default : forall h ,
   Forall P h ->
      default = accumulate_tag_for_ht h.
  Proof.
    intros.
    induction H.
      - reflexivity.
      -
         unfold P in H. destruct x. repeat destruct p.
         simpl in H. subst t.
         simpl.
         rewrite <- IHForall.
         rewrite Optt_default. auto.
  Qed.

(**拼接完整的树*)
Definition complete_tree_one  (b : RBtree) (H : Half_tree): RBtree :=
match H with
|(pb, pc, p, pv, pt, brother) =>
  (*当前子树base为左子树(false) 还是右(true) *)
  match pb with
  |false => T pc b p pv pt brother
  |true => T pc brother p pv pt b
  end
end.
Fixpoint complete_tree  (l: list Half_tree) (b : RBtree) : RBtree :=
match l with
|nil => b
|(pb, pc, p, pv, pt, brother) :: l' =>
  (*当前子树base为左子树(false) 还是右(true) *)
  match pb with
  |false => complete_tree l'  (T pc b p pv pt brother)
  |true => complete_tree l' (T pc brother p pv pt b)
  end
end.
Lemma complete_tree_true : forall l b  pc p pv pt brother,
 complete_tree (  (true, pc, p, pv, pt, brother) :: l) b =
    complete_tree l (T pc brother p pv pt b).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.
Lemma complete_tree_false : forall l b  pc p pv pt brother,
 complete_tree (  (false, pc, p, pv, pt, brother) :: l) b =
    complete_tree l (T pc b p pv pt brother).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.
Theorem complete_tree_app :
 forall l h r ,
  complete_tree (l ++ h) r = complete_tree h (complete_tree l r).
Proof.
 intros.
 revert r.
 induction l.
 - intros.
   simpl.
   reflexivity.
 - intros.
   destruct a.
   repeat destruct p.
   destruct b.
   + simpl.
     apply IHl.
   + simpl.
     apply IHl.
Qed.

(*SearchTree AND RedBlack Properties*)
Inductive SearchTree_half : Key -> list Half_tree -> Key ->  Prop :=
|ST_nil : forall lo hi, lo < hi -> SearchTree_half lo nil hi
|ST_cons_true : forall lo hi l co k kv kt tree low,
  SearchTree_half lo l hi  -> k < hi -> SearchTree' lo tree k ->
   k <= low -> low < hi->
    SearchTree_half low ((true,co,k,kv,kt,tree)::l) hi
|ST_cons_false : forall  lo  hi l co k kv kt tree high,
  SearchTree_half lo l hi  -> k < hi -> SearchTree' k tree hi ->
   high <= k -> lo < high ->
   SearchTree_half lo ((false,co,k,kv,kt,tree)::l) high.
Inductive SearchTree_half_tree: Key -> Half_tree -> Key -> Prop :=
| ST_ht_true : forall lo hi co k v t tree,
  SearchTree' lo tree k -> k < hi ->
    SearchTree_half_tree  lo (true, co, k,v,t,tree) hi
| ST_ht_false : forall lo hi co k v t tree,
  SearchTree' k tree hi -> lo < k ->
    SearchTree_half_tree  lo (false, co, k,v,t,tree) hi.
Inductive SearchTree_half_out : Key -> list Half_tree -> Key -> Prop :=
| ST_out_nil : forall lo hi, lo < hi -> SearchTree_half_out lo nil hi
| ST_out_cons : forall lo hi l b co k v t tree low high,
 SearchTree_half_out lo l hi ->
  SearchTree_half_tree low (b,co,k,v,t,tree) high ->
   SearchTree_half_out (min_k low lo) ((b,co,k,v,t,tree)::l) (max_k high hi).
Inductive is_redblack_color_half : list Half_tree -> color -> Prop :=
|IsRB_co_nil: is_redblack_color_half nil Black
|IsRB_co_r_cons: forall  l b k kv kt tree,
   is_redblack_color_half l Red ->
   is_redblack_color tree Red ->
   is_redblack_color_half ((b,Red,k,kv,kt,tree)::l) Black
|IsRB_co_b_cons: forall l c b k kv kt tree,
   is_redblack_color_half l Black ->
   is_redblack_color tree Black ->
   is_redblack_color_half ((b,Black,k,kv,kt,tree)::l) c.
Inductive is_redblack_dep_half : list Half_tree -> nat -> nat -> Prop :=
|IsRB_dep_nil: forall n , is_redblack_dep_half nil n n
|IsRB_dep_r_cons: forall  l b k kv kt tree nown needn,
   is_redblack_dep_half l nown needn ->
   is_redblack_dep tree needn ->
   is_redblack_dep_half ((b,Red,k,kv,kt,tree)::l) nown  needn
|IsRB_dep_b_cons: forall l b k kv kt tree nown needn ,
   is_redblack_dep_half l nown (S needn) ->
   is_redblack_dep tree needn ->
   is_redblack_dep_half ((b,Black,k,kv,kt,tree)::l) nown  needn.
Inductive is_redblack_color_half_loose : list Half_tree -> color -> Prop :=
|IsRB_co_nil_l: forall c, is_redblack_color_half_loose nil c
|IsRB_co_r_cons_l: forall  l b k kv kt tree,
   is_redblack_color_half_loose l Red ->
   is_redblack_color tree Red ->
   is_redblack_color_half_loose ((b,Red,k,kv,kt,tree)::l) Black
|IsRB_co_b_cons_l: forall l c b k kv kt tree,
   is_redblack_color_half_loose l Black ->
   is_redblack_color tree Black ->
   is_redblack_color_half_loose ((b,Black,k,kv,kt,tree)::l) c.

(*SearchTree Lemmas*)
  Lemma search_h_popro2 :
   forall lo t hi k ,
     SearchTree_half lo t hi -> k <= hi/\ lo < k -> SearchTree_half lo t k .
  Proof.
    intros. revert lo hi k H H0.
    induction t.
    -  intros. constructor. inversion H. destruct H0. tr.
    -  intros. inversion H.
       + subst.  destruct H0.
       eapply ST_cons_true. 3: apply H5.
       eapply IHt. apply H3.
       split. auto.
       pose proof search_popro _ _ _ H5.
       TR 5.
       tr.
       auto.
       auto.
       + subst. destruct H0.
         eapply ST_cons_false.
         3: apply H5.
         eapply IHt. apply H3.
         split. right. reflexivity. TR 5.
         auto.
         TR 5.
         auto.
  Qed.
  Lemma search_h_popro3 :
   forall lo t hi k ,
     SearchTree_half lo t hi -> lo <= k /\ k < hi -> SearchTree_half k t hi .
  Proof.
  intros. revert lo hi k H H0.
    induction t.
    -  intros. constructor. inversion H. destruct H0. tr.
    -  intros. inversion H.
       + subst.  destruct H0.
       eapply ST_cons_true. 3: apply H5.
       eapply IHt. apply H3.
       split. right. auto.
        pose proof search_popro _ _ _ H5.
       TR 5.
       tr.
       TR 5.
       auto.
       + subst. destruct H0.
         eapply ST_cons_false.
         3: apply H5.
         eapply IHt. apply H3.
         split.
         auto.
         TR 5.
         auto.
         TR 5.
         auto.
  Qed.
  Lemma search_half_popro :
   forall lo l hi,
    SearchTree_half_out lo l hi -> lo < hi.
  Proof.
    intros.
    induction H.
    - auto.
    - inversion H0.
      + subst.
      assert (low < high ).
      { pose proof search_popro _ _ _ H9. tr. }
      eapply min_max; try eassumption.
      + subst.
      assert (low < high ).
      { pose proof search_popro _ _ _ H9. tr. }
      eapply min_max; try eassumption.
  Qed.
  Lemma search_half_popro2:
    forall lo l hi k,
     SearchTree_half_out lo l k -> k < hi -> SearchTree_half_out lo l hi .
  Proof.
    intros.
    induction H.
    - constructor. tr.
    - assert (max_k (max_k high hi0) hi = hi).
      { unfold max_k at 1.
        assert (max_k high hi0 <? hi = true).
        { eapply ltb_lt. auto. }
        rewrite H2.
        reflexivity. }
      rewrite <- H2.
      constructor.
      + eapply IHSearchTree_half_out.
        eapply max_lt_right; try eassumption.
      + inversion H1.
       * subst.
         eapply ST_ht_true; try eassumption.
         pose proof max_left high hi0.
         tr.
       * subst.
         eapply ST_ht_false; try eassumption.
         eapply search_popro2_lte; try eassumption.
         apply max_left.
  Qed.
  Lemma search_half_popro2_lte:
    forall lo l hi k,
     SearchTree_half_out lo l k -> k <= hi -> SearchTree_half_out lo l hi .
  Proof.
    intros.
    destruct H0. eapply search_half_popro2; try eassumption.
    subst. auto.
  Qed.
  Lemma search_half_popro3:
    forall lo l hi k,
     SearchTree_half_out k l hi -> lo < k -> SearchTree_half_out lo l hi .
  Proof.
    intros.
    induction H.
    - constructor. tr.
    - assert (min_k (min_k low lo0) lo = lo).
      { unfold min_k at 1.
        assert (min_k low lo0  <? lo = false).
        { eapply ltb_false_lte. left. auto. }
        rewrite H2.
        reflexivity. }
      rewrite <- H2.
      constructor.
      + eapply IHSearchTree_half_out.
        eapply min_lt_right; try eassumption.
      + inversion H1.
       * subst.
         eapply ST_ht_true; try eassumption.
         eapply search_popro3_lte; try eassumption.
         pose proof min_left low lo0.
         auto.
       * subst.
         eapply ST_ht_false; try eassumption.
         pose proof min_left low lo0.
         tr.
  Qed.
  Lemma search_half_popro3_lte:
    forall lo l hi k,
     SearchTree_half_out k l hi -> lo <= k -> SearchTree_half_out lo l hi .
  Proof.
    intros.
    destruct H0. eapply search_half_popro3; try eassumption.
    subst. auto.
  Qed.
  Theorem complete_st_pre:
   forall l lo hi tree,
    SearchTree_half lo l hi -> SearchTree' lo tree hi -> SearchTree (complete_tree l tree).
  Proof.
    intro.
    induction l.
    - intros. simpl. eapply ST_intro. apply H0.
    - intros. inversion H.
      + simpl. subst. apply IHl with lo0 hi. auto. apply ST_T. auto.
        eapply search_popro3_lte; try eassumption.
      + simpl. subst. apply IHl with lo hi0. auto. apply ST_T.
        eapply search_popro2_lte; try eassumption. auto.
  Qed.
  Theorem complete_lt :
  forall lo hi h tree,
   SearchTree' lo (complete_tree h tree) hi ->
     SearchTree' lo tree hi.
  Proof.
    intros.
    revert lo hi tree H.
    induction h.
    - intros.
      simpl in H.
      auto.
    - intros.
      destruct a. repeat destruct p.
      destruct b.
      + simpl in H.
        pose proof IHh lo hi _ H.
        inversion H0. subst.
        eapply search_popro3; try eassumption.
        eapply search_popro; try eassumption.
      + simpl in H.
        pose proof IHh lo hi _ H.
        inversion H0. subst.
        eapply search_popro2; try eassumption.
        eapply search_popro; try eassumption.
  Qed.
  Theorem search_complete : forall l b lo hi olo ohi,
   SearchTree' lo b hi -> SearchTree_half lo l hi -> SearchTree_half_out olo l ohi ->
     SearchTree' (min_k lo olo) (complete_tree l b) (max_k hi ohi).
  Proof.
    intro.
    induction l.
    - intros.
      simpl.
      pose proof min_left lo olo.
      pose proof max_left hi ohi.
      pose proof search_popro2_lte _ _ _ _ H H3.
      eapply search_popro3_lte; try eassumption.
    - intros.
      destruct a. repeat destruct p.
      destruct b0.
      + inversion H0; subst. inversion H1; subst.
        simpl.
        inversion H17; subst.
        pose proof search_popro _ _ _ H9.
        pose proof search_popro _ _ _ H12.
        assert (low <= lo).
        { tr. }
        rewrite <- min_asso.
        rewrite (min_comm lo low).
        rewrite (min_lte _ _  H4).
        assert (SearchTree' (max_k lo0 low) r k).
        { pose proof lte_complete  lo0 low.
          destruct H5.
          * rewrite (max_lte _ _ H5). auto.
          * rewrite max_comm.
            rewrite (max_lte _ _ H5). auto. }
        assert (SearchTree' (max_k lo0 low) (T c r k v t b) hi ).
        { eapply ST_T; try eassumption.
          eapply search_popro3_lte; try eassumption. }
        assert (SearchTree_half (max_k lo0 low) l hi).
        {
          eapply search_h_popro3; try eassumption.
          split.
          * apply max_left.
          *
          erewrite <- max_lt.
          split. tr. tr. }
         pose proof IHl _ _ _ _ _ H6 H7 H16; clear IHl.
         assert (min_k low lo1 <= min_k (max_k lo0 low) lo1 ).
         { pose proof lte_complete  lo0 low.
           destruct H18.
           * erewrite (max_lte _ _ H18).
             right. auto.
           * rewrite max_comm.
             erewrite (max_lte _ _ H18).
             eapply min_xz; try eassumption. }
         eapply search_popro3_lte.
         2 : apply H18.
         eapply search_popro2_lte; try eassumption.
         erewrite (max_comm high hi0).
         erewrite <- max_asso.
         eapply max_left.
     + inversion H0; subst. inversion H1; subst.
        simpl.
        inversion H17; subst.
        pose proof search_popro _ _ _ H9.
        pose proof search_popro _ _ _ H12.
        assert (hi <= high).
        { tr. }
        rewrite <- max_asso.
        rewrite (max_lte _ _  H4).
        assert (SearchTree' k r (min_k hi0 high)).
        { pose proof lte_complete hi0 high.
          destruct H5.
          * rewrite (min_lte _ _ H5). auto.
          * rewrite min_comm.
            rewrite (min_lte _ _ H5). auto. }
        assert (SearchTree' lo (T c b k v t r) (min_k hi0 high) ).
        { eapply ST_T; try eassumption.
          eapply search_popro2_lte; try eassumption. }
        assert (SearchTree_half lo l  (min_k hi0 high)).
        {
          eapply search_h_popro2; try eassumption.
          split.
          * apply min_left.
          *
          erewrite <- min_lt.
          split. TR 5. tr. }
         pose proof IHl _ _ _ _ _ H6 H7 H16; clear IHl.
         assert ((max_k (min_k hi0 high) hi1) <= (max_k high hi1) ).
         { pose proof lte_complete hi0 high.
           destruct H18.
           *
             erewrite (min_lte _ _ H18).
             eapply max_xz; try eassumption.
           * rewrite min_comm.
             erewrite (min_lte _ _ H18).
             right. auto. }
         eapply search_popro2_lte.
         2 : apply H18.
         eapply search_popro3_lte; try eassumption.
         erewrite (min_comm low lo0).
         erewrite <- min_asso.
         eapply min_left.
  Qed.
  Lemma halftree_false_key_st : forall h lo hi k,
   Forall fst_false h ->
     Forall (fun x: Half_tree =>  k < snd ( fst (fst (fst x)))) h ->
      k < hi ->
       SearchTree_half_out lo h hi ->
        SearchTree_half_out k h hi.
  Proof.
    intro.
    induction h.
    - intros.
      eapply ST_out_nil; try eassumption.
    - intros.
      destruct a. repeat destruct p.
      inversion H; subst.
      inversion H0; subst.
      simpl in  H5.
      simpl in H7.
      destruct b.
      + inversion H5.
      + inversion H2. subst.
        inversion H17; subst.
        rewrite <- (min_self k).
        rewrite <- (max_self ( max_k high hi0)).
        eapply ST_out_cons.
        * assert (SearchTree_half_out lo0 h (max_k high hi0)).
          { eapply search_half_popro2_lte; try eassumption.
            apply max_right. }
          clear H16.
          eapply IHh; try eassumption.
        * eapply ST_ht_false; try eassumption.
        eapply search_popro2_lte; try eassumption.
        apply max_left.
  Qed.
  Lemma false_ht_true_app_st : forall l c k v t left h lo hi x x0 lo0,
    Forall fst_false l ->
     SearchTree_half  lo l hi ->
       SearchTree' x left k ->
         SearchTree_half x h x0 -> k < x0  ->  k < hi  ->
         SearchTree_half_out  lo0 l x0 ->
          SearchTree_half k (l ++ (true, c, k, v, t, left) :: h) (min_k hi x0).
  Proof.
    intro.
    induction l.
    - intros.
      simpl.
      pose proof search_popro _ _ _ H1.
      pose proof min_lt hi x0.
      eapply ST_cons_true; try eassumption.
      eapply search_h_popro2; try eassumption.
      split. apply min_right.
      rewrite <- H7. split. tr. tr.
      rewrite <- H7. split. tr. tr.
      right. auto.
      rewrite <- H7. split. tr. tr.
   - intros.
     destruct a. repeat destruct p.
     inversion H; subst.
     simpl in H8.
     destruct b.
     + contradiction.
     + inversion H0. subst.
       inversion H5;subst.
       inversion H23; subst.
       rewrite <- app_comm_cons.
       pose proof search_popro _ _ _ H15.
       assert (min_k hi (max_k high hi1) = hi).
       { rewrite  (min_lte hi (max_k high hi1)).
         reflexivity.
         pose proof max_left high hi1.
         tr. }
       rewrite H7.
       eapply ST_cons_false. 4: tr. 4: tr.
       eapply IHl; try eassumption.
       TR 5.
       eapply search_half_popro2_lte; try eassumption.
       apply max_right.
       pose proof min_lt hi0 (max_k high hi1).
       rewrite <- H10.
       split. tr. pose proof max_left high hi1. tr.
       pose proof lte_complete hi0 (max_k high hi1).
       destruct H10.
       *
         pose proof min_lte hi0 _ H10.
         rewrite H11.
         auto.
       *
         pose proof min_lte _ _ H10.
         rewrite min_comm.
         rewrite H11.
         clear H18.
         eapply search_popro2_lte; try eassumption.
         apply max_left.
  Qed.

(*Redblack Lemmas*)
  Lemma isr_isb_half:
   forall t, is_redblack_color_half t Red -> is_redblack_color_half t Black .
  Proof.
    intros.
    induction H.
    - apply IsRB_co_nil.
    - eapply IsRB_co_r_cons; try eassumption.
    - eapply IsRB_co_b_cons; try eassumption.
  Qed.
  Lemma isb_isr_half : forall l , ~ l = nil ->
   is_redblack_color_half l Black ->
  fst_black l -> is_redblack_color_half l Red.
  Proof.
    intros.
    inversion H0.
    subst. exfalso. auto.
    unfold fst_black in H0. subst. inversion H1.
    subst. eapply IsRB_co_b_cons; try eassumption.
  Qed.
  Lemma isrb_bro: forall b c k v t bro co l, is_redblack_color_half ((b, c, k, v, t, bro)::l) co -> is_redblack_color bro c.
  Proof.
    intros.
    inversion H.
    subst. auto.
    subst. auto.
  Qed.
  Lemma isrb_change_half : forall b1 b2 c k1 k2 v1 v2 t1 t2 tree1 tree2 co l,
      is_redblack_color_half ((b1, c, k1, v1, t1, tree1)::l) co ->
     is_redblack_color tree1 c -> is_redblack_color tree2 c
       -> is_redblack_color_half ((b2, c, k2, v2, t2, tree2)::l) co.
  Proof.
    intros.
    inversion H.
    subst. eapply IsRB_co_r_cons; try eassumption.
    subst. eapply IsRB_co_b_cons; try eassumption.
  Qed.
  Lemma rb_co_loose2ori: forall l c,
   is_redblack_color_half_loose l c ->
    last_black l ->  is_redblack_color_half l c.
  Proof.
    intros.
    induction H.
    - subst. inversion H0.
    - subst. destruct l. inversion H0.  eapply IsRB_co_r_cons; try eassumption.
      eapply IHis_redblack_color_half_loose;try eassumption.
    - subst.
      eapply IsRB_co_b_cons; try eassumption.
      destruct l.
      eapply IsRB_co_nil.
      eapply IHis_redblack_color_half_loose;try eassumption.
  Qed.
  Lemma rb_co_ori2loose: forall l c,
   is_redblack_color_half l c -> is_redblack_color_half_loose l c.
  Proof.
    intros.
    induction H.
    - eapply IsRB_co_nil_l.
    - eapply IsRB_co_r_cons_l;try eassumption.
    - eapply IsRB_co_b_cons_l;try eassumption.
  Qed.
  Lemma isr_isb_half_loose:
   forall t, is_redblack_color_half_loose t Red -> is_redblack_color_half_loose t Black .
  Proof.
    intros.
    induction H.
    - apply IsRB_co_nil_l.
    - eapply IsRB_co_r_cons_l; try eassumption.
    - eapply IsRB_co_b_cons_l; try eassumption.
  Qed.
  Lemma isb_isr_half_loose:
   forall t, fst_black t ->
    is_redblack_color_half_loose t Black -> is_redblack_color_half_loose t Red .
  Proof.
    intros.
    inversion H0.
    - apply IsRB_co_nil_l.
    - subst. inversion H.
    - subst. eapply IsRB_co_b_cons_l; try eassumption.
  Qed.
    Lemma isrb_dep_app_Red : forall l0 l b k v t bro d n x,
   is_redblack_dep_half l d n ->
    is_redblack_dep bro n ->
      is_redblack_dep_half l0 n x ->
        is_redblack_dep_half (l0 ++ (b, Red, k, v, t, bro) :: l) d x.
  Proof.
    intro.
    induction l0.
    - intros. simpl.
      inversion H1. subst.
      eapply IsRB_dep_r_cons;try eassumption.
    - intros.
      destruct a.
      repeat destruct p.
      inversion H1.
      + subst.
        eapply IsRB_dep_r_cons;try eassumption.
        eapply IHl0;try eassumption.
      + subst.
        eapply IsRB_dep_b_cons;try eassumption.
        eapply IHl0;try eassumption.
  Qed.

  Lemma isrb_dep_app_Black : forall l0 l b k v t bro d n x,
   is_redblack_dep_half l d (S n) ->
    is_redblack_dep bro n ->
      is_redblack_dep_half l0 n x ->
        is_redblack_dep_half (l0 ++ (b, Black, k, v, t, bro) :: l) d x.
  Proof.
    intro.
    induction l0.
    - intros. simpl.
      inversion H1. subst.
      eapply IsRB_dep_b_cons;try eassumption.
    - intros.
      destruct a.
      repeat destruct p.
      inversion H1.
      + subst.
        eapply IsRB_dep_r_cons;try eassumption.
        eapply IHl0;try eassumption.
      + subst.
        eapply IsRB_dep_b_cons;try eassumption.
        eapply IHl0;try eassumption.
  Qed.

Lemma complete_redblack_co :
  forall  h b , is_redblack_color_half h Black -> ~ b = Empty -> is_redblack_color b Black ->
  (  ( Red_tree b /\ fst_black h ) \/ Black_tree b)
   -> is_redblack_color (makeBlack(complete_tree h b)) Red.
Proof.
  intro.
  induction h.
  - intros. destruct b.
    + exfalso . auto.
    + simpl. inversion H1.
      subst. eapply IsRB_co_b; try eassumption. eapply isr_isb ;try eassumption. eapply isr_isb; try eassumption.
      subst. eapply IsRB_co_b; try eassumption.
  - intros.
    destruct a. repeat destruct p.
    inversion H.
    + subst. destruct b0.
      * simpl.
        assert (is_redblack_color b Red).
        {
         destruct b. exfalso. auto.
         simpl in H2. unfold fst_black in H2. unfold hd_error in H2.
         destruct c. exfalso. inversion H2. inversion H3. inversion H6. inversion H3.
         inversion H1 ; subst.
         eapply IsRB_co_b; try eassumption.
        }
        eapply IHh.
        eapply isr_isb_half; try eassumption.
        unfold not; intros. inversion H4.
        eapply IsRB_co_r; try eassumption.
        left. split. reflexivity.
        inversion H5. reflexivity.
      * simpl.
        assert (is_redblack_color b Red).
        {
         destruct b. exfalso. auto.
         simpl in H2. unfold fst_black in H2. unfold hd_error in H2.
         destruct c. exfalso. inversion H2. inversion H3. inversion H6. inversion H3.
         inversion H1 ; subst.
         eapply IsRB_co_b; try eassumption.
        }
        eapply IHh.
        eapply isr_isb_half; try eassumption.
        unfold not; intros. inversion H4.
        eapply IsRB_co_r; try eassumption.
        left. split. reflexivity.
        inversion H5. reflexivity.
    + subst. destruct b0.
      * simpl. apply IHh.
        auto.
        unfold not; intros. inversion H3.
        eapply IsRB_co_b; try eassumption.
        right. reflexivity.
      * simpl. apply IHh.
        auto.
        unfold not; intros. inversion H3.
        eapply IsRB_co_b; try eassumption.
        right. reflexivity.
Qed.
Lemma complete_rb_rev : forall  h b , ~ h = nil ->
 is_redblack_color (complete_tree h b) Red -> (
  is_redblack_color_half h Black /\ is_redblack_color b Black /\
    (  ( Red_tree b /\ fst_black h ) \/ ~ Red_tree b) ).
Proof.
  intro.
  induction h.
  - intros. exfalso. auto.
  - intros. destruct a. repeat destruct p.
    destruct h.
    *
    destruct b0.
    + simpl in H0. inversion H0. subst. split. apply IsRB_co_b_cons. apply IsRB_co_nil.
      auto. split. auto. unfold fst_black, hd_error. destruct b. right. unfold not;intro;contradiction.
      destruct c. left. split. reflexivity. reflexivity. right. unfold not;intro. inversion H1.
    + simpl in H0. inversion H0. subst. split. apply IsRB_co_b_cons. apply IsRB_co_nil.
      auto. split. auto. unfold fst_black, hd_error. destruct b. right. unfold not;intro. inversion H1.
      destruct c. left. split. reflexivity. reflexivity. right. unfold not;intro. inversion H1.
    * assert (h::h0 <> nil). { discriminate. }
      destruct b0.
      + rewrite complete_tree_true in H0.
        pose proof IHh _ H1 H0. destruct H2 as [ H2 [ H3 [ [ H4 H5] | H4 ]]].
        assert (c = Red). { destruct c.  reflexivity.  inversion H4. } subst.
         inversion H3. subst. split.
         inversion H2. subst. inversion H5. subst.
         eapply IsRB_co_r_cons. eapply IsRB_co_b_cons; try eassumption. auto. split.
         eapply isrb_right; try eassumption.
         right. destruct b. unfold not;intro. inversion H6.
         destruct c. inversion H12.  unfold not;intro. inversion H6.
        assert (c = Black). { destruct c. simpl in H4. exfalso. apply H4. auto. reflexivity. } subst.
         inversion H3. subst.
         split.
         eapply IsRB_co_b_cons; try eassumption.
         split. auto. unfold fst_black, hd_error. destruct b. right.  unfold not;intro. inversion H5.
         destruct c. left. split. reflexivity. reflexivity. right.  unfold not;intro. inversion H5.
      + rewrite complete_tree_false in H0.
        pose proof IHh _ H1 H0. destruct H2 as [ H2 [ H3 [ [ H4 H5] | H4 ]]].
        assert (c = Red). { destruct c.  reflexivity.  inversion H4. } subst.
         inversion H3. subst. split.
         inversion H2. subst. inversion H5. subst.
         eapply IsRB_co_r_cons. eapply IsRB_co_b_cons; try eassumption. auto. split.
         eapply isr_isb; try eassumption.
         right. destruct b.  unfold not;intro. inversion H6.
         destruct c. inversion H8.  unfold not;intro. inversion H6.
        assert (c = Black). { destruct c. simpl in H4. exfalso. apply H4. auto. reflexivity. } subst.
         inversion H3. subst.
         split.
         eapply IsRB_co_b_cons; try eassumption.
         split. auto. unfold fst_black, hd_error. destruct b. right. unfold not;intro. inversion H5.
         destruct c. left. split. reflexivity. reflexivity. right.  unfold not;intro. inversion H5.
Qed.
Lemma complete_isrb: forall h b, ~ h = nil ->
  is_redblack_color_half h Black -> (makeBlack (complete_tree h b ) = (complete_tree h b)).
Proof.
  intro.
  induction h.
  - intros. exfalso. auto.
  - intros.
    destruct h.
    + inversion H0. inversion H3. subst. destruct b0.  reflexivity. reflexivity.
    + destruct a. repeat destruct p.
      inversion H0.
      * subst. pose proof isr_isb_half _ H3. assert (h::h0 <> nil). { discriminate. }
        destruct b0. repeat rewrite complete_tree_true. eapply IHh; try eassumption.
        repeat rewrite complete_tree_false. eapply IHh; try eassumption.
      * subst. assert (h::h0 <> nil). { discriminate. }
        destruct b0. repeat rewrite complete_tree_true. eapply IHh; try eassumption.
        repeat rewrite complete_tree_false. eapply IHh; try eassumption.
Qed.
Lemma complete_isb_isr: forall h b, ~ h = nil -> is_redblack_color_half h Black ->
 is_redblack_color (complete_tree h b) Black -> is_redblack_color (complete_tree h b) Red.
Proof.
  intros.
  assert (complete_tree h b = makeBlack (complete_tree h b)).
  { symmetry. apply complete_isrb; try eassumption.
   }
   rewrite H2.
   eapply isb_isr. auto.
Qed.
Lemma complete_tree_empty_co: forall l,
  is_redblack_color_half l Black -> is_redblack_color (makeBlack(complete_tree l Empty)) Red.
Proof.
  intro.
  destruct l.
  - intros. simpl. apply IsRB_co_leaf.
  - intros. inversion H.
    + subst.  pose proof isr_isb_half _ H2. inversion H2;subst. pose proof IsRB_co_leaf Red.
      destruct b.
      rewrite complete_tree_true. eapply complete_redblack_co; try eassumption. discriminate. eapply IsRB_co_r; try eassumption. left. split; [reflexivity | reflexivity].
      rewrite complete_tree_false. eapply complete_redblack_co; try eassumption. discriminate. eapply IsRB_co_r; try eassumption. left. split; [reflexivity | reflexivity].
    + subst. pose proof IsRB_co_leaf Black.
      destruct b.
      rewrite complete_tree_true. eapply complete_redblack_co; try eassumption. discriminate. eapply IsRB_co_b; try eassumption.  right; reflexivity.
      rewrite complete_tree_false. eapply complete_redblack_co; try eassumption. discriminate. eapply IsRB_co_b; try eassumption.  right; reflexivity.
Qed.
Lemma complete_tree_co : forall l s,
 is_redblack_color_half l Black -> is_redblack_color  s Black ->
 ( s = Empty \/ ( Red_tree s /\ fst_black l ) \/ Black_tree s )
   -> is_redblack_color (makeBlack(complete_tree l s)) Red.
Proof.
  intros.
  destruct H1.
  - subst. eapply complete_tree_empty_co; try eassumption.
  - eapply complete_redblack_co; try eassumption.
    destruct s;[| discriminate].
    inversion H1. destruct H2. inversion H2. inversion H2.
Qed.
Lemma complete_makeBlack_dep : forall  l r d n,
    is_redblack_dep r n ->
    is_redblack_dep_half l d n ->
     exists n' : nat, is_redblack_dep (makeBlack (complete_tree l r)) n'.
Proof.
  intro.
  induction l.
  - intros.
    simpl.
    inversion H.
    + subst;simpl. exists 0. apply IsRB_dep_em.
    + subst;simpl. exists (S n). eapply IsRB_dep_b;try eassumption.
    + subst;simpl. exists (S n0). auto.
  - intros.
     destruct a. repeat destruct p.
     inversion H0.
     +  subst.
        simpl.
        repeat (match goal with
        | |- exists n' : nat, is_redblack_dep (makeBlack (if ?x then _ else _ )) _
               => destruct x
        | |- exists n' : nat, is_redblack_dep (makeBlack (complete_tree l _ )) _
              => eapply IHl;try eassumption
        | |- is_redblack_dep (T Red _ _ _ _ _) _ => eapply IsRB_dep_r;try eassumption
        end).
     + subst.
       simpl.
       repeat (match goal with
        | |- exists n' : nat, is_redblack_dep (makeBlack (if ?x then _ else _ )) _
               => destruct x
        | |- exists n' : nat, is_redblack_dep (makeBlack (complete_tree l _ )) _
              => eapply IHl;try eassumption
        | |- is_redblack_dep (T Black _ _ _ _ _) _ => eapply IsRB_dep_b;try eassumption
        end).
 Qed.

End Section_Half_Tree.


Require Import datatypes.

(************* Syntax of Turing machines with lists ***************)

Definition HTape2: Set := list Sym.

Inductive Tape2: Set := pair2: HTape2 -> HTape2 -> Tape2.

Definition read2 (t:Tape2): Sym :=
           match t with (pair2 l r) =>
           match r with nil => B
                      | cons b r' => b
           end end.

Definition is_value2 (T:Spec) (t:Tape2) (q:State) :=
           tr T q (read2 t) = None.

(****************** INDUCTIVE Semantics *********************)

Inductive bf2: Spec -> Tape2 -> State -> Tape2 -> State -> Prop :=

(* HALT move *)

   bfH2: forall T:Spec, forall q:State,
        forall t:Tape2,
        (is_value2 T t q) ->
        (bf2 T t q t q)

(* RIGHT moves *)

 | bfRc: forall T:Spec, forall p q i:State,
        forall l r:HTape2, forall t:Tape2, forall b:Sym,
        (tr T p (read2 (pair2 l (cons b r)))) = (Some (i, R)) ->
        (bf2 T (pair2 (cons b l) r) i t q) ->
        (bf2 T (pair2 l (cons b r)) p t q)

 | bfRn: forall T:Spec, forall p q i:State,
        forall l:HTape2, forall t:Tape2,
        (tr T p (read2 (pair2 l nil))) = (Some (i, R)) ->
        (bf2 T (pair2 (cons B l) nil) i t q) ->
        (bf2 T (pair2 l nil) p t q)

(* LEFT moves *)

 | bfLc: forall T:Spec, forall p q i:State,
        forall l r:HTape2, forall t:Tape2, forall b:Sym,
        (tr T p (read2 (pair2 (cons b l) r))) = (Some (i, L)) ->
        (bf2 T (pair2 l (cons b r)) i t q) ->
        (bf2 T (pair2 (cons b l) r) p t q)

 | bfLn: forall T:Spec, forall p q i:State,
        forall r:HTape2, forall t:Tape2,
        (tr T p (read2 (pair2 nil r))) = (Some (i, L)) ->
        (bf2 T (pair2 nil (cons B r)) i t q) ->
        (bf2 T (pair2 nil r) p t q)

(* WRITE moves *)

 | bfWc: forall T:Spec, forall p q i:State,
        forall l r:HTape2, forall t:Tape2, forall a b:Sym,
        (tr T p (read2 (pair2 l (cons b r)))) = (Some (i, (W a))) ->
        (bf2 T (pair2 l (cons a r)) i t q) ->
        (bf2 T (pair2 l (cons b r)) p t q)

 | bfWn: forall T:Spec, forall p q i:State,
        forall l:HTape2, forall t:Tape2, forall a:Sym,
        (tr T p (read2 (pair2 l nil))) = (Some (i, (W a))) ->
        (bf2 T (pair2 l (cons a nil)) i t q) ->
        (bf2 T (pair2 l nil) p t q).

(****************** COINDUCTIVE Semantics *********************)

CoInductive bi2: Spec -> Tape2 -> State -> Prop :=

(* RIGHT moves *)

   biRc: forall T:Spec, forall p q:State,
        forall l r:HTape2, forall b:Sym,
        (tr T p (read2 (pair2 l (cons b r)))) = (Some (q, R)) ->
        (bi2 T (pair2 (cons b l) r) q) ->
        (bi2 T (pair2 l (cons b r)) p)

 | biRn: forall T:Spec, forall p q:State,
        forall l:HTape2,
        (tr T p (read2 (pair2 l nil))) = (Some (q, R)) ->
        (bi2 T (pair2 (cons B l) nil) q) ->
        (bi2 T (pair2 l nil) p)

(* LEFT moves *)

 | biLc: forall T:Spec, forall p q:State,
        forall l r:HTape2, forall b:Sym,
        (tr T p (read2 (pair2 (cons b l) r))) = (Some (q, L)) ->
        (bi2 T (pair2 l (cons b r)) q) ->
        (bi2 T (pair2 (cons b l) r) p)

 | biLn: forall T:Spec, forall p q:State,
        forall r:HTape2,
        (tr T p (read2 (pair2 nil r))) = (Some (q, L)) ->
        (bi2 T (pair2 nil (cons B r)) q) ->
        (bi2 T (pair2 nil r) p)

(* WRITE moves *)

 | biWc: forall T:Spec, forall p q:State,
        forall l r:HTape2, forall a b:Sym,
        (tr T p (read2 (pair2 l (cons b r)))) = (Some (q, (W a))) ->
        (bi2 T (pair2 l (cons a r)) q) ->
        (bi2 T (pair2 l (cons b r)) p)

 | biWn: forall T:Spec, forall p q:State,
        forall l:HTape2, forall a:Sym,
        (tr T p (read2 (pair2 l nil))) = (Some (q, (W a))) ->
        (bi2 T (pair2 l (cons a nil)) q) ->
        (bi2 T (pair2 l nil) p).


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (C) 2010-2012, ENS de Lyon.
Copyright (C) 2010-2016, Inria.
Copyright (C) 2014-2016, IRIT.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import ZArith Reals Psatz.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrfun eqtype ssrnat bigop.
From Coquelicot Require Import Coquelicot.

Require Import Stdlib.
Require Import MathComp.
Require Import Xreal.
Require Import Interval.
Require Import Taylor.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope nat_scope.

Notation IInan := Interval.Inan (only parsing).

(**************************************************************)
(** Some support results relating inequalities and [contains] *)
(**************************************************************)

Definition intvl a b x := (a <= x <= b)%R.

Lemma intvl_connected a b : connected (intvl a b).
Proof.
move=> x y Hx Hy z Hz; split.
- exact: Rle_trans (proj1 Hx) (proj1 Hz).
- exact: Rle_trans (proj2 Hz) (proj2 Hy).
Qed.

Lemma intvl_l l u x0 :
  intvl l u x0 -> intvl l u l.
Proof. by case=> [H1 H2]; split =>//; apply: Rle_refl || apply: Rle_trans H2. Qed.

Lemma intvl_u l u x0 :
  intvl l u x0 -> intvl l u u.
Proof. by case=> [H1 H2]; split =>//; apply: Rle_refl || apply: Rle_trans H2. Qed.

Lemma intvl_lVu l u x0 x :
  intvl l u x -> intvl l u x0 -> intvl l x0 x \/ intvl x0 u x.
Proof.
move=> [H1 H2] [H3 H4].
have [Hle|Hlt] := Rle_lt_dec x x0.
by left.
by move/Rlt_le in Hlt; right.
Qed.

(********************************************)
(** Some support results about monotonicity *)
(********************************************)

Section PredArg.
Variable P : R -> Prop.

Definition Rincr (f : R -> R) :=
  forall x y : R,
  P x -> P y ->
  (x <= y -> f x <= f y)%R.

Definition Rdecr (f : R -> R) :=
  forall x y : R,
  P x -> P y ->
  (x <= y -> f y <= f x)%R.

Definition Rmonot (f : R -> R) :=
  Rincr f \/ Rdecr f.

Definition Rpos_over (g : R -> R) :=
  forall x : R, (P x -> 0 <= g x)%R.

Definition Rneg_over (g : R -> R) :=
  forall x : R, (P x -> g x <= 0)%R.

Definition Rcst_sign (g : R -> R) :=
  Rpos_over g \/ Rneg_over g.

Definition Rderive_over (f f' : R -> R) :=
  forall x : R, P x -> is_derive f x (f' x).

Lemma Rderive_pos_imp_incr (f f' : R -> R) :
  connected P -> Rderive_over f f' -> Rpos_over f' -> Rincr f.
Proof.
rewrite /Rpos_over /Rincr.
move=> Hco Hder H0 x y Hx Hy Hxy; rewrite //=.
eapply (derivable_pos_imp_increasing f f' P) =>//.
move=> r Hr.
move/(_ _ Hr) in Hder.
move/(_ _ Hr) in H0.
apply: conj H0.
exact/is_derive_Reals.
Qed.

Lemma Rderive_neg_imp_decr (f f' : R -> R) :
  connected P -> Rderive_over f f' -> Rneg_over f' -> Rdecr f.
Proof.
rewrite /Rneg_over /Rdecr.
move=> Hco Hder H0 x y Hx Hy Hxy; rewrite //=.
eapply (derivable_neg_imp_decreasing f f' P) =>//.
move=> r Hr.
move/(_ _ Hr) in Hder.
move/(_ _ Hr) in H0.
apply: conj H0.
exact/is_derive_Reals.
Qed.

Lemma Rderive_cst_sign (f f' : R -> R) :
  connected P -> Rderive_over f f' -> Rcst_sign f' -> Rmonot f.
Proof.
move=> Hco Hder [H|H].
left; exact: Rderive_pos_imp_incr H.
right; exact: Rderive_neg_imp_decr H.
Qed.

End PredArg.

(********************************************************************)
(** Instantiation of [Taylor.Cor_Taylor_Lagrange] for intervals *)
(********************************************************************)

Lemma sum_f_to_big n (f : nat -> R) :
  sum_f_R0 f n = \big[Rplus/0%R]_(0 <= i < n.+1) f i.
Proof.
elim: n =>[|n IHn]; first by rewrite big_nat_recl // big_mkord big_ord0 Rplus_0_r.
by rewrite big_nat_recr //= IHn.
Qed.

Section NDerive.
Variable xf : R -> ExtendedR.
Let f x := proj_val (xf x).
Let Dn := Derive_n f.
Variable dom : R -> Prop.
Hypothesis Hdom : connected dom.
Variable n : nat.
Hypothesis Hdef : forall r, dom r -> xf r <> Xnan.
Hypothesis Hder : forall n r, dom r -> ex_derive_n f n r.

Theorem ITaylor_Lagrange x0 x :
  dom x0 ->
  dom x ->
  exists xi : R,
  dom xi /\
  (f x - \big[Rplus/0%R]_(0 <= i < n.+1)
          (Dn i x0 / INR (fact i) * (x - x0)^i))%R =
  (Dn n.+1 xi / INR (fact n.+1) * (x - x0) ^ n.+1)%R /\
  (x <= xi <= x0 \/ x0 <= xi <= x)%R.
Proof.
move=> Hx0 Hx.
case (Req_dec x0 x)=> [->|Hneq].
  exists x; split =>//=; split; last by auto with real.
  rewrite (Rminus_diag_eq x) // Rmult_0_l Rmult_0_r.
  rewrite big_nat_recl // pow_O big1 /Dn /=; try field.
  by move=> i _; rewrite Rmult_0_l Rmult_0_r.
have Hlim x1 x2 : (x1 < x2)%R -> dom x1 -> dom x2 ->
  forall (k : nat) (r1 : R), (k <= n)%coq_nat ->
  (fun r2 : R => x1 <= r2 <= x2)%R r1 ->
  derivable_pt_lim (Dn k) r1 (Dn (S k) r1).
  move=> Hx12 Hdom1 Hdom2 k y Hk Hy.
  have Hdy: (dom y) by move: Hdom; rewrite /connected; move/(_ x1 x2); apply.
  by apply/is_derive_Reals/Derive_correct; apply: (Hder k.+1 Hdy).
destruct (total_order_T x0 x) as [[H1|H2]|H3]; last 2 first.
    by case: Hneq.
  have H0 : (x <= x0 <= x0)%R by auto with real.
  have H : (x <= x <= x0)%R by auto with real.
  case: (Cor_Taylor_Lagrange x x0 n (fun n r => (Dn n r))
    (Hlim _ _ (Rgt_lt _ _ H3) Hx Hx0) x0 x H0 H) => [c [Hc Hc1]].
  exists c.
  have Hdc : dom c.
    move: Hdom; rewrite /connected; move/(_ x x0); apply=>//.
    by case: (Hc1 Hneq)=> [J|K]; lra.
  split=>//; split; last by case:(Hc1 Hneq);rewrite /=; [right|left]; intuition.
  rewrite sum_f_to_big in Hc.
  exact: Hc.
have H0 : (x0 <= x0 <= x)%R by auto with real.
have H : (x0 <= x <= x)%R by auto with real.
case: (Cor_Taylor_Lagrange x0 x n (fun n r => Dn n r)
  (Hlim _ _ (Rgt_lt _ _ H1) Hx0 Hx) x0 x H0 H) => [c [Hc Hc1]].
exists c.
have Hdc : dom c.
  move: Hdom; rewrite /connected; move/(_ x0 x); apply=>//.
  by case: (Hc1 Hneq)=> [J|K]; lra.
split=>//; split; last by case:(Hc1 Hneq);rewrite /=; [right|left]; intuition.
rewrite sum_f_to_big in Hc.
exact: Hc.
Qed.

End NDerive.

(******************************************************************************)
(** The sequel of the file is parameterized by an implementation of intervals *)
(******************************************************************************)

Module IntervalAux (I : IntervalOps).

(** The following predicate will be used by [Ztech]. *)
Definition isNNegOrNPos (X : I.type) : bool :=
  if I.sign_large X is Xund then false else true.

Lemma isNNegOrNPos_false (X : I.type) :
  I.convert X = IInan -> isNNegOrNPos X = false.
Proof.
move=> H; rewrite /isNNegOrNPos; have := I.sign_large_correct X.
by case: I.sign_large =>//; rewrite H; move/(_ Xnan I) =>//; case.
Qed.

Definition gt0 xi : bool :=
  if I.sign_strict xi is Xgt then true else false.

Definition apart0 xi : bool :=
  match I.sign_strict xi with
  | Xlt | Xgt => true
  | _ => false
  end.

Lemma gt0_correct X x :
  contains (I.convert X) (Xreal x) -> gt0 X -> (0 < x)%R.
Proof.
move=> Hx; rewrite /gt0.
have := I.sign_strict_correct X; case: I.sign_strict=>//.
by case/(_ _ Hx) =>/=.
Qed.

Lemma apart0_correct X x :
  contains (I.convert X) (Xreal x) -> apart0 X -> (x <> 0)%R.
Proof.
move=> Hx; rewrite /apart0.
have := I.sign_strict_correct X; case: I.sign_strict=>//;
  by case/(_ _ Hx) =>/=; auto with real.
Qed.

(******************************************************************************)
(** Correctness predicates dealing with reals only, weaker than [I.extension] *)
(******************************************************************************)

Lemma R_from_nat_correct :
  forall p (b : I.type) (n : nat),
  contains (I.convert (I.fromZ p (Z.of_nat n)))
           (Xreal (INR n)).
Proof. move=> p b n; rewrite INR_IZR_INZ; exact: I.fromZ_correct. Qed.

Section PrecArgument.

Variable prec : I.precision.

Lemma mul_0_contains_0_l y Y X :
  contains (I.convert Y) y ->
  contains (I.convert X) (Xreal 0) ->
  contains (I.convert (I.mul prec X Y)) (Xreal 0).
Proof.
move=> Hy H0.
have H0y ry : (Xreal 0) = (Xreal 0 * Xreal ry)%XR by rewrite /= Rmult_0_l.
case: y Hy => [|ry] Hy; [rewrite (H0y 0%R)|rewrite (H0y ry)];
  apply: I.mul_correct =>//.
by case ->: (I.convert Y) Hy.
Qed.

Lemma mul_0_contains_0_r y Y X :
  contains (I.convert Y) y ->
  contains (I.convert X) (Xreal 0) ->
  contains (I.convert (I.mul prec Y X)) (Xreal 0).
Proof.
move=> Hy H0.
have Hy0 ry : (Xreal 0) = (Xreal ry * Xreal 0)%XR by rewrite /= Rmult_0_r.
case: y Hy => [|ry] Hy; [rewrite (Hy0 0%R)|rewrite (Hy0 ry)];
  apply: I.mul_correct=>//.
by case: (I.convert Y) Hy.
Qed.

Lemma pow_contains_0 (X : I.type) (n : Z) :
  (n > 0)%Z ->
  contains (I.convert X) (Xreal 0) ->
  contains (I.convert (I.power_int prec X n)) (Xreal 0).
Proof.
move=> Hn HX.
rewrite (_: (Xreal 0) = (Xpower_int (Xreal 0) n)); first exact: I.power_int_correct.
case: n Hn =>//= p Hp; rewrite pow_ne_zero //.
by zify; auto with zarith.
Qed.

Lemma subset_sub_contains_0 x0 (X0 X : I.type) :
  contains (I.convert X0) x0 ->
  subset' (I.convert X0) (I.convert X) ->
  contains (I.convert (I.sub prec X X0)) (Xreal 0).
Proof.
move=> Hx0 Hsub.
destruct x0 as [|x0].
rewrite I.sub_propagate_r //.
now destruct (I.convert X0).
replace (Xreal 0) with (Xreal x0 - Xreal x0)%XR.
apply I.sub_correct with (2 := Hx0).
now apply Hsub.
apply (f_equal Xreal).
now apply Rminus_diag_eq.
Qed.

End PrecArgument.
End IntervalAux.