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

Require Export Rbase.
Require Export Rfunctions.
Require Export R_sqrt.
Require Export Lra.

Open Scope R_scope.

Lemma def_sqrt : forall x : R, x >= 0 -> sqrt x * sqrt x = x.
intros.
apply sqrt_sqrt; auto with real.
Qed.

Lemma sqrt_pos : forall x : R, x >= 0 -> sqrt x >= 0.
intros.
apply Rle_ge.
apply sqrt_positivity; auto with real.
Qed.

Lemma Rmult_pos : forall x y : R, x >= 0 -> y >= 0 -> x * y >= 0.
intros.
apply Rle_ge.
apply Rmult_le_pos; auto with real.
Qed.

Lemma Rinv_le_pos : forall x : R, x <> 0 -> x >= 0 -> / x >= 0.
intros.
inversion H0.
apply Rle_ge.
apply Rlt_le; auto with real.
absurd (x = 0); auto.
Qed.

Lemma non_sqrt_zero : forall r : R, r >= 0 -> r <> 0 -> sqrt r <> 0.
unfold not in |- *; intros.
apply H0.
rewrite <- (def_sqrt r); auto.
rewrite H1; ring.
Qed.

Lemma Rinv_sqrt_pos : forall r : R, r <> 0 -> r >= 0 -> / sqrt r >= 0.
intros r H H0; try assumption.
apply Rinv_le_pos; auto.
apply non_sqrt_zero; auto.
apply sqrt_pos; auto.
Qed.
#[export] Hint Resolve non_sqrt_zero Rinv_sqrt_pos Rinv_le_pos Rmult_pos sqrt_pos
  def_sqrt: real.

Lemma resolution : forall x y : R, x >= 0 -> y >= 0 -> x * x = y * y -> x = y.
intros.
rewrite <- (def_sqrt x); auto with real.
rewrite <- (def_sqrt y); auto with real.
rewrite <- sqrt_mult; auto with real.
rewrite <- sqrt_mult; auto with real.
Qed.

Lemma inversion_sqr :
 forall x y : R, x >= 0 -> y >= 0 -> x = y * y -> y = sqrt x.
intros; symmetry  in |- *.
apply sqrt_lem_1; auto with real.
Qed.

Lemma sqrt_Rinv : forall x : R, x >= 0 -> x <> 0 -> sqrt (/ x) = / sqrt x.
intros.
inversion H.
replace (/ x) with (1 / x); auto with real.
rewrite sqrt_div; auto with real.
rewrite sqrt_1.
replace (1 / sqrt x) with (1 * / sqrt x); auto with real.
replace (1 / x) with (1 * / x); auto with real.
absurd (x = 0); auto.
Qed.

Lemma resolution2 :
 forall x y x' y' : R, x <> 0 -> x = y -> x * x' = y * y' -> x' = y'.
