Top

Module mathcomp.algebra.interval

From HB Require Import structures.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq choice.
From mathcomp Require Import fintype nmodule order.

                        Intervals in ordered types

This file provides support for intervals in ordered types. The datatype
(interval T) gives a formal characterization of an interval, as the pair
of its right and left bounds.
   interval T    == the type of formal intervals on T.
   x \in i       == when i is a formal interval on an ordered type,
                    \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 implies
lteBSide, bnd_simp == multirules to simplify inequalities between interval
                    bounds
   miditv i      == middle point of interval i

When using interval.v, the lemma `in_itv` is in practice very useful. For
example, the execution of the tactic `rewrite in_itv` w.r.t. an hypothesis
of the form x \in `]a, b[ into a < x < b.

Intervals of T form an partially ordered type (porderType) whose ordering
is the subset relation. If T is a lattice, intervals also form a lattice
(latticeType) whose meet and join are intersection and convex hull
respectively. They are distributive if T is an orderType.

We provide a set of notations to write intervals (see below)
`[a, b], `]a, b], ..., `]-oo, a], ..., `]-oo, +oo[
The substrings "oo", "oc", "co", "cc" in the names of lemmas respectively
stand for the intervals of the shape `]a, b[, `]a, b], `[a, b[, `[a, b].
The substrings "pinfty" and "ninfty" in the names of lemmas stand for
+oo and -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 ordered types, for this problem might be undecidable. Note
also that type (interval R) may contain several inhabitants coding for the
same interval. However, these pathological issues do not arise when R is a
real domain: we could provide a specific theory for this important case.

References:
- Cyril Cohen, Assia Mahboubi, Formal proofs in real algebraic geometry:
from ordered fields quantifier elimination, LMCS, 2012
- Cyril Cohen, Formalized algebraic numbers: construction and first-order
theory, PhD thesis, 2012, section 4.3

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

Reserved Notation "'-oo'".
Reserved Notation "'+oo'".
Reserved Notation "`[ a , b ]" (format "`[ a , b ]").
Reserved Notation "`] a , b ]" (format "`] a , b ]").
Reserved Notation "`[ a , b [" (format "`[ a , b [").
Reserved Notation "`] a , b [" (format "`] a , b [").
Reserved Notation "`] '-oo' , b ]" (format "`] '-oo' , b ]").
Reserved Notation "`] '-oo' , b [" (format "`] '-oo' , b [").
Reserved Notation "`[ a , '+oo' [" (format "`[ a , '+oo' [").
Reserved Notation "`] a , '+oo' [" (format "`] a , '+oo' [").
Reserved Notation "`] -oo , '+oo' [" (format "`] -oo , '+oo' [").

Local Open Scope order_scope.
Import Order.TTheory.

Variant itv_bound (T : Type) : Type := BSide of bool & T | BInfty of bool.
Notation BLeft := (BSide true).
Notation BRight := (BSide false).
Notation "'-oo'" := (BInfty _ true) : order_scope.
Notation "'+oo'" := (BInfty _ false) : order_scope.
Variant interval (T : Type) := Interval of itv_bound T & itv_bound T.

Coercion pair_of_interval T (I : interval T) : itv_bound T * itv_bound T :=
  let: Interval b1 b2 := I in (b1, b2).

Notation "`[ a , b ]" := (Interval (BLeft a) (BRight b)) : order_scope.
Notation "`] a , b ]" := (Interval (BRight a) (BRight b)) : order_scope.
Notation "`[ a , b [" := (Interval (BLeft a) (BLeft b)) : order_scope.
Notation "`] a , b [" := (Interval (BRight a) (BLeft b)) : order_scope.
Notation "`] '-oo' , b ]" := (Interval -oo (BRight b)) : order_scope.
Notation "`] '-oo' , b [" := (Interval -oo (BLeft b)) : order_scope.
Notation "`[ a , '+oo' [" := (Interval (BLeft a) +oo) : order_scope.
Notation "`] a , '+oo' [" := (Interval (BRight a) +oo) : order_scope.
Notation "`] -oo , '+oo' [" := (Interval -oo +oo) : order_scope.

Notation "`[ a , b ]" := (Interval (BLeft a) (BRight b)) : ring_scope.
Notation "`] a , b ]" := (Interval (BRight a) (BRight b)) : ring_scope.
Notation "`[ a , b [" := (Interval (BLeft a) (BLeft b)) : ring_scope.
Notation "`] a , b [" := (Interval (BRight a) (BLeft b)) : ring_scope.
Notation "`] '-oo' , b ]" := (Interval -oo (BRight b)) : ring_scope.
Notation "`] '-oo' , b [" := (Interval -oo (BLeft b)) : ring_scope.
Notation "`[ a , '+oo' [" := (Interval (BLeft a) +oo) : ring_scope.
Notation "`] a , '+oo' [" := (Interval (BRight a) +oo) : ring_scope.
Notation "`] -oo , '+oo' [" := (Interval -oo +oo) : ring_scope.

Fact itv_bound_display (disp : Order.disp_t) : Order.disp_t

Proof.

exact. Qed.

Fact interval_display (disp : Order.disp_t) : Order.disp_t

Proof.

exact. Qed.

Module IntervalCan.
Section IntervalCan.

Variable T : Type.

Lemma itv_bound_can :
  cancel (fun b : itv_bound T =>
            match b with BSide b x => (b, Some x) | BInfty b => (b, None) end)
         (fun b =>
            match b with (b, Some x) => BSide b x | (b, None) => BInfty _ b end).

Proof.

by case. Qed.

Lemma interval_can :
  @cancel _ (interval T)
    (fun '(Interval b1 b2) => (b1, b2)) (fun '(b1, b2) => Interval b1 b2).

Proof.

by case. Qed.

End IntervalCan.

#[export, hnf]
HB.instance Definition _ (T : eqType) := Equality.copy (itv_bound T)
  (can_type (@itv_bound_can T)).
#[export, hnf]
HB.instance Definition _ (T : eqType) := Equality.copy (interval T)
  (can_type (@interval_can T)).
#[export, hnf]
HB.instance Definition _ (T : choiceType) := Choice.copy (itv_bound T)
  (can_type (@itv_bound_can T)).
#[export, hnf]
HB.instance Definition _ (T : choiceType) := Choice.copy (interval T)
  (can_type (@interval_can T)).
#[export, hnf]
HB.instance Definition _ (T : countType) := Countable.copy (itv_bound T)
  (can_type (@itv_bound_can T)).
#[export, hnf]
HB.instance Definition _ (T : countType) := Countable.copy (interval T)
  (can_type (@interval_can T)).
#[export, hnf]
HB.instance Definition _ (T : finType) := Finite.copy (itv_bound T)
  (can_type (@itv_bound_can T)).
#[export, hnf]
HB.instance Definition _ (T : finType) := Finite.copy (interval T)
  (can_type (@interval_can T)).

Module Exports. HB.reexport. End Exports.

End IntervalCan.

Export IntervalCan.Exports.

Section IntervalPOrder.

Variable (disp : Order.disp_t) (T : porderType disp).
Implicit Types (x y z : T) (b bl br : itv_bound T) (i : interval T).

Definition le_bound b1 b2 :=
  match b1, b2 with
    | -oo, _ | _, +oo => true
    | BSide b1 x1, BSide b2 x2 => x1 < x2 ?<= if b2 ==> b1
    | _, _ => false
  end.

Definition lt_bound b1 b2 :=
  match b1, b2 with
    | -oo, +oo | -oo, BSide _ _ | BSide _ _, +oo => true
    | BSide b1 x1, BSide b2 x2 => x1 < x2 ?<= if b1 && ~~ b2
    | _, _ => false
  end.

Lemma lt_bound_def b1 b2 : lt_bound b1 b2 = (b2 != b1) && le_bound b1 b2.

Proof.

by case: b1 b2 => [[]?|[]][[]?|[]] //=; rewrite lt_def. Qed.

Lemma le_bound_refl : reflexive le_bound.

Proof.

by move=> [[]?|[]] /=. Qed.

Lemma le_bound_anti : antisymmetric le_bound.

Proof.

by case=> [[]?|[]] [[]?|[]] //=; case: comparableP => // ->. Qed.

Lemma le_bound_trans : transitive le_bound.

Proof.

by case=> [[]?|[]] [[]?|[]] [[]?|[]] lexy leyz //;
  apply: (lteif_imply _ (lteif_trans lexy leyz)).
Qed.

HB.instance Definition _ :=
  Order.isPOrder.Build (itv_bound_display disp) (itv_bound T)
    lt_bound_def le_bound_refl le_bound_anti le_bound_trans.

Lemma bound_lexx c1 c2 x : (BSide c1 x <= BSide c2 x) = (c2 ==> c1).

Proof.

by rewrite /<=%O /= lteifxx. Qed.

Lemma bound_ltxx c1 c2 x : (BSide c1 x < BSide c2 x) = (c1 && ~~ c2).

Proof.

by rewrite /<%O /= lteifxx. Qed.

Lemma ge_pinfty b : (+oo <= b) = (b == +oo)

Proof.

by case: b => [|] []. Qed.

Lemma le_ninfty b : (b <= -oo) = (b == -oo)

Proof.

by case: b => // - []. Qed.

Lemma gt_pinfty b : (+oo < b) = false

Proof.

by []. Qed.

Lemma lt_ninfty b : (b < -oo) = false

Proof.

by case: b => // -[]. Qed.

Lemma ltBSide x y (b b' : bool) :
  (BSide b x < BSide b' y) = (x < y ?<= if b && ~~ b').

Proof.

by []. Qed.

Lemma leBSide x y (b b' : bool) :
  (BSide b x <= BSide b' y) = (x < y ?<= if b' ==> b).

Proof.

by []. Qed.

Definition lteBSide := (ltBSide, leBSide).

Lemma ltBRight_leBLeft b x : (b < BRight x) = (b <= BLeft x).

Proof.

by move: b => [[] b|[]]. Qed.

Lemma leBRight_ltBLeft b x : (BRight x <= b) = (BLeft x < b).

Proof.

by move: b => [[] b|[]]. Qed.

Let BLeft_ltE x y (b : bool) : (BSide b x < BLeft y) = (x < y).

Proof.

by case: b. Qed.

Let BRight_leE x y (b : bool) : (BSide b x <= BRight y) = (x <= y).

Proof.

by case: b. Qed.

Let BRight_BLeft_leE x y : (BRight x <= BLeft y) = (x < y).

Proof.

by []. Qed.

Let BLeft_BRight_ltE x y : (BLeft x < BRight y) = (x <= y).

Proof.

by []. Qed.

Let BRight_BSide_ltE x y (b : bool) : (BRight x < BSide b y) = (x < y).

Proof.

by case: b. Qed.

Let BLeft_BSide_leE x y (b : bool) : (BLeft x <= BSide b y) = (x <= y).

Proof.

by case: b. Qed.

Let BSide_ltE x y (b : bool) : (BSide b x < BSide b y) = (x < y).

Proof.

by case: b. Qed.

Let BSide_leE x y (b : bool) : (BSide b x <= BSide b y) = (x <= y).

Proof.

by case: b. Qed.

Let BInfty_leE a : a <= BInfty T false

Proof.

by case: a => [[] a|[]]. Qed.

Let BInfty_geE a : BInfty T true <= a

Proof.

by case: a => [[] a|[]]. Qed.

Let BInfty_le_eqE a : (BInfty T false <= a) = (a == BInfty T false).

Proof.

by case: a => [[] a|[]]. Qed.

Let BInfty_ge_eqE a : (a <= BInfty T true) = (a == BInfty T true).

Proof.

by case: a => [[] a|[]]. Qed.

Let BInfty_ltE a : (a < BInfty T false) = (a != BInfty T false).

Proof.

by case: a => [[] a|[]]. Qed.

Let BInfty_gtE a : (BInfty T true < a) = (a != BInfty T true).

Proof.

by case: a => [[] a|[]]. Qed.

Let BInfty_ltF a : (BInfty T false < a) = false.

Proof.

by case: a => [[] a|[]]. Qed.

Let BInfty_gtF a : (a < BInfty T true) = false.

Proof.

by case: a => [[] a|[]]. Qed.

Let BInfty_BInfty_ltE : BInfty T true < BInfty T false

Proof.

by []. Qed.

Definition bnd_simp := (BLeft_ltE, BRight_leE,
  BRight_BLeft_leE, BLeft_BRight_ltE,
  BRight_BSide_ltE, BLeft_BSide_leE, BSide_ltE, BSide_leE,
  BInfty_leE, BInfty_geE, BInfty_BInfty_ltE,
  BInfty_le_eqE, BInfty_ge_eqE, BInfty_ltE, BInfty_gtE, BInfty_ltF, BInfty_gtF,
  @lexx _ T, @ltxx _ T, @eqxx T).

Lemma comparable_BSide_min s (x y : T) : (x >=< y)%O ->
  BSide s (Order.min x y) = Order.min (BSide s x) (BSide s y).

Proof.

by rewrite !minEle bnd_simp => /comparable_leP[]. Qed.

Lemma comparable_BSide_max s (x y : T) : (x >=< y)%O ->
  BSide s (Order.max x y) = Order.max (BSide s x) (BSide s y).

Proof.

by rewrite !maxEle bnd_simp => /comparable_leP[]. Qed.

Definition subitv i1 i2 :=
  let: Interval b1l b1r := i1 in
  let: Interval b2l b2r := i2 in (b2l <= b1l) && (b1r <= b2r).

Lemma subitv_refl : reflexive subitv.

Proof.

by case=> /= ? ?; rewrite !lexx. Qed.

Lemma subitv_anti : antisymmetric subitv.

Proof.

by case=> [? ?][? ?]; rewrite andbACA => /andP[] /le_anti -> /le_anti ->.
Qed.

Lemma subitv_trans : transitive subitv.

Proof.

case=> [yl yr][xl xr][zl zr] /andP [Hl Hr] /andP [Hl' Hr'] /=.
by rewrite (le_trans Hl' Hl) (le_trans Hr Hr').
Qed.

HB.instance Definition _ :=
  Order.isPOrder.Build (interval_display disp) (interval T)
  (fun _ _ => erefl) subitv_refl subitv_anti subitv_trans.

Definition pred_of_itv i : pred T := [pred x | `[x, x] <= i].

Canonical Structure itvPredType := PredType pred_of_itv.

Lemma subitvE b1l b1r b2l b2r :
  (Interval b1l b1r <= Interval b2l b2r) = (b2l <= b1l) && (b1r <= b2r).

Proof.

by []. Qed.

Lemma in_itv x i :
  (x \in i) =
  let: Interval l u := i in
  match l with
    | BSide b lb => lb < x ?<= if b
    | BInfty b => b
  end &&
  match u with
    | BSide b ub => x < ub ?<= if ~~ b
    | BInfty b => ~~ b
  end.

Proof.

by case: i => [[? ?|[]][|[]]]. Qed.

Lemma itv_boundlr bl br x :
  (x \in Interval bl br) = (bl <= BLeft x) && (BRight x <= br).

Proof.

by []. Qed.

Lemma itv_splitI bl br x :
  (x \in Interval bl br) = (x \in Interval bl +oo) && (x \in Interval -oo br).

Proof.

by rewrite !itv_boundlr andbT. Qed.

Lemma subitvP i1 i2 : i1 <= i2 -> {subset i1 <= i2}.

Proof.

by move=> ? ? /le_trans; exact. Qed.

#[warn(note="The lemma subset_itv was generalized in MathComp 2.4.0 and the original was renamed to subset_itv_bound.",
  cats="mathcomp-subset-itv")]
Lemma subset_itv (x y z u : itv_bound T) : x <= y -> z <= u ->
  {subset Interval y z <= Interval x u}.

Proof.

by move=> xy zu; apply: subitvP; rewrite subitvE xy zu. Qed.

#[deprecated(since="mathcomp 2.4.0", use=subset_itv)]
Lemma subset_itv_bound (r s u v : bool) x y : r <= u -> v <= s ->
  {subset Interval (BSide r x) (BSide s y) <= Interval (BSide u x) (BSide v y)}.

Proof.

by move: r s u v=> [] [] [] []// *; apply: subset_itv; rewrite bnd_simp.
Qed.

Lemma subset_itv_oo_cc x y : {subset `]x, y[ <= `[x, y]}.

Proof.

by apply: subset_itv; rewrite bnd_simp. Qed.

Lemma subset_itv_oo_oc x y : {subset `]x, y[ <= `]x, y]}.

Proof.

by apply: subset_itv; rewrite bnd_simp. Qed.

Lemma subset_itv_oo_co x y : {subset `]x, y[ <= `[x, y[}.

Proof.

by apply: subset_itv; rewrite bnd_simp. Qed.

Lemma subset_itv_oc_cc x y : {subset `]x, y] <= `[x, y]}.

Proof.

by apply: subset_itv; rewrite bnd_simp. Qed.

Lemma subset_itv_co_cc x y : {subset `[x, y[ <= `[x, y]}.

Proof.

by apply: subset_itv; rewrite bnd_simp. Qed.

Lemma itvxx x : `[x, x] =i pred1 x.

Proof.

by move=> y; rewrite in_itv/= -eq_le eq_sym. Qed.

Lemma itvxxP y x : reflect (y = x) (y \in `[x, x]).

Proof.

by rewrite itvxx; apply/eqP. Qed.

Lemma subitvPl b1l b2l br :
  b2l <= b1l -> {subset Interval b1l br <= Interval b2l br}.

Proof.

by move=> ?; apply: subitvP; rewrite subitvE lexx andbT. Qed.

Lemma subitvPr bl b1r b2r :
  b1r <= b2r -> {subset Interval bl b1r <= Interval bl b2r}.

Proof.

by move=> ?; apply: subitvP; rewrite subitvE lexx. Qed.

Lemma itv_xx x cl cr y :
  (y \in Interval (BSide cl x) (BSide cr x)) = cl && ~~ cr && (y == x).

Proof.

by case: cl cr => [] []; rewrite [LHS]lteif_anti // eq_sym. Qed.

Lemma boundl_in_itv c x b :
  (x \in Interval (BSide c x) b) = c && (BRight x <= b).

Proof.

by rewrite itv_boundlr bound_lexx. Qed.

Lemma boundr_in_itv c x b :
  (x \in Interval b (BSide c x)) = ~~ c && (b <= BLeft x).

Proof.

by rewrite itv_boundlr bound_lexx implybF andbC. Qed.

Definition bound_in_itv := (boundl_in_itv, boundr_in_itv).

Lemma lt_in_itv bl br x : x \in Interval bl br -> bl < br.

Proof.

by case/andP; apply/le_lt_trans. Qed.

Lemma lteif_in_itv cl cr yl yr x :
  x \in Interval (BSide cl yl) (BSide cr yr) -> yl < yr ?<= if cl && ~~ cr.

Proof.

exact: lt_in_itv. Qed.

Lemma itv_ge b1 b2 : ~~ (b1 < b2) -> Interval b1 b2 =i pred0.

Proof.

by move=> ltb12 y; apply/contraNF: ltb12; apply/lt_in_itv. Qed.

Definition itv_decompose i x : Prop :=
  let: Interval l u := i in
  (match l return Prop with
     | BSide b lb => lb < x ?<= if b
     | BInfty b => b
   end *
   match u return Prop with
     | BSide b ub => x < ub ?<= if ~~ b
     | BInfty b => ~~ b
   end)%type.

Lemma itv_dec : forall x i, reflect (itv_decompose i x) (x \in i).

Proof.

by move=> ? [[? ?|[]][? ?|[]]]; apply: (iffP andP); case. Qed.

Arguments itv_dec {x i}.

Definition itv_rewrite i x : Type :=
  let: Interval l u := i in
    (match l with
       | BLeft a => (a <= x) * ((x < a) = false)
       | BRight a => (a <= x) * (a < x) * ((x <= a) = false) * ((x < a) = false)
       | -oo => forall x : T, x == x
       | +oo => forall b : bool, unkeyed b = false
     end *
     match u with
       | BRight b => (x <= b) * ((b < x) = false)
       | BLeft b => (x <= b) * (x < b) * ((b <= x) = false) * ((b < x) = false)
       | +oo => forall x : T, x == x
       | -oo => forall b : bool, unkeyed b = false
     end *
     match l, u with
       | BLeft a, BRight b =>
         (a <= b) * ((b < a) = false) * (a \in `[a, b]) * (b \in `[a, b])
       | BLeft a, BLeft b =>
         (a <= b) * (a < b) * ((b <= a) = false) * ((b < a) = false)
         * (a \in `[a, b]) * (a \in `[a, b[) * (b \in `[a, b]) * (b \in `]a, b])
       | BRight a, BRight b =>
         (a <= b) * (a < b) * ((b <= a) = false) * ((b < a) = false)
         * (a \in `[a, b]) * (a \in `[a, b[) * (b \in `[a, b]) * (b \in `]a, b])
       | BRight a, BLeft b =>
         (a <= b) * (a < b) * ((b <= a) = false) * ((b < a) = false)
         * (a \in `[a, b]) * (a \in `[a, b[) * (b \in `[a, b]) * (b \in `]a, b])
       | _, _ => forall x : T, x == x
     end)%type.

Lemma itvP x i : x \in i -> itv_rewrite i x.

Proof.

case: i => [[[]a|[]][[]b|[]]] /andP [] ha hb; rewrite /= ?bound_in_itv;
  do ![split | apply/negbTE; rewrite (le_gtF, lt_geF)];
  by [|apply: ltW | move: (lteif_trans ha hb) => //=; exact: ltW].
Qed.

Arguments itvP [x i].

Lemma itv_splitU1 b x : b <= BLeft x ->
  Interval b (BRight x) =i [predU1 x & Interval b (BLeft x)].

Proof.

move=> bx z; rewrite !inE/= !subitvE ?bnd_simp//= lt_neqAle.
by case: (eqVneq z x) => [->|]//=; rewrite lexx bx.
Qed.

Lemma itv_split1U b x : BRight x <= b ->
  Interval (BLeft x) b =i [predU1 x & Interval (BRight x) b].

Proof.

move=> bx z; rewrite !inE/= !subitvE ?bnd_simp//= lt_neqAle.
by case: (eqVneq z x) => [->|]//=; rewrite lexx bx.
Qed.

End IntervalPOrder.

Section IntervalLattice.

Variable (disp : Order.disp_t) (T : latticeType disp).
Implicit Types (x y z : T) (b bl br : itv_bound T) (i : interval T).

Definition bound_meet bl br : itv_bound T :=
  match bl, br with
    | -oo, _ | _, -oo => -oo
    | +oo, b | b, +oo => b
    | BSide xb x, BSide yb y =>
      BSide (((x <= y) && xb) || ((y <= x) && yb)) (x `&` y)
  end.

Definition bound_join bl br : itv_bound T :=
  match bl, br with
    | -oo, b | b, -oo => b
    | +oo, _ | _, +oo => +oo
    | BSide xb x, BSide yb y =>
      BSide ((~~ (x <= y) || yb) && (~~ (y <= x) || xb)) (x `|` y)
  end.

Lemma bound_meetC : commutative bound_meet.

Proof.

case=> [? ?|[]][? ?|[]] //=; rewrite meetC; congr BSide.
by case: lcomparableP; rewrite ?orbF // orbC.
Qed.

Lemma bound_joinC : commutative bound_join.

Proof.

case=> [? ?|[]][? ?|[]] //=; rewrite joinC; congr BSide.
by case: lcomparableP; rewrite ?andbT // andbC.
Qed.

Lemma bound_meetA : associative bound_meet.

Proof.

case=> [? x|[]][? y|[]][? z|[]] //=; rewrite !lexI meetA; congr BSide.
by case: (lcomparableP x y) => [|||->]; case: (lcomparableP y z) => [|||->];
  case: (lcomparableP x z) => [|||//<-]; case: (lcomparableP x y);
  rewrite //= ?andbF ?orbF ?lexx ?orbA //; case: (lcomparableP y z).
Qed.

Lemma bound_joinA : associative bound_join.

Proof.

case=> [? x|[]][? y|[]][? z|[]] //=; rewrite !leUx joinA; congr BSide.
by case: (lcomparableP x y) => [|||->]; case: (lcomparableP y z) => [|||->];
  case: (lcomparableP x z) => [|||//<-]; case: (lcomparableP x y);
  rewrite //= ?orbT ?andbT ?lexx ?andbA //; case: (lcomparableP y z).
Qed.

Lemma bound_meetKU b2 b1 : bound_join b1 (bound_meet b1 b2) = b1.

Proof.

case: b1 b2 => [? ?|[]][? ?|[]] //=;
  rewrite ?meetKU ?joinxx ?leIl ?lexI ?lexx ?andbb //=; congr BSide.
by case: lcomparableP; rewrite ?orbF /= ?andbb ?orbK.
Qed.

Lemma bound_joinKI b2 b1 : bound_meet b1 (bound_join b1 b2) = b1.

Proof.

case: b1 b2 => [? ?|[]][? ?|[]] //=;
  rewrite ?joinKI ?meetxx ?leUl ?leUx ?lexx ?orbb //=; congr BSide.
by case: lcomparableP; rewrite ?orbF ?orbb ?andKb.
Qed.

Lemma bound_leEmeet b1 b2 : (b1 <= b2) = (bound_meet b1 b2 == b1).

Proof.

case: b1 b2 => [[]t[][]|[][][]] //=; rewrite ?eqxx// => t';
  rewrite [LHS]/<=%O /eq_op ?andbT ?andbF ?orbF/= /eq_op/= /eq_op/=;
  case: lcomparableP => //=; rewrite ?eqxx//=; [| | |].
- by move/lt_eqF.
- move=> ic; apply: esym; apply: contraNF ic.
  by move=> /eqP/meet_idPl; apply: le_comparable.
- by move/lt_eqF.
- move=> ic; apply: esym; apply: contraNF ic.
  by move=> /eqP/meet_idPl; apply: le_comparable.
Qed.

HB.instance Definition _ :=
  Order.POrder_isLattice.Build (itv_bound_display disp) (itv_bound T)
    bound_meetC bound_joinC bound_meetA bound_joinA
    bound_joinKI bound_meetKU bound_leEmeet.

Lemma bound_le0x b : -oo <= b

Proof.

by []. Qed.

Lemma bound_lex1 b : b <= +oo

Proof.

by case: b => [|[]]. Qed.

HB.instance Definition _ :=
  Order.hasBottom.Build (itv_bound_display disp) (itv_bound T) bound_le0x.
HB.instance Definition _ :=
  Order.hasTop.Build (itv_bound_display disp) (itv_bound T) bound_lex1.

Definition itv_meet i1 i2 : interval T :=
  let: Interval b1l b1r := i1 in
  let: Interval b2l b2r := i2 in Interval (b1l `|` b2l) (b1r `&` b2r).

Definition itv_join i1 i2 : interval T :=
  let: Interval b1l b1r := i1 in
  let: Interval b2l b2r := i2 in Interval (b1l `&` b2l) (b1r `|` b2r).

Lemma itv_meetC : commutative itv_meet.

Proof.

by case=> [? ?][? ?] /=; rewrite meetC joinC. Qed.

Lemma itv_joinC : commutative itv_join.

Proof.

by case=> [? ?][? ?] /=; rewrite meetC joinC. Qed.

Lemma itv_meetA : associative itv_meet.

Proof.

by case=> [? ?][? ?][? ?] /=; rewrite meetA joinA. Qed.

Lemma itv_joinA : associative itv_join.

Proof.

by case=> [? ?][? ?][? ?] /=; rewrite meetA joinA. Qed.

Lemma itv_meetKU i2 i1 : itv_join i1 (itv_meet i1 i2) = i1.

Proof.

by case: i1 i2 => [? ?][? ?] /=; rewrite meetKU joinKI. Qed.

Lemma itv_joinKI i2 i1 : itv_meet i1 (itv_join i1 i2) = i1.

Proof.

by case: i1 i2 => [? ?][? ?] /=; rewrite meetKU joinKI. Qed.

Lemma itv_leEmeet i1 i2 : (i1 <= i2) = (itv_meet i1 i2 == i1).

Proof.

by case: i1 i2 => [? ?] [? ?]; rewrite /eq_op/=/eq_op/= eq_meetl eq_joinl.
Qed.

HB.instance Definition _ :=
  Order.POrder_isLattice.Build (interval_display disp) (interval T)
    itv_meetC itv_joinC itv_meetA itv_joinA
    itv_joinKI itv_meetKU itv_leEmeet.

Lemma itv_le0x i : Interval +oo -oo <= i

Proof.

by case: i => [[|[]]]. Qed.

Lemma itv_lex1 i : i <= `]-oo, +oo[

Proof.

by case: i => [?[|[]]]. Qed.

HB.instance Definition _ :=
  Order.hasBottom.Build (interval_display disp) (interval T) itv_le0x.
HB.instance Definition _ :=
  Order.hasTop.Build (interval_display disp) (interval T) itv_lex1.

Lemma in_itvI x i1 i2 : (x \in i1 `&` i2) = (x \in i1) && (x \in i2).

Proof.

exact: lexI. Qed.

End IntervalLattice.

Section IntervalTotal.

Variable (disp : Order.disp_t) (T : orderType disp).
Implicit Types (a b c : itv_bound T) (x y z : T) (i : interval T).

Lemma BSide_min s (x y : T) :
  BSide s (Order.min x y) = Order.min (BSide s x) (BSide s y).

Proof.

exact: comparable_BSide_min. Qed.

Lemma BSide_max s (x y : T) :
  BSide s (Order.max x y) = Order.max (BSide s x) (BSide s y).

Proof.

exact: comparable_BSide_max. Qed.

Lemma itv_bound_total : total (<=%O : rel (itv_bound T)).

Proof.

by move=> [[]?|[]][[]?|[]]; rewrite /<=%O //=; case: ltgtP. Qed.

HB.instance Definition _ :=
  Order.Lattice_isTotal.Build
    (itv_bound_display disp) (itv_bound T) itv_bound_total.

Lemma itv_meetUl : @left_distributive (interval T) _ Order.meet Order.join.

Proof.

by move=> [? ?][? ?][? ?]; rewrite /Order.meet /Order.join /= -meetUl -joinIl.
Qed.

HB.instance Definition _ :=
  Order.Lattice_Meet_isDistrLattice.Build
    (interval_display disp) (interval T) itv_meetUl.

Lemma itv_splitU c a b : a <= c <= b ->
  forall y, (y \in Interval a b) = (y \in Interval a c) || (y \in Interval c b).

Proof.

case/andP => leac lecb y.
rewrite !itv_boundlr !(ltNge (BLeft y) _ : (BRight y <= _) = _).
case: (leP a) (leP b) (leP c) => leay [] leby [] lecy //=.
- by case: leP lecy (le_trans lecb leby).
- by case: leP leay (le_trans leac lecy).
Qed.

Lemma itv_splitUeq x a b : x \in Interval a b ->
  forall y, (y \in Interval a b) =
    [|| y \in Interval a (BLeft x), y == x | y \in Interval (BRight x) b].

Proof.

case/andP => ax xb y; rewrite (@itv_splitU (BLeft x)) ?ax ?ltW //.
by congr orb; rewrite (@itv_splitU (BRight x)) ?bound_lexx // itv_xx.
Qed.

Lemma itv_total_meet3E i1 i2 i3 :
  i1 `&` i2 `&` i3 \in [:: i1 `&` i2; i1 `&` i3; i2 `&` i3].

Proof.

case: i1 i2 i3 => [b1l b1r] [b2l b2r] [b3l b3r]; rewrite !inE /eq_op /=.
case: (leP b1l b2l); case: (leP b1l b3l); case: (leP b2l b3l);
  case: (leP b1r b2r); case: (leP b1r b3r); case: (leP b2r b3r);
  rewrite ?eqxx ?orbT //= => b23r b13r b12r b23l b13l b12l.
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13r (lt_trans b23r b12r).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13r (lt_trans b23r b12r).
- by case: leP b13r (lt_trans b23r b12r).
Qed.

Lemma itv_total_join3E i1 i2 i3 :
  i1 `|` i2 `|` i3 \in [:: i1 `|` i2; i1 `|` i3; i2 `|` i3].

Proof.

case: i1 i2 i3 => [b1l b1r] [b2l b2r] [b3l b3r]; rewrite !inE /eq_op /=.
case: (leP b1l b2l); case: (leP b1l b3l); case: (leP b2l b3l);
  case: (leP b1r b2r); case: (leP b1r b3r); case: (leP b2r b3r);
  rewrite ?eqxx ?orbT //= => b23r b13r b12r b23l b13l b12l.
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13r (le_trans b12r b23r).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13l (le_trans b12l b23l).
- by case: leP b13r (lt_trans b23r b12r).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13l (lt_trans b23l b12l).
- by case: leP b13r (lt_trans b23r b12r).
Qed.

Lemma predC_itvl a : [predC Interval -oo a] =i Interval a +oo.

Proof.

case: a => [b x|[]//] y.
by rewrite !inE !subitvE/= bnd_simp andbT !lteBSide/= lteifNE negbK.
Qed.

Lemma predC_itvr a : [predC Interval a +oo] =i Interval -oo a.

Proof.

by move=> y; rewrite inE/= -predC_itvl negbK. Qed.

Lemma predC_itv i : [predC i] =i [predU Interval -oo i.1 & Interval i.2 +oo].

Proof.

case: i => [a a']; move=> x; rewrite inE/= itv_splitI negb_and.
by symmetry; rewrite inE/= -predC_itvl -predC_itvr.
Qed.

End IntervalTotal.