Require Export Sets.

(* 万有集合の非存在  *)
Theorem notex_universalset :
  ~ exists U, forall x, x ∈ U.
Proof.
  intro H.
  induction H as [U H].
  specialize (Comprehension (fun x => ~ x ∈  x) U)as F.
  induction F as [F HF].
  specialize (HF F).
  specialize (H F).
  case (ExcludedMiddle (F ∈ F)) as [FF |notFF].
  + apply HF in FF as notFF.
    induction notFF as [_ notFF].
    apply (notFF FF).
  + apply notFF.
    apply HF.
    apply (conj H notFF).
Qed.

(* 順序対の相等 *)

Lemma x_xOPy (x y : set) :
  Single x ∈ <|x,y|>.
Proof.
  apply couple.
  by apply or_introl.
Qed.

Lemma xy_xOPy (x y : set) :
   Couple x y ∈ <|x,y|>.
Proof.
  apply couple.
  by apply or_intror.
Qed.

Lemma single (x : set) :
  forall y, y ∈ (Single x) <-> y = x.
Proof.
  intros y.
  split => [H | H].
  + apply couple in H.
    induction H as [L | R].
    - apply L.
    - apply R.
  + rewrite couple.
    apply (or_intror H) .
Qed.

Theorem x_xx (x : set) :
  x ∈( Single x).
Proof.
  apply couple.
  by apply or_introl.
Qed.

Theorem x_xy (x y : set) :
  x ∈ (Couple x y).
Proof.
  apply couple.
  by apply or_introl.
Qed.

Theorem y_xy (x y: set) :
  y ∈ (Couple x y).
Proof.
  apply couple.
  by apply or_intror.
Qed.

Lemma single_single (x X : set) :
  Single x = Single X <-> x = X.
Proof.
  split => [H | H].
  + specialize (x_xx x) as Hx_xx.
    rewrite H in Hx_xx.
    by  apply single in Hx_xx.
  + by subst x.
Qed.

Lemma single_couple (x X Y : set) :
  Single x = Couple X Y <-> x = X /\ x = Y.
Proof.
  specialize (x_xy X Y) as X_XY.
  specialize (y_xy X Y) as Y_XY.
  split => [H | H].
  + rewrite <- H in X_XY.
    rewrite <- H in Y_XY.
    apply single in X_XY.
    apply single in Y_XY.
    by subst x Y.
  + by induction H; subst X Y.
Qed.

Lemma couple_couple (x y X Y : set) :
  Couple x y = Couple X Y -> (x = X \/ x = Y) /\ (y = X \/ y = Y).
Proof.
  intro H.
  specialize (x_xy x y) as Hx_xy.
  specialize (y_xy x y) as Hy_xy.
  rewrite H in Hx_xy.
  rewrite H in Hy_xy.
  clear H.
  apply couple in Hx_xy.
  apply couple in Hy_xy.
  done.
Qed.

Lemma couple_single (x y X : set) :
  Couple x y = Single X <-> x = X /\ y = X.
Proof.
  specialize (x_xy x y) as Hx_xy.
  specialize (y_xy x y) as Hy_xy.
  split => [H | H].
  + rewrite H in Hx_xy.
    rewrite H in Hy_xy.
    apply single in Hx_xy.
    apply single in Hy_xy.
    by subst x y.
  + by induction H; subst x y.
Qed.

Theorem eq_OrderPair {x y X Y : set} :
  <|x,y|> = <|X,Y|> <-> x = X /\ y = Y.
Proof.
specialize (xy_xOPy x y) as H1.
specialize (xy_xOPy X Y) as H2.
specialize (x_xOPy x y) as H3.
split => [H | H].
+ rewrite H in H1.
  rewrite <- H in H2.
  rewrite H in H3.
  apply couple in H1.
  apply couple in H2.
  apply couple in H3.
  case (ExcludedMiddle (x = y)) as [xy | notxy].
  - subst y.
    induction H1 as [x_X | x_XY].
    * apply (single_single x X) in x_X.
      subst X.
      induction H2 as [xY_x | xY_x].
        apply couple_single in xY_x.
        by induction xY_x; subst Y.
        apply couple_single in xY_x.
        by induction xY_x; subst Y.
    * by apply single_couple in x_XY.
  - induction H1 as [xy_X | xy_XY].
    * apply couple_single in xy_X.
      induction xy_X; subst x y.
      case (notxy (eq_refl X)).
    * apply couple_couple in xy_XY.
      induction xy_XY as [L R].
      induction H3 as [x_X | x_XY].
        apply (single_single x X) in x_X.
        apply (conj x_X).
        subst X.
        induction R as [yx | yY].
        assert (xy : x = y) by done.
        case (notxy xy).
        done.
        apply single_couple in x_XY.
        induction x_XY; subst X Y.
        apply (conj (eq_refl x)).
        induction R as [yx | yx].
        done.
        done.
+ by  induction H; subst X Y.
Qed.

(* 分配則  *)
Theorem cap_sym  {A B : set} :
    A ∩ B = B ∩ A.
Proof.
  apply Extensionality.
  intro x.
  repeat rewrite cap.
  split => [AB | BA].
  + by induction AB.
  + by induction BA.
Qed.

Theorem cup_sym {A B : set} :
  A ∪ B = B ∪ A.
  Proof.
    apply Extensionality => x.
    repeat rewrite cap .
    unfold isCups.
    repeat rewrite cup.
    split => [H | H].
    + induction H as [a | b].
      apply (or_intror a).
      apply (or_introl b).
    + induction H as [b | a].
      - apply (or_intror b).
      - apply (or_introl a).
Qed.

  Theorem cap_dist_cup_l {A B C : set} :
    A ∩ (B ∪ C)  = (A ∩ B) ∪ (A ∩ C).
  Proof.
    apply Extensionality => x.
    repeat rewrite cup.
    rewrite cap.
    rewrite cup.
    repeat rewrite cap.
    split => [H | H].
    + induction H as [a bc].
      induction bc as [b | c].
      - by apply or_introl.
      - by apply or_intror.
    + induction H as [ab | ac].
      - induction ab as [a b].
        apply (conj a (or_introl b)).
      - induction ac as [a c].
        apply (conj a (or_intror c)).
  Qed.

  Theorem cap_dist_cup_r {A B C : set} :
    (B ∪ C) ∩ A = (B ∩ A) ∪ (C ∩ A).
  Proof.
    repeat rewrite [_ ∩ A] cap_sym.
    by apply cap_dist_cup_l.
  Qed.

  Theorem cup_dist_cap_l {A B C : set} :
    A ∪ (B ∩ C) = (A ∪ B) ∩ (A ∪ C).
  Proof.
    apply Extensionality => x.
    rewrite cup.
    rewrite cap.
    rewrite cap.
    repeat rewrite cup.
    split => [H | H].
    + induction H as [a | bc].
    - apply (conj (or_introl a) (or_introl a)).
    - induction bc as [b c].
      apply (conj (or_intror b) (or_intror c)).
    + induction H as [ab ac].
      induction ab as [a | b].
      apply (or_introl a).
      induction ac as [a | c].
      apply (or_introl a).
      apply (or_intror (conj b c)).
  Qed.

  Theorem cup_dist_cap_r {A B C : set} :
    (B ∩ C) ∪ A = (B ∪ A) ∩ (C ∪ A).
  Admitted.


Require Import FunctionalExtensionality.
Require Import Helpers.Instances.

Set Implicit Arguments.

