Added a library for solving recursive domain equations.

lib/recdom/CBUltInst.v

+(** 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.

lib/recdom/CSetoid.v

+(** 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.

lib/recdom/Constr.v

+(** 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.