intros.
cut (y <> 0); intros.
replace x' with (/ x * x * x').
replace (/ x * x * x') with (/ x * (x * x')).
rewrite H1; rewrite H0.
replace (/ y * (y * y')) with (/ y * y * y').
replace (/ y * y) with 1.
ring.
auto with real.
ring.
ring.
replace (/ x * x) with 1.
ring.
auto with real.
rewrite <- H0; auto.
Qed.

Lemma deux_demi : 2 * / 2 = 1.
cut (2 <> 0); intros.
auto with real.
try lra.
Qed.
#[export] Hint Resolve deux_demi: real.

Lemma deux_demi_a : forall a : R, a = / 2 * a + / 2 * a.
intros.
replace (/ 2 * a + / 2 * a) with (2 * / 2 * a).
replace (2 * / 2) with 1; auto with real.
ring.
Qed.
#[export] Hint Resolve deux_demi_a: real.

Lemma integre_not : forall a b : R, a <> 0 -> b <> 0 -> a * b <> 0.
intros.
apply Rmult_integral_contrapositive; (split; auto; try lra).
Qed.
#[export] Hint Resolve integre_not: real.

Lemma lR14 : 1 + - / 2 = / 2.
Proof.
field.
Qed.
#[export] Hint Resolve lR14: real.

Lemma lR15 : forall k : R, k * k = (1 + - k) * (1 + - k) -> k = / 2.
intros.
cut (2 <> 0); intros.
cut (2 * k = 1); intros.
replace k with (/ 2 * (2 * k)).
rewrite H1.
ring.
replace (/ 2 * (2 * k)) with (/ 2 * 2 * k).
replace (/ 2 * 2) with 1.
ring.
auto with real.
ring.
cut ((1 + - k) * (1 + - k) = - (2 * k) + (k * k + 1)); intros.
rewrite <- H in H1.
cut (2 * k = k * k + 1 + - (k * k)); intros.
rewrite H2.
ring.
pattern (k * k) at 2 in |- *.
rewrite H1.
replace (- (- (2 * k) + (k * k + 1))) with (2 * k + - (k * k + 1)).
ring.
ring.
ring.
lra.
Qed.
#[export] Hint Resolve lR15: real.

Lemma lR20 : forall a : R, ~ a >= 0 -> -1 * a >= 0.
intros.
replace (-1 * a) with (- a) by ring.
lra.
Qed.
#[export] Hint Resolve lR20: real.

Lemma non_produit_un : forall k k' : R, k' * k <> 1 -> 1 + - (k' * k) <> 0.
intros; red in |- *; intros.
apply H.
replace 1 with (1 + - (k' * k) + k' * k); [ idtac | ring ].
rewrite H0; ring.
Qed.
#[export] Hint Resolve non_produit_un: real.

Lemma opp_inv_demi_nonzero : - / 2 <> 0.
cut (-2 <> 0); intros.
replace (- / 2) with (/ -2); auto with real.
rewrite Ropp_inv_permute; auto with real.
lra.
Qed.
#[export] Hint Resolve opp_inv_demi_nonzero: real.

Lemma nonzero_un : 1 <> 0.
lra.
Qed.

Lemma nonzero_oppun : -1 <> 0.
lra.
Qed.

Lemma nonzero_deux : 2 <> 0.
lra.
Qed.

Lemma nonzero_oppdeux : -2 <> 0.
lra.
Qed.

Lemma nonzero_invdeux : / 2 <> 0.
lra.
Qed.

Lemma nonzero_trois : 3 <> 0.
lra.
Qed.

Lemma nonzero_opptrois : -3 <> 0.
lra.
Qed.

Lemma nonzero_invtrois : / 3 <> 0.
lra.
Qed.
#[export] Hint Resolve nonzero_invtrois nonzero_opptrois nonzero_trois nonzero_invdeux
  nonzero_oppdeux nonzero_deux nonzero_oppun nonzero_un: real.

Lemma double_zero : forall a : R, 2 * a = 0 -> a = 0.
intros.
replace a with (/ 2 * (2 * a)); auto with real.
field.
Qed.

Lemma zero_double : forall a : R, a = 0 -> 2 * a = 0.
intuition.
Qed.
#[export] Hint Resolve double_zero zero_double: real.

Lemma nonzero_oppinvtrois : - / 3 <> 0.
cut (-3 <> 0); intros; auto with real.
Qed.

Lemma nonzero_oppinvdeux : - / 2 <> 0.
cut (-2 <> 0); intros; auto with real.
Qed.
#[export] Hint Resolve nonzero_oppinvtrois nonzero_oppinvdeux: real.

Lemma Rgt_inv : forall k : R, k > 0 -> / k > 0.
intros.
cut (k <> 0); intros; [ idtac | auto with real ].
cut (k >= 0); intros.
cut (/ k >= 0); intros.
2: apply Rinv_le_pos; auto.
elim H2; intros; auto.
absurd (/ k = 0); auto with real.
red in |- *.
left; try assumption.
Qed.
#[export] Hint Resolve Rgt_inv: real.

Definition R2 := 2.

Definition R4 := 2 + 2.
#[export] Hint Unfold R2 R4: real geo.


Require Import Iron.Language.Simple.Step.
Require Import Iron.Language.Simple.Ty.
Require Import Iron.Language.Simple.Exp.

(* A closed, well typed expression is either a value or can
   take a step in the evaluation. *)
Theorem progress
 :  forall x t
 ,  TYPE nil x t
 -> value x \/ (exists x', STEP x x').
Proof.
 intros.
 remember (@nil ty) as tyenv.
 induction H; subst.

 Case "XVar".
  burn.

 Case "XLam".
  left. burn.

 Case "XApp".
  right.
  assert (@nil ty = nil). burn. rip.

  destruct IHTYPE1.
  SCase "value x1".
   destruct IHTYPE2.
   SSCase "value x2".
    have (exists t x, x1 = XLam t x).
     destruct H4 as [t11].
     destruct H4 as [x11].
     subst.
    exists (substX 0 x2 x11). burn.

   SSCase "x2 steps".
    destruct H3 as [x2'].
    exists (XApp x1 x2').
    lets D: EsContext XcApp2; burn.

   SSCase "x1 steps".
    destruct H2 as [x1'].
    exists (XApp x1' x2).
    lets D: EsContext XcApp1; burn.
Qed.


Require Export CatSem.CAT.rmonad.
Require Export CatSem.CAT.rmonad_hom.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** pullback *)

Section pullback.
Variables obC obD : Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C : Cat_struct morC.
Variable D : Cat_struct morD.
Variable F : Functor C D.

Variables P Q : RMonad F.
Variable h : RMonad_Hom P Q.

Section pb_def.

Variable obE : Type.
Variable morE : obE -> obE -> Type.
Variable E : Cat_struct morE.

Section PbRMod.

Variable N : RMOD Q E.

Obligation Tactic := idtac.

Program Instance PbRMod_struct : RModule_struct P E N := {
  rmkleisli c d f := rmkleisli (f ;; h d )
}.
Next Obligation.
Proof.
  intros c d.
  unfold Proper; red.
  intros x y H.
  rewrite H.
  rmonad.
Qed.
Next Obligation.
Proof.
  rmonad.
  apply h.
Qed.
Next Obligation.
Proof.
  rmonad.
  apply h.
Qed.

Definition PbRMod : RMOD P E := Build_RModule PbRMod_struct.

End PbRMod.

Section PbRMod_Hom.

Variables M N : RMOD Q E.
Variable S : M ---> N.

Obligation Tactic := rmonad.

Program Instance PbRMod_Hom_struct : RModule_Hom_struct
       (M := PbRMod M) (N:=PbRMod N) S.
(*Next Obligation.
Proof.
  simpl.
  rewrite (rmod_hom_rmkl);
  try cat.
  apply S.
Qed.
*)
Definition PbRMod_Hom : PbRMod M ---> PbRMod N :=
      Build_RModule_Hom PbRMod_Hom_struct.

End PbRMod_Hom.

Obligation Tactic := unfold Proper; red; simpl; rmonad.

Program Instance PbRMOD_struct : Functor_struct PbRMod_Hom.

Canonical Structure PbRMOD := Build_Functor PbRMOD_struct.

Section pb_prod.

Variable H : Cat_Prod E.

Existing Instance RMOD_PROD.

Variables M N : RModule Q E.

Notation "a 'x' b" := (product a b)(at level 60).

Obligation Tactic := cat.

Program Instance PROD_RPB_s : RModule_Hom_struct
  (M:= product (C:=RMOD P E) (PbRMod M) (PbRMod N))
  (N:=PbRMod (product (C:=RMOD Q E) M N))
  (fun c => id (M c x N c) ).

Definition PROD_RPB :
   (PbRMod M x PbRMod N) ---> PbRMod (M x N) :=
       Build_RModule_Hom PROD_RPB_s.

End pb_prod.

End pb_def.

Program Instance PbRMod_ind_Hom_struct :
  RModule_Hom_struct (M:= P) (N:=PbRMOD _ Q) (fun x => h x).
Next Obligation.
Proof.
  rmonad;
  try apply h.
Qed.

Definition PbRMod_ind_Hom : Taut_RMod P ---> PbRMod Q :=
     Build_RModule_Hom PbRMod_ind_Hom_struct.

End pullback.

Coercion PbRMod_ind_Hom : RMonad_Hom >-> mor.


Require Import Coq.Reals.Reals.
Require Import Coquelicot.Coquelicot.
Require Import Coq.micromega.Psatz.
Require Import Coq.Classes.Morphisms.
Require Import ChargeCore.Logics.ILogic.
Require Import Control.Barrier.
Require Import Control.Syntax.
Local Transparent ILInsts.ILFun_Ops.

Section BarrierRules.

  Variable state : NormedModule R_AbsRing.

  Lemma Proper_derive_barrier_dom :
    forall (G1 G2 : StateProp state) (e1 e2 : barrier state) (e1' e2' : dbarrier state),
      G1 -|- G2 ->
      |-- e1 [=] e2 ->
      derive_barrier_dom G1 e1 e1' ->
      $[G1] |-- e1' [=] e2' ->
      derive_barrier_dom G2 e2 e2'.
  Proof.
    unfold derive_barrier_dom. simpl. intros.
    apply is_derive_ext with (f:=fun t => e1 (F t)).
    { intros. auto. }
    { rewrite <- H2; auto.
      { apply H1; auto; apply H; auto. }
      { apply H; auto. } }
  Qed.

  Lemma derive_barrier_pure :
    forall (x : R) (G : StateProp state),
      derive_barrier_dom G (pure x) (pure 0).
  Proof.
    unfold derive_barrier, derive_barrier_dom, pure.
    simpl. intros. auto_derive; auto.
  Qed.

  Lemma derive_barrier_plus :
    forall (e1 e2 : barrier state) (e1' e2' : dbarrier state) (G : StateProp state),
      derive_barrier_dom G e1 e1' ->
      derive_barrier_dom G e2 e2' ->
      derive_barrier_dom G (e1 [+] e2) (e1' [+] e2').
  Proof.
    unfold derive_barrier, derive_barrier_dom. simpl. intros.
    specialize (H F D H1 H2 t H3). specialize (H0 F D H1 H2 t H3).
    apply (is_derive_plus _ _ _ _ _ H H0).
  Qed.

  Lemma derive_barrier_minus :
    forall (e1 e2 : barrier state) (e1' e2' : dbarrier state) (G : StateProp state),
      derive_barrier_dom G e1 e1' ->
      derive_barrier_dom G e2 e2' ->
      derive_barrier_dom G (e1 [-] e2) (e1' [-] e2').
  Proof.
    unfold derive_barrier, derive_barrier_dom. simpl. intros.
    specialize (H F D H1 H2 t H3). specialize (H0 F D H1 H2 t H3).
    apply (is_derive_minus _ _ _ _ _ H H0).
  Qed.

  Lemma derive_barrier_mult :
    forall (e1 e2 : barrier state) (e1' e2' : dbarrier state) (G : StateProp state),
      derive_barrier_dom G e1 e1' ->
      derive_barrier_dom G e2 e2' ->
      derive_barrier_dom G (e1 [*] e2) ((e1' [[*]] $[e2]) [+] ($[e1] [[*]] e2')).
  Proof.
    unfold derive_barrier, derive_barrier_dom. simpl. intros.
    specialize (H F D H1 H2 t H3). specialize (H0 F D H1 H2 t H3).
    apply (is_derive_mult _ _ _ _ _ H H0). compute. intros.
    apply Rmult_comm.
  Qed.

  Lemma derive_barrier_div :
    forall (e1 e2 : barrier state) (e1' e2' : dbarrier state) (G : StateProp state),
      derive_barrier_dom G e1 e1' ->
      derive_barrier_dom G e2 e2' ->
      G |-- e2 [<>] #0 ->
      derive_barrier_dom G (e1 [/] e2)
                         (((e1' [[*]] $[e2]) [-] ($[e1] [[*]] e2'))[[/]]($[e2][[^]]##2%nat)).
  Proof.
    unfold derive_barrier, derive_barrier_dom. simpl. intros.
    specialize (H F D H2 H3 t H4). specialize (H0 F D H2 H3 t H4).
    apply (is_derive_div _ _ _ _ _ H H0). apply H1; auto.
  Qed.

  Lemma derive_barrier_sqrt :
    forall (e : barrier state) (e' : dbarrier state) (G : StateProp state),
      derive_barrier_dom G e e' ->
      G |-- #0 [<] e ->
      derive_barrier_dom G ([sqrt] e) (e' [[/]](##2[[*]]([[sqrt]]$[e]))).
  Proof.
    unfold derive_barrier, derive_barrier_dom. simpl. intros.
    specialize (H F D H1 H2 t H3). apply (is_derive_sqrt _ _ _ H).
    apply H0; auto.
  Qed.

  Definition piecewise {T U : Type} (f g : U -> T) (a : R) (k : U -> R) (x : U) :=
    if Rle_dec (k x) a then f x else g x.

  Lemma piecewise_is_derive :
    forall (T : NormedModule R_AbsRing) (f g df dg : R -> T) (a : R) (k : R -> R) (K : R -> Prop),
    (forall x, K x -> k x <= a -> is_derive f x (df x)) ->
    (forall x, K x -> k x >= a -> is_derive g x (dg x)) ->
    (forall x, K x -> k x = a -> df x = dg x) ->
    (forall x, K x -> k x = a -> f x = g x) ->
    (forall x, continuous k x) ->
    forall x, K x -> is_derive (piecewise f g a k) x (piecewise df dg a k x).
  Proof.
    intros.
    destruct (Rle_dec (k x) a).
    { destruct r.
      { apply (is_derive_ext_loc f).
        { apply locally_open with (D:= fun x => k x < a); auto.
          { apply (open_comp k (fun x => x < a)).
            { simpl. intros. apply H3. }
            { apply open_lt. } }
          { simpl. intros. unfold piecewise.
            destruct (Rle_dec (k x0) a); try psatzl R. reflexivity. } }
        { unfold piecewise. destruct (Rle_dec (k x) a); try psatzl R.
          apply H; auto. } }
      { split.
        { apply is_linear_scal_l. }
        { intros x0 Hx eps. pose proof (is_filter_lim_locally_unique _ _ Hx).
          simpl. subst x0. specialize (H x H4 (or_intror H5)). specialize (H0 x H4 (or_intror H5)).
          destruct H as [? Cf]. destruct H0 as [? Cg].
          specialize (Cf _ Hx eps). specialize (Cg _ Hx eps). pose proof (filter_and _ _ Cf Cg).
          eapply filter_imp; eauto. simpl. intros. unfold piecewise.
          destruct (Rle_dec (k x) a); try psatzl R. destruct (Rle_dec (k x0) a).
          { tauto. }
          { rewrite H1; auto. rewrite H2; tauto. } } } }
    { apply (is_derive_ext_loc g).
      { apply locally_open with (D:= fun x => k x > a); try psatzl R.
        { apply (open_comp k (fun x => x > a)).
          { simpl. intros. apply H3. }
          { apply open_gt. } }
        { simpl. intros. unfold piecewise.
          destruct (Rle_dec (k x0) a); try psatzl R. reflexivity. } }
      { unfold piecewise. destruct (Rle_dec (k x) a); try psatzl R.
        apply H0; auto. psatzl R. } }
  Qed.

  Lemma derive_barrier_piecewise :
    forall (c : StateVal state R) (x : R) (e1 e2 : barrier state)
           (e1' e2' : dbarrier state) (G : StateProp state),
      derive_barrier_dom (G //\\ c [<=] #x) e1 e1' ->
      derive_barrier_dom (G //\\ c [>=] #x) e2 e2' ->
      $[G] //\\ $[c] [[=]] ##x |-- e1' [[=]] e2' ->
      G //\\ c [=] #x |-- e1 [=] e2 ->
      (forall x, continuous c x) ->
      derive_barrier_dom G (c ?<= x [?] e1 [:] e2) ($[c] ??<= x [?] e1' [:] e2').
  Proof.
    unfold derive_barrier, derive_barrier_dom. simpl. intros.
    apply piecewise_is_derive
    with (k:=fun t => c (F t))
           (f:=fun t => e1 (F t))
           (g:=fun t => e2 (F t))
           (df:=fun t => e1' (D t) (F t))
           (dg:=fun t => e2' (D t) (F t))
           (K:=fun t => G (F t)); auto.
    intros. apply continuous_comp; auto.
  Qed.

  Lemma continuous_dB_pure :
    forall (x : R) (G : FlowProp state),
      continuous_dB G (pure x).
  Proof.
    unfold continuous_dB, pure.
    simpl. intros. apply continuous_const.
  Qed.

  Lemma continuous_dB_plus :
    forall (e1 e2 : dbarrier state) (G : FlowProp state),
      continuous_dB G e1 ->
      continuous_dB G e2 ->
      continuous_dB G (e1 [+] e2).
  Proof.
    unfold continuous_dB. simpl. intros.
    specialize (H p H1). specialize (H0 p H1).
    apply (continuous_plus _ _ _ H H0).
  Qed.

  Lemma continuous_dB_minus :
    forall (e1 e2 : dbarrier state) (G : FlowProp state),
      continuous_dB G e1 ->
      continuous_dB G e2 ->
      continuous_dB G (e1 [-] e2).
  Proof.
    unfold continuous_dB. simpl. intros.
    specialize (H p H1). specialize (H0 p H1).
    apply (continuous_minus _ _ _ H H0).
  Qed.

  Lemma continuous_dB_mult :
    forall (e1 e2 : dbarrier state) (G : FlowProp state),
      continuous_dB G e1 ->
      continuous_dB G e2 ->
      continuous_dB G (e1 [*] e2).
  Proof.
    unfold continuous_dB. simpl. intros.
    specialize (H p H1). specialize (H0 p H1).
    apply (continuous_mult _ _ _ H H0).
  Qed.

  Lemma continuous_dB_div :
    forall (e1 e2 : dbarrier state) (G : FlowProp state),
      continuous_dB G e1 ->
      continuous_dB G e2 ->
      G |-- e2 [<>] #0 ->
      continuous_dB G (e1 [/] e2).
  Proof.
    unfold continuous_dB. simpl. intros.
    specialize (H p H2). specialize (H0 p H2).
    apply (continuous_mult (fun p0 => e1 (fst p0) (snd p0))
                           (fun p0 => / e2 (fst p0) (snd p0))); auto.
    unfold continuous. simpl. eapply filterlim_comp.
    { apply H0. }
    { simpl.
      replace (locally (e2 (fst p) (snd p)))
      with (Rbar_locally (e2 (fst p) (snd p))) by reflexivity.
      replace (@locally (AbsRing_UniformSpace R_AbsRing) (/ e2 (fst p) (snd p)))
              with (Rbar_locally (/ e2 (fst p) (snd p))) by reflexivity.
      apply filterlim_Rbar_inv. apply Rbar_finite_neq. auto. }
  Qed.

  Lemma continuous_dB_sqrt :
    forall (e : dbarrier state) (G : FlowProp state),
      continuous_dB G e ->
      G |-- #0 [<] e ->
      continuous_dB G ([sqrt] e).
  Proof.
    unfold continuous_dB. simpl. intros. specialize (H p H1).
    apply continuous_comp.
    { apply H. }
    { apply continuity_pt_filterlim. apply continuity_pt_sqrt.
      specialize (H0 _ _ H1). psatzl R. }
  Qed.

  Lemma piecewise_continuous :
    forall (T U : UniformSpace)  (f g : U -> T) (a : R) (k : U -> R),
    (forall x, k x <= a -> continuous f x) ->
    (forall x, k x >= a -> continuous g x) ->
    (forall x, k x = a -> f x = g x) ->
    (forall x, continuous k x) ->
    forall x, continuous (piecewise f g a k) x.
  Proof.
    intros.
    destruct (Rle_dec (k x) a).
    { destruct r.
      { apply (continuous_ext_loc _ f).
        { apply locally_open with (D:= fun x => k x < a); auto.
          { apply (open_comp k (fun x => x < a)).
            { simpl. intros. apply H2. }
            { apply open_lt. } }
          { simpl. intros. unfold piecewise.
            destruct (Rle_dec (k x0) a); try psatzl R. reflexivity. } }
        { apply H. psatzl R. } }
      { apply filterlim_locally. intros.
        specialize (H _ (or_intror H3)). specialize (H0 _ (or_intror H3)).
        pose proof (proj1 (filterlim_locally _ _) H eps) as Cf.
        pose proof (proj1 (filterlim_locally _ _) H0 eps) as Cg.
        pose proof (filter_and _ _ Cf Cg).
        eapply filter_imp; eauto; simpl. intros. unfold piecewise.
        destruct (Rle_dec (k x) a); try psatzl R. destruct (Rle_dec (k x0) a).
        { tauto. }
        { rewrite H1; tauto. } } }
    { apply (continuous_ext_loc _ g).
      { apply locally_open with (D:= fun x => k x > a); auto.
        { apply (open_comp k (fun x => x > a)).
          { simpl. intros. apply H2. }
          { apply open_gt. } }
        { simpl. intros. unfold piecewise.
          destruct (Rle_dec (k x0) a); try psatzl R. reflexivity. }
        { psatzl R. } }
      { apply H0; psatzl R. } }
  Qed.

  Lemma continuous_dB_piecewise :
    forall (c : StateVal state R) (x : R)
           (e1 e2 : dbarrier state) (G : FlowProp state),
      continuous_dB ($[c] [[<=]] #x) e1 ->
      continuous_dB ($[c] [[>=]] #x) e2 ->
      $[c] [[=]] #x |-- e1 [[=]] e2 ->
      (forall x : state, continuous c x) ->
      continuous_dB G ($[c] ??<= x [?] e1 [:] e2).
  Proof.
    unfold continuous_dB. simpl. intros.
    apply piecewise_continuous
    with (k:=fun p => c (snd p))
           (f:=fun p => e1 (fst p) (snd p))
           (g:=fun p => e2 (fst p) (snd p)); auto.
    intros. apply continuous_comp.
    { apply continuous_snd. }
    { apply H2. }
  Qed.

End BarrierRules.

Ltac auto_derive_barrier :=
  repeat match goal with
         | [ |- derive_barrier_dom _ (#_) _ ] => apply derive_barrier_pure
         | [ |- derive_barrier_dom _ (_ [-] _) _ ] => apply derive_barrier_minus
         | [ |- derive_barrier_dom _ (_ [+] _) _ ] => apply derive_barrier_plus
         | [ |- derive_barrier_dom _ (_ [/] _) _ ] => apply derive_barrier_div
         | [ |- derive_barrier_dom _ (_ [*] _) _ ] => apply derive_barrier_mult
         | [ |- derive_barrier_dom _ ([sqrt] _) _ ] => apply derive_barrier_sqrt
         end.

Ltac auto_continuous_dB :=
  repeat match goal with
         | [ |- continuous_dB _ (#_) ] => apply continuous_dB_pure
         | [ |- continuous_dB _ (_ [-] _) ] => apply continuous_dB_minus
         | [ |- continuous_dB _ (_ [+] _) ] => apply continuous_dB_plus
         | [ |- continuous_dB _ (_ [/] _) ] => apply continuous_dB_div
         | [ |- continuous_dB _ (_ [*] _) ] => apply continuous_dB_mult
         | [ |- continuous_dB _ ([sqrt] _) ] => apply continuous_dB_sqrt
         end.

Lemma is_derive_fst :
  forall (T U : NormedModule R_AbsRing) (F : trajectory (prod_NormedModule _ T U)) D,
    (forall t : R, is_derive F t (D t)) ->
    forall t, is_derive (fun t : R => fst (F t)) t (fst (D t)).
Proof.
  intros. eapply filterdiff_ext_lin.
  { apply (filterdiff_comp' F).
    { apply H. }
    { instantiate (1:=fst). split.
      { apply is_linear_fst. }
      { intros. unfold locally. intro. exists eps.
        intros. destruct y. destruct x. simpl. unfold minus at 2.
        rewrite minus_eq_zero. rewrite norm_zero. rewrite <- norm_ge_0.
        psatz R. destruct eps. simpl. psatzl R. } } }
  { simpl. intros. reflexivity. }
Qed.
Lemma derive_barrier_fst_R :
  forall (U : NormedModule R_AbsRing) (G : StateProp (prod_NormedModule _ R_NormedModule U)),
    derive_barrier_dom G fst (d[fst]).
Proof.
  unfold derive_barrier_dom. simpl. intros.
  apply is_derive_fst; auto.
Qed.
Lemma is_derive_snd :
  forall (T U : NormedModule R_AbsRing) (F : trajectory (prod_NormedModule _ T U)) D,
    (forall t : R, is_derive F t (D t)) ->
    forall t, is_derive (fun t : R => snd (F t)) t (snd (D t)).
Proof.
  intros. eapply filterdiff_ext_lin.
  { apply (filterdiff_comp' F).
    { apply H. }
    { instantiate (1:=snd). split.
      { apply is_linear_snd. }
      { intros. unfold locally. intro. exists eps.
        intros. destruct y. destruct x. simpl. unfold minus at 2.
        rewrite minus_eq_zero. rewrite norm_zero. rewrite <- norm_ge_0.
        psatz R. destruct eps. simpl. psatzl R. } } }
  { simpl. intros. reflexivity. }
Qed.
Lemma derive_barrier_snd_R :
  forall (U : NormedModule R_AbsRing) (G : StateProp (prod_NormedModule _ U R_NormedModule)),
    derive_barrier_dom G snd (d[snd]).
Proof.
  unfold derive_barrier_dom. simpl. intros.
  apply is_derive_snd; auto.
Qed.

Lemma continuous_dB_fst :
  forall (U : NormedModule R_AbsRing) (G : FlowProp (prod_NormedModule _ R_NormedModule U)),
    continuous_dB G ($[fst]).
Proof.
  unfold continuous_dB. simpl. intros.
  apply continuous_comp.
  { apply continuous_snd. }
  { apply continuous_fst. }
Qed.
Lemma continuous_dB_snd :
  forall (U : NormedModule R_AbsRing) (G : FlowProp (prod_NormedModule _ U R_NormedModule)),
    continuous_dB G ($[snd]).
Proof.
  unfold continuous_dB. simpl. intros.
  apply continuous_comp.
  { apply continuous_snd. }
  { apply continuous_snd. }
Qed.
Lemma continuous_dB_dfst :
  forall (U : NormedModule R_AbsRing) (G : FlowProp (prod_NormedModule _ R_NormedModule U)),
    continuous_dB G (d[fst]).
Proof.
  unfold continuous_dB. simpl. intros.
  apply continuous_comp.
  { apply continuous_fst. }
  { apply continuous_fst. }
Qed.
Lemma continuous_dB_dsnd :
  forall (U : NormedModule R_AbsRing) (G : FlowProp (prod_NormedModule _ U R_NormedModule)),
    continuous_dB G (d[snd]).
Proof.
  unfold continuous_dB. simpl. intros.
  apply continuous_comp.
  { apply continuous_fst. }
  { apply continuous_snd. }
Qed.

Ltac continuous_dB_vars :=
  apply continuous_dB_fst ||
  apply continuous_dB_dfst ||
  apply continuous_dB_snd ||
  apply continuous_dB_dsnd.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype tuple path fingraph bigop order ssralg.
From mathcomp Require Import ssrnum ssrint div intdiv.
From fourcolor Require Import hypermap geometry coloring grid matte.
From fourcolor Require Import real realplane.
From Coq Require Import Setoid Morphisms.
From fourcolor Require Import realsyntax realprop.

(******************************************************************************)
(*   Approximations of real scalars, points, regions and rectangles, used to  *)
(* cast the continuous four color problem into a combinatorial form.          *)
(*   Because the grid decomposition is based on dichotomy, we choose to       *)
(* approximate the real coordinates with binary decimals (i.e., floating      *)
(* point numbers), rather than arbitrary rationals.                           *)
(*   For a Real.model R, we define:                                           *)
(*          exp2R R s == 2 ^ s in R, for s : nat.                             *)
(*        scale R s m == m : int scaled back s, in R (i.e., m / 2 ^ s).       *)
(*  scale_point R s p == p : gpoint scaled back s, in point R.                *)
(*       approx s x m <-> m is the int approximation of x : R at scale s.     *)
(*                    := m <= x * 2 ^ s < m + 1.                              *)
(*  approx_point s z p <-> p : gpoint is the approximation of z : point R at  *)
(*                        scale s.                                            *)
(*   mem_approx s gr z <-> the approximation of z at scale s is in gregion gr *)
(*       scaled_rect R == the type of pairs of a natural integer scale and a  *)
(*                        grid rectangle. The phantom parameter R lets us     *)
(*                        coerce from scaled_rect R to a (rectangular) region *)
(*                        via mem_approx.                                     *)
(*    refine_srect s b == the scaled rectangle resulting from increasing the  *)
(*                        scale of b : scaled_rect by s while simultaneously  *)
(*                        scaling b's coordinates by s, so that b and         *)
(*                        refine_srect s b coerce to the same region.         *)
(*       inset_srect b == the scaled recangle inset one grid pixel from b;    *)
(*                        this insets the corresponding real region by        *)
(*                        1 / 2 ^ s on all sides.                             *)
(* cap_interval xz1 xz2 == the intersection of xz1 xz2 : interval R; this is  *)
(*                        a (possibly empty) interval.                        *)
(*      cap_rect r1 r2 == the rectangle intersection of r1 r2 : rectangle R.  *)
(*  sep_interval x1 x2 == a separating interval R containing x2 and NOT       *)
(*                        containing x1, provided x1 != x2.                   *)
(*      sep_rect z1 z2 == a separating rectangle R containing z2 : point R    *)
(*                        but not z1, unless z1 is extensionally equal to z2  *)
(*                        (belongs to the same regions).                      *)
(*      scaled_matte R == the type of pairs of a natural integer scale and a  *)
(*                        grid matte. The phantom parameter R lets us coerce  *)
(*                        from scaled_matte R to a (polygonal) region via     *)
(*                        mem_approx.                                         *)
(*   refine_smatte s m == the scaled matte resulting from increasing the      *)
(*                        scale of m : scaled_matte by s while simultaneously *)
(*                        scaling m's coordinates by s, so that m and         *)
(*                        refine_matte s m coerce to the same region.         *)
(******************************************************************************)

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

Import Order.TTheory GRing.Theory Num.Theory RealPlaneCoercions.

Definition scaled_rect (R : Real.model) : Type := nat * grect.
Definition scaled_matte (R : Real.model) : Type := nat * matte.

Section ApproxMap.

Open Scope real_scope.

Variable R : Real.model.
Implicit Types x y : R.

Local Notation Rstr := (Real.model_structure R).
Local Notation point := (point Rstr).
Local Notation region := (region Rstr).
Local Notation map := (map Rstr).
Local Notation interval := (interval Rstr).
Local Notation rectangle := (rectangle Rstr).
Local Coercion intRR := intR R.

Let ltR01 := ltR01 R.
Let ltR02 := ltR02 R.
Let ltR12 : 1 < 2 := @ltRS R 1.

(* Real powers of 2, for scaling approximations.                          *)

Definition exp2R s := intR R (2 ^ s)%N.

Lemma exp2RS s : exp2R s.+1 == 2 * exp2R s.
Proof. by rewrite /exp2R expnS PoszM intRM. Qed.

Lemma leR1exp2 s : 1 <= exp2R s.
Proof. by apply/(@intR_leP R 1); rewrite lez_nat expn_gt0. Qed.

Lemma ltR0exp2 s : 0 < exp2R s.
Proof. exact/(ltR_le_trans ltR01)/leR1exp2. Qed.
Arguments ltR0exp2 : clear implicits.
Hint Resolve ltR0exp2 : core.

Lemma exp2R_add s1 s2 : exp2R (s1 + s2) == exp2R s1 * exp2R s2.
Proof. by rewrite /exp2R expnD -intRM. Qed.

Lemma leRexp2 s1 s2 : (s1 <= s2)%N -> exp2R s1 <= exp2R s2.
Proof. by move=> le_s12; apply/intR_leP; rewrite lez_nat leq_exp2l. Qed.

Lemma ltR1exp2S s : 1 < exp2R s.+1.
Proof. by apply/(@intR_ltP R 1); rewrite lez_nat (leq_exp2l 1). Qed.
Arguments ltR1exp2S : clear implicits.

(* Scalar decimal approximation.                                       *)

Definition approx s x (m : int) := range1 m (exp2R s * x).

Instance approx_Proper : Proper (eq ==> Real.eq ==> eq ==> iff) approx.
Proof. by move=> _ s -> x y Dx  _ m ->; rewrite /approx Dx. Qed.

Lemma approx_inj s x m1 m2 : approx s x m1 -> approx s x m2 -> m1 = m2.
Proof. exact: range1z_inj. Qed.

Lemma approx_exists s x : exists m, approx s x m.
Proof. by apply: find_range1z. Qed.

Definition scale s (m : int) := m / exp2R s.

Lemma approx_scale s m : approx s (scale s m) m.
Proof.
by rewrite /approx /scale (mulRC m) mulRCA pmulKR //; apply: range1zz.
Qed.

Lemma approx_halfz s x m : approx s.+1 x m -> approx s x (m %/ 2)%Z%N.
Proof.
rewrite /approx exp2RS -mulRA [m : R]intR_addbit -/intRR modz2.
move: {s x}(_ * x) {m}(odd `|m|) (m %/ 2)%Z%N => x b m [Hxm Hmx].
split; rewrite -(leR_pmul2l _ _ ltR02).
  by apply: leR_trans Hxm; rewrite -subR_ge0 addRK; apply: leR0n.
apply: (ltR_le_trans Hmx); rewrite mulRDr mulR1 addRCA -addRA leR_add2r.
by apply/(@intR_leP R _ 1); rewrite lez_nat leq_b1.
Qed.

Lemma scale_exists x : x > 0 -> exists s, exp2R s * x > 1.
Proof.
move=> Hx; have [[s|s'] [_]] := find_range1z x^-1; last first.
  case; apply: ltRW; apply: leR_lt_trans (invR_gt0 Hx).
  by rewrite NegzE addRC intRN -leR_opp2 oppR0 oppRB -intRB1; apply: leR0n.
rewrite -intRS -/intRR -(leR_pmul2l _ _ Hx) (divRR (gtR_neq Hx)) mulRC => Hs.
exists s; apply: ltR_le_trans Hs _; rewrite leR_pmul2r {x Hx}//.
by apply/intR_leP; rewrite lez_nat ltn_expl.
Qed.

Lemma approx_between s x1 x2 m1 m2 :
   approx s.+1 x1 m1 -> approx s.+1 x2 m2 -> 1 < exp2R s * (x2 - x1) ->
  exists2 m, (m1 + 1 <= m)%R & (m + 1 <= m2)%R.
Proof.
have [m] := approx_exists s (x1 + x2); rewrite /approx exp2RS.
move: (exp2R s) => s2; set y := s2 * (x1 + x2); set z := s2 * (x2 - x1).
have ->: 2 * s2 * x1 == y - z.
  by rewrite -mulRA mulRCA mul2R -mulRN -mulRDr oppRD addRA addRK oppRK.
have ->: 2 * s2 * x2 == y + z.
  by rewrite -mulRA mulRCA -mulRDr (addRC (x1 + x2)) -addRA addKR mul2R.
case=> Hmy Hym [Hm1 _] [_ Hm2] Hz.
exists m; apply/(@intR_ltP R); rewrite -/intRR.
  apply: (leR_lt_trans Hm1); rewrite -(leR_add2r z) subRK.
  by apply: (ltR_trans Hym); rewrite leR_add2l.
apply: (leR_lt_trans Hmy); rewrite -(leR_add2r z).
by apply: (ltR_trans Hm2); rewrite leR_add2l.
Qed.

(* Geometrical binary approximation.                                   *)

Definition approx_point s (z : point) p :=
  let: Point x y := z in let: Gpoint mx my := p in
  approx s x mx /\ approx s y my.

Lemma approx_point_inj s z p1 p2 :
  approx_point s z p1 -> approx_point s z p2 -> p1 = p2.
Proof.
case: z p1 p2 => [x y] [mx1 my1] [mx2 my2] [Hx1 Hy1] [Hx2 Hy2].
by congr (Gpoint _ _); eapply approx_inj; eauto.
Qed.

Lemma approx_point_exists s z : exists p, approx_point s z p.
Proof.
case: z => x y.
have [[mx Hmx] [my Hmy]] := (approx_exists s x, approx_exists s y).
by exists (Gpoint mx my).
Qed.

Definition scale_point s p : point :=
  let: Gpoint mx my := p in Point (scale s mx) (scale s my).

Lemma approx_scale_point s p : approx_point s (scale_point s p) p.
Proof. by case: p => mx my; split; apply: approx_scale. Qed.

Lemma approx_halfg s z p : approx_point s.+1 z p -> approx_point s z (halfg p).
Proof. by case: z p => [x y] [mx my] [Hx Hy]; split; apply: approx_halfz. Qed.

Definition mem_approx s (gr : gregion) : region :=
  fun z => exists2 p, approx_point s z p & gr p.

Lemma sub_mem_approx s (gr1 gr2 : gregion) :
  subpred gr1 gr2 -> subregion (mem_approx s gr1) (mem_approx s gr2).
Proof. by move=> Hgr12 z [p Dp Hp]; exists p; auto. Qed.

Lemma mem_approx_scale s gr p :
  reflect (mem_approx s gr (scale_point s p)) (gr p).
Proof.
apply: (iffP idP) => [Hp | [p' Dp' Hp']].
  by exists p; first by apply approx_scale_point.
by rewrite (approx_point_inj (approx_scale_point _ _) Dp').
Qed.

Lemma eq_mem_approx s (gr1 gr2 : gregion) z :
  gr1 =1 gr2 -> (mem_approx s gr1 z <-> mem_approx s gr2 z).
Proof. by move=> Dgr; split; apply/sub_mem_approx=> p; rewrite Dgr. Qed.

Lemma mem_approx_refine s (gr : gregion) z :
  mem_approx s.+1 (preim halfg gr) z <-> mem_approx s gr z.
Proof.
split=> [] [p Dp Hp]; first by exists (halfg p); first apply/approx_halfg.
have [q Dq] := approx_point_exists s.+1 z; exists q => //=.
by rewrite (approx_point_inj (approx_halfg Dq) Dp).
Qed.

Lemma mem_approx_refine_inset s (b : grect) :
  subregion (mem_approx s (inset b)) (mem_approx s.+1 (inset (refine_rect b))).
Proof.
move=> z /mem_approx_refine[p Dp]; rewrite /= -in_refine_rect refine_inset.
by move/insetW; exists p.
Qed.

(* Scaled rectangle *)

Let srect := scaled_rect R.
Definition srect_region (b : srect) : region := mem_approx b.1 b.2.
Local Coercion srect_region : srect >-> region.

Definition refine_srect s (b : srect) : srect :=
  (s + b.1, iter s refine_rect b.2)%N.

Definition inset_srect (b : srect) : srect := (b.1, inset b.2).

Lemma in_refine_srect s b z : refine_srect s b z <-> b z.
Proof.
elim: s => // s <-; rewrite -[refine_srect s b z]mem_approx_refine.
by apply/eq_mem_approx=> t /=; rewrite in_refine_rect.
Qed.

Lemma in_refine_inset s b z :
  inset_srect b z -> inset_srect (refine_srect s b) z.
Proof. by elim: s => // s IHs /IHs; apply/mem_approx_refine_inset. Qed.

Lemma approx_rect z (r : rectangle) :
  r z -> exists2 b, inset_srect b z & subregion b r.
Proof.
case: z r => [x y] [[x0 x1] [y0 y1]] [[lbx ubx] [lby uby]].
pose i4 := @Ordinal 4; pose dxy := tnth [tuple x - x0; x1 - x; y - y0; y1 - y].
have{lbx ubx lby uby} [s scale_s_dxy]: exists s, forall i, 1 < exp2R s * dxy i.
  have dxy_gt0 i: 0 < dxy i by case: i; do 4?case=> [?|]; rewrite ?subR_le0.
  have /fin_all_exists[s lbs] i := scale_exists (dxy_gt0 i).
  exists (\max_i s i) => i.
  exact/(ltR_le_trans (lbs i))/leR_pmul2r/leRexp2/leq_bigmax.
pose s1 := s.+1; pose ap_s1 := approx s1; have es1gt0 := ltR0exp2 s1.
have [[mx Dmx] [my Dmy]] := (approx_exists s1 x, approx_exists s1 y).
have [[mx0 Dmx0] [mx1 Dmx1]] := (approx_exists s1 x0, approx_exists s1 x1).
have [[my0 Dmy0] [my1 Dmy1]] := (approx_exists s1 y0, approx_exists s1 y1).
have [nx0 lbx0 ubx0] := approx_between Dmx0 Dmx (scale_s_dxy (i4 0%N isT)).
have [nx1 lbx1 ubx1] := approx_between Dmx Dmx1 (scale_s_dxy (i4 1%N isT)).
have [ny0 lby0 uby0] := approx_between Dmy0 Dmy (scale_s_dxy (i4 2%N isT)).
have [ny1 lby1 uby1] := approx_between Dmy Dmy1 (scale_s_dxy (i4 3%N isT)).
exists (s1, Grect nx0 (nx1 + 1) ny0 (ny1 + 1)) => /=.
  by exists (Gpoint mx my); rewrite //= !addrK -!lez_addr1 ubx0 lbx1 uby0 lby1.
have lt_approx u v mu mv: ap_s1 u mu -> ap_s1 v mv -> (mu + 1 <= mv)%R -> u < v.
  case=> _ ubu [lbv _] ltuv; apply/(leR_pmul2l v u es1gt0)/(ltR_le_trans ubu).
  by apply: leR_trans lbv; rewrite -intRD1; apply/intR_leP.
case=> x2 y2 [[mx2 my2] [Dmx2 Dmy2]] /=; rewrite -andbA -!lez_addr1 => /and4P[].
move=> /(le_trans lbx0)/lt_approx-lbx /le_trans/(_ ubx1)/lt_approx-ubx.
move=> /(le_trans lby0)/lt_approx-lby /le_trans/(_ uby1)/lt_approx-uby.
by do 2!split; [apply/lbx | apply/ubx | apply/lby | apply/uby].
Qed.

Lemma rect_approx s z p (b_p : srect := (s, ltouch p)) :
  approx_point s z p -> exists2 r : rectangle, r z & subregion r b_p.
Proof.
case: z p => x y [mx my] in b_p * => -[[lbx ubx] [lby uby]].
have sXgt0: exp2R s > 0 by apply: ltR0exp2.
have sZK u: exp2R s * (u / exp2R s) == u by rewrite [u / _]mulRC mulRCA pmulKR.
pose step (m : int) := Interval ((m - 1)%R / exp2R s) ((m + 1)%R / exp2R s).
exists (Rectangle (step mx) (step my)) => [|[x1 y1] [[]]].
  split; split; rewrite -(leR_pmul2l _ _ sXgt0) sZK /intRR ?intRD1 //.
    by apply: ltR_le_trans lbx; apply/intR_ltP; rewrite subrK.
  by apply: ltR_le_trans lby; apply/intR_ltP; rewrite subrK.
rewrite -(leR_pmul2l _ x1 sXgt0) -(leR_pmul2l x1 _ sXgt0) !sZK => lbx1 ubx1 [].
rewrite -(leR_pmul2l _ y1 sXgt0) -(leR_pmul2l y1 _ sXgt0) !sZK => lby1 uby1.
have [p1 Dp1] := approx_point_exists s (Point x1 y1); exists p1 => //.
case: p1 Dp1 => [p1x p1y] [[ubp1x lbp1x] [ubp1y lbp1y]] /=.
rewrite -!(rwP andP) -!ltz_addr1 -!lez_addr1 -!(rwP (@intR_ltP R _ _)).
rewrite (intRD1 R p1x) (intRD1 R p1y)  -/intRR; split.
  by split; [apply: ltR_trans lbp1x | apply: leR_lt_trans ubx1].
by split; [apply: ltR_trans lbp1y | apply: leR_lt_trans uby1].
Qed.

(* Some rectangle operations.                                                 *)

Definition cap_interval (xz1 xz2 : interval) :=
  let: Interval x1 z1 := xz1 in let: Interval x2 z2 := xz2 in
  Interval (max x1 x2) (min z1 z2).

Lemma mem_cap_interval xz1 xz2 y : cap_interval xz1 xz2 y <-> xz1 y /\ xz2 y.
Proof.
by case: xz1 xz2 => x1 z1 [x2 z2] /=; rewrite ltR_max ltR_min; tauto.
Qed.

Definition cap_rect r1 r2 :=
  let: Rectangle w1 h1 := r1 in let: Rectangle w2 h2 := r2 in
  Rectangle (cap_interval w1 w2) (cap_interval h1 h2).

Lemma mem_cap_rect r1 r2 p : cap_rect r1 r2 p <-> r1 p /\ r2 p.
Proof.
by case: p r1 r2 => x y [w1 h1] [w2 h2] /=; rewrite !mem_cap_interval; tauto.
Qed.

Definition sep_interval x1 x2 :=
  let w := (x1 + x2) / 2 in
  Interval (IF x2 <= w then x2 - 1 else w) (IF x2 >= w then x2 + 1 else w).

Lemma mem_sep_interval x1 x2 : sep_interval x1 x2 x2.
Proof.
rewrite /sep_interval; move: {x1}(_ / 2) => y; split.
  by case: IFR_cases => _ [][lex2y ->] //; apply: ltPR.
by case: IFR_cases => _ [][leyx2 ->] //; apply: ltRS.
Qed.

Lemma meet_sep_interval x y t :
  sep_interval x y t -> sep_interval y x t -> x == y.
Proof.
without loss ltxy: x y / x < y.
  by move=> IHxy ? ?; have [|/ltR_total[]/IHxy->] := reals_classic R (x == y).
case; set u := (x + y) / 2 => /ltRW-lttu _ [_ []]; rewrite addRC.
suffices{lttu} [ltxu ltuy]: x < u < y by rewrite !IFR_else in lttu *.
have Du: 2 * u == x + y by rewrite [u]mulRC mulRCA pmulKR.
by split; rewrite -(leR_pmul2l _ _ ltR02) Du mul2R (leR_add2l, leR_add2r).
Qed.

Definition sep_rect z1 z2 :=
  let: Point x1 y1 := z1 in let: Point x2 y2 := z2 in
  Rectangle (sep_interval x1 x2) (sep_interval y1 y2).

Lemma mem_sep_rect z1 z2 : sep_rect z1 z2 z2.
Proof. by case: z1 z2 => [x1 y1] [x2 y2]; split; apply: mem_sep_interval. Qed.

Lemma meet_sep_rect z1 z2 :
    meet (sep_rect z1 z2) (sep_rect z2 z1) ->
  forall rr : rectangle, rr z1 -> rr z2.
Proof.
case: z1 z2 => x1 y1 [x2 y2] [[x y] [[x12x y12y] [x21x y21y]]] [[? ?] [? ?]] /=.
by rewrite (meet_sep_interval x12x x21x) (meet_sep_interval y12y y21y).
Qed.

(* Scaled matte *)

Let smatte := scaled_matte R.
Definition smatte_region (m : smatte) : region := mem_approx m.1 m.2.
Local Coercion smatte_region : smatte >-> region.

Definition refine_smatte s (m : smatte) : smatte :=
  (s + m.1, iter s refine_matte m.2)%N.

Lemma in_refine_smatte s (m : smatte) z : refine_smatte s m z <-> m z.
Proof.
elim: s => // s <-; rewrite -[refine_smatte s m z]mem_approx_refine.
by apply/eq_mem_approx=> t; rewrite /= in_refine_matte.
Qed.

End ApproxMap.

Coercion srect_region : scaled_rect >-> region.
Coercion smatte_region : scaled_matte >-> region.