Section FunMap.

  Variable A : Type.
  Variable V : Type.
  Context {Aeq : EqualDec A}.

  Definition funmap := A -> V.

  Definition fupd (a : A) (v : V) (m : funmap) : funmap :=
    fun a' => if a == a' then v else m a'.

  Theorem fupd_eq : forall a v m,
    fupd a v m a = v.
  Proof.
    unfold fupd; intros.
    destruct (a == a); congruence.
  Qed.

  Theorem fupd_ne : forall a a' v m,
    a <> a' ->
    fupd a v m a' = m a'.
  Proof.
    unfold fupd; intros.
    destruct (a == a'); congruence.
  Qed.

  Theorem fupd_fupd_eq : forall a v v' m,
    fupd a v (fupd a v' m) = fupd a v m.
  Proof.
    unfold fupd; intros.
    eapply functional_extensionality; intros.
    destruct (a == x); congruence.
  Qed.

  Theorem fupd_fupd_ne : forall a v a' v' m,
    a <> a' ->
    fupd a v (fupd a' v' m) = fupd a' v' (fupd a v m).
  Proof.
    unfold fupd; intros.
    eapply functional_extensionality; intros.
    destruct (a == x); destruct (a' == x); congruence.
  Qed.

  Theorem fupd_same : forall a v m,
      m a = v ->
      fupd a v m = m.
  Proof.
    intros.
    extensionality a'; subst.
    destruct (a == a'); subst.
    rewrite fupd_eq; auto.
    rewrite fupd_ne; auto.
  Qed.

End FunMap.

Hint Rewrite fupd_eq : fupd.
Hint Rewrite fupd_ne using (congruence || solve [ auto ]) : fupd.
Hint Rewrite fupd_fupd_eq : fupd.

Identity Coercion funmap_apply : funmap >-> Funclass.


(*
   Ich habe dort, wo dependent induction oder destruction vorhommt/kam, Alternativen hingeschrieben,
   die Schemata aus der Fin-Bibliothek benutzen; so koennten wir auf "Program" verzichten.
*)

Require Import Fin.
Require Import Program.

(* type isomorphisms a.s.o. *)

Record Iso (A B : Type) : Type :=
  MkIso {
      to : A -> B;
      from : B -> A;
      toFrom : forall (b : B), (to (from b) = b);
      fromTo : forall (a : A), (from (to a) = a)
  }.

(* identity isomorphism *)
Lemma idIso (A : Type) : Iso A A.
Proof.
  exact (MkIso _ _ id id (fun _ => eq_refl) (fun _ => eq_refl)).
Defined.

Print idIso.

(* inversion of isomorphisms *)
Lemma symIso (A B : Type) : Iso A B -> Iso B A.
Proof.
  intro isoAB.
  destruct isoAB as [to from toFrom fromTo].
  exact (MkIso _ _ from to fromTo toFrom).
Defined.

(* we even have (but never use..) *)
Lemma symIsoIso (A B : Type) : Iso (Iso A B) (Iso B A).
Proof.
  apply (MkIso _ _ (symIso A B) (symIso B A));
  intro isoab; destruct isoab; compute; reflexivity.
Defined.

(* composition of isomorphisms *)
Lemma transIso (A B C : Type) : Iso B C -> Iso A B -> Iso A C.
Proof.
  intros isoBC isoAB.
  destruct isoBC as [bc cb bccb cbbc].
  destruct isoAB as [ab ba abba baab].
  apply (MkIso _ _ (compose bc ab) (compose ba cb)).
  + intro c; compute; rewrite (abba (cb c)); rewrite (bccb c); reflexivity.
  + intro a; compute; rewrite (cbbc (ab a)); rewrite (baab a); reflexivity.
Defined.

(* "flipped" version just for convenience *)
Lemma transIso' (A B C : Type) : Iso A B -> Iso B C -> Iso A C.
Proof.
  intros isoab isobc.
  exact (transIso _ _ _ isobc isoab).
Defined.

(*
(* with function extensionality, we would even have:
 *)
Lemma transIsoIso (A B C : Type) (isoBC : Iso B C) : Iso (Iso A B) (Iso A C).
Proof.
  apply (MkIso _ _ (transIso A _ _ isoBC) (transIso A _ _ (symIso _ _ isoBC))).
  + intro isoAB.
    destruct isoAB as [ab ba abba baab].
    destruct isoBC as [bc cb bccb cbbc].

  but not here...
*)

(* finite types *)

Record Finite (X : Type) : Type :=
  MkFinite {
      card : nat;
      isoFin : Iso X (@Fin.t card)
  }.

Definition FiniteType : Type :=
  sigT Finite.

(* for any cardinality, we have the standard finite type
   of that cardinality *)

Definition FinFinite (card : nat) : FiniteType.
Proof.
  unfold FiniteType.
  exact (existT Finite (@Fin.t card) (MkFinite (@Fin.t card) card (idIso (@Fin.t card)))).

 (* alternativ:

  exists (@Fin.t card).
  apply (MkFinite (@Fin.t card) card (idIso (@Fin.t card))).

*)
Defined.

(* recursion and induction "principles"...
   idea: things about finite types are determined
         if they are determined for the standard finite types
   very preliminary
*)

Lemma recFinite0 (B : Type) (onFin : forall (card : nat), B) (X : FiniteType) : B.
Proof.
  destruct X as [_ [card _]].
  exact (onFin card).
Defined.

Lemma indFinite0 (B : nat -> Type)
                 (onFin : forall (card : nat), B card)
                 (X : FiniteType) : recFinite0 Type B X.
Proof.
  destruct X as [X [card iso]].
  simpl.
  exact (onFin card).
Defined.

Lemma recFinite (B : Type)
                (onFin : forall (card : nat) (i : @Fin.t card), B)
                {X : FiniteType}
                (x : (projT1 X)) : B.
Proof.
  destruct X as [X [card iso]].
  destruct iso as [to from toFrom fromTo].
  simpl in x.
  exact (onFin card (to x)).
Defined.

(*
Lemma indFinite (B : nat -> Type)
                (onFin : forall (card : nat) (i : @Fin.t card), B card)
                {X : FiniteType}
                (x : (projT1 X)) : recFinite Type ...
*)

(* let's do the operations we need "by hand" *)

(* towards optionFinite *)

Fixpoint optionFinTo {n : nat} (f : @Fin.t (S n)) : option (Fin.t n) :=
match f with
| F1 => None
| FS f' => Some f'
end.

Inductive Auto (A : Type) : Type := MkAuto : (A -> A) -> Auto A.

Fixpoint optionFinFrom {n : nat} (of : option (Fin.t n)) : @Fin.t (S n) :=
match of with
| None => F1
| Some f' => FS f'
end.

Fixpoint optionFinIso {n : nat} : Iso (@Fin.t (S n)) (option (Fin.t n)).
Proof.
 apply (MkIso (t (S n)) (option (t n)) (@optionFinTo n) (@optionFinFrom n));
 induction n; intro a; dependent destruction a; simpl; reflexivity.

(* Variante, die zwar nicht so kurz ist, aber "dependent destruction" vermeidet:

  apply (MkIso (t (S n)) (option (t n)) (@optionFinTo n) (@optionFinFrom n)).
  - induction n; intro b; destruct b; simpl;reflexivity.
  - induction n; intro a; apply (caseS' a); simpl; reflexivity.

*)
Defined.

Fixpoint mapOption {A B : Type} (f: A -> B) (oa : option A) : option B :=
match oa with
| None   => None
| Some a => Some (f a)
end.

Fixpoint optionIso {A B : Type} (AIsoB : Iso A B) : Iso (option A) (option B).
Proof.
  destruct AIsoB as [ab ba abba baab].
  apply (MkIso (option A) (option B) (mapOption ab) (mapOption ba)).
  - intro ob; induction ob as [ b | ]; simpl.
    + rewrite (abba b); reflexivity.
    + reflexivity.
  - intro oa; induction oa as [ a | ]; simpl.
    + rewrite (baab a); reflexivity.
    + reflexivity.
Defined.

Fixpoint optionFinite (X : FiniteType) : FiniteType.
Proof.
  destruct X as [X [card iso]].
  pose (optionIso iso) as oIso.
  pose (transIso _ _ _
          (symIso _ _ (@optionFinIso card))
          oIso
          ) as oIso2.
  assert (Finite (option X)) as optionIsFinite.
  apply (MkFinite (option X) (S card) oIso2).
  exact (existT Finite (option X) optionIsFinite).

(* Variante:

  destruct X as [X [card iso]].
  apply optionIso in iso as oIso.
  apply (transIso _ _ _
          (symIso _ _ (@optionFinIso card))) in oIso as oIso2.
  exists (option X).
  apply (MkFinite (option X) (S card) oIso2).
*)

Defined.

Print sigT.

Fixpoint decideFin (X : Type) (Xfin : Finite X) : (Iso X (Fin.t 0)) + {n : nat & Iso X (option (Fin.t n))}.
Proof.
  destruct Xfin as [card iso].
  induction card.
  + exact (inl iso). (* Alternativ: "left. exact iso." *)
  + apply inr. (* Die "normale" zugehoerige Taktik waere "right" *)
    pose (@optionFinIso card0) as iso2.
    pose (transIso _ _ _ iso2 iso) as iso3.
    apply (existT _ card0 iso3). (* oder: "exists card0. exact iso3." *)

(* Alternative:

  + left. exact iso.
  + right.
    exists card0.
    apply (transIso X (t (S card0)) (option (t card0))).
    - apply optionFinIso.
    - exact iso.
*)

Defined.

Fixpoint optionSumTo (X Y : Type) ( oxY : (option X) + Y) : option (X + Y) :=
  match oxY with
      | (inl None)      => None
      | (inl (Some x))  => Some (inl x)
      | (inr y)         => Some (inr y)
  end.

Fixpoint optionSumFrom (X Y : Type) (oXy : option (X + Y)) : (option X) + Y :=
  match oXy with
      | None            => inl None
      | Some (inl x)    => inl (Some x)
      | Some (inr y)    => inr y
  end.

Lemma optionSumIso (X Y : Type) : Iso ((option X) + Y) (option (X + Y)).
Proof.
  apply (MkIso _ _ (optionSumTo X Y) (optionSumFrom X Y)).
  + intro oxy; induction oxy as [xy | ].
    - induction xy; simpl; reflexivity. (* oder mit "destruct xy;..." *)
    - simpl; reflexivity.
  + intro oxy; induction oxy as [ox | y].
    - induction ox as [x | ]; simpl; reflexivity.
    - simpl; reflexivity.
Defined.

Fixpoint sumFlip (X Y : Type) (xy : X + Y) : (Y + X) :=
  match xy with
      | inl x => inr x
      | inr y => inl y
  end.

Lemma sumCommutative (X Y : Type) : Iso (X + Y) (Y + X).
Proof.
  apply (MkIso _ _ (sumFlip X Y) (sumFlip Y X)).
  intro yx; induction yx; simpl; reflexivity.
  intro xy; induction xy; simpl; reflexivity.
Defined.

Definition univSum {X Y Z : Type} (f : X -> Z) (g : Y -> Z) (xy: X + Y) : Z :=
  match xy with
      | inl x => f x
      | inr y => g y
  end.

Definition sumMap {X Y Z W : Type} (f : X -> Z) (g : Y -> W) : (X + Y) -> (Z + W) :=
  univSum (compose inl f) (compose inr g).

Lemma sumIsoLeft (X Y Z : Type) (isoXY: Iso X Y) : Iso (X + Z) (Y + Z).
Proof.
  destruct isoXY as [xy yx xyyx yxxy].
  apply (MkIso _ _ (sumMap xy id) (sumMap yx id)).
  + intro oyz; induction oyz as [y | z].
    - compute; rewrite (xyyx y); reflexivity.
    - trivial.
  + intro oxz; induction oxz as [x | z].
    - compute; rewrite (yxxy x); reflexivity.
    - trivial.
Defined.

Lemma sumIsoRight (X Y Z : Type) (isoXY: Iso X Y) : Iso (Z + X) (Z + Y).
Proof. (* couldn't we deduce this from sumIsoLeft and symmetry properties ?*)
  destruct isoXY as [xy yx xyyx yxxy].
  apply (MkIso _ _ (sumMap id xy) (sumMap id yx)).
  + intro ozy; induction ozy as [z | y].
    - trivial.
    - compute. rewrite (xyyx y); reflexivity.
  + intro ozx; induction ozx as [z | x].
    - trivial.
    - compute; rewrite (yxxy x); reflexivity.
Defined.

Lemma falseFromFin0 (x : Fin.t 0) : False.
Proof.
  apply case0; exact x.
Defined.

Lemma finZeroIsoFalse : Iso False (Fin.t 0).
Proof.
  apply (MkIso _ _ (False_rect (t 0)) falseFromFin0).
  + intro x; dependent induction x. (* "case0." wuerde reichen; sonst ginge auch "dependent destruction x" *)
  + intro a; apply False_rect; exact a. (* "intro a; destruct a." reicht *)
Defined.

Lemma sumFalseIso (X : Type) : Iso (False + X) X.
Proof.
  apply (MkIso _ _ (univSum (False_rect X) id) inr).
  + intro x; compute; reflexivity.
  + intro fx; induction fx as [f | x].
    - destruct f.
    - compute; reflexivity.
Defined.

(* Definition OfCard (n : nat) (X : Type) : Type := Iso X (Fin.t n). *)

Lemma sumFiniteLemma (n m : nat) : forall (X Y : Type),
                                   (Iso X (Fin.t n)) -> (Iso Y (Fin.t m)) ->
                                   (Iso (X + Y) (Fin.t (n + m))).
Proof.
  induction n.
  + intros X Y isoXt0 isoYtm.
    compute.
    pose (transIso _ _ _ (symIso _ _ finZeroIsoFalse) isoXt0) as isoXF.
    pose (sumIsoLeft _ _ Y isoXF) as isoSumXYSumFY.
    apply (transIso' _ _ (t m) isoSumXYSumFY).
    apply (transIso' _ _ (t m) (sumFalseIso Y)).
    exact isoYtm.
  + intros X Y isoXtSn isoYtm.
    pose (sumIsoLeft _ _ Y isoXtSn) as isoSumXYSumtSnY.
    apply (transIso' _ _ (t (S n + m)) isoSumXYSumtSnY).
    clear isoXtSn isoSumXYSumtSnY X.
    pose (sumIsoLeft _ _ Y (@optionFinIso n)) as isoSumtSnYSumOtn.
    apply (transIso' _ _ (t (S n + m)) isoSumtSnYSumOtn).
    clear isoSumtSnYSumOtn.
    apply (transIso' _ _ (t (S n + m)) (optionSumIso (t n) Y)).
    pose (IHn (t n) Y (idIso (t n)) isoYtm) as isoSumtnYtnm.
    apply (transIso' _ _ (t (S n + m)) (optionIso isoSumtnYtnm)).
    clear isoYtm isoSumtnYtnm Y.
    apply (transIso' _ _ (t (S n + m)) (symIso _ _ (@optionFinIso (n + m)))).
    exact (idIso (t (S n + m))).
Defined.

Lemma sumFinite (X Y : Type) (Xfin : Finite X) (Yfin : Finite Y) : Finite (X + Y).
Proof.
  destruct Xfin as [cardX isoX].
  destruct Yfin as [cardY isoY].
  apply (MkFinite _ (cardX + cardY)).
  apply (sumFiniteLemma cardX cardY X Y isoX isoY).
Defined.

Fixpoint addFinite (X Y : FiniteType) : FiniteType.
Proof.
   destruct X as [X Xfin].
   destruct Y as [Y Yfin].
   exact (existT Finite (sum X Y) (sumFinite X Y Xfin Yfin)).
Defined.


Require Import HoTT.

(** A few lemmas regarding equivalences we either didn't find in the HoTT library, or wanted to do differently. *)

Definition equiv_emoveR_fV `{Funext} {A B C : Type} (e : A <~> B) (f : B -> C) (g : A -> C) :
  g = f o e <~> g o e^-1 = f.
Proof.
  transitivity (g == f o e).
  { apply equiv_inverse.
    apply equiv_path_arrow. }
  transitivity (g o e^-1 == f).
  { unfold pointwise_paths.
    apply equiv_inverse.
    apply (equiv_functor_forall' e).
    intro b.
    apply (equiv_concat_l).
    apply (ap g).
    change (e^-1 (e b)) with ((e^-1 o e) b).
    apply (ap10 (f:= idmap)).
    apply path_arrow.
    intro x. apply inverse. apply (eissect e). }
    apply equiv_path_arrow.
Defined.

Definition sum_assoc (A B C : Type)
  : A + B + C -> A + (B + C).
Proof.
  intros [[a | b] | c].
  - exact (inl a).
  - exact (inr (inl b)).
  - exact (inr (inr c)).
Defined.

Definition sum_assoc_inv (A B C : Type)
  : A + (B + C) -> (A + B) + C.
Proof.
  intros [a | [b | c]].
  - exact (inl (inl a)).
  - exact (inl (inr b)).
  - exact (inr c).
Defined.

Definition equiv_sum_assoc' (A B C : Type)
  : (A + B) + C <~> A + (B + C).
Proof.
  apply (equiv_adjointify (sum_assoc A B C) (sum_assoc_inv A B C)).
  - intros [a | [b | c]]; reflexivity.
  - intros [[a | b] | c]; reflexivity.
Defined.

(* Definition equiv_emoveL `{Funext} {A B C : Type} (e : A <~> B) (f : B -> C) (g : A -> C) :  *)
(*   g = f o e <~> g o e^-1 = e f. *)
(* Proof. *)
(*   transitivity (g == f o e). *)
(*   apply equiv_inverse. *)
(*   apply equiv_path_arrow. *)
(*   transitivity (g o e^-1 == f). *)
(*   unfold pointwise_paths. *)
(*   apply equiv_inverse. *)
(*   apply (equiv_functor_forall' e). *)
(*   intro b. *)
(*   apply (equiv_concat_l). *)
(*   apply (ap g). *)
(*   change (e^-1 (e b)) with ((e^-1 o e) b). *)
(*   apply (ap10 (f:= idmap)). *)
(*   apply path_arrow. *)
(*   intro x. apply inverse. apply (eissect e). *)
(*   apply equiv_path_arrow. *)
(* Defined. *)

Lemma equiv_is_embedding `{Funext} {A B : Type} (f : A -> B) {isequiv_f : IsEquiv f}
  : IsEmbedding f.
Proof.
  unfold IsEmbedding. intro b.
  srapply @trunc_succ.
  apply fcontr_isequiv. exact isequiv_f.
Defined.

Definition ecancelL `{Funext} {A B C : Type} (f : A -> B) {isequiv_f : IsEquiv f} (g h : B -> C) :
  g o f = h o f -> g = h.
Proof.
  intro p.
  apply path_arrow.
  intro b.
  refine (ap g (eisretr f b)^ @ _ @ ap h (eisretr f b)).
  exact (ap10 p (f^-1 b)).
Defined.

Definition ecancelR `{Funext} {A B C : Type} (f g : A -> B) (h : B -> C) {isequiv_h : IsEquiv h} :
  h o f = h o g -> f = g.
Proof.
  intro p.
  apply path_arrow.
  intro a.
  refine ((eissect h (f a))^ @ _ @ (eissect h (g a))).
  exact (ap (h^-1) (ap10 p a)).
Defined.

Definition equiv_functor_sum_1 `{Funext} {A B : Type} : @equiv_idmap A +E @equiv_idmap B = equiv_idmap.
Proof.
  apply path_equiv. apply path_arrow. intros [a | b]; reflexivity.
Defined.


Require Import Coq.Setoids.Setoid.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Lists.List.

Require Import Tactics.
Require Import Relation.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Equivalence.
Require Import Equivalences.
Require Import Rules.
Require Import Defined.

Definition equivr {object a} (r r' : @row object a) : Prop :=
  mcr equiv a r r'.

Definition equivctx {object} (G G' : @context object) : Prop :=
  Forall2 equivh G G'.

Inductive equivj {object} : @judgement object -> @judgement object -> Prop :=
| equivj_i :
    forall m m' n n' a a',
      equiv m m'
      -> equiv n n'
      -> equiv a a'
      -> equivj (deq m n a) (deq m' n' a').

Lemma equivr_refl :
  forall object a (r : @row object a),
    equivr r r.
Proof.
unfold equivr.
intros object a r.
induct r; auto using mcr_nil.
intros i a t r H.
apply mcr_cons; auto using equiv_refl.
Qed.

Lemma equivr_symm :
  forall object a (r r' : @row object a),
    equivr r r'
    -> equivr r' r.
Proof.
unfold equivr.
intros object a r r' Heq.
induct Heq; eauto using mcr_nil.
intros i a m m' r r' Heqm _ IH.
apply mcr_cons; auto using equiv_symm.
Qed.

Lemma equivr_trans :
  forall object a (r1 r2 r3 : @row object a),
    equivr r1 r2
    -> equivr r2 r3
    -> equivr r1 r3.
Proof.
unfold equivr.
intros object a r1 r2 r3 H12 H23.
revert r3 H23.
induct H12.

(* nil *)
{
intros r3 H23.
invertc H23.
intros <-.
apply mcr_nil.
}

(* cons *)
{
intros i a m1 m2 r1 r2 Heqm _ IH rr H23.
invertc H23.
intros m3 r3 Hm23 H23 <-.
apply mcr_cons; eauto using equiv_trans.
}
Qed.

Lemma equiv_oper :
  forall object a (t : operator object a) (r r' : row object a),
    equivr r r'
    -> equiv (oper a t r) (oper a t r').
Proof.
intros object a t r r' Heqr.
apply equiv_compat.
apply mc_oper.
clear t.
induct Heqr; auto using mcr_nil.
(* cons *)
intros i a m m' r r' Heqm _ IH.
apply mcr_cons; auto.
Qed.

Lemma equivh_funct :
  forall object s s' (h h' : @hyp object),
    equivsub s s'
    -> equivh h h'
    -> equivh (substh s h) (substh s' h').
Proof.
intros object s s' h h' Hs Hh.
induct Hh; intros; simpsub; eauto using equivh_tpl, equivh_tp, equivh_emp, equivh_tm, equivh_tml, equiv_funct.
Qed.

Lemma equivctx_refl :
  forall object (G : @context object),
    equivctx G G.
Proof.
intros object G.
unfold equivctx.
induct G; eauto using Forall2, equivh_refl.
Qed.

Lemma equivctx_symm :
  forall object (G G' : @context object),
    equivctx G G'
    -> equivctx G' G.
Proof.
unfold equivctx.
intros object G G' H.
induct H; eauto using Forall2, equivh_symm.
Qed.

Lemma equivctx_trans :
  forall object (G1 G2 G3 : @context object),
    equivctx G1 G2
    -> equivctx G2 G3
    -> equivctx G1 G3.
Proof.
unfold equivctx.
intros object G1 G2 G3 H12 H23.
revert G3 H23.
induct H12.

(* nil *)
{
intros G3 H23.
invertc H23.
intros <-.
apply Forall2_nil.
}

(* cons *)
{
intros h1 h2 G1 G2 H12 _ IH GG H23.
invertc H23.
intros h3 G3 Hh23 H23 <-.
apply Forall2_cons; eauto using equivh_trans.
}
Qed.

Lemma equivctx_length :
  forall object (G G' : @context object),
    equivctx G G'
    -> length G = length G'.
Proof.
intros object G G' Hequiv.
induct Hequiv; intros; cbn; auto.
Qed.

Lemma equivctx_funct :
  forall object s s' (G G' : @context object),
    equivsub s s'
    -> equivctx G G'
    -> equivctx (substctx s G) (substctx s' G').
Proof.
intros object s s' G G' Hs HG.
induct HG.

(* nil *)
{
simpsub.
apply equivctx_refl.
}

(* cons *)
{
intros h h' G G' Hh _ IH.
simpsub.
apply Forall2_cons; auto.
apply equivh_funct; auto.
replace (length G') with (length G).
2:{
  so (equivctx_length _#3 IH) as H.
  rewrite -> !length_substctx in H.
  auto.
  }
apply equivsub_under; auto.
}
Qed.

Lemma equivj_refl :
  forall object (J : @judgement object),
    equivj J J.
Proof.
intros object J.
destruct J as [m n a].
apply equivj_i; auto using equiv_refl.
Qed.

Lemma equivj_symm :
  forall object (J J' : @judgement object),
    equivj J J'
    -> equivj J' J.
Proof.
intros object J J' Heq.
invertc Heq.
intros m m' n n' a a' Heqm Heqn Heqa <- <-.
apply equivj_i; auto using equiv_symm.
Qed.

Lemma equivj_trans :
  forall object (J1 J2 J3 : @judgement object),
    equivj J1 J2
    -> equivj J2 J3
    -> equivj J1 J3.
Proof.
intros object J1 J2 J3 H12 H23.
invertc H12.
intros m1 m2 n1 n2 a1 a2 Hm12 Hn12 Ha12 <- <-.
invertc H23.
intros m3 n3 a3 Hm23 Hn23 Ha23 <-.
apply equivj_i; eauto using equiv_trans.
Qed.

Lemma equiv_deq :
  forall object (m1 m1' m2 m2' a a' : @term object),
    equiv m1 m1'
    -> equiv m2 m2'
    -> equiv a a'
    -> equivj (deq m1 m2 a) (deq m1' m2' a').
Proof.
intro.
exact equivj_i.
Qed.

Lemma equiv_tr :
  forall (G G' : @context obj) (J J' : @judgement obj),
    equivctx G G'
    -> equivj J J'
    -> tr G J <-> tr G' J'.
Proof.
intros G G' J J' HeqG HeqJ.
transitivity (tr G J').
  {
  destruct J as [m n a].
  destruct J' as [m' n' a'].
  invertc HeqJ.
  intros Heqm Heqn Heqa.
  split.
    {
    intro Htr.
    refine (tr_compute _#7 _ _ _ Htr); eauto using equiv_symm.
    }

    {
    intro Htr.
    refine (tr_compute _#7 _ _ _ Htr); auto.
    }
  }
clear J HeqJ.
rename J' into J.
cut (forall G2, tr (G2 ++ G) J <-> tr (G2 ++ G') J).
  {
  intro Hcond.
  apply (Hcond nil).
  }
unfold equivctx in HeqG.
induct HeqG.

(* nil *)
{
intros G2.
rewrite -> app_nil_r.
reflexivity.
}

(* cons *)
{
intros h h' G G' Heqh _ IH G2.
transitivity (tr (G2 ++ h :: G') J).
  {
  change (tr (G2 ++ (h :: nil) ++ G) J <-> tr (G2 ++ (h :: nil) ++ G') J).
  rewrite -> !app_assoc.
  apply IH.
  }
split; intro Htr.
  {
  refine (tr_compute_hyp _#5 _ Htr); auto.
  apply equivh_symm; auto.
  }

  {
  refine (tr_compute_hyp _#5 _ Htr); auto.
  }
}
Qed.

Add Parametric Relation object : (@term object) (@equiv object)
  reflexivity proved by (equiv_refl object)
  symmetry proved by (equiv_symm object)
  transitivity proved by (equiv_trans object)
  as equiv_rel.

Add Parametric Relation object a : (@row object a) (@equivr object a)
  reflexivity proved by (equivr_refl object a)
  symmetry proved by (equivr_symm object a)
  transitivity proved by (equivr_trans object a)
  as equivr_rel.

Add Parametric Relation object : (@hyp object) (@equivh object)
  reflexivity proved by (equivh_refl object)
  symmetry proved by (equivh_symm object)
  transitivity proved by (equivh_trans object)
  as equivh_rel.

Add Parametric Relation object : (@context object) (@equivctx object)
  reflexivity proved by (equivctx_refl object)
  symmetry proved by (equivctx_symm object)
  transitivity proved by (equivctx_trans object)
  as equivctx_rel.

Add Parametric Relation object : (@judgement object) (@equivj object)
  reflexivity proved by (equivj_refl object)
  symmetry proved by (equivj_symm object)
  transitivity proved by (equivj_trans object)
  as equivj_rel.

Add Parametric Relation object : (@sub object) (@equivsub object)
  reflexivity proved by (equivsub_refl object)
  symmetry proved by (equivsub_symm object)
  transitivity proved by (equivsub_trans object)
  as equivsub_rel.

Add Parametric Morphism object a : (@oper object a)
  with signature eq ==> (@equivr object a) ==> (@equiv object)
  as oper_mor.
Proof.
intros t r r' Hr.
apply equiv_oper; auto.
Qed.

Add Parametric Morphism object i a : (@rw_cons object i a)
  with signature (@equiv object) ==> (@equivr object a) ==> (@equivr object (cons i a))
  as rw_cons_mor.
Proof.
intros m m' Hm r r' Hr.
unfold equivr.
apply mcr_cons; auto.
Qed.

Add Parametric Morphism object : (@deq object)
  with signature (@equiv object) ==> (@equiv object) ==> (@equiv object) ==> (@equivj object)
  as deq_mor.
Proof.
intros m1 m1' H1 m2 m2' H2 a a' Ha.
apply equiv_deq; auto.
Qed.

Add Parametric Morphism object : (@hyp_tm object)
  with signature Equivalence.equiv ==> equivh
  as tm_mor.
Proof.
intros h h' Hequiv.
apply equivh_tm; auto.
Qed.

Add Parametric Morphism object : (@hyp_tml object)
  with signature Equivalence.equiv ==> equivh
  as tml_mor.
Proof.
intros h h' Hequiv.
apply equivh_tml; auto.
Qed.

Add Parametric Morphism object : (@cons (@hyp object))
  with signature equivh ==> equivctx ==> equivctx
  as cons_mor.
Proof.
intros h h' Hh G G' HG.
apply Forall2_cons; auto.
Qed.

Add Morphism tr
  with signature equivctx ==> equivj ==> iff
  as tr_mor.
Proof.
intros G G' HG J J' HJ.
apply equiv_tr; auto.
Qed.

Add Parametric Morphism object : (@arrow object)
  with signature equiv ==> equiv ==> equiv
  as equiv_arrow.
Proof.
intros m1 m1' H1 m2 m2' H2.
unfold arrow.
rewrite H1, H2.
reflexivity.
Qed.

Add Parametric Morphism object : (@equal object)
  with signature equiv ==> equiv ==> equiv ==> equiv
  as equiv_equal.
Proof.
intros m1 m1' H1 m2 m2' H2 m3 m3' H3.
unfold equal.
rewrite H1, H2, H3.
reflexivity.
Qed.

Add Parametric Morphism object : (@eqtype object)
  with signature equiv ==> equiv ==> equiv
  as equiv_eqtype.
Proof.
intros m1 m1' H1 m2 m2' H2.
unfold eqtype.
rewrite H1, H2.
reflexivity.
Qed.

Lemma equiv_deqtype :
  forall object (a a' b b' : @term object),
    equiv a a'
    -> equiv b b'
    -> equivj (deqtype a b) (deqtype a' b').
Proof.
intros.
unfold deqtype.
apply equiv_deq; auto using equiv_refl.
apply equiv_eqtype; auto.
Qed.

Add Parametric Morphism object : (@deqtype object)
  with signature (@equiv object) ==> (@equiv object) ==> (@equivj object)
  as deqtype_mor.
Proof.
intros a a' Ha b b' Hb.
apply equiv_deqtype; auto.
Qed.

Add Parametric Morphism object : (@pi object)
  with signature equiv ==> equiv ==> equiv
  as equiv_pi.
Proof.
intros m1 m1' H1 m2 m2' H2.
unfold pi.
rewrite H1, H2.
reflexivity.
Qed.

Add Parametric Morphism object : (@ppair object)
  with signature equiv ==> equiv ==> equiv
  as equiv_pair.
Proof.
intros m1 m1' H1 m2 m2' H2.
apply equiv_ppair; auto.
Qed.

Add Parametric Morphism object : (@set object)
  with signature equiv ==> equiv ==> equiv
  as equiv_set.
Proof.
intros m1 m1' H1 m2 m2' H2.
unfold set.
rewrite H1, H2.
reflexivity.
Qed.

Add Parametric Morphism object : (@intersect object)
  with signature equiv ==> equiv ==> equiv
  as equiv_intersect.
Proof.
intros m1 m1' H1 m2 m2' H2.
unfold intersect.
rewrite H1, H2.
reflexivity.
Qed.

Add Parametric Morphism object : (@subtype object)
  with signature equiv ==> equiv ==> equiv
  as equiv_subtype.
Proof.
intros m1 m1' H1 m2 m2' H2.
unfold subtype.
rewrite H1, H2.
reflexivity.
Qed.

Add Parametric Morphism object : (@univ object)
  with signature equiv ==> equiv
  as equiv_univ.
Proof.
intros m1 m1' H1.
unfold univ.
rewrite H1.
reflexivity.
Qed.

Add Parametric Morphism object : (@app object)
  with signature equiv ==> equiv ==> equiv
  as equiv_app.
Proof.
intros m1 m1' H1 m2 m2' H2.
unfold app.
rewrite H1, H2.
reflexivity.
Qed.

Add Parametric Morphism object : (@dot object)
  with signature equiv ==> equivsub ==> equivsub
  as equiv_dot.
Proof.
intros m1 m1' H1 m2 m2' H2.
apply equivsub_dot; auto.
Qed.

Add Parametric Morphism object : (@subst object)
  with signature equivsub ==> equiv ==> equiv
  as equiv_subst.
Proof.
intros s s' Hs m m' Hm.
apply equiv_funct; auto.
Qed.

Add Parametric Morphism object : (@under object)
  with signature eq ==> equivsub ==> equivsub
  as equiv_under.
Proof.
intros n s s' Hs.
apply equivsub_under; auto.
Qed.

Add Parametric Morphism object : (@List.app (@hyp object))
  with signature equivctx ==> equivctx ==> equivctx
  as app_mor.
Proof.
intros G1 G1' H1 G2 G2' H2.
apply Forall2_app; auto.
Qed.

Add Parametric Morphism object : (@substctx object)
  with signature equivsub ==> equivctx ==> equivctx
  as equiv_substctx.
Proof.
intros s s' Hs G G' HG.
apply equivctx_funct; auto.
Qed.

Add Parametric Morphism object : (@bite object)
  with signature equiv ==> equiv ==> equiv ==> equiv
  as equiv_bite.
Proof.
intros m1 m1' H1 m2 m2' H2 m3 m3' H3.
unfold bite.
rewrite H1, H2, H3.
reflexivity.
Qed.

Add Parametric Morphism object : (@sumleft object)
  with signature equiv ==> equiv
  as equiv_sumleft.
Proof.
intros m1 m1' H1.
unfold sumleft.
rewrite H1.
reflexivity.
Qed.

Add Parametric Morphism object : (@sumright object)
  with signature equiv ==> equiv
  as equiv_sumright.
Proof.
intros m1 m1' H1.
unfold sumright.
rewrite H1.
reflexivity.
Qed.

Add Parametric Morphism object : (@sumcase object)
  with signature equiv ==> equiv ==> equiv ==> equiv
  as equiv_sumcase.
Proof.
intros m1 m1' H1 m2 m2' H2 m3 m3' H3.
unfold sumcase.
apply equiv_bite.
  {
  apply equiv_ppi1.
  rewrite H1.
  reflexivity.
  }

  {
  apply equiv_funct1; auto.
  apply equiv_ppi2; auto.
  }

  {
  apply equiv_funct1; auto.
  apply equiv_ppi2; auto.
  }
Qed.

Add Parametric Morphism object : (@nsucc object)
  with signature equiv ==> equiv
  as equiv_nsucc.
Proof.
intros m1 m1' H1.
rewrite H1.
reflexivity.
Qed.

(*
Goal
  forall G G' a a' b m n,
    sequivctx G G'
    -> sequiv a a'
    -> tr G (deq m n (arrow a b))
    -> tr G' (deq m n (arrow a' b)).
Proof.
intros G G' a a' b m n Heq Heq' H.
rewrite <- Heq.
rewrite <- Heq'.
exact H.
Qed.
*)


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice fintype.
Require Import bigop ssralg finset fingroup zmodp ssrint ssrnum.

(*****************************************************************************)
(* This file provide support for intervals in numerical and real domains.    *)
(* The datatype (interval R) gives a formal characterization of an           *)
(* interval, as the pair of its right and left bounds.                       *)
(*    interval R    == the type of formal intervals on R.                    *)
(*    x \in i       == when i is a formal interval on a numeric domain,      *)
(*                   \in can be used to test membership.                     *)
(*    itvP x_in_i   == where x_in_i has type x \in i, if i is ground,        *)
(*                   gives a set of rewrite rules that x_in_i imply.         *)
(* x <= y ?< if c   == x is smaller than y, and strictly if c is true        *)
(*                                                                           *)
(* We provide a set of notations to write intervals (see below)              *)
(* `[a, b], `]a, b], ..., `]-oo, a], ..., `]-oo, +oo[                        *)
(* We also provide the lemma subitvP which computes the inequalities one     *)
(* needs to prove when trying to prove the inclusion of intervals.           *)
(*                                                                           *)
(* Remark that we cannot implement a boolean comparison test for intervals   *)
(* on an arbitrary numeric domains, for this problem might be undecidable.   *)
(* Note also that type (interval R) may contain several inhabitants coding   *)
(* for the same interval. However, this pathological issues do nor arise     *)
(* when R is a real domain: we could provide a specific theory for this      *)
(* important case.                                                           *)
(*                                                                           *)
(* See also ``Formal proofs in real algebraic geometry: from ordered fields  *)
(* to quantifier elimination'', LMCS journal, 2012                           *)
(* by Cyril Cohen and Assia Mahboubi                                         *)
(*                                                                           *)
(* And "Formalized algebraic numbers: construction and first-order theory"   *)
(* Cyril Cohen, PhD, 2012, section 4.3.                                      *)
(*****************************************************************************)

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

Local Open Scope ring_scope.
Import GRing.Theory Num.Theory.

Local Notation mid x y := ((x + y) / 2%:R).

Section IntervalPo.

CoInductive itv_bound (T : Type) : Type := BOpen_if of bool & T | BInfty.
Notation BOpen := (BOpen_if true).
Notation BClose := (BOpen_if false).
CoInductive interval (T : Type) := Interval of itv_bound T & itv_bound T.

Variable (R : numDomainType).

Definition pred_of_itv (i : interval R) : pred R :=
  [pred x | let: Interval l u := i in
      match l with
        | BOpen a => a < x
        | BClose a => a <= x
        | BInfty => true
      end &&
      match u with
        | BOpen b => x < b
        | BClose b => x <= b
        | BInfty => true
      end].
Canonical Structure itvPredType := Eval hnf in mkPredType pred_of_itv.

(* We provide the 9 following notations to help writing formal intervals *)
Notation "`[ a , b ]" := (Interval (BClose a) (BClose b))
  (at level 0, a, b at level 9 , format "`[ a ,  b ]") : ring_scope.
Notation "`] a , b ]" := (Interval (BOpen a) (BClose b))
  (at level 0, a, b at level 9 , format "`] a ,  b ]") : ring_scope.
Notation "`[ a , b [" := (Interval (BClose a) (BOpen b))
  (at level 0, a, b at level 9 , format "`[ a ,  b [") : ring_scope.
Notation "`] a , b [" := (Interval (BOpen a) (BOpen b))
  (at level 0, a, b at level 9 , format "`] a ,  b [") : ring_scope.
Notation "`] '-oo' , b ]" := (Interval (BInfty _) (BClose b))
  (at level 0, b at level 9 , format "`] '-oo' ,  b ]") : ring_scope.
Notation "`] '-oo' , b [" := (Interval (BInfty _) (BOpen b))
  (at level 0, b at level 9 , format "`] '-oo' ,  b [") : ring_scope.
Notation "`[ a , '+oo' [" := (Interval (BClose a) (BInfty _))
  (at level 0, a at level 9 , format "`[ a ,  '+oo' [") : ring_scope.
Notation "`] a , '+oo' [" := (Interval (BOpen a) (BInfty _))
  (at level 0, a at level 9 , format "`] a ,  '+oo' [") : ring_scope.
Notation "`] -oo , '+oo' [" := (Interval (BInfty _) (BInfty _))
  (at level 0, format "`] -oo ,  '+oo' [") : ring_scope.

(* we compute a set of rewrite rules associated to an interval *)
Definition itv_rewrite (i : interval R) x : Type :=
  let: Interval l u := i in
    (match l with
       | BClose a => (a <= x) * (x < a = false)
       | BOpen a => (a <= x) * (a < x) * (x <= a = false)
       | BInfty => forall x : R, x == x
     end *
    match u with
       | BClose b => (x <= b) * (b < x = false)
       | BOpen b => (x <= b) * (x < b) * (b <= x = false)
       | BInfty => forall x : R, x == x
     end *
    match l, u with
       | BClose a, BClose b =>
         (a <= b) * (b < a = false) * (a \in `[a, b]) * (b \in `[a, b])
       | BClose a, BOpen b =>
         (a <= b) * (a < b) * (b <= a = false)
         * (a \in `[a, b]) * (a \in `[a, b[)* (b \in `[a, b]) * (b \in `]a, b])
       | BOpen a, BClose b =>
         (a <= b) * (a < b) * (b <= a = false)
         * (a \in `[a, b]) * (a \in `[a, b[)* (b \in `[a, b]) * (b \in `]a, b])
       | BOpen a, BOpen b =>
         (a <= b) * (a < b) * (b <= a = false)
         * (a \in `[a, b]) * (a \in `[a, b[)* (b \in `[a, b]) * (b \in `]a, b])
       | _, _ => forall x : R, x == x
    end)%type.

Definition itv_decompose (i : interval R) x : Prop :=
  let: Interval l u := i in
  ((match l with
    | BClose a => (a <= x) : Prop
    | BOpen a => (a < x) : Prop
    | BInfty => True
  end : Prop) *
  (match u with
    | BClose b => (x <= b) : Prop
    | BOpen b => (x < b) : Prop
    | BInfty => True
  end : Prop))%type.

Lemma itv_dec : forall (x : R) (i : interval R),
  reflect (itv_decompose i x) (x \in i).
Proof. by move=> x [[[] a|] [[] b|]]; apply: (iffP andP); case. Qed.

Implicit Arguments itv_dec [x i].

Definition lersif (x y : R) b := if b then x < y else x <= y.

Local Notation "x <= y ?< 'if' b" := (lersif x y b)
  (at level 70, y at next level,
  format "x '[hv'  <=  y '/'  ?<  'if'  b ']'") : ring_scope.

Lemma lersifxx x b: (x <= x ?< if b) = ~~ b.
Proof. by case: b; rewrite /= lterr. Qed.

Lemma lersif_trans x y z b1 b2 :
  x <= y ?< if b1 -> y <= z ?< if b2 -> x <= z ?< if b1 || b2.
Proof.
case: b1; first by case: b2; [apply: ltr_trans | apply: ltr_le_trans].
by case: b2; [apply: ler_lt_trans | apply: ler_trans].
Qed.

Lemma lersifW b x y : x <= y ?< if b -> x <= y.
Proof. by case: b => //; move/ltrW. Qed.

Lemma lersifNF x y b : y <= x ?< if ~~ b ->  x <= y ?< if b = false.
Proof. by case: b => /= [/ler_gtF|/ltr_geF]. Qed.

Lemma lersifS x y b : x < y -> x <= y ?< if b.
Proof. by case: b => //= /ltrW. Qed.

Lemma lersifT x y : x <= y ?< if true = (x < y). Proof. by []. Qed.

Lemma lersifF x y : x <= y ?< if false = (x <= y). Proof. by []. Qed.

Definition le_boundl b1 b2 :=
  match b1, b2 with
    | BOpen_if b1 x1, BOpen_if b2 x2 => x1 <= x2 ?< if (~~ b2 && b1)
    | BOpen_if _ _, BInfty => false
    | _, _ => true
  end.

Definition le_boundr b1 b2 :=
  match b1, b2 with
    | BOpen_if b1 x1, BOpen_if b2 x2 => x1 <= x2 ?< if (~~ b1 && b2)
    | BInfty, BOpen_if _ _ => false
    | _, _ => true
  end.

Lemma itv_boundlr bl br x :
  (x \in Interval bl br) =
  (le_boundl bl (BClose x)) && (le_boundr (BClose x) br).
Proof. by move: bl br => [[] a|] [[] b|]. Qed.

Lemma le_boundr_refl : reflexive le_boundr.
Proof. by move=> [[] b|]; rewrite /le_boundr /= ?lerr. Qed.

Hint Resolve le_boundr_refl.

Lemma le_boundl_refl : reflexive le_boundl.
Proof. by move=> [[] b|]; rewrite /le_boundl /= ?lerr. Qed.

Hint Resolve le_boundl_refl.

Lemma le_boundl_bb x b1 b2 :
  le_boundl (BOpen_if b1 x) (BOpen_if b2 x) = (b1 ==> b2).
Proof. by rewrite /le_boundl lersifxx andbC negb_and negbK implybE. Qed.

Lemma le_boundr_bb x b1 b2 :
  le_boundr (BOpen_if b1 x) (BOpen_if b2 x) = (b2 ==> b1).
Proof. by rewrite /le_boundr lersifxx andbC negb_and negbK implybE. Qed.

Lemma itv_xx x bl br :
  Interval (BOpen_if bl x) (BOpen_if br x) =i
  if ~~ (bl || br) then pred1 x else pred0.
Proof.
by move: bl br => [] [] y /=; rewrite !inE 1?eq_sym (eqr_le, lter_anti).
Qed.

Lemma itv_gte ba xa bb xb :  xb <= xa ?< if ~~ (ba || bb)
  -> Interval (BOpen_if ba xa) (BOpen_if bb xb) =i pred0.
Proof.
move=> hx y; rewrite itv_boundlr inE /=.
by apply/negP => /andP [] /lersif_trans hy /hy {hy}; rewrite lersifNF.
Qed.

Lemma boundl_in_itv : forall ba xa b,
  xa \in Interval (BOpen_if ba xa) b =
  if ba then false else le_boundr (BClose xa) b.
Proof. by move=> [] xa [[] xb|] //=; rewrite inE lterr. Qed.

Lemma boundr_in_itv : forall bb xb a,
  xb \in Interval a (BOpen_if bb xb) =
  if bb then false else le_boundl a (BClose xb).
Proof. by move=> [] xb [[] xa|] //=; rewrite inE lterr ?andbT ?andbF. Qed.

Definition bound_in_itv := (boundl_in_itv, boundr_in_itv).

Lemma itvP : forall (x : R) (i : interval R), (x \in i) -> itv_rewrite i x.
Proof.
move=> x [[[] a|] [[] b|]]; move/itv_dec=> //= [hl hu];do ?[split=> //;
  do ?[by rewrite ltrW | by rewrite ltrWN | by rewrite ltrNW |
    by rewrite (ltr_geF, ler_gtF)]];
  rewrite ?(bound_in_itv) /le_boundl /le_boundr //=; do ?
    [ by rewrite (@ler_trans _ x)
    | by rewrite 1?ltrW // (@ltr_le_trans _ x)
    | by rewrite 1?ltrW // (@ler_lt_trans _ x) // 1?ltrW
    | by apply: negbTE; rewrite ler_gtF // (@ler_trans _ x)
    | by apply: negbTE; rewrite ltr_geF // (@ltr_le_trans _ x) // 1?ltrW
    | by apply: negbTE; rewrite ltr_geF // (@ler_lt_trans _ x)].
Qed.

Hint Rewrite intP.
Implicit Arguments itvP [x i].

Definition subitv (i1 i2 : interval R) :=
  match i1, i2 with
    | Interval a1 b1, Interval a2 b2 => le_boundl a2 a1 && le_boundr b1 b2
  end.

Lemma subitvP : forall (i2 i1 : interval R),
  (subitv i1 i2) -> {subset i1 <= i2}.
Proof.
by move=> [[[] a2|] [[] b2|]] [[[] a1|] [[] b1|]];
  rewrite /subitv //; case/andP=> /= ha hb; move=> x hx; rewrite ?inE;
    rewrite ?(ler_trans ha) ?(ler_lt_trans ha) ?(ltr_le_trans ha) //;
      rewrite ?(ler_trans _ hb) ?(ltr_le_trans _ hb) ?(ler_lt_trans _ hb) //;
        rewrite ?(itvP hx) //.
Qed.

Lemma subitvPr : forall (a b1 b2 : itv_bound R),
  le_boundr b1 b2 -> {subset (Interval a b1) <= (Interval a b2)}.
Proof. by move=> a b1 b2 hb; apply: subitvP=> /=; rewrite hb andbT. Qed.

Lemma subitvPl : forall (a1 a2 b : itv_bound R),
  le_boundl a2 a1 -> {subset (Interval a1 b) <= (Interval a2 b)}.
Proof. by move=> a1 a2 b ha; apply: subitvP=> /=; rewrite ha /=. Qed.

Lemma lersif_in_itv : forall ba bb xa xb x,
  x \in Interval (BOpen_if ba xa) (BOpen_if bb xb) ->
        xa <= xb ?< if ba || bb.
Proof.
by move=> ba bb xa xb y; rewrite itv_boundlr; case/andP; apply: lersif_trans.
Qed.

Lemma ltr_in_itv : forall ba bb xa xb x, ba || bb ->
  x \in Interval (BOpen_if ba xa) (BOpen_if bb xb) -> xa < xb.
Proof.
move=> ba bb xa xb x; case bab: (_ || _) => // _.
by move/lersif_in_itv; rewrite bab.
Qed.

Lemma ler_in_itv : forall ba bb xa xb x,
  x \in Interval (BOpen_if ba xa) (BOpen_if bb xb) -> xa <= xb.
Proof. by move=> ba bb xa xb x; move/lersif_in_itv; move/lersifW. Qed.

Lemma mem0_itvcc_xNx : forall x, (0 \in `[-x, x]) = (0 <= x).
Proof.
by move=> x; rewrite !inE; case hx: (0 <= _); rewrite (andbT, andbF) ?ge0_cp.
Qed.

Lemma mem0_itvoo_xNx : forall x, 0 \in `](-x), x[ = (0 < x).
Proof.
by move=> x; rewrite !inE; case hx: (0 < _); rewrite (andbT, andbF) ?gt0_cp.
Qed.

Lemma itv_splitI : forall a b, forall x,
  x \in Interval a b = (x \in Interval a (BInfty _)) && (x \in Interval (BInfty _) b).
Proof. by move=> [[] a|] [[] b|] x; rewrite ?inE ?andbT. Qed.

Lemma real_lersifN x y b : x \in Num.real -> y \in Num.real ->
  x <= y ?< if ~~b = ~~ (y <= x ?< if b).
Proof. by case: b => [] xR yR /=; rewrite (real_ltrNge, real_lerNgt). Qed.

Lemma oppr_itv ba bb (xa xb x : R) :
  (-x \in Interval (BOpen_if ba xa) (BOpen_if bb xb)) =
  (x \in Interval (BOpen_if bb (-xb)) (BOpen_if ba (-xa))).
Proof. by move: ba bb => [] []; rewrite ?inE lter_oppr andbC lter_oppl. Qed.

Lemma oppr_itvoo (a b x : R) : (-x \in `]a, b[) = (x \in `](-b), (-a)[).
Proof. exact: oppr_itv. Qed.

Lemma oppr_itvco (a b x : R) : (-x \in `[a, b[) = (x \in `](-b), (-a)]).
Proof. exact: oppr_itv. Qed.

Lemma oppr_itvoc (a b x : R) : (-x \in `]a, b]) = (x \in `[(-b), (-a)[).
Proof. exact: oppr_itv. Qed.

Lemma oppr_itvcc (a b x : R) : (-x \in `[a, b]) = (x \in `[(-b), (-a)]).
Proof. exact: oppr_itv. Qed.

End IntervalPo.

Notation BOpen := (BOpen_if true).
Notation BClose := (BOpen_if false).
Notation "`[ a , b ]" := (Interval (BClose a) (BClose b))
  (at level 0, a, b at level 9 , format "`[ a ,  b ]") : ring_scope.
Notation "`] a , b ]" := (Interval (BOpen a) (BClose b))
  (at level 0, a, b at level 9 , format "`] a ,  b ]") : ring_scope.
Notation "`[ a , b [" := (Interval (BClose a) (BOpen b))
  (at level 0, a, b at level 9 , format "`[ a ,  b [") : ring_scope.
Notation "`] a , b [" := (Interval (BOpen a) (BOpen b))
  (at level 0, a, b at level 9 , format "`] a ,  b [") : ring_scope.
Notation "`] '-oo' , b ]" := (Interval (BInfty _) (BClose b))
  (at level 0, b at level 9 , format "`] '-oo' ,  b ]") : ring_scope.
Notation "`] '-oo' , b [" := (Interval (BInfty _) (BOpen b))
  (at level 0, b at level 9 , format "`] '-oo' ,  b [") : ring_scope.
Notation "`[ a , '+oo' [" := (Interval (BClose a) (BInfty _))
  (at level 0, a at level 9 , format "`[ a ,  '+oo' [") : ring_scope.
Notation "`] a , '+oo' [" := (Interval (BOpen a) (BInfty _))
  (at level 0, a at level 9 , format "`] a ,  '+oo' [") : ring_scope.
Notation "`] -oo , '+oo' [" := (Interval (BInfty _) (BInfty _))
  (at level 0, format "`] -oo ,  '+oo' [") : ring_scope.

Notation "x <= y ?< 'if' b" := (lersif x y b)
  (at level 70, y at next level,
  format "x '[hv'  <=  y '/'  ?<  'if'  b ']'") : ring_scope.

Section IntervalOrdered.

Variable R : realDomainType.

Lemma lersifN (x y : R) b : (x <= y ?< if ~~ b) = ~~ (y <= x ?< if b).
Proof. by rewrite real_lersifN ?num_real. Qed.

Lemma itv_splitU (xc : R) bc a b : xc \in Interval a b ->
  forall y, y \in Interval a b =
    (y \in Interval a (BOpen_if (~~ bc) xc))
    || (y \in Interval (BOpen_if bc xc) b).
Proof.
move=> hxc y; rewrite !itv_boundlr [le_boundr]lock /=.
have [la /=|nla /=] := boolP (le_boundl a _); rewrite -lock.
  have [lb /=|nlb /=] := boolP (le_boundr _ b); rewrite ?andbT ?andbF ?orbF //.
    by case: bc => //=; case: ltrgtP.
  symmetry; apply: contraNF nlb; rewrite /le_boundr /=.
  case: b hxc => // bb xb hxc hyc.
  suff /(lersif_trans hyc) : xc <= xb ?< if bb.
    by case: bc {hyc} => //= /lersifS.
  by case: a bb hxc {la} => [[] ?|] [] /= /itvP->.
symmetry; apply: contraNF nla => /andP [hc _].
case: a hxc hc => [[] xa|] hxc; rewrite /le_boundl //=.
  by move=> /lersifW /(ltr_le_trans _) -> //; move: b hxc=> [[] ?|] /itvP->.
by move=> /lersifW /(ler_trans _) -> //; move: b hxc=> [[] ?|] /itvP->.
Qed.

Lemma itv_splitU2 (x : R) a b : x \in Interval a b ->
  forall y, y \in Interval a b =
    [|| (y \in Interval a (BOpen x)), (y == x)
      | (y \in Interval (BOpen x) b)].
Proof.
move=> xab y; rewrite (itv_splitU false xab y); congr (_ || _).
rewrite (@itv_splitU x true _ _ _ y); first by rewrite itv_xx inE.
by move: xab; rewrite boundl_in_itv itv_boundlr => /andP [].
Qed.

End IntervalOrdered.

Section IntervalField.

Variable R : realFieldType.

Lemma mid_in_itv : forall ba bb (xa xb : R), xa <= xb ?< if (ba || bb)
  -> mid xa xb \in Interval (BOpen_if ba xa) (BOpen_if bb xb).
Proof.
by move=> [] [] xa xb /= hx; apply/itv_dec=> /=; rewrite ?midf_lte // ?ltrW.
Qed.

Lemma mid_in_itvoo : forall (xa xb : R), xa < xb -> mid xa xb \in `]xa, xb[.
Proof. by move=> xa xb hx; apply: mid_in_itv. Qed.

Lemma mid_in_itvcc : forall (xa xb : R), xa <= xb -> mid xa xb \in `[xa, xb].
Proof. by move=> xa xb hx; apply: mid_in_itv. Qed.

End IntervalField.


Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Import ListNotations.

Fixpoint nth {X : Type} (n : nat) (xs : list X) : option X :=
match xs with
| nil => None
| x :: xs' =>
  match n with
  | O => Some x
  | S n' => nth n' xs'
  end
end.

(* We want to be able to list the tests being used in a test_strategy, so
   it's convenient to consider a Type finite if there is a list that
   contains each element of it *)
Inductive listable : Type -> Type :=
  prove_listable : forall X, forall xs : list X, forall index : (X -> nat),
    forall index_correct : (forall n : nat, forall x : X, (nth n xs = Some x <-> n = index x)),
    listable X.

Definition listable_to_list {X : Type} (lX : listable X) : list X :=
match lX with
| prove_listable _ xs _ _ => xs
end.

Fixpoint flatten {X : Type} (l : list (list X)) : list X :=
match l with
| nil => nil
| xs :: l' => xs ++ (flatten l')
end.


(** * Miscellaneous Well-Foundedness Facts *)
Require Import Coq.Setoids.Setoid Coq.Program.Program Coq.Program.Wf Coq.Arith.Wf_nat.

Set Implicit Arguments.

Section wf.
  Section wf_prod.
    Context A B (RA : relation A) (RB : relation B).

    Definition prod_relation : relation (A * B)
      := fun ab a'b' =>
           RA (fst ab) (fst a'b') \/ (fst a'b' = fst ab /\ RB (snd ab) (snd a'b')).

    Fixpoint well_founded_prod_relation_helper
             a b
             (wf_A : Acc RA a) (wf_B : well_founded RB) {struct wf_A}
    : Acc prod_relation (a, b)
      := match wf_A with
           | Acc_intro fa => (fix wf_B_rec b' (wf_B' : Acc RB b') : Acc prod_relation (a, b')
                              := Acc_intro
                                   _
                                   (fun ab =>
                                      match ab as ab return prod_relation ab (a, b') -> Acc prod_relation ab with
                                        | (a'', b'') =>
                                          fun pf =>
                                            match pf with
                                              | or_introl pf'
                                                => @well_founded_prod_relation_helper
                                                     _ _
                                                     (fa _ pf')
                                                     wf_B
                                              | or_intror (conj pfa pfb)
                                                => match wf_B' with
                                                     | Acc_intro fb
                                                       => eq_rect
                                                            _
                                                            (fun a'' => Acc prod_relation (a'', b''))
                                                            (wf_B_rec _ (fb _ pfb))
                                                            _
                                                            pfa
                                                   end
                                            end
                                      end)
                             ) b (wf_B b)
         end.

    Definition well_founded_prod_relation : well_founded RA -> well_founded RB -> well_founded prod_relation.
    Proof.
      intros wf_A wf_B [a b]; hnf in *.
      apply well_founded_prod_relation_helper; auto.
    Defined.
  End wf_prod.

  Section wf_sig.
    Context A B (RA : relation A) (RB : forall a : A, relation (B a)).

    Definition sigT_relation : relation (sigT B)
      := fun ab a'b' =>
           RA (projT1 ab) (projT1 a'b') \/ (exists pf : projT1 a'b' = projT1 ab, RB (projT2 ab)
                                                                                (eq_rect _ B (projT2 a'b') _ pf)).

    Fixpoint well_founded_sigT_relation_helper
             a b
             (wf_A : Acc RA a) (wf_B : forall a, well_founded (@RB a)) {struct wf_A}
    : Acc sigT_relation (existT _ a b).
    Proof.
      refine match wf_A with
               | Acc_intro fa => (fix wf_B_rec b' (wf_B' : Acc (@RB a) b') : Acc sigT_relation (existT _ a b')
                                  := Acc_intro
                                       _
                                       (fun ab =>
                                          match ab as ab return sigT_relation ab (existT _ a b') -> Acc sigT_relation ab with
                                            | existT a'' b'' =>
                                              fun pf =>
                                                match pf with
                                                  | or_introl pf'
                                                    => @well_founded_sigT_relation_helper
                                                         _ _
                                                         (fa _ pf')
                                                         wf_B
                                                  | or_intror (ex_intro pfa pfb)
                                                    => match wf_B' with
                                                         | Acc_intro fb
                                                           => _(*eq_rect
                                                            _
                                                            (fun a'' => Acc sigT_relation (existT B a'' _(*b''*)))
                                                            (wf_B_rec _ (fb _ _(*pfb*)))
                                                            _
                                                            pfa*)
                                                       end
                                                end
                                          end)
                                 ) b (wf_B a b)
             end;
      simpl in *.
      destruct pfa; simpl in *.
      exact (wf_B_rec _ (fb _ pfb)).
    Defined.

    Definition well_founded_sigT_relation : well_founded RA
                                            -> (forall a, well_founded (@RB a))
                                            -> well_founded sigT_relation.
    Proof.
      intros wf_A wf_B [a b]; hnf in *.
      apply well_founded_sigT_relation_helper; auto.
    Defined.
  End wf_sig.

  Section wf_projT1.
    Context A (B : A -> Type) (R : relation A).

    Definition projT1_relation : relation (sigT B)
      := fun ab a'b' =>
           R (projT1 ab) (projT1 a'b').

    Definition well_founded_projT1_relation : well_founded R -> well_founded projT1_relation.
    Proof.
      intros wf [a b]; hnf in *.
      induction (wf a) as [a H IH].
      constructor.
      intros y r.
      specialize (IH _ r (projT2 y)).
      destruct y.
      exact IH.
    Defined.
  End wf_projT1.
End wf.

Section Fix_rect.
  Context A (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : A -> Type) (F : forall x : A, (forall y : A, R y x -> P y) -> P x)
          (Q : forall x, P x -> Type)
          (H : forall x, (forall y, R y x -> Q y (@Fix A R Rwf P F y)) -> Q x (@F x (fun (y : A) (_ : R y x) => @Fix A R Rwf P F y)))
          (F_ext : forall (x : A) (f g : forall y : A, R y x -> P y),
                   (forall (y : A) (p : R y x), f y p = g y p) -> F _ f = F _ g).

  Definition Fix_rect x
  : @Q x (@Fix A R Rwf P F x).
  Proof.
    induction (Rwf x).
    rewrite Init.Wf.Fix_eq; auto.
  Defined.
End Fix_rect.

(** A variant of [Fix] that has a nice [Fix_eq] for functions which
    doesn't require [functional_extensionality]. *)
Section Fix3.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c, D a b c -> Type)
          (F : forall x : A, (forall y : A, R y x -> forall b c d, P y b c d) -> forall b c d, P x b c d).

  Definition Fix3 a b c d : @P a b c d
    := @Fix { a : A & { b : B a & { c : C b & D c } } }
            (fun x y => R (projT1 x) (projT1 y))
            (well_founded_projT1_relation Rwf)
            (fun abcd => P (projT2 (projT2 (projT2 abcd))))
            (fun x f => @F (projT1 x) (fun y r b c d => f (existT _ y (existT _ b (existT _ c d))) r) _ _ _)
            (existT _ a (existT _ b (existT _ c d))).

  Definition Fix3_eq
             (F_ext : forall x (f g : forall y, R y x -> forall b c d, @P y b c d),
                        (forall y (p : R y x) b c d, f y p b c d = g y p b c d)
                        -> forall b c d, @F x f b c d = @F x g b c d)
  : forall a b c d, @Fix3 a b c d = @F a (fun y (_ : R y a) b c d => @Fix3 y b c d) b c d.
  Proof.
    intros.
    unfold Fix3; simpl.
    match goal with
      | [ |- @Fix ?A ?R ?Rwf ?P ?F ?x = _ ]
        => refine (@Coq.Init.Wf.Fix_eq A R Rwf P F _ x)
    end.
    intros; apply F_ext; intros.
    match goal with
      | [ H : forall y p, ?f y p = ?g y p
                          |- ?f ?y ?p = ?g ?y ?p ]
        => exact (H y p)
    end.
  Defined.

  Definition Fix3_rect
             (Q : forall a b c d, @P a b c d -> Type)
             (H : forall x, (forall y, R y x -> forall b c d, @Q y b c d (@Fix3 y b c d))
                            -> forall b c d, @Q x b c d (@F x (fun (y : A) (_ : R y x) => @Fix3 y) b c d))
             (F_ext : forall x (f g : forall y, R y x -> forall b c d, @P y b c d),
                        (forall y (p : R y x) b c d, f y p b c d = g y p b c d)
                        -> forall b c d, @F x f b c d = @F x g b c d)
             a b c d
  : @Q a b c d (@Fix3 a b c d).
  Proof.
    induction (Rwf a).
    rewrite Fix3_eq; auto.
  Defined.
End Fix3.

Section Fix4.
  Context A (B : A -> Type) (C : forall a, B a -> Type) (D : forall a b, C a b -> Type) (E : forall a b c, D a b c -> Type)
          (R : A -> A -> Prop) (Rwf : well_founded R)
          (P : forall a b c d, E a b c d -> Type)
          (F : forall x : A, (forall y : A, R y x -> forall b c d e, P y b c d e) -> forall b c d e, P x b c d e).

  Definition Fix4 a b c d e : @P a b c d e
    := @Fix { a : A & { b : B a & { c : C b & { d : D c & E d } } } }
            (fun x y => R (projT1 x) (projT1 y))
            (well_founded_projT1_relation Rwf)
            (fun abcde => P (projT2 (projT2 (projT2 (projT2 abcde)))))
            (fun x f => @F (projT1 x) (fun y r b c d e => f (existT _ y (existT _ b (existT _ c (existT _ d e)))) r) _ _ _ _)
            (existT _ a (existT _ b (existT _ c (existT _ d e)))).

  Definition Fix4_eq
             (F_ext : forall x (f g : forall y, R y x -> forall b c d e, @P y b c d e),
                        (forall y (p : R y x) b c d e, f y p b c d e = g y p b c d e)
                        -> forall b c d e, @F x f b c d e = @F x g b c d e)
  : forall a b c d e, @Fix4 a b c d e = @F a (fun y (_ : R y a) b c d e => @Fix4 y b c d e) b c d e.
  Proof.
    intros.
    unfold Fix4; simpl.
    match goal with
      | [ |- @Fix ?A ?R ?Rwf ?P ?F ?x = _ ]
        => refine (@Coq.Init.Wf.Fix_eq A R Rwf P F _ x)
    end.
    intros; apply F_ext; intros.
    match goal with
      | [ H : forall y p, ?f y p = ?g y p
                          |- ?f ?y ?p = ?g ?y ?p ]
        => exact (H y p)
    end.
  Defined.

  Definition Fix4_rect
             (Q : forall a b c d e, @P a b c d e -> Type)
             (H : forall x, (forall y, R y x -> forall b c d e, @Q y b c d e (@Fix4 y b c d e))
                            -> forall b c d e, @Q x b c d e (@F x (fun (y : A) (_ : R y x) => @Fix4 y) b c d e))
             (F_ext : forall x (f g : forall y, R y x -> forall b c d e, @P y b c d e),
                        (forall y (p : R y x) b c d e, f y p b c d e = g y p b c d e)
                        -> forall b c d e, @F x f b c d e = @F x g b c d e)
             a b c d e
  : @Q a b c d e (@Fix4 a b c d e).
  Proof.
    induction (Rwf a).
    rewrite Fix4_eq; auto.
  Defined.
End Fix4.


Require Import FloatishDef.

Section floatish_ops.

  Context {floatish_impl:floatish}.
  Local Open Scope float.

  Definition pos_sign (e:float)
    := if e >= 0 then 1 else Fopp 1.

  Definition neg_sign (e:float)
    := if e <= 0 then Fopp 1 else 1.

  Definition sign (e:float)
    := if e < 0 then Fopp 1
       else if e > 0 then 1
            else 0.

  Definition Fmax (x y:float)
    := if x < y then y else x.

  Definition Fmin (x y:float)
    := if x > y then y else x.

End floatish_ops.