Require Import Coq.Bool.Bool.
Require Import Equivalence.
Require Import ExtLib.Core.RelDec.

Class Lte T := { lte : T -> T -> Prop }.
Definition neg_lte {T} {L:Lte T} (x:T) (y:T) : Prop := not (lte x y).

Definition lt {T} {L:Lte T} x y := lte x y /\ ~lte y x.
Definition neg_lt {T} {L:Lte T} x y := not (lt x y).

#[global]
Instance lt_RelDec {T} {L:Lte T} {RD:RelDec lte} : RelDec lt :=
  { rel_dec x y := (rel_dec x y && negb (rel_dec y x))%bool }.

#[global]
Instance lt_RelDecCorrect {T} {L:Lte T} {RD:RelDec lte} {RDC:RelDec_Correct RD}
  : RelDec_Correct lt_RelDec.
Proof. constructor.
  intros ; constructor ; intros.
  unfold rel_dec in H. simpl in H. apply andb_true_iff in H. destruct H.
    unfold lt. constructor. apply rel_dec_correct. auto.
    apply neg_rel_dec_correct. simpl in H0.
    apply negb_true_iff in H0. auto.
  unfold lt in H. destruct H. unfold rel_dec. simpl. apply andb_true_iff.
    constructor. apply rel_dec_correct. auto.
    apply negb_true_iff. apply neg_rel_dec_correct. auto.
Qed.

Class LteWF T :=
{ lteWFLte :> Lte T
; lteWFPreOrder :> PreOrder lte
}.

#[global]
Instance LteWF_Build {T} {L:Lte T} {PO:PreOrder lte} : LteWF T :=
  { lteWFLte := L ; lteWFPreOrder := PO }.

Definition lte_dec {T} {L:Lte T} {R:RelDec lte} := rel_dec.
Definition neg_lte_dec {T} {L:Lte T} {R:RelDec lte} x y := negb (lte_dec x y).

Definition lt_dec {T} {L:Lte T} {R:RelDec lte} := rel_dec.
Definition neg_lt_dec {T} {L:Lte T} {R:RelDec lte} x y := negb (lt_dec x y).

Section dec_p.
  Context {T} {L:Lte T} {RD:RelDec lte} {DC:RelDec_Correct RD}.

  Definition lte_dec_p (x:T) (y:T) : {lte x y} + {~lte x y} := rel_dec_p x y.
  Definition neg_lte_dec_p (x:T) (y:T) : {~lte x y} + {lte x y} := neg_rel_dec_p x y.
  Definition lt_dec_p (x:T) (y:T) : {lt x y} + {~lt x y} := rel_dec_p x y.
  Definition neg_lt_dec_p (x:T) (y:T) : {~lt x y} + {lt x y} := neg_rel_dec_p x y.
End dec_p.

Module LteNotation.
  Notation "x <=! y"       := (lte_dec x y)
    (at level 35, no associativity).
  Notation "x <=! y <=! z" := (lte_dec x y /\ lte_dec y z)
    (at level 35, y at next level, no associativity).
  Notation "x >=! y"       := (lte_dec y x)
    (at level 35, no associativity, only parsing).
  Notation "x >=! y >=! z" := (lte_dec z y /\ lte_dec y x)
    (at level 35, y at next level, no associativity).

  Notation "x <! y"       := (lt_dec x y)
    (at level 35, no associativity).
  Notation "x <! y <! z"  := (lt_dec x y /\ lt_dec y z)
    (at level 35, y at next level, no associativity).
  Notation "x >! y"       := (lt_dec y x)
    (at level 35, no associativity, only parsing).
  Notation "x >! y >! z"  := (lt_dec z y /\ lt_dec y x)
    (at level 35, y at next level, no associativity).

  Notation "x <=? y"       := (lte_dec_p y x)
    (at level 35, no associativity).
  Notation "x <=? y <=? z" := (lte_dec_p x y /\ lte_dec_p y z)
    (at level 35, y at next level, no associativity).
  Notation "x >=? y"       := (lte_dec_p y x)
    (at level 35, no associativity, only parsing).
  Notation "x >=? y >=? z" := (lte_dec_p z y /\ lte_dec_p y x)
    (at level 35, y at next level, no associativity, only parsing).

  Notation "x <? y"       := (lt_dec_p y x)
    (at level 35, no associativity).
  Notation "x <? y <? z"  := (lt_dec_p x y /\ lt_dec_p y z)
    (at level 35, y at next level, no associativity).
  Notation "x >? y"       := (lt_dec_p y x)
    (at level 35, no associativity, only parsing).
  Notation "x >? y >? z"  := (lt_dec_p z y /\ lt_dec_p y x)
    (at level 35, y at next level, no associativity, only parsing).

  Notation "x <=. y"       := (lte x y)
    (at level 70, no associativity).
  Notation "x <=. y <=. z" := (lte x y /\ lte y z)
    (at level 70, y at next level, no associativity).
  Notation "x >=. y"       := (lte y x)
    (at level 70, no associativity, only parsing).
  Notation "x >=. y >=. z" := (lte z y /\ lte y x)
    (at level 70, y at next level, no associativity, only parsing).

  Notation "x <. y"       := (lt x y)
    (at level 70, no associativity).
  Notation "x <. y <. z" := (lt x y /\ lt y z)
    (at level 70, y at next level, no associativity).
  Notation "x >. y"       := (lt y x)
    (at level 70, no associativity, only parsing).
  Notation "x >. y >. z" := (lt z y /\ lt y x)
    (at level 70, y at next level, no associativity, only parsing).
End LteNotation.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.implementations.peano_naturals
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.theory.groups
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.dec_fields
  HoTT.Classes.orders.dec_fields
  HoTT.Classes.orders.sum
  HoTT.Classes.theory.rationals
  HoTT.Classes.orders.lattices
  HoTT.Classes.implementations.assume_rationals
  HoTT.Classes.tactics.ring_quote
  HoTT.Classes.tactics.ring_tac.

Import NatPair.Instances.
Import Quoting.Instances.
Generalizable Variables A B.

Local Set Universe Minimization ToSet.

Class Closeness@{i} (A : Type@{i}) := close : Q+ -> Relation@{i i} A.

Global Instance Q_close@{} : Closeness Q := fun e q r => - ' e < q - r < ' e.

Class Separated A `{Closeness A}
  := separated : forall x y, (forall e, close e x y) -> x = y :> A.

Class Triangular A `{Closeness A}
  := triangular : forall u v w e d, close e u v -> close d v w ->
  close (e+d) u w.

Class Rounded@{i j} (A:Type@{i}) `{Closeness A}
  := rounded : forall e u v, iff@{i j j} (close e u v)
    (merely@{j} (sig@{UQ j} (fun d => sig@{UQ j} (fun d' =>
      e = d + d' /\ close d u v)))).

Class PreMetric@{i j} (A:Type@{i}) {Aclose : Closeness A} :=
  { premetric_prop : forall e, is_mere_relation A (close e)
  ; premetric_refl : forall e, Reflexive (close (A:=A) e)
  ; premetric_symm : forall e, Symmetric (close (A:=A) e)
  ; premetric_separated : Separated A
  ; premetric_triangular : Triangular A
  ; premetric_rounded : Rounded@{i j} A }.
#[export] Existing Instances
  premetric_prop
  premetric_refl
  premetric_symm
  premetric_separated
  premetric_triangular
  premetric_rounded.

Global Instance premetric_hset@{i j} `{Funext}
  {A:Type@{i} } `{PreMetric@{i j} A} : IsHSet A.
Proof.
apply (@HSet.ishset_hrel_subpaths@{j i j} _ (fun x y => forall e, close e x y)).
- intros x;reflexivity.
- apply _.
- apply separated.
Qed.

Record Approximation@{i} (A:Type@{i}) {Aclose : Closeness A} :=
  { approximate :> Q+ -> A
  ; approx_equiv : forall d e, close (d+e) (approximate d) (approximate e) }.

Lemma approx_eq `{Funext} `{Closeness A} `{forall e x y, IsHProp (close e x y)}
  : forall x y : Approximation A,
  approximate _ x = approximate _ y -> x = y.
Proof.
intros [x Ex] [y Ey];simpl;intros E.
destruct E. apply ap. apply path_ishprop.
Qed.

Definition IsLimit@{i} {A:Type@{i} } {Aclose : Closeness A}
  (x : Approximation A) (l : A)
  := forall e d : Q+, close (e+d) (x d) l.

Class Lim@{i} (A:Type@{i}) {Aclose : Closeness A} := lim : Approximation A -> A.

Class CauchyComplete@{i} (A:Type@{i}) {Aclose : Closeness A} {Alim : Lim A}
  := cauchy_complete : forall x : Approximation A, IsLimit x (lim x).

Section contents.
Context {funext : Funext} {univalence : Univalence}.

Lemma rounded_plus `{Rounded A} : forall d d' u v, close d u v ->
  close (d+d') u v.
Proof.
intros d d' u v xi;apply rounded.
apply tr;exists d,d';auto.
Qed.

Lemma rounded_le' `{Rounded A}
  : forall e u v, close e u v ->
  forall d, ' e <= ' d -> close d u v.
Proof.
intros e u v xi d E.
apply le_equiv_lt in E. destruct E as [E|E].
- apply pos_eq in E. rewrite <-E;trivial.
- pose proof (pos_eq _ (_ + _) (Qpos_diff_pr _ _ E)) as E'.
  rewrite E'. apply rounded_plus. trivial.
Qed.

