Commit 3d69aaa0 authored by Filip Sieczkowski's avatar Filip Sieczkowski

Added a library for solving recursive domain equations.

parents
This diff is collapsed.
(** This file provides the proof that CBUlt, the category of complete,
bisected, ultrametric spaces, forms an M-category. *)
Require Import MetricCore.
Require Import MetricRec.
Module CBUlt <: MCat.
Local Open Scope cat_scope.
Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances.
Definition M := cmtyp.
Instance MArr : BC_morph M := fun U V : cmtyp => cmfromType (U -n> V).
Instance MComp : BC_comp M := fun U V W => comp.
Instance MId : BC_id M := fun U => (umid _).
Instance MTermO : BC_term M := cmfromType unit.
Program Instance MTermA : BC_terminal M := fun U => n[(const tt)].
Instance Cat : BaseCat M.
Proof.
split; intros; intros n; simpl; reflexivity || exact I.
Qed.
Section Limits.
Context (T : Tower).
Definition guard := fun (σ : forall i, tow_objs T i) => forall n, tow_morphs T n (σ (S n)) == σ n.
Instance lpg : LimitPreserving guard.
Proof.
intros σ σc HG n.
rewrite !dep_chain_compl.
rewrite nonexp_continuous; apply umet_complete_ext; intros k.
simpl; apply HG.
Qed.
Definition lim_obj : cmtyp := cmfromType {σ : forall i, tow_objs T i | guard σ}.
Definition lim_proj i : lim_obj -n> tow_objs T i := MprojI i <M< inclM.
Program Definition lim_cone : Cone T := mkBaseCone T lim_obj lim_proj _.
Next Obligation.
intros [σ HG]; simpl; apply HG.
Qed.
Program Definition lim_map (C : Cone T) : (cone_t T C : cmtyp) -n> (cone_t T lim_cone : cmtyp) :=
n[(fun m => exist _ (fun i => cone_m T C i m) _)].
Next Obligation.
intros n; simpl.
assert (HT := cone_m_com T C n m); apply HT.
Qed.
Lemma AllLimits : Limit T.
Proof.
refine (mkBaseLimit T lim_cone lim_map _ _).
+ intros C n x; simpl; reflexivity.
+ intros C h HCom x n; simpl.
specialize (HCom n x); simpl in HCom.
symmetry; apply HCom.
Qed.
End Limits.
End CBUlt.
(** Basic categorical definitions. The role of objects is played by
the class [type] which is a type equipped with an equivalence
relation.
Then there are standard constructions defined using these objects
(product, exponential, initial objects and functors at the end)
and some of their properties are proved.
*)
Require Export Coq.Program.Program.
Require Export Morphisms SetoidClass SetoidTactics.
Generalizable Variables T U V W.
(* Make sure equiv is in the right scope and that it's not simplified
too soon. *)
Definition equiv `{Setoid T} := SetoidClass.equiv.
Arguments equiv {_ _} _ _ /.
Notation "'mkType' R" := (@Build_Setoid _ R _) (at level 10).
(** A morphism between two types is an actual function together with a
proof that it preserves equality. *)
Record morphism S T `{eqS : Setoid S} `{eqT : Setoid T} :=
mkMorph {
morph :> S -> T;
morph_resp : Proper (equiv ==> equiv) morph}.
Arguments mkMorph [S T eqS eqT] _ _.
Arguments morph_resp [S T eqS eqT] _ _ _ _.
Infix "-=>" := morphism (at level 45, right associativity).
Notation "'s[(' f ')]'" := (mkMorph f _).
Ltac resp_set :=
intros t1 t2 HEqt; repeat (intros ?); simpl in *; try rewrite !HEqt; reflexivity.
(** This seems just to be a package putting together all the
ingredients of [type], i.e. the carrier set, the relation and the
property that the relation is an equivalence relation. *)
Record eqType :=
{eqtyp :> Type;
eqtype : Setoid eqtyp}.
Instance eqType_proj_type {ET : eqType} : Setoid ET := eqtype _.
Definition fromType T `{eT : Setoid T} : eqType := Build_eqType T _.
Section Morphisms.
Context `{eT : Setoid T} `{eU : Setoid U} `{eV : Setoid V}.
(** The type of equivalence-preserving maps is again a type with
equivalence, defined pointwise. *)
Global Program Instance morph_type : Setoid (T -=> U) :=
mkType (fun f g => forall x, f x == g x).
Next Obligation.
clear; split.
- intros f x; reflexivity.
- intros f g HS x; symmetry; apply HS.
- intros f g h Hfg Hgh x; etransitivity; [apply Hfg | apply Hgh].
Qed.
(** The application of [morphsm] to its argument preserves equality
in both the function and the argument. *)
Global Instance equiv_morph :
Proper (equiv ==> equiv ==> equiv) (morph T U).
Proof.
intros f g HEq x y HEq'; etransitivity; [apply HEq | apply g, HEq'].
Qed.
(** Definition of composition of morphisms. Note the different
arrows, i.e., -=> and ->. *)
Program Definition mcomp (f: U -=> V) (g: T -=> U) : (T -=> V) :=
s[(f g)].
Next Obligation.
intros x y HEq; apply f, g; assumption.
Qed.
Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances.
(** Two specific morphisms, identity and constant maps. *)
Program Definition mid : T -=> T := s[(fun x => x)].
Program Definition mconst (u : U) : T -=> U := s[(const u)].
End Morphisms.
Infix "<<" := mcomp (at level 35).
Arguments mid T {eT}.
Arguments compose {_ _ _} _ _ _ /.
Section MorphConsts.
Context `{eT : Setoid T} `{eU : Setoid U} `{eV : Setoid V} `{eW : Setoid W}.
(** Composition maps equal morphism to equal morphisms. *)
Global Instance equiv_mcomp :
Proper (equiv (T := U -=> V) ==> equiv ==> equiv) mcomp.
Proof.
intros f f' HEq g g' HEq' x; simpl; rewrite HEq, HEq'; reflexivity.
Qed.
(** Composition of morphisms is associative. *)
Lemma mcomp_assoc (f: V -=> W) (g: U -=> V) (h: T -=> U) :
f << (g << h) == (f << g) << h.
Proof. intros x; reflexivity. Qed.
(** Identity is left- and right- identity for composition *)
Lemma mcomp_idR (f : U -=> V) :
f << mid _ == f.
Proof. intros x; reflexivity. Qed.
Lemma mcomp_idL (f : U -=> V) :
mid _ << f == f.
Proof. intros x; reflexivity. Qed.
(** Lift an ordinary function to a function on [type]'s. *)
Definition lift2s (f : T -> U -> V) p q : (T -=> U -=> V) :=
mkMorph (fun x => mkMorph (f x) (p x)) q.
Local Obligation Tactic := intros; resp_set || eauto with typeclass_instances.
(** Pre- and postcomposition, as equality-preserving maps *)
Program Definition precomp (f : T -=> U) : (U -=> V) -=> (T -=> V) :=
s[(fun g => g << f)].
Program Definition postcomp (f : T -=> U) : (V -=> T) -=> (V -=> U) :=
s[(fun g => f << g)].
End MorphConsts.
(*Instance Equiv_PropP : Equiv Prop := iff.
Instance type_PropP : type Prop := iff_equivalence.*)
Section SetoidProducts.
Context `{eU : Setoid U} `{eV : Setoid V}.
(** The product of two types is another type, with equality defined pointwise. *)
Global Program Instance prod_type : Setoid (U * V) :=
mkType (fun p1 p2 : U * V => (fst p1) == (fst p2) /\ (snd p1) == (snd p2)).
Next Obligation.
split.
- intros [u v]; split; reflexivity.
- intros [u1 v1] [u2 v2] [Hu Hv]; split; symmetry; assumption.
- intros [u1 v1] [u2 v2] [u3 v3] [Hu12 Hv12] [Hu23 Hv23]; split; etransitivity; eassumption.
Qed.
Global Instance prod_proper : Proper (equiv ==> equiv ==> equiv) (@pair U V).
Proof.
intros u1 u2 Hu v1 v2 Hv; split; assumption.
Qed.
Global Instance mfst_proper : Proper (equiv ==> equiv) (@fst U V).
Proof.
intros [u1 v1] [u2 v2] [Hu Hv]; assumption.
Qed.
Global Instance msnd_proper : Proper (equiv ==> equiv) (@snd U V).
Proof.
intros [u1 v1] [u2 v2] [Hu Hv]; assumption.
Qed.
Local Obligation Tactic := intros; resp_set || program_simpl.
(** The projections are in fact proper morphisms, i.e. they preserve equality. *)
Program Definition mfst : (U * V) -=> U := s[(fst)].
Program Definition msnd : (U * V) -=> V := s[(snd)].
Context `{eT : Setoid T}.
(** Tupling is also a proper morphism, i.e. respects equality. *)
Program Definition mprod (f: T -=> U) (g: T -=> V) : T -=> (U * V) :=
s[(fun t => (f t, g t))].
Next Obligation.
add_morphism_tactic; intros.
rewrite H; reflexivity.
Qed.
Lemma mprod_unique (f: T -=> U) (g: T -=> V) (h: T -=> U * V) :
mfst << h == f -> msnd << h == g -> h == mprod f g.
Proof.
intros HL HR x; split; simpl; [rewrite <- HL | rewrite <- HR]; reflexivity.
Qed.
End SetoidProducts.
Arguments mprod_unique [U eU V eV T eT f g h] _ _ _.
Section IndexedProducts.
Context {I : Type} {P : I -> eqType}.
(** Equality on the indexed product. Essentially the same as for binary products, i.e. pointwise. *)
Global Program Instance prodI_type : Setoid (forall i, P i) :=
mkType (fun p1 p2 => forall i, p1 i == p2 i).
Next Obligation.
split.
- intros X x; reflexivity.
- intros X Y HS x; symmetry; apply HS.
- intros X Y Z HPQ HQR x; etransitivity; [apply HPQ | apply HQR].
Qed.
Local Obligation Tactic := intros; resp_set || program_simpl.
(** Projection functions. *)
Program Definition mprojI (i : I) : (forall i, P i) -=> P i :=
s[(fun X => X i)].
Context `{eT : Setoid T}.
(** Tupling into the indexed products. *)
Program Definition mprodI (f : forall i, T -=> P i) : T -=> (forall i, P i) :=
s[(fun t i => f i t)].
Lemma mprod_projI (f : forall i, T -=> P i) i : mprojI i << mprodI f == f i.
Proof. intros X; reflexivity. Qed.
(** Product with the projections is an actual product. *)
Lemma mprodI_unique (f : forall i, T -=> P i) (h : T -=> forall i, P i) :
(forall i, mprojI i << h == f i) -> h == mprodI f.
Proof.
intros HEq x i; simpl; rewrite <- HEq; reflexivity.
Qed.
End IndexedProducts.
Section Exponentials.
Context `{eT : Setoid T} `{eU : Setoid U} `{eV : Setoid V} `{eW : Setoid W}.
Local Obligation Tactic := intros; resp_set || program_simpl.
(** Composition of morphism _as a morphims_. *)
Program Definition comps : (U -=> V) -=> (T -=> U) -=> T -=> V :=
lift2s (fun f g => f << g) _ _.
Program Definition muncurry (f : T -=> U -=> V) : T * U -=> V :=
s[(fun p => f (fst p) (snd p))].
Next Obligation.
add_morphism_tactic; intros [t1 u1] [t2 u2] [Ht Hu]; simpl in *.
rewrite Ht, Hu; reflexivity.
Qed.
(** Currying map, i.e. the exponential transpose. *)
Program Definition mcurry (f : T * U -=> V) : T -=> U -=> V :=
lift2s (fun t u => f (t, u)) _ _.
(** f × g, i.e. 〈 f ∘ π, g ∘ π' 〉 *)
Definition mprod_map (f : T -=> U) (g : V -=> W) := mprod (f << mfst) (g << msnd).
(** Evaluation map. *)
Program Definition meval : (T -=> U) * T -=> U :=
s[(fun p => fst p (snd p))].
Next Obligation.
add_morphism_tactic; intros [f1 t1] [f2 t2] [Hf Ht]; simpl in *.
rewrite Hf, Ht; reflexivity.
Qed.
End Exponentials.
Section Exp_props.
Context `{eT : Setoid T} `{eU : Setoid U} `{eV : Setoid V} `{eW : Setoid W}.
(** (Λ(f) × id) ; eval = f, where Λ(f) is the exponential transpose. *)
Lemma mcurry_com (f : T * U -=> V) : f == meval << (mprod_map (mcurry f) (mid _)).
Proof. intros [a b]; reflexivity. Qed.
(** Exponential transposes are unique. *)
Lemma mcurry_unique (f : T * U -=> V) h :
f == meval << (mprod_map h (mid _)) -> h == mcurry f.
Proof. intros HEq a b; simpl; rewrite HEq; reflexivity. Qed.
End Exp_props.
Program Instance unit_type : Setoid unit := mkType (fun _ _ => True).
Next Obligation.
split.
- intros _; exact I.
- intros _ _ _; exact I.
- intros _ _ _ _ _; exact I.
Qed.
(** The [unit] type is the terminal object, i.e., there's a unique
morphism from any [Setoid] to [unit] *)
Section Terminals.
Context `{eT : Setoid T}.
Definition mone_term : T -=> unit := mconst tt.
Lemma mone_term_unique (f g : T -=> unit) : f == g.
Proof.
intros x; destruct (f x); destruct (g x); reflexivity.
Qed.
End Terminals.
Inductive empty : Set :=.
Program Instance empty_type : Setoid empty := mkType (fun _ _ => False).
Next Obligation.
split; intros x; case x.
Qed.
(** The empty [type] is the initial element, i.e. there is unique a
morphism from it to any other [type]. *)
Section Initials.
Context `{eT : Setoid T}.
Program Definition mzero_init : empty -=> T := s[(fun x => match x with end)].
Next Obligation. intros x; case x; fail. Qed.
Lemma mzero_init_unique (f g : empty -=> T) : f == g.
Proof. intros x; case x. Qed.
End Initials.
(** Subsets. *)
Section Subsetoid.
Context `{eT : Setoid T} {P : T -> Prop}.
(** [type] of elements that satisfy the predicate P, i.e. a
subset. Equality is inherited from the carrier type. *)
Global Program Instance subset_type : Setoid {t : T | P t} :=
mkType (fun x y => ` x == ` y).
Next Obligation.
split.
- intros [x Hx]; simpl; reflexivity.
- intros [x Hx] [y Hy] HS; simpl in *; symmetry; assumption.
- intros [x Hx] [y Hy] [z Hz] Hxy Hyz; simpl in *; etransitivity; eassumption.
Qed.
Global Instance proj1sig_proper :
Proper (equiv (T := {t : T | P t}) ==> equiv) (@proj1_sig _ _).
Proof. intros [x Hx] [y Hy] HEq; simpl in *; assumption. Qed.
(** Inclusion from the subset to the superset is an
equality-preserving morphism. *)
Program Definition mincl : {t : T | P t} -=> T := s[(@proj1_sig _ _)].
(** If we have a morphism from B to A whose image is in the subset
determined by P, then this morphism restricts to the one into
the subset determined by P. *)
Context `{eU : Setoid U}.
Program Definition minherit (f : U -=> T) (HB : forall u, P (f u)) :
U -=> {t : T | P t} := s[(fun u => exist P (f u) (HB u))].
Next Obligation.
intros x y HEq; unfold equiv; red; simpl; rewrite HEq; reflexivity.
Qed.
(** Inclusion from subset determined by P to the superset is a monomorphism. *)
Lemma mforget_mono (f g : U -=> {t : T | P t}) :
mincl << f == mincl << g -> f == g.
Proof.
intros HEq x; simpl; rewrite (HEq x); reflexivity.
Qed.
End Subsetoid.
(** Lifting of a type by adding a new distinct element.
This is used for several constructions: lookups in finite maps
return function types, for instance.
*)
Section Option.
Context `{eT : Setoid T}.
Definition opt_eq (x y : option T) :=
match x, y with
| None, None => True
| Some x, Some y => x == y
| _, _ => False
end.
Global Program Instance option_type : Setoid (option T) :=
mkType opt_eq.
Next Obligation.
split.
- intros [a |]; simpl; reflexivity.
- intros [a |] [b |] HS; simpl in *; now trivial || symmetry; assumption.
- intros [a |] [b |] [c |] Hab Hbc; simpl in *; try (exact I || contradiction); [].
etransitivity; eassumption.
Qed.
End Option.
Section OptDefs.
Context `{eT : Setoid T} `{eU : Setoid U}.
Global Instance Some_proper : Proper (equiv ==> equiv) (@Some T).
Proof. intros a b HEq; simpl; apply HEq. Qed.
Program Definition msome : T -=> option T := s[(@Some T)].
Definition optbind (f : T -> option U) (ov : option T) : option U :=
match ov with
| Some v => f v
| None => None
end.
Program Definition moptbind : (T -=> option U) -=> option T -=> option U :=
lift2s optbind _ _.
Next Obligation.
intros [v1 |] [v2 |] EQv; try (contradiction EQv || exact I); [].
unfold optbind; apply x, EQv.
Qed.
Next Obligation.
intros f1 f2 EQf [x |]; [simpl morph | exact I].
apply EQf.
Qed.
End OptDefs.
(** This module provides some additional constructions on CBUlt. These
are:
- the "1/2" functor, which divides all the distances by 1/2,
and so makes any locally non-expansive functor locally
contractive,
- an extension operation on the space Tᵏ, for k ∈ nat, as a
non-expansive morphism. *)
Require Import MetricRec.
Require Export UPred.
Section Halving.
Context (T : cmtyp).
Definition dist_halve n :=
match n with
| O => fun (_ _ : T) => True
| S n => dist n
end.
Program Definition halve_metr : metric T := mkMetr dist_halve.
Next Obligation.
destruct n; [resp_set | simpl; apply _].
Qed.
Next Obligation.
split; intros HEq.
- apply dist_refl; intros n; apply (HEq (S n)).
- intros [| n]; [exact I |]; revert n; apply dist_refl, HEq.
Qed.
Next Obligation.
intros t1 t2 HEq; destruct n; [exact I |]; symmetry; apply HEq.
Qed.
Next Obligation.
intros t1 t2 t3 HEq12 HEq23; destruct n; [exact I |]; etransitivity; [apply HEq12 | apply HEq23].
Qed.
Next Obligation.
destruct n; [exact I | apply dist_mono, H].
Qed.
Definition halveM : Mtyp := Build_Mtyp T halve_metr.
Instance halve_chain (σ : chain halveM) {σc : cchain σ} : cchain (fun n => σ (S n) : T).
Proof.
unfold cchain; intros.
apply (chain_cauchy σ σc (S n)); auto with arith.
Qed.
Definition compl_halve (σ : chain halveM) (σc : cchain σ) :=
compl (fun n => σ (S n)) (σc := halve_chain σ).
Program Definition halve_cm : cmetric halveM := mkCMetr compl_halve.
Next Obligation.
intros [| n]; [exists 0; intros; exact I |].
destruct (conv_cauchy _ (σc := halve_chain σ) n) as [m HCon].
exists (S m); intros [| i] HLe; [inversion HLe |].
apply HCon; auto with arith.
Qed.
Definition halve : cmtyp := Build_cmtyp halveM halve_cm.
End Halving.
Ltac unhalve :=
match goal with
| |- dist_halve _ ?n ?f ?g => destruct n as [| n]; [exact I | change (f = n = g) ]
| |- ?f = ?n = ?g => destruct n as [| n]; [exact I | change (f = n = g) ]
end.
(* TODO: Refactor the following so that one can make it work for PCM
instantiation without a lot of extra work. *)
Require Import CBUltInst.
Section Halving_Fun.
Context F {FA : BiFMap F} {FFun : BiFunctor F}.
Local Obligation Tactic := intros; resp_set || eauto.
Program Instance halveFMap : BiFMap (fun T1 T2 => halve (F T1 T2)) :=
fun m1 m2 m3 m4 => lift2m (lift2s (fun ars ob => fmorph (F := F) ars ob) _ _) _ _.
Next Obligation.
intros p1 p2 EQp x; simpl; rewrite EQp; reflexivity.
Qed.
Next Obligation.
intros e1 e2 EQ; simpl. unhalve.
rewrite EQ; reflexivity.
Qed.
Next Obligation.
intros p1 p2 EQ e; simpl; unhalve.
apply dist_mono in EQ.
rewrite EQ; reflexivity.
Qed.
Instance halveF : BiFunctor (fun T1 T2 => halve (F T1 T2)).
Proof.
split; intros.
+ intros T; simpl.
apply (fmorph_comp _ _ _ _ _ _ _ _ _ _ T).
+ intros T; simpl.
<