(* Coq pre 8.8 produces phantom universes, see coq/coq#6483 **)
Definition rounded_le@{i j} := ltac:(first [exact @rounded_le'@{j i Ularge}|
                                            exact @rounded_le'@{j i Ularge j}|
                                            exact @rounded_le'@{i j}]).
Arguments rounded_le {A _ _} e u v _ d _.

Section close_prod.
Universe UA UB i.
Context (A:Type@{UA}) (B:Type@{UB}) `{Closeness A} `{Closeness B}
  `{forall e, is_mere_relation A (close e)}
  `{forall e, is_mere_relation B (close e)}.

Global Instance close_prod@{} : Closeness@{i} (A /\ B)
  := fun e x y => close e (fst x) (fst y) /\ close e (snd x) (snd y).

Global Instance close_prod_refl@{}
  `{forall e, Reflexive (close (A:=A) e)}
  `{forall e, Reflexive (close (A:=B) e)}
  : forall e, Reflexive (close (A:=A /\ B) e).
Proof.
intros e;split;reflexivity.
Qed.

Global Instance close_prod_symm@{}
  `{forall e, Symmetric (close (A:=A) e)}
  `{forall e, Symmetric (close (A:=B) e)}
  : forall e, Symmetric (close (A:=A /\ B) e).
Proof.
intros e u v xi;split;symmetry;apply xi.
Qed.

Global Instance close_prod_separated@{}
  `{!Separated A}
  `{!Separated B}
  : Separated (A /\ B).
Proof.
intros x y E.
apply Prod.path_prod;apply separated;intros;apply E.
Qed.

Global Instance close_prod_triangular@{}
  `{!Triangular A}
  `{!Triangular B}
  : Triangular (A /\ B).
Proof.
intros u v w e d E1 E2;split;(eapply triangular;[apply E1|apply E2]).
Qed.

Lemma close_prod_rounded'
  `{!Rounded A}
  `{!Rounded B}
  : Rounded (A /\ B).
Proof.
intros e u v. split.
- intros [E0 E0'];apply rounded in E0;apply rounded in E0'.
  revert E0;apply (Trunc_ind _);intros [d1 [d1' [E1 E2]]].
  revert E0';apply (Trunc_ind _);intros [d2 [d2' [E3 E4]]].
  apply tr;exists (join d1 d2), (meet d1' d2');split.
  + rewrite E1. apply Qpos_sum_eq_join_meet. rewrite <-E1;trivial.
  + split.
    * apply rounded_le with d1;trivial.
      apply join_ub_l.
    * apply rounded_le with d2;trivial.
      apply join_ub_r.
- apply (Trunc_ind _);intros [d [d' [E1 E2]]].
  rewrite E1;split;apply rounded_plus,E2.
Qed.

(* Coq pre 8.8 produces phantom universes, see coq/coq#6483 **)
Definition close_prod_rounded@{j} := ltac:(first [exact @close_prod_rounded'@{j j j j j}|
                                                  exact @close_prod_rounded'@{j j}|
                                                  exact @close_prod_rounded'@{j j j}]).
Arguments close_prod_rounded {_ _} _ _ _.
Global Existing Instance close_prod_rounded.

Lemma prod_premetric@{j} `{!PreMetric@{UA j} A} `{!PreMetric@{UB j} B}
  : PreMetric@{i j} (A /\ B).
Proof.
split;try apply _.
Qed.
Global Existing Instance prod_premetric.

Context {Alim : Lim A} {Blim : Lim B}.

Global Instance prod_lim@{} : Lim (A /\ B).
Proof.
intros xy. split;apply lim;
[exists (fun e => fst (xy e))|exists (fun e => snd (xy e))];intros;apply xy.
Defined.

Global Instance prod_cauchy_complete `{!CauchyComplete A} `{!CauchyComplete B}
  : CauchyComplete (A /\ B).
Proof.
intros xy e d;split.
- apply (cauchy_complete
    {| approximate := fun e0 : Q+ => fst (xy e0); approx_equiv := _ |}).
- apply (cauchy_complete
    {| approximate := fun e0 : Q+ => snd (xy e0); approx_equiv := _ |}).
Qed.

End close_prod.

Section close_arrow.
Context {A:Type} `{Bclose : Closeness B} `{!PreMetric B}.

(* Using [forall x, close e (f x) (g x)] works for closed balls, not open ones. *)
Global Instance close_arrow : Closeness (A -> B)
  := fun e f g => merely (exists d d', e = d + d' /\ forall x, close d (f x) (g x)).

Lemma close_arrow_apply : forall e (f g : A -> B), close e f g ->
  forall x, close e (f x) (g x).
Proof.
intros e f g E x;revert E;apply (Trunc_ind _);intros [d [d' [E1 E2]]].
rewrite E1;apply rounded_plus;trivial.
Qed.

Global Instance close_arrow_premetric : PreMetric (A -> B).
Proof.
split.
- apply _.
- intros e f;apply tr; exists (e/2), (e/2);split.
  + apply pos_split2.
  + intros x;reflexivity.
- intros e f g;apply (Trunc_ind _);intros [d [d' [E1 E2]]].
  apply tr;exists d, d';split;trivial.
  intros x;symmetry;trivial.
- intros f g E. apply path_forall;intros x.
  apply separated. intros e.
  apply (merely_destruct (E e)). intros [d [d' [E1 E2]]].
  rewrite E1. apply rounded_plus. trivial.
- intros f g h e d E1 E2.
  apply (merely_destruct E1);intros [d1 [d1' [E3 E4]]].
  apply (merely_destruct E2);intros [d2 [d2' [E5 E6]]].
  apply tr;exists (d1+d2),(d1'+d2'). split.
  + rewrite E3,E5.
   abstract (apply pos_eq; ring_tac.ring_with_nat).
  + intros x. apply triangular with (g x);trivial.
- intros e f g. split.
  + apply (Trunc_ind _). intros [d [d' [E1 E2]]].
    apply tr;exists (d+d'/2),(d'/2). split.
    * rewrite <-Qpos_plus_assoc,<-pos_split2. exact E1.
    * apply tr. exists d, (d'/2);split;trivial.
  + apply (Trunc_ind _);intros [d [d' [E1 E2]]].
    apply tr;exists d,d';split;trivial.
    apply close_arrow_apply. trivial.
Qed.

Context {Blim : Lim B}.

Global Instance arrow_lim : Lim (A -> B).
Proof.
intros f x. apply lim. exists (fun e => f e x).
intros. apply close_arrow_apply. apply approx_equiv.
Defined.
Arguments arrow_lim _ / _.

Context `{!CauchyComplete B}.
Global Instance arrow_cauchy_complete : CauchyComplete (A -> B).
Proof.
intros f e d.
unfold lim;simpl.
apply tr. exists (e/2 + d), (e/2). split.
+ abstract (set (e' := e/2);rewrite (pos_split2 e);unfold e';
  apply pos_eq;ring_tac.ring_with_nat).
+ intros x.
  set (S := {| approximate := fun e0 : Q+ => (f e0) x
            ;  approx_equiv := _ |}).
  pose proof (cauchy_complete S) as E;red in E.
  apply E.
Qed.

End close_arrow.

Class NonExpanding `{Closeness A} `{Closeness B} (f : A -> B)
  := non_expanding : forall e x y, close e x y -> close e (f x) (f y).
Arguments non_expanding {A _ B _} f {_ e x y} _.

Class Lipschitz `{Closeness A} `{Closeness B} (f : A -> B) (L : Q+)
  := lipschitz : forall e x y, close e x y -> close (L * e) (f x) (f y).
Arguments lipschitz {A _ B _} f L {_ e x y} _.

Class Uniform `{Closeness A} `{Closeness B} (f : A -> B) (mu : Q+ -> Q+)
  := uniform : forall e x y, close (mu e) x y -> close e (f x) (f y).
Arguments uniform {A _ B _} f mu {_} _ _ _ _.

Class Continuous@{UA UB}
  {A:Type@{UA} } `{Closeness A}
  {B:Type@{UB} } `{Closeness B} (f : A -> B)
  := continuous : forall u e, merely@{Ularge} (sig@{UQ Ularge}
    (fun d => forall v, close d u v ->
    close e (f u) (f v))).
Arguments continuous {A _ B _} f {_} _ _.

Definition BinaryDup@{i} {A : Type@{i} } : A -> A /\ A := fun x => (x, x).
Definition uncurry {A B C} (f : A -> B -> C) : A /\ B -> C
  := fun x => f (fst x) (snd x).
Definition map2 {A B C D} (f : A -> C) (g : B -> D) : A /\ B -> C /\ D
  := fun x => (f (fst x), g (snd x)).

Section closeness.
Universe UA.
Context {A:Type@{UA} } `{Closeness A}.

Global Instance id_nonexpanding : NonExpanding (@id A).
Proof.
hnf;trivial.
Qed.

Global Instance BinaryDup_nonexpanding@{} : NonExpanding (@BinaryDup A).
Proof.
intros e x y E;split;exact E.
Qed.

Universe UB.
Context {B:Type@{UB} } `{Closeness B} (f : A -> B).

Lemma nonexpanding_lipschitz' `{!NonExpanding f}
  : Lipschitz f 1.
Proof.
red. intro;rewrite left_identity;apply non_expanding,_.
Qed.

Definition nonexpanding_lipschitz@{} `{!NonExpanding f}
  : Lipschitz f 1
  := ltac:(first [exact nonexpanding_lipschitz'@{Ularge}|
                  exact nonexpanding_lipschitz'@{}]).
Global Existing Instance nonexpanding_lipschitz.

Lemma lipschitz_nonexpanding@{} `{!Lipschitz f 1} : NonExpanding f.
Proof.
red. intros e x y E;rewrite <-(left_identity e). apply (lipschitz f 1 E).
Qed.

Global Instance const_nonexpanding@{} `{forall e, Reflexive (close (A:=B) e)}
  (b : B) : NonExpanding (fun _ : A => b).
Proof.
hnf. intros;reflexivity.
Qed.

Global Instance lipschitz_const@{} `{forall e, Reflexive (close (A:=B) e)}
  : forall (b:B) (L:Q+), Lipschitz (fun _ : A => b) L.
Proof.
intros;hnf.
intros e _ _ _. reflexivity.
Qed.

Global Instance lipschitz_uniform@{} (L:Q+) `{!Lipschitz f L}
  : Uniform f (fun e => e / L) | 5.
Proof.
intros e u v xi.
rewrite <-(pos_unconjugate L e),<-Qpos_mult_assoc.
apply (lipschitz f L),xi.
Qed.

Lemma uniform_continuous@{} mu `{!Uniform@{UA UB} f mu} : Continuous f.
Proof.
hnf.
intros u e;apply tr;exists (mu e).
apply (uniform f mu).
Qed.
Global Existing Instance uniform_continuous | 5.

Definition lipschitz_continuous@{} (L:Q+) `{!Lipschitz f L} : Continuous f
  := _.

Definition nonexpanding_continuous@{} `{!NonExpanding f} : Continuous f
  := _.

End closeness.

Section compositions.
Universe UA.
Context {A:Type@{UA} } `{Closeness A}.
Universe UB.
Context {B:Type@{UB} } `{Closeness B}.
Universe UC.
Context {C:Type@{UC} } `{Closeness C} (g : B -> C) (f : A -> B).

Global Instance nonexpanding_compose@{}
  {Eg : NonExpanding g} {Ef : NonExpanding f}
  : NonExpanding (Compose g f).
Proof.
hnf. intros e x y xi;exact (non_expanding g (non_expanding f xi)).
Qed.

Global Instance lipschitz_compose@{}
  Lg {Eg : Lipschitz g Lg} Lf {Ef : Lipschitz f Lf}
  : Lipschitz (Compose g f) (Lg * Lf).
Proof.
intros ??? He.
unfold Compose;apply Ef,Eg in He.
pattern (Lg * Lf * e).
eapply transport;[|exact He].
apply associativity.
Qed.

Lemma lipschitz_compose_nonexpanding_r'
  L {Eg : Lipschitz g L} {Ef : NonExpanding f}
  : Lipschitz (Compose g f) L.
Proof.
rewrite <-(left_identity L),commutativity. apply _.
Qed.

Global Instance lipschitz_compose_nonexpanding_r@{}
  L {Eg : Lipschitz g L} {Ef : NonExpanding f}
  : Lipschitz (Compose g f) L
  := ltac:(first [exact (lipschitz_compose_nonexpanding_r'@{Ularge} L)|
                  exact (lipschitz_compose_nonexpanding_r'@{} L)]).

Lemma lipschitz_compose_nonexpanding_l'
  L {Eg : NonExpanding g} {Ef : Lipschitz f L}
  : Lipschitz (Compose g f) L.
Proof.
rewrite <-(left_identity L). apply _.
Qed.

Global Instance lipschitz_compose_nonexpanding_l@{}
  L {Eg : NonExpanding g} {Ef : Lipschitz f L}
  : Lipschitz (Compose g f) L
  := ltac:(first [exact (lipschitz_compose_nonexpanding_l'@{Ularge} L)|
                  exact (lipschitz_compose_nonexpanding_l'@{} L)]).

Lemma uniform_compose@{} mu {Eg : Uniform g mu} mu' {Ef : Uniform f mu'}
  : Uniform (Compose g f) (Compose mu' mu).
Proof.
intros e u v xi. unfold Compose.
apply (uniform g _),(uniform f _),xi.
Qed.
Global Existing Instance uniform_compose.

Global Instance continuous_compose@{} {Eg : Continuous g} {Ef : Continuous f}
  : Continuous (Compose g f).
Proof.
intros u e.
apply (merely_destruct (continuous g (f u) e)).
intros [d E].
apply (merely_destruct (continuous f u d)).
intros [d' E'].
apply tr;exists d';intros v xi.
apply E,E',xi.
Qed.

End compositions.

Section currying.
Universe UA.
Context {A:Type@{UA} } `{Closeness A}.
Universe UB.
Context {B:Type@{UB} } `{Closeness B}.
Universe UC.
Context {C:Type@{UC} } `{Closeness C} `{!Triangular C}.

Global Instance uncurry_lipschitz (f : A -> B -> C) L1 L2
  `{!forall x, Lipschitz (f x) L1}
  `{!forall y, Lipschitz (fun x => f x y) L2}
  : Lipschitz (uncurry f) (L1 + L2).
Proof.
intros e [u1 u2] [v1 v2] [xi1 xi2]. simpl in xi1,xi2.
unfold uncurry;simpl.
assert (Hrw : (L1 + L2) * e = L1 * e + L2 * e)
by abstract (apply pos_eq;ring_tac.ring_with_nat);
rewrite Hrw;clear Hrw.
apply (triangular _ (f u1 v2)).
- apply (lipschitz _ L1). trivial.
- apply (lipschitz (fun u => f u v2) L2). trivial.
Qed.

Lemma uncurry_uniform
  `{!Rounded A} `{!Rounded B} (f : A -> B -> C) mu mu'
  `{!forall x, Uniform (f x) mu}
  `{!forall y, Uniform (fun x => f x y) mu'}
  : Uniform (uncurry f) (fun e => meet (mu (e/2)) (mu' (e/2))).
Proof.
intros e [u1 u2] [v1 v2] [xi1 xi2].
simpl in *.
rewrite (pos_split2 e).
apply (triangular _ (f u1 v2)).
- apply (uniform (f u1) _).
  eapply rounded_le.
  + exact xi2.
  + apply meet_lb_l.
- apply (uniform (fun v => f v v2) _).
  eapply rounded_le.
  + exact xi1.
  + apply meet_lb_r.
Qed.

End currying.

Section pair.
Universe UA.
Context {A:Type@{UA} } `{Closeness A} `{forall e, Reflexive (close (A:=A) e)}.
Universe UB.
Context {B:Type@{UB} } `{Closeness B} `{forall e, Reflexive (close (A:=B) e)}.

Global Instance pair_nonexpanding_l : forall x, NonExpanding (@pair A B x).
Proof.
intros x e u v xi;split;simpl.
- reflexivity.
- exact xi.
Qed.

Global Instance pair_nonexpanding_r : forall y,
  NonExpanding (fun x => @pair A B x y).
Proof.
intros x e u v xi;split;simpl.
- exact xi.
- reflexivity.
Qed.

Global Instance fst_nonexpanding : NonExpanding (@fst A B).
Proof.
intros e u v xi;apply xi.
Qed.

Global Instance snd_nonexpanding : NonExpanding (@snd A B).
Proof.
intros e u v xi;apply xi.
Qed.

End pair.

Section prod_equiv.
Universe UA.
Context {A:Type@{UA} } `{Closeness A}.
Universe UB.
Context {B:Type@{UB} } `{Closeness B}.

Global Instance equiv_prod_symm_nonexpanding
  : NonExpanding (@Prod.equiv_prod_symm A B).
Proof.
intros e u v xi;split;apply xi.
Qed.

Global Instance equiv_prod_symm_inv_nonexpanding
  : NonExpanding ((@Prod.equiv_prod_symm A B)^-1).
Proof.
intros e u v xi;split;apply xi.
Qed.

Universe UC.
Context {C:Type@{UC} } `{Closeness C}.

Global Instance equiv_prod_assoc_nonexpanding
  : NonExpanding (@Prod.equiv_prod_assoc A B C).
Proof.
intros e u v xi;repeat split;apply xi.
Qed.

Global Instance equiv_prod_assoc_inc_nonexpanding
  : NonExpanding ((@Prod.equiv_prod_assoc A B C)^-1).
Proof.
intros e u v xi;repeat split;apply xi.
Qed.

End prod_equiv.

Section map2.
Universe UA.
Context {A:Type@{UA} } `{Closeness A}.
Universe UB.
Context {B:Type@{UB} } `{Closeness B}.
Universe UC.
Context {C:Type@{UC} } `{Closeness C}.
Universe UD.
Context {D:Type@{UD} } `{Closeness D}.
Variables (f : A -> C) (g : B -> D).

Lemma map2_nonexpanding'
  `{!NonExpanding f} `{!NonExpanding g}
  : NonExpanding (map2 f g).
Proof.
intros e u v xi;split;simpl; apply (non_expanding _),xi.
Qed.

Definition map2_nonexpanding@{i} := @map2_nonexpanding'@{i i}.
Arguments map2_nonexpanding {_ _} e x y xi.
Global Existing Instance map2_nonexpanding.

Lemma map2_lipschitz' `{!Rounded C} `{!Rounded D} Lf Lg
  `{!Lipschitz f Lf} `{!Lipschitz g Lg}
  : Lipschitz (map2 f g) (join Lf Lg).
Proof.
intros e u v xi. split;simpl.
- apply rounded_le with (Lf * e).
  + apply (lipschitz _ _),xi.
  + apply (order_preserving (.* ' e)).
    apply join_ub_l.
- apply rounded_le with (Lg * e).
  + apply (lipschitz _ _),xi.
  + apply (order_preserving (.* ' e)).
    apply join_ub_r.
Qed.

(* Coq pre 8.8 produces phantom universes, see coq/coq#6483 **)
Definition map2_lipschitz@{i} := ltac:(first [exact @map2_lipschitz'@{i i i}|exact @map2_lipschitz'@{i i i i}]).
Arguments map2_lipschitz {_ _} Lf Lg {_ _} e x y xi.
Global Existing Instance map2_lipschitz.

Lemma map2_continuous' `{!Rounded A} `{!Rounded B}
  `{!Continuous f} `{!Continuous g}
  : Continuous (map2 f g).
Proof.
intros u e.
apply (merely_destruct (continuous f (fst u) e));intros [d1 E1].
apply (merely_destruct (continuous g (snd u) e));intros [d2 E2].
apply tr;exists (meet d1 d2). intros v xi.
split;simpl.
- apply E1. apply rounded_le with (meet d1 d2).
  + apply xi.
  + apply meet_lb_l.
- apply E2. apply rounded_le with (meet d1 d2).
  + apply xi.
  + apply meet_lb_r.
Qed.

(* Coq pre 8.8 produces phantom universes, see coq/coq#6483 **)
Definition map2_continuous@{i} := ltac:(first [exact @map2_continuous'@{i i i}|exact @map2_continuous'@{i i i i}]).
Arguments map2_continuous {_ _ _ _} u e.
Global Existing Instance map2_continuous.

End map2.

Section interval.
Universe UA UALE.
Context {A:Type@{UA} } {Ale : Le@{UA UALE} A}.

Definition Interval a b := sig (fun x : A => a <= x /\ x <= b).

Definition interval_proj a b : Interval a b -> A := pr1.

Context {Ameet : Meet A} {Ajoin : Join A}
  `{!LatticeOrder@{UA UALE} Ale}.

Definition Interval_restrict@{} (a b : A) (E : a <= b) : A -> Interval a b.
Proof.
intros x.
exists (join a (meet x b)).
split.
- apply join_ub_l.
- apply join_le.
  + exact E.
  + apply meet_lb_r.
Defined.

Lemma Interval_restrict_pr : forall a b E x (E': a <= x /\ x <= b),
  Interval_restrict a b E x = exist _ x E'.
Proof.
intros a b E x E'.
unfold Interval_restrict.
apply Sigma.path_sigma_hprop.
simpl. rewrite meet_l;[apply join_r|];apply E'.
Qed.

Context `{Closeness A}.

Global Instance Interval_close (a b : A) : Closeness (Interval a b)
  := fun e x y => close e (interval_proj a b x) (interval_proj a b y).
Arguments Interval_close _ _ _ _ _ /.

(* NB: for some reason this forces UALE <= UA *)
Lemma Interval_premetric@{i} `{!PreMetric@{UA i} A} a b
  : PreMetric@{UA i} (Interval a b).
Proof.
split.
- unfold close;simpl. apply _.
- intros e u. red;red. reflexivity.
- intros e u v xi;red;red;symmetry;apply xi.
- intros u v E.
  apply Sigma.path_sigma_hprop. apply separated,E.
- intros u v w e d xi1 xi2.
  red;red. apply (triangular _ (interval_proj a b v)).
  + exact xi1.
  + exact xi2.
- intros e u v. split.
  + intros xi. do 2 red in xi. apply (fst (rounded _ _ _)) in xi.
    exact xi.
  + intros E. unfold close,Interval_close in E. apply (snd (rounded _ _ _)) in E.
    exact E.
Qed.
Global Existing Instance Interval_premetric.

Global Instance interval_proj_nonexpanding (a b : A)
  : NonExpanding (interval_proj a b)
  := fun _ _ _ xi => xi.

End interval.

Section rationals.

Lemma Qclose_alt : forall e (q r : Q), close e q r <-> abs (q - r) < ' e.
Proof.
intros e q r;split.
- intros [E1 E2].
  destruct (total le 0 (q - r)) as [E|E].
  + rewrite (Qabs_of_nonneg _ E).
    trivial.
  + rewrite (Qabs_of_nonpos _ E).
    apply flip_lt_negate. rewrite involutive. trivial.
- intros E. split;[apply flip_lt_negate;rewrite involutive|];
  apply le_lt_trans with (abs (q - r));trivial.
  + apply Qabs_le_neg_raw.
  + apply Qabs_le_raw.
Qed.

Lemma Qclose_neg@{} : forall e (x y : Q), close e x y <-> close e (- x) (- y).
Proof.
intros e x y;split;intros E;apply Qclose_alt in E;apply Qclose_alt.
- rewrite <-(negate_plus_distr),Qabs_neg. trivial.
- rewrite <-(negate_plus_distr),Qabs_neg in E. trivial.
Qed.

Instance Q_close_symm@{} : forall e, Symmetric (@close Q _ e).
Proof.
red;unfold close;simpl.
intros e x y [E1 E2];split.
- apply flip_lt_negate. rewrite <-negate_swap_r,involutive.
  trivial.
- apply flip_lt_negate.
  rewrite negate_swap_r,involutive. trivial.
Qed.

Lemma Q_triangular_one@{} : forall (q r : Q)
(e : Q+) (Hqr : close e q r)
(q0 : Q) (n : Q+),
  (close n q q0 -> close (e + n) r q0).
Proof.
unfold close;simpl.
intros q r e [E1 E1'] s n [E2 E2'].
split.
- apply flip_lt_negate. rewrite negate_swap_r,!involutive.
  apply flip_lt_negate in E2.
  rewrite negate_swap_r,!involutive in E2.
  pose proof (plus_lt_compat _ _ _ _ E1' E2) as E.
  assert (Hrw : s - r = q - r + (s - q))
    by abstract ring_tac.ring_with_integers (NatPair.Z nat).
  rewrite Hrw;trivial.
- apply flip_lt_negate in E1.
  rewrite negate_swap_r,!involutive in E1.
  pose proof (plus_lt_compat _ _ _ _ E1 E2') as E.
  assert (Hrw : r - s = r - q + (q - s))
    by abstract ring_tac.ring_with_integers (NatPair.Z nat).
  rewrite Hrw;trivial.
Qed.

Instance Q_triangular@{} : Triangular Q.
Proof.
hnf. intros u v w e d E1 E2.
apply Q_triangular_one with v.
- symmetry;trivial.
- trivial.
Qed.

Lemma Qclose_separating_not_lt : forall q r : Q, (forall e, close e q r) ->
  ~ (q < r).
Proof.
intros q r E1 E2.
pose proof (E1 (Qpos_diff _ _ E2)) as E3.
apply symmetry in E3;apply Qclose_alt in E3.
unfold cast in E3;simpl in E3.
apply (irreflexivity lt (r - q)).
apply le_lt_trans with (abs (r - q));trivial.
apply Qabs_le_raw.
Qed.

Instance Qclose_separating : Separated Q.
Proof.
hnf. intros q r E1.
apply tight_apart. intros E2.
apply apart_iff_total_lt in E2. destruct E2 as [E2|E2].
- exact (Qclose_separating_not_lt _ _ E1 E2).
- refine (Qclose_separating_not_lt _ _ _ E2).
  intros;symmetry;trivial.
Qed.

Instance Qclose_rounded@{} : Rounded Q.
Proof.
intros e q r;split.
- intros E;apply Qclose_alt in E.
  pose proof (Q_average_between _ _ E) as [E1 E2].
  apply tr;simple refine (exist _ (mkQpos ((abs (q - r) + ' e) / 2) _) _).
  { apply pos_mult_compat;[|solve_propholds].
    red. apply pos_plus_le_lt_compat_r;[solve_propholds|apply Qabs_nonneg].
  }
  simpl. exists (Qpos_diff _ _ E2).
  split.
  + apply pos_eq. exact (Qpos_diff_pr _ _ E2).
  + apply Qclose_alt. exact E1.
- apply (Trunc_ind _). intros [d [d' [He xi]]].
  apply Qclose_alt;rewrite He.
  apply Qclose_alt in xi.
  apply lt_le_trans with (' d);trivial.
  apply nonneg_plus_le_compat_r. solve_propholds.
Qed.

Global Instance Q_premetric@{} : PreMetric Q.
Proof.
split;try apply _.
intros e u;apply Qclose_alt. rewrite plus_negate_r.
unfold abs. rewrite (fst (abs_sig 0).2).
- solve_propholds.
- reflexivity.
Qed.

Global Instance Qneg_nonexpanding@{} : NonExpanding ((-) : Negate Q).
Proof.
intros e x y.
apply Qclose_neg.
Defined.

Global Instance Qplus_nonexpanding_l@{} : forall s : Q, NonExpanding (+ s).
Proof.
red. unfold close,Q_close;simpl. intros s e q r E.
assert (Hrw : q + s - (r + s) = q - r)
  by abstract ring_tac.ring_with_integers (NatPair.Z nat).
rewrite Hrw;trivial.
Qed.

Global Instance Qplus_nonexpanding_r@{} : forall s : Q, NonExpanding (s +).
Proof.
red;unfold close,Q_close;simpl. intros s e q r E.
assert (Hrw : s + q - (s + r) = q - r)
  by abstract ring_tac.ring_with_integers (NatPair.Z nat).
rewrite Hrw;trivial.
Qed.

Global Instance Qabs_nonexpanding : NonExpanding (abs (A:=Q)).
Proof.
intros e q r xi.
apply Qclose_alt in xi;apply Qclose_alt.
apply le_lt_trans with (abs (q - r));trivial.
apply Qabs_triangle_alt.
Qed.

Global Instance Qmeet_nonexpanding_l : forall s : Q, NonExpanding (⊓ s).
Proof.
intros s e q r xi.
apply Qclose_alt;apply Qclose_alt in xi.
apply le_lt_trans with (abs (q - r));trivial. clear xi.
destruct (total le q s) as [E1|E1], (total le r s) as [E2|E2];
rewrite ?(meet_l _ _ E1), ?(meet_r _ _ E1), ?(meet_l _ _ E2), ?(meet_r _ _ E2).
- reflexivity.
- rewrite (Qabs_of_nonpos (q - r))
  by (apply (snd (flip_nonpos_minus _ _)); transitivity s;trivial).
  rewrite <-negate_swap_r.
  rewrite (Qabs_of_nonpos _ (snd (flip_nonpos_minus _ _) E1)).
  rewrite <-negate_swap_r.
  apply (order_preserving (+ (- q))).
  trivial.
- rewrite (Qabs_of_nonneg (q - r))
  by (apply (snd (flip_nonneg_minus _ _)); transitivity s;trivial).
  rewrite (Qabs_of_nonneg _ (snd (flip_nonneg_minus _ _) E2)).
  apply (order_preserving (+ (- r))). trivial.
- rewrite plus_negate_r,Qabs_of_nonneg by reflexivity.
  apply Qabs_nonneg.
Qed.

Global Instance Qmeet_nonexpanding_r : forall s : Q, NonExpanding (s ⊓).
Proof.
intros s e q r xi.
pose proof meet_sl_order_meet_sl.
rewrite !(commutativity s).
apply (non_expanding (fun x => meet x s)). trivial.
Qed.

Global Instance Qjoin_nonexpanding_l : forall s : Q, NonExpanding (⊔ s).
Proof.
intros s e q r xi.
apply Qclose_alt;apply Qclose_alt in xi.
apply le_lt_trans with (abs (q - r));trivial. clear xi.
destruct (total le q s) as [E1|E1], (total le r s) as [E2|E2];
rewrite ?(join_l _ _ E1), ?(join_r _ _ E1), ?(join_l _ _ E2), ?(join_r _ _ E2).
- rewrite plus_negate_r,Qabs_of_nonneg by reflexivity.
  apply Qabs_nonneg.
- rewrite (Qabs_of_nonpos (q - r))
  by (apply (snd (flip_nonpos_minus _ _)); transitivity s;trivial).
  rewrite <-negate_swap_r.
  rewrite (Qabs_of_nonpos _ (snd (flip_nonpos_minus _ _) E2)).
  rewrite <-negate_swap_r.
  apply (order_preserving (r +)).
  apply (snd (flip_le_negate _ _)). trivial.
- rewrite (Qabs_of_nonneg (q - r))
  by (apply (snd (flip_nonneg_minus _ _)); transitivity s;trivial).
  rewrite (Qabs_of_nonneg _ (snd (flip_nonneg_minus _ _) E1)).
  apply (order_preserving (q +)).
  apply (snd (flip_le_negate _ _)). trivial.
- reflexivity.
Qed.

Global Instance Qjoin_nonexpanding_r : forall s : Q, NonExpanding (s ⊔).
Proof.
intros s e q r xi.
pose proof join_sl_order_join_sl.
rewrite !(commutativity s).
apply (non_expanding (fun x => join x s)). trivial.
Qed.

Global Instance Qmult_lipschitz@{} : forall q : Q, Lipschitz (q *.) (pos_of_Q q).
Proof.
intros q e x y xi.
apply Qclose_alt.
rewrite negate_mult_distr_r,<-plus_mult_distr_l,Qabs_mult.
apply pos_mult_le_lt_compat;try split.
- apply Qabs_nonneg.
- rewrite Qabs_is_join. apply join_le.
  + apply flip_le_negate;rewrite involutive; apply Q_abs_plus_1_bounds.
  + apply Q_abs_plus_1_bounds.
- solve_propholds.
- apply Qabs_nonneg.
- apply Qclose_alt,xi.
Qed.

Global Instance Qpos_upper_close e : Closeness (Qpos_upper e)
  := fun n x y => close n x.1 y.1.
Arguments Qpos_upper_close _ _ _ _ /.

Global Instance Q_recip_lipschitz (e : Q+)
  : Lipschitz ((/) ∘ pr1 ∘ (Qpos_upper_inject e)) (/ (e * e)).
Proof.
intros n q r xi.
unfold Compose;simpl. apply Qclose_alt.
assert (PropHolds (0 < join q (' e))) as E
  by (apply lt_le_trans with (' e);[solve_propholds|apply join_ub_r]).
apply (strictly_order_reflecting ((join q (' e)) *.)).
assert (PropHolds (0 < join r (' e))) as E'
  by (apply lt_le_trans with (' e);[solve_propholds|apply join_ub_r]).
apply (strictly_order_reflecting ((join r (' e)) *.)).
set (X := join r (' e)) at 2 3.
rewrite <-(Qabs_of_nonneg (join r _)) by solve_propholds.
set (Y := join q (' e)) at 2 3.
rewrite <-(Qabs_of_nonneg (join q _)) by solve_propholds.
rewrite <-!Qabs_mult.
rewrite !(plus_mult_distr_l (Aplus:=Qplus)).
rewrite dec_recip_inverse by (apply irrefl_neq,symmetric_neq in E;trivial).
rewrite mult_1_r.
assert (Hrw :  (r ⊔ ' e) * ((q ⊔ ' e) * - / (r ⊔ ' e)) = - Y * (X / X))
  by ring_tac.ring_with_integers (NatPair.Z nat).
rewrite Hrw;clear Hrw.
rewrite dec_recip_inverse by (apply irrefl_neq,symmetric_neq in E';trivial).
rewrite mult_1_r. unfold X, Y.
eapply lt_le_trans.
- apply Qclose_alt. eapply (non_expanding (⊔ ' e)). symmetry. apply xi.
- transitivity (' (((e * e) / (e * e)) * n)).
  + rewrite pos_recip_r,Qpos_mult_1_l;reflexivity.
  + rewrite <-!Qpos_mult_assoc.
    change (' (e * (e * (/ (e * e) * n)))) with (' e * (' e * ' (/ (e * e) * n))).
    apply mult_le_compat;try solve_propholds;[apply join_ub_r|].
    apply mult_le_compat;try solve_propholds;[apply join_ub_r|].
    reflexivity.
Qed.

End rationals.

Section cauchy.
Universe UA.
Context {A : Type@{UA} } {Aclose : Closeness A}.
Context `{!PreMetric A}.

Lemma limit_unique : forall x l1 l2, IsLimit x l1 -> IsLimit x l2 -> l1 = l2.
Proof.
intros x l1 l2 E1 E2.
apply separated.
intros e. rewrite (pos_split2 e),(pos_split2 (e/2)).
apply triangular with (x (e / 2 / 2));[symmetry;apply E1|apply E2].
Qed.

Lemma equiv_through_approx0 : forall (y : Approximation A) ly, IsLimit y ly ->
  forall u e d, close e u (y d) -> close (e+d) u ly.
Proof.
intros y ly E1 u e d xi.
apply (merely_destruct ((fst (rounded _ _ _) xi))).
intros [d0 [d' [He E2]]].
pose proof (triangular _ _ _ _ _ E2 (E1 d' _)) as E3.
assert (Hrw : e + d = d0 + (d' + d));[|rewrite Hrw;trivial].
rewrite He. symmetry. apply Qpos_plus_assoc.
Qed.

Context {Alim : Lim A} `{!CauchyComplete A}.

Lemma equiv_through_approx : forall u (y : Approximation A) e d,
  close e u (y d) -> close (e+d) u (lim y).
Proof.
intros u y;apply equiv_through_approx0. apply cauchy_complete.
Qed.

Lemma equiv_lim_lim (x y : Approximation A) (e d n e' : Q+)
  : e = d + n + e' -> close e' (x d) (y n) -> close e (lim x) (lim y).
Proof.
intros He xi.
rewrite He.
assert (Hrw : d + n + e' = e' + d + n) by (apply pos_eq;ring_tac.ring_with_nat);
rewrite Hrw;clear Hrw.
apply equiv_through_approx.
symmetry. apply equiv_through_approx. symmetry;trivial.
Qed.

Lemma lim_same_distance@{} : forall (x y : Approximation A) e,
  (forall d n, close (e+d) (x n) (y n)) ->
  forall d, close (e+d) (lim x) (lim y).
Proof.
intros x y e E d.
apply equiv_lim_lim with (d/3) (d/3) (e + d/3);[|apply E].
path_via (e + 3 / 3 * d).
- rewrite pos_recip_r,Qpos_mult_1_l;trivial.
- apply pos_eq;ring_tac.ring_with_nat.
Qed.

End cauchy.

Section lipschitz_lim.
Context {A:Type} {Aclose : Closeness A} `{!PreMetric A}
  `{Bclose : Closeness B} `{!PreMetric B} {Blim : Lim B}
   `{!CauchyComplete B}.

Global Instance lipschitz_lim_lipschitz (s : Approximation (A -> B)) L
  `{!forall e, Lipschitz (s e) L} : Lipschitz (lim s) L.
Proof.
intros e x y xi.
apply rounded in xi;revert xi;apply (Trunc_ind _);intros [d [d' [E xi]]].
rewrite E,Qpos_plus_mult_distr_l.
apply lim_same_distance.
clear e d' E.
intros d' n. simpl.
apply rounded_plus.
apply (lipschitz (s n) L). trivial.
Qed.

End lipschitz_lim.

End contents.

Arguments rounded_le {_ _ A _ _} e u v _ d _.
Arguments non_expanding {A _ B _} f {_ e x y} _.
Arguments lipschitz {A _ B _} f L {_ e x y} _.
Arguments uniform {A _ B _} f mu {_} _ _ _ _.
Arguments continuous {A _ B _} f {_} _ _.

Arguments map2_nonexpanding {A _ B _ C _ D _} f g {_ _} e x y xi.
Arguments map2_lipschitz {_ _ A _ B _ C _ D _} f g {_ _} Lf Lg {_ _} e x y xi.
Arguments map2_continuous {_ _ A _ B _ C _ D _} f g {_ _ _ _} u e.

Arguments Interval_close {_ _ _} _ _ _ _ _ /.

Arguments Lim A {_}.
Arguments lim {A _ _} _.

Arguments Approximation A {_}.
Arguments Build_Approximation {A _} _ _.
Arguments approximate {A _} _ _.
Arguments approx_equiv {A _} _ _ _.

Arguments CauchyComplete A {_ _}.

Arguments arrow_lim {A B _ _ _} _ / _.


Require Import RGref.DSL.Core.
Require Export RGref.DSL.Theories.
Require Export RGref.DSL.LinearEnv.

(** * A Monad for RGref programs *)

(* TODO: Should probably be a type-class *)
Inductive splits : Set -> Set -> Set -> Prop :=
  | natsp : splits nat nat nat
  | boolsp : splits bool bool bool
  | unitsp : splits unit unit unit
  | pairsp : forall A A' A'' B B' B'',
               splits A A' A'' ->
               splits B B' B'' ->
               splits (A*B) (A'*B') (A''*B'')
  | listsp : forall A A' A'', splits A A' A'' -> splits (list A) (list A') (list A'')
  | funsp : forall (A B:Set),
               splits (forall x:A, B) (forall x:A, B) (forall x:A, B)
.
Inductive rgref (Δ:tyenv) (T:Set) (Δ':tyenv) : Type :=
  (*| mkRGR :  envlist Δ -> T -> envlist Δ' -> (heap -> heap) -> rgref Δ T Δ'.*)
  | mkRGR : (envlist Δ * heap -> T * envlist Δ' * heap) -> rgref Δ T Δ'.

(* TODO: Really bind should be doing some kind of framing on environments, a subenv type thing. *)
Definition rgref_bind {Δ Δ' Δ'':tyenv}{t t':Set} (a:rgref Δ t Δ') (b:t->rgref Δ' t' Δ'') : rgref Δ t' Δ'' :=
  match a with
    | mkRGR transA => mkRGR _ _ _
                            (fun eh => match transA eh with
                                         | (x,e',h') => match b x with
                                                          | mkRGR transB => transB (e',h')
                                                        end
                                       end)
  end.

(* TODO: To actually define this properly, bind needs to do framing and ret should use the empty env. *)
Definition rgret {Δ:tyenv}{A:Set}(a:A) : rgref Δ A Δ :=
  mkRGR Δ A Δ (fun eh => match eh with (e,h) => (a,e,h) end).

Axiom dropvar : forall {Δ} (v:var) (t:Set) (tm:tymember v t Δ), rgref Δ unit (tyrem tm).

(** The core problem with folding here is that we want the user (and automated provers!) to see the same dereference on either side of
    G's state.  But G applies to elements of A, not [R,G]>>A.  We could introduce an internal "cheat_deref" that skipped
    folding, but then the two sides aren't equal, and many automated tactics that treat !e as essentially an uninterpreted
    symbol fail because the pre and post values use different uninterpreted symbols.  Another alternative is to
    ALSO add an axiom relating the behaviors of deref and cheat_deref, but this will run into serious issues with
    polymorphism over A and [R,G]>>A.  John Major equality might handle this okay, but I haven't had much success using
    JMeq for anything yet.

    A slightly different approach would be to have a folding version of heap-specific dereference, and do the guarantee
    validity check in a context with the assumption that ∀ e, !e = h[e]>> (where h[x]>> is the folding specific-heap read).
    This still runs into some JMeq issues (e.g. ∀ x h, JMeq h[x] h[x]>>), but they might be easier to deal with.

    A less serious (easier to solve) version of this occurs with reflexivity checks on G for reads.  Still need two symbols,
    one for devs that checks reflexivity on reads, the other for metatheory proofs like satisfying G, with either an axiom
    or per-context assumption that their results are equal (eq equal, since the types are equal, unless we're also solving
    the general folding issue at the same time).

    In practice the folding shouldn't matter too much (for pure types, folding is identity), but we need to support it
    in general.  Eventually both store and write will need to take rel_fold A instances so they can use them in proofs
    and obligation statements.
*)

(** Ideally deref would have the type
<<
forall {A:Set}`{rel_fold A}{P:hpred A}{R G:hrel A}, hreflexive G -> ref A P R G -> rgfold R G.
>>
But unforunately, Coq's default type conversion procedure doesn't fully reduce the rgfold instance,
which in most cases is reduced naturally by
<<
cbv iota delta beta
>>
But that reduction is stronger than default conversion (at least in 8.3... still building 8.4).
*)
Axiom mderef : forall {A:Set}{B:Set}{P:hpred A}{R G:hrel A}`{readable_at A R G}, hreflexive G -> res = B -> ref A P R G -> forall {E}, rgref E B E.
(*Axiom deref : forall {A:Set}{P:hpred A}{R G:hrel A}, ref A P R G -> A.*)
Notation "! e" := (mderef _ _ e) (at level 30). (* with reflexivity, add an _ in there *)

(* This axiom asserts that all folds that produce the same result type operate equally on
   the underlying values. This is fragile if a developer specifies multiple instances for
   folding the same type.  This is a weaker version of a more general axiom that
   the relationship between the results of folds of different result types depends on the
   relationship between results of the fold members of the instances when applied to the
   same value.  This version is really only useful for equating identity folds with
   the identity meta_fold instance results. *)
Axiom mderef_conversion : forall (A B:Set) P R G RA1 RA2 rf1 rf2 fe1 fe2,
                         @mderef A B P R G RA1 rf1 fe1 = @mderef A B P R G RA2 rf2 fe2.

(** TODO: Fix store to work properly with the linear environment. *)
Program Definition asB T R G B `{readable_at T R G} (pf:res = B) (b:res) : B.
intros. rewrite pf in b. exact b. Defined.

Program Axiom store : forall {Δ:tyenv}{A:Set}{P R G}`{readable_at A R G}`{res=A}`{hreflexive G}
                             (x:ref{A|P}[R,G])(e:A)
                             (guar:(forall (h:heap),
                                      P (h[x]) h -> G (h[x]) e h (heap_write x e h)))
                             (pres:(forall h, P (h[x]) h -> P e (heap_write x e h))),
                                      rgref Δ unit Δ.
Notation "[ x ]:= e" := (@store _ _ _ _ _ _ _ _ x e _ _) (at level 70).

(*Program Axiom write' : forall {Δ:tyenv}{A:Set}`{rel_fold A}{P R G}`{hreflexive G}(x:ref{A|P}[R,G])(e:A)
                      (meta_x_deref:A) (meta_e_fold:A)
                      (** These meta args are notationally expanded x and e using the identity relation folding *)
                 (*{guar:forall h, G (!x) e h (heap_write x e h)} *)
                 {guar:forall h, (forall A (fa:rel_fold A), fa = meta_fold) -> G (meta_x_deref) e h (heap_write x e h)}
                 (** temporarily not using meta_e_fold... the cases where I needed the "nop" behavior are once where the types are actually equal *)
                 {pres:(forall h, P meta_x_deref h -> P meta_e_fold (heap_write x meta_e_fold h))}
                 , rgref Δ unit Δ.*)
(** Notation "[ x ]:= e" := (@write' _ _ _ _ _ _ _ x e ({{{!x}}}) ({{{e}}}) _ _) (at level 70).*)
(** TODO: heap writes that update the predicate.  Because of the monadic style, we'll actually
   need a new axiom and syntax support for this, to rebind the variable at the strengthened type *)

(** Interactions between pure terms and monadic terms *)
(** valueOf should be treated as roughly a more serious version of unsafePerformIO;
    it's a coreturn like the latter, but should actually never be written in user programs! *)
Definition valueOf {Δ Δ'}{A:Set} (e:envlist Δ) (h:heap) (m:rgref Δ A Δ') : A :=
  match m with
    | mkRGR f => match f (e,h) with (x,_,_) => x end
  end.
(** pureApp is essentially based on valueOf... Technically this is weaker than what's in the paper,
    since dependently-typed pure functions are allowed if the instantiation of the range type is
    closed, but right now I don't need the expressiveness and can't figure out how to properly treat the
    dependency in binding B.

    I supposed technically this makes rgref an indexed functor (in the Haskell sense), and with a
    small tweak, an applicative functor if we need it. *)
Definition pureApp {Δ Δ'}{A:Set}`{splits A A A}{B:Set} (f:A->B) (m:rgref Δ A Δ') : rgref Δ B Δ' :=
  match m with
    | mkRGR body => mkRGR _ _ _ (fun eh => match body eh with (a,e,h) => (f a, e, h) end)
  end.

(** This is just strong enough to get the race-free counter example to go through... Need to strengthen this at some point. *)
Lemma weak_pureApp_morphism :
  forall Δ Δ' τ env h (e:rgref Δ τ Δ') (sp:splits τ τ τ) (f:τ->τ) (P:τ->τ->Prop),
    (forall v:τ, P v (f v)) ->
    P (valueOf env h e) (valueOf env h (@pureApp _ _ _ sp _ f e)).
Proof.
  intros. destruct e. unfold pureApp. unfold valueOf.
  induction (p (env,h)). induction a. auto.
Qed.

(* Impure read expression (using a direct ref value) *)
Program Axiom read_imp : forall {Δ}{A B:Set}`{rel_fold A}{P R G}`{hreflexive G}`{rgfold R G = B}(x:ref{A|P}[R,G]), rgref Δ B Δ.

(* Sometimes it's useful to observe a cell to introduce a subsequent refinement *)
Axiom read_refine : forall {Γ Γ' T P R G B X}
                           `{readable_at T R G}
                           (fld : res = B)
                      (r:ref{T|P}[R,G])
                      (P' : B -> hpred T) , (** TODO: Do we need to constrain how the B is used? *)
                      (forall h b, P' (asB fld (dofold b)) b h) ->
                      (forall t, stable (P' t) R) ->
                      (forall t, (forall h, P' t (h[r]) h) ->
                                 rgref Γ X Γ') ->
                      rgref Γ X Γ'.
Notation "'observe' r 'as' x , pf 'in' P ';' m" :=
  (@read_refine _ _ _ _ _ _ _ _ _ _ r (fun x => P) _ _ (fun x pf => m))
    (at level 65).

(* Writing with an impure source expression (and direct ref value) *)
Program Axiom write_imp_exp : forall {Δ Δ'}{A:Set}{P R G}`{readable_at A R G}`{hreflexive G}(x:ref{A|P}[R,G])(e:rgref Δ A Δ')
(* TODO: These Δs are ordered wrong...*)(meta_x:rgref Δ A Δ') (meta_e:rgref Δ A Δ')
                              {guar:forall h env, G (valueOf env h meta_x) (valueOf env h e) h (heap_write x (valueOf env h e) h)}
                              {pres:(forall h env, P (valueOf env h meta_x) h -> P (valueOf env h meta_e) (heap_write x (valueOf env h meta_e) h))}
                              , rgref Δ unit Δ'.
Notation "[[ x ]]:= e" := (@write_imp_exp _ _ _ _ _ _ _ _ x e ({{{read_imp x}}}) ({{{e}}}) _ _) (at level 70).

Axiom alloc : forall {Δ}{T:Set}{RT:ImmediateReachability T}{CT:Containment T}
                     P R G {FT:readable_at T R G} (e:T),
                stable P R ->        (* predicate is stable *)
                (forall h, P e h) -> (* predicate is true *)
                precise_pred P ->    (* P precise *)
                precise_rel R ->     (* R precise *)
                precise_rel G ->     (* G precise *)
                G ⊆ R ->             (* self-splitting *)
                rgref Δ (ref{T|P}[R,G]) Δ.
Notation "'Alloc' e" := (alloc _ _ _ e _ _ _ _ _ _) (at level 70).

(** Sometimes it is useful to know explicitly that some other reference from before allocation is
    not equal to the fresh allocation *)
Axiom allocne : forall {Δ}{T:Set}{RT:ImmediateReachability T}{CT:Containment T}
                     P R G {FT:readable_at T R G} (e:T),
                stable P R ->        (* predicate is stable *)
                (forall h, P e h) -> (* predicate is true *)
                precise_pred P ->    (* P precise *)
                precise_rel R ->     (* R precise *)
                precise_rel G ->     (* G precise *)
                G ⊆ R ->             (* self-splitting *)
                forall {A' P' G' R'} (old : ref{A'|P'}[R',G']),
                rgref Δ (sigT (fun (r:(ref{T|P}[R,G])) => (~(r ≡ old))) ) Δ.
Notation "'AllocNE' e r" := (allocne _ _ _ e _ _ _ _ _ _ r) (at level 65).

(** Sometimes it is useful to refine P to give equality with the allocated value, which
    propagates assumptions and equalities across "statements." *)
Axiom alloc' : forall {Δ}{T:Set}{RT:ImmediateReachability T}{CT:Containment T}
                      P R G {FT:readable_at T R G} (e:T),
                stable P R ->        (* predicate is stable *)
                (forall h, P e h) -> (* predicate is true *)
                precise_pred P ->    (* P precise *)
                precise_rel R ->     (* R precise *)
                precise_rel G ->     (* G precise *)
                G ⊆ R ->             (* self-splitting *)
                 rgref Δ (ref{T|P ⊓ (fun t=>fun h=> (locally_const R -> t=e))}[R,G]) Δ.
Notation "Alloc! e" := (alloc' _ _ _ e _ _ _ _ _ _) (at level 70).

Notation "x <- M ; N" := (rgref_bind M (fun x => N)) (at level 49, right associativity).

Axiom varalloc' : forall {Δ}{T:Set}{RT:ImmediateReachability T}{CT:Containment T}
                         P R G {FT:readable_at T R G} (v:var) (e:T),
                stable P R ->        (* predicate is stable *)
                (forall h, P e h) -> (* predicate is true *)
                precise_pred P ->    (* P precise *)
                precise_rel R ->     (* R precise *)
                precise_rel G ->     (* G precise *)
                 rgref Δ unit (v:ref{T|P ⊓ (fun t=>fun h=> (locally_const R -> t=e))}[R,G],Δ).
Notation "VarAlloc! v e" := (varalloc' _ _ _ v e _ _ _ _ _) (at level 70).

(** ** Fixpoints *)
(** Possibly non-terminating fixpoint combinators. *)
(* TODO: This is only a first cut, and doesn't allow polymorphic recursion. *)
Axiom RGFix : forall { Δ Δ' }(t t':Set),
    ((t -> rgref Δ t' Δ') -> (t -> rgref Δ t' Δ')) -> t -> rgref Δ t' Δ'.
Axiom RGFix2 : forall { Δ Δ' }(t t2 t':Set),
    ((t -> t2 -> rgref Δ t' Δ') -> (t -> t2 -> rgref Δ t' Δ')) ->
    t -> t2 -> rgref Δ t' Δ'.
Axiom RGFixT2 : forall { Δ Δ' }(t t2:Type) (t':Set),
    ((t -> t2 -> rgref Δ t' Δ') -> (t -> t2 -> rgref Δ t' Δ')) ->
    t -> t2 -> rgref Δ t' Δ'.
Axiom RGFix3 : forall { Δ Δ' }(t t2 t3 t':Set),
    ((t -> t2 -> t3 -> rgref Δ t' Δ') -> (t -> t2 -> t3 -> rgref Δ t' Δ')) ->
    t -> t2 -> t3 -> rgref Δ t' Δ'.
Axiom RGFix4 : forall { Δ Δ' }(t t2 t3 t4 t':Set),
    ((t -> t2 -> t3 -> t4 -> rgref Δ t' Δ') -> (t -> t2 -> t3 -> t4 -> rgref Δ t' Δ')) ->
    t -> t2 -> t3 -> t4 -> rgref Δ t' Δ'.

(** *** Fixpoint definitional axioms *)
Axiom RGFix_unfold : forall {Γ Γ'}(t t':Set)(f:(t -> rgref Γ t' Γ') -> (t -> rgref Γ t' Γ')),
                       RGFix t t' f = f (RGFix t t' f).
Axiom RGFix2_unfold : forall {Γ Γ'}(t t2 t':Set)(f:(t -> t2 -> rgref Γ t' Γ') -> (t -> t2 -> rgref Γ t' Γ')),
                       RGFix2 t t2 t' f = f (RGFix2 t t2 t' f).


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_rfn_sel_nom_reduce :
  forall T1 x1 L1 Ts1 T', T1 = (t_rfn_sel x1 L1 Ts1 T') ->
                     forall T2 L2 t2 T2', T2 = t_nom L2 t2 T2' ->
                                     subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


(** * Preliminaries FOL*  *)

(** ** Syntax of FOL* **)

From FOL Require Export unscoped Terms.

Section fix_sig.

Context {Sigma : Signature}.

Inductive form  : Type :=
  | Fal : form
  | Pred : forall (P : Preds), Vector.t term (pred_ar P) -> form
  | Impl : form  -> form  -> form
  | All : form  -> form.

Definition congr_Fal  : Fal  = Fal  :=
  eq_refl.

Definition congr_Pred { P : Preds }  { s0 : Vector.t term (pred_ar P) } { t0 : Vector.t term (pred_ar P) } (H1 : s0 = t0) : Pred  P s0 = Pred  P t0 :=
  (eq_trans) (eq_refl) ((ap) (fun x => Pred  P x) H1).

Definition congr_Impl  { s0 : form  } { s1 : form  } { t0 : form  } { t1 : form  } (H1 : s0 = t0) (H2 : s1 = t1) : Impl  s0 s1 = Impl  t0 t1 :=
  (eq_trans) ((eq_trans) (eq_refl) ((ap) (fun x => Impl  x (_)) H1)) ((ap) (fun x => Impl  (_) x) H2).

Definition congr_All  { s0 : form  } { t0 : form  } (H1 : s0 = t0) : All  s0 = All  t0 :=
  (eq_trans) (eq_refl) ((ap) (fun x => All  x) H1).

Fixpoint subst_form   (sigmaterm : (fin)  -> term ) (s : form ) : _ :=
    match s with
    | Fal   => Fal
    | Pred  P s0 => Pred  P ((Vector.map (subst_term sigmaterm)) s0)
    | Impl  s0 s1 => Impl  ((subst_form sigmaterm) s0) ((subst_form sigmaterm) s1)
    | All  s0 => All  ((subst_form (up_term_term sigmaterm)) s0)
    end.

Fixpoint idSubst_form  (sigmaterm : (fin)  -> term ) (Eqterm : forall x, sigmaterm x = (var_term ) x) (s : form ) : subst_form sigmaterm s = s :=
    match s with
    | Fal   => congr_Fal
    | Pred  P s0 => congr_Pred ((vec_id (idSubst_term sigmaterm Eqterm)) s0)
    | Impl  s0 s1 => congr_Impl ((idSubst_form sigmaterm Eqterm) s0) ((idSubst_form sigmaterm Eqterm) s1)
    | All  s0 => congr_All ((idSubst_form (up_term_term sigmaterm) (upId_term_term (_) Eqterm)) s0)
    end.

Fixpoint ext_form   (sigmaterm : (fin)  -> term ) (tauterm : (fin)  -> term ) (Eqterm : forall x, sigmaterm x = tauterm x) (s : form ) : subst_form sigmaterm s = subst_form tauterm s :=
    match s with
    | Fal   => congr_Fal
    | Pred  P s0 => congr_Pred ((vec_ext (ext_term sigmaterm tauterm Eqterm)) s0)
    | Impl  s0 s1 => congr_Impl ((ext_form sigmaterm tauterm Eqterm) s0) ((ext_form sigmaterm tauterm Eqterm) s1)
    | All  s0 => congr_All ((ext_form (up_term_term sigmaterm) (up_term_term tauterm) (upExt_term_term (_) (_) Eqterm)) s0)
    end.

Fixpoint compSubstSubst_form    (sigmaterm : (fin)  -> term ) (tauterm : (fin)  -> term ) (thetaterm : (fin)  -> term ) (Eqterm : forall x, ((funcomp) (subst_term tauterm) sigmaterm) x = thetaterm x) (s : form ) : subst_form tauterm (subst_form sigmaterm s) = subst_form thetaterm s :=
    match s with
    | Fal   => congr_Fal
    | Pred  P s0 => congr_Pred ((vec_comp (compSubstSubst_term sigmaterm tauterm thetaterm Eqterm)) s0)
    | Impl  s0 s1 => congr_Impl ((compSubstSubst_form sigmaterm tauterm thetaterm Eqterm) s0) ((compSubstSubst_form sigmaterm tauterm thetaterm Eqterm) s1)
    | All  s0 => congr_All ((compSubstSubst_form (up_term_term sigmaterm) (up_term_term tauterm) (up_term_term thetaterm) (up_subst_subst_term_term (_) (_) (_) Eqterm)) s0)
    end.

Lemma instId_form  : subst_form (var_term ) = (@id) (form ) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_form (var_term ) (fun n => eq_refl) (((@id) (form )) x))). Qed.

Lemma compComp_form    (sigmaterm : (fin)  -> term ) (tauterm : (fin)  -> term ) (s : form ) : subst_form tauterm (subst_form sigmaterm s) = subst_form ((funcomp) (subst_term tauterm) sigmaterm) s .
Proof. exact (compSubstSubst_form sigmaterm tauterm (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_form    (sigmaterm : (fin)  -> term ) (tauterm : (fin)  -> term ) : (funcomp) (subst_form tauterm) (subst_form sigmaterm) = subst_form ((funcomp) (subst_term tauterm) sigmaterm) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_form sigmaterm tauterm n)). Qed.

End fix_sig.

Instance Subst_term (Sigma : Signature)   : Subst1 ((fin)  -> term ) (term ) (term ) := @subst_term Sigma.

Instance Subst_form (Sigma : Signature)   : Subst1 ((fin)  -> term ) (form ) (form ) := @subst_form Sigma.

Instance VarInstance_term (Sigma : Signature) : Var ((fin) ) (term ) := @var_term Sigma.

Notation "x '__term'" := (var_term x) (at level 5, format "x __term") : subst_scope.

Notation "x '__term'" := (@ids (_) (_) VarInstance_term x) (at level 5, only printing, format "x __term") : subst_scope.

Notation "'var'" := (var_term) (only printing, at level 1) : subst_scope.

Class Up_term X Y := up_term : X -> Y.

Notation "↑__term" := (up_term) (only printing) : subst_scope.

Notation "↑__term" := (up_term_term) (only printing) : subst_scope.

Instance Up_term_term (Sigma : Signature)   : Up_term (_) (_) := @up_term_term Sigma.

Notation "s [ sigmaterm ]" := (subst_term sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_term sigmaterm) (at level 0, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form sigmaterm) (at level 0, left associativity, only printing) : fscope.

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  Subst_term,  Subst_form,  VarInstance_term.

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  Subst_term,  Subst_form,  VarInstance_term in *.

Ltac asimpl' := repeat first [progress rewrite ?instId_term| progress rewrite ?term| progress rewrite ?compComp_term| progress rewrite ?compComp'_term| progress rewrite ?instId_form| progress rewrite ?form| progress rewrite ?compComp_form| progress rewrite ?compComp'_form| progress rewrite ?varL_term| progress (unfold up_ren, up_term_term)| progress (cbn [subst_term subst_form])| fsimpl].

Ltac asimpl := repeat try unfold_funcomp; auto_unfold in *; asimpl'; repeat try unfold_funcomp.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case (asimpl; cbn; eauto).

Tactic Notation "asimpl" "in" "*" := auto_unfold in *; repeat first [progress rewrite ?instId_term in *| progress rewrite ?term in *| progress rewrite ?compComp_term in *| progress rewrite ?compComp'_term in *| progress rewrite ?instId_form in *| progress rewrite ?form in *| progress rewrite ?compComp_form in *| progress rewrite ?compComp'_form in *| progress rewrite ?varL_term in *| progress (unfold up_ren, up_term_term)| progress (cbn [subst_term subst_form] in *)| fsimpl in *].

Ltac comp := repeat (progress (cbn in *; autounfold in *; asimpl in *)).
Hint Unfold idsRen.


(* Check forward dependencies *)

Check
  (fun (P : nat -> Prop) Q (A : P 0 -> Q) (B : forall n : nat, P (S n) -> Q)
     x =>
   match x return Q with
   | exist _ O H => A H
   | exist _ (S n) H => B n H
   end).

(* Check dependencies in anonymous arguments (from FTA/listn.v) *)

Inductive listn (A : Set) : nat -> Set :=
  | niln : listn A 0
  | consn : forall (a : A) (n : nat), listn A n -> listn A (S n).

Section Folding.
Variable B C : Set.
Variable g : B -> C -> C.
Variable c : C.

Fixpoint foldrn (n : nat) (bs : listn B n) {struct bs} : C :=
  match bs with
  | niln _ => c
  | consn _ b _ tl => g b (foldrn _ tl)
  end.
End Folding.

(** Testing post-processing of nested dependencies *)

Check fun x:{x|x=0}*nat+nat => match x with
      | inl ((exist _ 0 eq_refl),0) => None
      | _ => Some 0
      end.

Check fun x:{_:{x|x=0}|True}+nat => match x with
      | inl (exist _ (exist _ 0 eq_refl) I) => None
      | _ => Some 0
      end.

Check fun x:{_:{x|x=0}|True}+nat => match x with
      | inl (exist _ (exist _ 0 eq_refl) I) => None
      | _ => Some 0
      end.

Check fun x:{_:{x|x=0}|True}+nat => match x return option nat with
      | inl (exist _ (exist _ 0 eq_refl) I) => None
      | _ => Some 0
      end.

  (* the next two examples were failing from r14703 (Nov 22 2011) to r14732 *)
  (* due to a bug in dependencies postprocessing (revealed by CoLoR) *)

Check fun x:{x:nat*nat|fst x = 0 & True} => match x return option nat with
      | exist2 _ _ (x,y) eq_refl I => None
      end.

Check fun x:{_:{x:nat*nat|fst x = 0 & True}|True}+nat => match x return option nat with
      | inl (exist _ (exist2 _ _ (x,y) eq_refl I) I) => None
      | _ => Some 0
      end.

(* -------------------------------------------------------------------- *)
(*   Example to test patterns matching on dependent families            *)
(* This exemple extracted from the developement done by Nacira Chabane  *)
(* (equipe Paris 6)                                                     *)
(* -------------------------------------------------------------------- *)

Require Import Prelude.
Require Import Logic_Type.

Section Orderings.
   Variable U : Type.

   Definition Relation := U -> U -> Prop.

   Variable R : Relation.

   Definition Reflexive : Prop := forall x : U, R x x.

   Definition Transitive : Prop := forall x y z : U, R x y -> R y z -> R x z.

   Definition Symmetric : Prop := forall x y : U, R x y -> R y x.

   Definition Antisymmetric : Prop := forall x y : U, R x y -> R y x -> x = y.

   Definition contains (R R' : Relation) : Prop :=
     forall x y : U, R' x y -> R x y.
  Definition same_relation (R R' : Relation) : Prop :=
    contains R R' /\ contains R' R.
Inductive Equivalence : Prop :=
    Build_Equivalence : Reflexive -> Transitive -> Symmetric -> Equivalence.

   Inductive PER : Prop :=
       Build_PER : Symmetric -> Transitive -> PER.

End Orderings.

(***** Setoid  *******)

Inductive Setoid : Type :=
    Build_Setoid :
      forall (S : Type) (R : Relation S), Equivalence _ R -> Setoid.

Definition elem (A : Setoid) := let (S, R, e) := A in S.

Definition equal (A : Setoid) :=
  let (S, R, e) as s return (Relation (elem s)) := A in R.

Axiom prf_equiv : forall A : Setoid, Equivalence (elem A) (equal A).
Axiom prf_refl : forall A : Setoid, Reflexive (elem A) (equal A).
Axiom prf_sym : forall A : Setoid, Symmetric (elem A) (equal A).
Axiom prf_trans : forall A : Setoid, Transitive (elem A) (equal A).

Section Maps.
Variable A B : Setoid.

Definition Map_law (f : elem A -> elem B) :=
  forall x y : elem A, equal _ x y -> equal _ (f x) (f y).

Inductive Map : Type :=
    Build_Map : forall (f : elem A -> elem B) (p : Map_law f), Map.

Definition explicit_ap (m : Map) :=
  match m return (elem A -> elem B) with
  | Build_Map f p => f
  end.

Axiom pres : forall m : Map, Map_law (explicit_ap m).

Definition ext (f g : Map) :=
  forall x : elem A, equal _ (explicit_ap f x) (explicit_ap g x).

Axiom Equiv_map_eq : Equivalence Map ext.

Definition Map_setoid := Build_Setoid Map ext Equiv_map_eq.

End Maps.

Notation ap := (explicit_ap _ _).

(* <Warning> : Grammar is replaced by Notation *)

Definition ap2 (A B C : Setoid) (f : elem (Map_setoid A (Map_setoid B C)))
  (a : elem A) := ap (ap f a).

(*****    posint     ******)

Inductive posint : Type :=
  | Z : posint
  | Suc : posint -> posint.

Axiom
  f_equal : forall (A B : Type) (f : A -> B) (x y : A), x = y -> f x = f y.
Axiom eq_Suc : forall n m : posint, n = m -> Suc n = Suc m.

(* The predecessor function *)

Definition pred (n : posint) : posint :=
  match n return posint with
  | Z => (* Z *)  Z
      (* Suc u *)
  | Suc u => u
  end.

Axiom pred_Sucn : forall m : posint, m = pred (Suc m).
Axiom eq_add_Suc : forall n m : posint, Suc n = Suc m -> n = m.
Axiom not_eq_Suc : forall n m : posint, n <> m -> Suc n <> Suc m.

Definition IsSuc (n : posint) : Prop :=
  match n return Prop with
  | Z => (* Z *)  False
      (* Suc p *)
  | Suc p => True
  end.
Definition IsZero (n : posint) : Prop :=
  match n with
  | Z => True
  | Suc _ => False
  end.

Axiom Z_Suc : forall n : posint, Z <> Suc n.
Axiom Suc_Z : forall n : posint, Suc n <> Z.
Axiom n_Sucn : forall n : posint, n <> Suc n.
Axiom Sucn_n : forall n : posint, Suc n <> n.
Axiom eqT_symt : forall a b : posint, a <> b -> b <> a.

(*******  Dsetoid *****)

Definition Decidable (A : Type) (R : Relation A) :=
  forall x y : A, R x y \/ ~ R x y.

Record DSetoid : Type :=
  {Set_of : Setoid; prf_decid : Decidable (elem Set_of) (equal Set_of)}.

(* example de Dsetoide d'entiers *)

Axiom eqT_equiv : Equivalence posint (eq (A:=posint)).
Axiom Eq_posint_deci : Decidable posint (eq (A:=posint)).

(* Dsetoide des posint*)

Definition Set_of_posint := Build_Setoid posint (eq (A:=posint)) eqT_equiv.

Definition Dposint := Build_DSetoid Set_of_posint Eq_posint_deci.

(**************************************)

(* Definition des signatures *)
(* une signature est un ensemble d'operateurs muni
 de l'arite de chaque operateur *)

Module Sig.

Record Signature : Type :=
  {Sigma : DSetoid; Arity : Map (Set_of Sigma) (Set_of Dposint)}.

Variable S : Signature.

Variable Var : DSetoid.

Inductive TERM : Type :=
  | var : elem (Set_of Var) -> TERM
  | oper :
      forall op : elem (Set_of (Sigma S)), LTERM (ap (Arity S) op) -> TERM
with LTERM : posint -> Type :=
  | nil : LTERM Z
  | cons : TERM -> forall n : posint, LTERM n -> LTERM (Suc n).

(* -------------------------------------------------------------------- *)
(*                  Examples                                            *)
(* -------------------------------------------------------------------- *)

Parameter t1 t2 : TERM.

Type
  match t1, t2 with
  | var v1, var v2 => True
  | oper op1 l1, oper op2 l2 => False
  | _, _ => False
  end.

Parameter n2 : posint.
Parameter l1 l2 : LTERM n2.

Type
  match l1, l2 with
  | nil, nil => True
  | cons v m y, nil => False
  | _, _ => False
  end.

Type
  match l1, l2 with
  | nil, nil => True
  | cons u n x, cons v m y => False
  | _, _ => False
  end.

Module Type Version1.

Definition equalT (t1 t2 : TERM) : Prop :=
  match t1, t2 with
  | var v1, var v2 => True
  | oper op1 l1, oper op2 l2 => False
  | _, _ => False
  end.

Definition EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
  (l2 : LTERM n2) : Prop :=
  match l1, l2 with
  | nil, nil => True
  | cons t1 n1' l1', cons t2 n2' l2' => False
  | _, _ => False
  end.

End Version1.

(* ------------------------------------------------------------------*)
(*          Initial exemple (without patterns)                       *)
(*-------------------------------------------------------------------*)

Module Version2.

Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
  match t1 return (TERM -> Prop) with
  | var v1 =>
      (*var*)
      fun t2 : TERM =>
      match t2 return Prop with
      | var v2 =>
          (*var*) equal _ v1 v2
          (*oper*)
      | oper op2 _ => False
      end
      (*oper*)
  | oper op1 l1 =>
      fun t2 : TERM =>
      match t2 return Prop with
      | var v2 =>
          (*var*) False
          (*oper*)
      | oper op2 l2 =>
          equal _ op1 op2 /\
          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
      end
  end

 with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} :
 forall n2 : posint, LTERM n2 -> Prop :=
  match l1 in (LTERM _) return (forall n2 : posint, LTERM n2 -> Prop) with
  | nil =>
      (*nil*)
      fun (n2 : posint) (l2 : LTERM n2) =>
      match l2 in (LTERM _) return Prop with
      | nil =>
          (*nil*) True
          (*cons*)
      | cons t2 n2' l2' => False
      end
      (*cons*)
  | cons t1 n1' l1' =>
      fun (n2 : posint) (l2 : LTERM n2) =>
      match l2 in (LTERM _) return Prop with
      | nil =>
          (*nil*)  False
          (*cons*)
      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
      end
  end.

End Version2.

(* ---------------------------------------------------------------- *)
(*                Version with simple patterns                      *)
(* ---------------------------------------------------------------- *)

Module Version3.

Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
  match t1 with
  | var v1 =>
      fun t2 : TERM =>
      match t2 with
      | var v2 => equal _ v1 v2
      | oper op2 _ => False
      end
  | oper op1 l1 =>
      fun t2 : TERM =>
      match t2 with
      | var _ => False
      | oper op2 l2 =>
          equal _ op1 op2 /\
          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
      end
  end

 with EqListT (n1 : posint) (l1 : LTERM n1) {struct l1} :
 forall n2 : posint, LTERM n2 -> Prop :=
  match l1 return (forall n2 : posint, LTERM n2 -> Prop) with
  | nil =>
      fun (n2 : posint) (l2 : LTERM n2) =>
      match l2 with
      | nil => True
      | _ => False
      end
  | cons t1 n1' l1' =>
      fun (n2 : posint) (l2 : LTERM n2) =>
      match l2 with
      | nil => False
      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
      end
  end.

End Version3.

Module Version4.

Fixpoint equalT (t1 : TERM) : TERM -> Prop :=
  match t1 with
  | var v1 =>
      fun t2 : TERM =>
      match t2 with
      | var v2 => equal _ v1 v2
      | oper op2 _ => False
      end
  | oper op1 l1 =>
      fun t2 : TERM =>
      match t2 with
      | var _ => False
      | oper op2 l2 =>
          equal _ op1 op2 /\
          EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
      end
  end

 with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
 (l2 : LTERM n2) {struct l1} : Prop :=
  match l1 with
  | nil => match l2 with
           | nil => True
           | _ => False
           end
  | cons t1 n1' l1' =>
      match l2 with
      | nil => False
      | cons t2 n2' l2' => equalT t1 t2 /\ EqListT n1' l1' n2' l2'
      end
  end.

End Version4.

(* ---------------------------------------------------------------- *)
(*                  Version with multiple patterns                  *)
(* ---------------------------------------------------------------- *)

Module Version5.

Fixpoint equalT (t1 t2 : TERM) {struct t1} : Prop :=
  match t1, t2 with
  | var v1, var v2 => equal _ v1 v2
  | oper op1 l1, oper op2 l2 =>
      equal _ op1 op2 /\ EqListT (ap (Arity S) op1) l1 (ap (Arity S) op2) l2
  | _, _ => False
  end

 with EqListT (n1 : posint) (l1 : LTERM n1) (n2 : posint)
 (l2 : LTERM n2) {struct l1} : Prop :=
  match l1, l2 with
  | nil, nil => True
  | cons t1 n1' l1', cons t2 n2' l2' =>
      equalT t1 t2 /\ EqListT n1' l1' n2' l2'
  | _, _ => False
  end.

End Version5.

(* ------------------------------------------------------------------ *)

End Sig.

(* Exemple soumis par Bruno *)

Definition bProp (b : bool) : Prop := if b then True else False.

Definition f0 (F : False) (ty : bool) : bProp ty :=
  match ty as _, ty return (bProp ty) with
  | true, true => I
  | _, false => F
  | _, true => I
  end.

(* Simplification of bug/wish #1671 *)

Inductive I : unit -> Type :=
| C : forall a, I a -> I tt.

(*
Definition F (l:I tt) : l = l :=
match l return l = l with
| C tt (C _ l')  => refl_equal (C tt (C _ l'))
end.

one would expect that the compilation of F (this involves
some kind of pattern-unification) would produce:
*)

Definition F (l:I tt) : l = l :=
match l return l = l with
| C tt l' => match l' return C _ l' = C _ l' with C _ l''  => refl_equal (C tt (C _ l'')) end
end.

Inductive J : nat -> Type :=
| D : forall a, J (S a) -> J a.

(*
Definition G (l:J O) : l = l :=
match l return l = l with
| D O (D 1 l')  => refl_equal (D O (D 1 l'))
| D _ _  => refl_equal _
end.

one would expect that the compilation of G (this involves inversion)
would produce:
*)

Definition G (l:J O) : l = l :=
match l return l = l with
| D 0 l'' =>
    match l'' as _l'' in J n return
      match n return forall l:J n, Prop with
      | O => fun _ => l = l
      | S p => fun l'' => D p l'' = D p l''
      end _l'' with
    | D 1 l'  => refl_equal (D O (D 1 l'))
    | _ => refl_equal _
    end
| _ => refl_equal _
end.

Fixpoint app {A} {n m} (v : listn A n) (w : listn A m) : listn A (n + m) :=
  match v with
    | niln _ => w
    | consn _ a n' v' => consn _ a _ (app v' w)
  end.

(* Testing regression of bug 2106 *)

Set Implicit Arguments.
Require Import List.

Inductive nt := E.
Definition root := E.
Inductive ctor : list nt -> nt -> Type :=
 Plus : ctor (cons E (cons E nil)) E.

Inductive term : nt -> Type :=
| Term : forall s n, ctor s n -> spine s -> term n
with spine : list nt -> Type :=
| EmptySpine : spine nil
| ConsSpine : forall n s, term n -> spine s -> spine (n :: s).

Inductive step : nt -> nt -> Type :=
  | Step : forall l n r n' (c:ctor (l++n::r) n'), spine l -> spine r -> step n
n'.

Definition test (s:step E E) :=
  match s with
    | @Step nil _ (cons E nil) _ Plus l l' => true
    | _ => false
  end.

(* Testing regression of bug 2454 ("get" used not be type-checkable when
   defined with its type constraint) *)

Inductive K : nat -> Type := KC : forall (p q:nat), K p.

Definition get : K O -> nat := fun x => match x with KC p q => q end.

(* Checking correct order of substitution of realargs *)
(* (was broken from revision 14664 to 14669) *)
(* Example extracted from contrib CoLoR *)

Inductive EQ : nat -> nat -> Prop := R x y : EQ x y.

Check fun e t (d1 d2:EQ e t) =>
      match d1 in EQ e1 t1, d2 in EQ e2 t2 return
        (e1,t1) = (e2,t2) -> (e1,t1) = (e,t) -> 0=0
      with
      | R _ _, R _ _ => fun _ _ => eq_refl
      end.


(* 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                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: DivDirac.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)
From Coq Require Import ArithRing.
From Bertrand Require Export Div.
From Bertrand Require Import Summation.

(** Define a function that returns 1 if the second argument divides the
    first one, 0 otherwise*)

Definition div_dirac (p q : nat) :=
  match snd (pdiv p q) with
  | O => 1
  | _ => 0
  end.

Theorem div_dirac_prop1 :
 forall p q : nat, 0 < q -> divides q p -> div_dirac p q = 1.
Proof.
intros p q H H1; unfold div_dirac in |- *; rewrite divides_pdiv; auto.
Qed.

Theorem div_dirac_prop2 :
 forall p q : nat, 0 < q -> ~ divides q p -> div_dirac p q = 0.
Proof.
intros p q H H1; unfold div_dirac in |- *;
 generalize (not_divides_pdiv p q H H1); case (snd (pdiv p q));
 auto with arith.
intros H2; case H2; auto.
Qed.

Theorem div_dirac_div :
 forall p q : nat,
 0 < p -> 0 < q -> div p q = sum_nm 1 (pred p) (fun x => div_dirac x q).
Proof.
intros p q H H0; generalize H; clear H.
elim p; auto with arith.
intros H1; inversion H1.
intros n1; case n1.
2: intros n H H1.
2: replace (pred (S (S n))) with (S (pred (S n))); auto with arith.
2: rewrite sum_nm_f.
2: case (divides_dec q (S (S n))); intros H2.
2: rewrite div_divides_S; auto with arith.
2: rewrite H; auto with arith.
2: rewrite div_dirac_prop1; auto with arith.
2: ring.
2: rewrite div_not_divides_S; auto with arith.
2: rewrite H; auto with arith.
2: rewrite div_dirac_prop2; auto with arith.
simpl in |- *.
generalize H0; case q; simpl in |- *.
intros H1; inversion H1.
intros n2; case n2.
unfold div in |- *; unfold div_dirac in |- *; simpl in |- *; auto.
unfold div in |- *; unfold div_dirac in |- *; simpl in |- *; auto.
Qed.