(**********************************************************************************
 * mpremet.v                                                                      *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(* Preordered complete bounded ultrametric spaces *)

(*Require Import ssreflect ssrbool eqtype.*)
Require Export PredomCore MetricCore FinmapMetric.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Open Scope C_scope.
Open Scope O_scope.
Open Scope M_scope.

(*=PreCBUmet *)
Module PreCBUmet.
  Definition respect (S:setoidType) (le:S -> S -> Prop) :=
    forall s s' t t':S, s =-= s' -> t =-= t' -> le s t -> le s' t'.
  Definition axiom (T:cmetricType) (le:T -> T -> Prop) :=
     respect le /\ forall c c' : cchain T, (forall i, le (c i) (c' i)) ->
                                   le (umet_complete c) (umet_complete c'). (*CLEAR*)
  Record mixin_of (T:cmetricType) : Type := Mixin
  { pre :> PreOrd.mixin_of T; _ : @axiom T (@Ole (PreOrd.Pack pre T)); _ : T }.

  Section ClassDef.
  Record class_of (T:Type) := Class
  { base : CMetric.class_of T; ext : mixin_of (CMetric.Pack base T) }.
  Local Coercion base: class_of >-> CMetric.class_of.
  Local Coercion ext : class_of >-> mixin_of.

  Definition base2 T (c:class_of T) : PreOrd.class_of T := ext c.
  Local Coercion base2 : class_of >-> PreOrd.class_of.

  Structure type : Type := Pack {sort : Type; _ : class_of sort; _ : Type}.

  Local Coercion sort : type >-> Sortclass.

  Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
  Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
    let: Pack T c _ := cT return K _ (class cT) in k _ c.
  Definition repack (cT:type) : _ -> Type -> type := let k T c p := p c in unpack k cT.

  Definition pack := let k T c m := Pack (@Class T c m) T in CMetric.unpack k.

  Definition ordType (cT:type) := @PreOrd.Pack cT (class cT) cT.
  Definition cmetricType (cT:type) := CMetric.Pack (class cT) cT.
  Definition metricType (cT:type) := Metric.Pack (class cT) cT.
  Definition setoidType (cT:type) := Setoid.Pack (class cT) cT.

  Definition getelem (cT:type) : cT := let: Mixin _ _ e := ext (class cT) in e.
  End ClassDef.
  Module Import Exports.
  Coercion sort : type >-> Sortclass.
  Coercion cmetricType : type >-> CMetric.type.
  Coercion base: class_of >-> CMetric.class_of.
  Coercion ext : class_of >-> mixin_of.
  Coercion base2 : class_of >-> PreOrd.class_of.
Notation PCMMixin := Mixin.
Notation pcmType := type.
Notation PCMType := pack.

Canonical Structure ordType.
Canonical Structure cmetricType.
Canonical Structure metricType.
Canonical Structure setoidType.
End Exports.

(*CLEARED*)
End PreCBUmet.
(*=End *)
Export PreCBUmet.Exports.

Lemma pcm_chain_mono (T:pcmType) (c c':cchain T) : (forall i, (c i) <= (c' i)) -> umet_complete c <= umet_complete c'.
case: T c c' => T. case => b. case => p A e.
move => T' c c' C. apply A. by apply C.
Qed.

Lemma pcm_respect (T:pcmType) (x x' y y':T) : x =-= x' -> y =-= y' -> x <= y -> x' <= y'.
move: T x x' y y'.
case => T. case. move => b. case. simpl. move => p A T' x x' y y' e e'. by apply (proj1 A).
Qed.

Definition pcm_getElem (T:pcmType) : T := PreCBUmet.getelem T.

(*=pcm_morphisms *)
Module FPCM. Section fpcm.
  Variable O1 O2 : pcmType.
  Record class_of (f:O1 -> O2) :=
    Class { base : FMet.mixin_of f; ext : FMon.mixin_of f }.
  Local Coercion base : class_of >-> FMet.mixin_of.
  Local Coercion ext : class_of >-> FMon.mixin_of.
  Definition base2 f (c:class_of f) : FMon.mixin_of f := fmonoMixin c. (*CLEAR*)
  Local Coercion base2 : class_of >-> FMon.mixin_of.

  Structure type : Type := Pack {sort : O1 -> O2; _ : class_of sort; _ : O1 -> O2}.
  Local Coercion sort : type >-> Funclass.
  Definition class (cT:type) := let: Pack _ c _ := cT return class_of cT in c.
  Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
    let: Pack T c _ := cT return K _ (class cT) in k _ c.
  Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.
  Definition pack := let k T c m := Pack (@Class T c m) T in FMet.unpack k.

  Definition fmet f : fmet O1 O2 := FMet.Pack (class f) f.
  Definition fset f : fset O1 O2 := FSet.Pack (class f) f.
  Definition fmono f : fmono _ _ := FMon.Pack (class f) f.

(*CLEARED*)
End fpcm.
Module Import Exports.
Coercion fmet : type >-> FMet.type.
Coercion fmono : type >-> FMon.type.
  Coercion base : class_of >-> FMet.mixin_of.
  Coercion ext : class_of >-> FMon.mixin_of.
  Coercion base2 : class_of >-> FMon.mixin_of.
  Coercion sort : type >-> Funclass.
Notation fpcm := FPCM.type.
Notation fpcmType := FPCM.pack.
Canonical Structure fset.
Canonical Structure fmono.
Canonical Structure fmet.
End Exports.

End FPCM.
(*=End *)
Export FPCM.Exports.

Definition mk_fpcmM (A B : pcmType) (f:fmet A B) (m:monotonic (FMet.Pack (FMet.class f) f)) := fmonoMixin m.
Definition mk_fpcm (A B : pcmType) (f:fmet A B) (m:monotonic (FMet.Pack (FMet.class f) f)) :
   fpcm A B := Eval hnf in fpcmType (mk_fpcmM m).

Lemma mcomp_mono (A B C : pcmType) (f:fpcm B C) (g:fpcm A B) : monotonic (mcomp f g).
move => x y l. simpl. apply: fmonotonic. by apply: fmonotonic.
Qed.

Definition pcomp (A B C : pcmType) (f:fpcm B C) (g:fpcm A B) : fpcm A C := Eval hnf in mk_fpcm (mcomp_mono f g).

Lemma mid_mono (A:pcmType) : monotonic (@mid A).
by [].
Qed.

Definition pid (A:pcmType) : fpcm A A := Eval hnf in mk_fpcm (@mid_mono A).

Lemma pcmMorphSetoidAxiom A B : @Setoid.axiom (fpcm A B) (fun f g => (f:metricCatType _ _) =-= g).
split ; last split.
by move => f.
by move => f g h ; apply: tset_trans.
by move => f g ; apply: tset_sym.
Qed.

Canonical Structure pcmMorphSetoidMixin A B := SetoidMixin (pcmMorphSetoidAxiom A B).
Canonical Structure pcmMorphSetoidType A B := Eval hnf in SetoidType (pcmMorphSetoidMixin A B).

Lemma pcmCatAxiom : @Category.axiom pcmType pcmMorphSetoidType (@pcomp) (@pid).
split ; last split ; last split.
by move => A B f x.
by move => A B f x.
by move => A B C D f g h x.
move => A B C f f' g g' e e' x. apply tset_trans with (y:=f (g' x)).
simpl in f. apply: (frespect f). by apply e'.
by apply e.
Qed.

Canonical Structure pcmCatMixin := CatMixin pcmCatAxiom.
Canonical Structure pcmCatType := Eval hnf in CatType pcmCatMixin.

Definition mk_fpcmX (A B : pcmType) (f:A -> B) (n:nonexpansive f) (m:monotonic f)
  : A =-> B := FPCM.Pack (FPCM.Class (FMet.Mixin n) (FMon.Mixin m)) f.

Section PROD.
Variable A B : pcmType.

Lemma prod_pcm_axiom : PreCBUmet.axiom (PreOrd.Ole (prod_ordMixin (PreCBUmet.ordType A) (PreCBUmet.ordType B))).
split.
- case => x0 x1. case => x0' x1'. case => y0 y1. case => y0' y1'. simpl. case => e0 e1. simpl in e0. simpl in e1.
  case => e2 e3. simpl in e2. simpl in e3. case => l l'.
  by split ; [apply (pcm_respect e0 e2 l) | apply (pcm_respect e1 e3 l')].
- move => c c' X. by split ; simpl ; apply pcm_chain_mono => i ; by [apply (proj1 (X i)) | apply (proj2 (X i))].
Qed.

Canonical Structure prod_pcmMixin := PCMMixin prod_pcm_axiom (pcm_getElem A,pcm_getElem B).
Canonical Structure prod_pcmType := Eval hnf in PCMType prod_pcmMixin.

Variable (C:pcmType) (f:C =-> A) (g:C =-> B).

Definition pprod_fun : C =-> prod_pcmType := Eval hnf in mk_fpcmX (Sprod_fun_ne f g) (Prod_fun_mono f g).
Definition pfst : prod_pcmType =-> A := Eval hnf in mk_fpcmX (@Sfst_ne _ _) (@fst_mon _ _).
Definition psnd : prod_pcmType =-> B := Eval hnf in mk_fpcmX (@Ssnd_ne _ _) (@snd_mon _ _).

End PROD.

Lemma pcomp_simpl (A B C : pcmType) (f:A =-> B) (g: B =-> C) x : (g << f) x = g (f x).
by [].
Qed.

Lemma pcmProdCatAxiom : CatProduct.axiom (@pfst) (@psnd) (@pprod_fun).
move => A B C f g ; split ; [split | move => h ; case => P Q].
- by move => x.
- by move => x.
move => x. specialize (P x). specialize (Q x). rewrite <- (pair_eq_compat P Q).
simpl. by case: (h x).
Qed.

Canonical Structure pcmProdCatMixin := prodCatMixin pcmProdCatAxiom.
Canonical Structure pcmProdCatType := Eval hnf in prodCatType pcmProdCatMixin.

Lemma fpcm_respect2 (M M':pcmType) n : setoid_respect2 (fun f g : fpcm M M' => (f:fmet _ _) = n = g).
split.
- move => f g h e. split => E.
  + by apply (Mrel_trans (Msym (proj2 (Mrefl (g:fmet _ _) h) e n)) E).
  + by apply (Mrel_trans ((proj2 (Mrefl (g:fmet _ _) h) e n)) E).
- move => f g h e. split => E.
  + by apply (Mrel_trans E (proj2 (Mrefl (g : fmet _ _) h) e n)).
  + by apply (Mrel_trans E ((proj2 (Mrefl (h : fmet _ _) g) (tset_sym e) n))).
Qed.

Lemma fpcm_metric_axiom A B : Metric.axiom (fun n => (fun f g : fpcm A B => (f:fmet _ _) = n = g)).
move => n x y z. split ; last split ; last split ; last split ; clear.
- by apply: Mrefl.
- by apply: Msym.
- by apply: Mrel_trans.
- by apply: Mmono.
- by apply: Mbound.
Qed.

Canonical Structure fpcm_metricMixin (A B : pcmType) := MetricMixin (@fpcm_metric_axiom A B).
Canonical Structure fpcm_metricType (A B : pcmType) := Eval hnf in MetricType (@fpcm_metricMixin A B).

Lemma pcm_morph_nonexp A B : nonexpansive (fun f:fpcm_metricType A B => (f:(A:cmetricType) -=> B)).
move => n f g e x. by apply e.
Qed.

Definition PCM_morph (A B:pcmType) : (fpcm_metricType A B) =-> ((A:cmetricType) -=> B) :=
 Eval hnf in mk_fmet (@pcm_morph_nonexp A B).
Implicit Arguments PCM_morph [A B].

Lemma lub_mono A B (c:cchain (fpcm_metricType A B)) : monotonic (umet_complete (liftc PCM_morph c)).
move => a a' L. simpl.
apply pcm_chain_mono => i. simpl. by apply: fmonotonic.
Qed.

Definition lub_pcm_morph A B (c:cchain (fpcm_metricType A B)) : fpcm_metricType A B := Eval hnf in mk_fpcm (lub_mono c).

Lemma fpcm_cmetric_axiom A B : CMetric.axiom (@lub_pcm_morph A B).
move => c. by apply (cumet_conv (liftc PCM_morph c)).
Qed.

Canonical Structure fpcm_cmetricMixin (A B : pcmType) := CMetricMixin (@fpcm_cmetric_axiom A B).
Canonical Structure fpcm_cmetricType (A B : pcmType) := Eval hnf in CMetricType (fpcm_cmetricMixin A B).

Lemma fpcm_ordAxiom A B : PreOrd.axiom (fun (x y : fpcm_cmetricType A B) => (x:fmono _ _) <= y).
move => x. split ; first by [].
by move => y z ; apply Ole_trans.
Qed.

Canonical Structure fpcm_ordMixin A B := OrdMixin (@fpcm_ordAxiom A B).
Canonical Structure fpcm_ordType A B := Eval hnf in OrdType (fpcm_ordMixin A B).

Lemma fpcm_axiom A B : @PreCBUmet.axiom (fpcm_cmetricType A B) (fun x y => x <= y).
split.
- move => x x' y y'. simpl. move => e e' l a. specialize (l a). specialize (e a). specialize (e' a). by apply (pcm_respect e e' l).
- move => c c' X. move => a. apply Ole_trans with (umet_complete (chain_app (liftc PCM_morph c) a)) ; first by [].
  apply Ole_trans with (umet_complete (chain_app (liftc PCM_morph c') a)) ; last by [].
  apply pcm_chain_mono. move => i. simpl. by apply (X i).
Qed.

Definition pconst (T T':pcmType) (x:T') : T =-> T' := Eval hnf in mk_fpcmX (@sconst_ne T T' x) (const_mon x).

Canonical Structure fpcm_pcmMixin (A B : pcmType) := PCMMixin (@fpcm_axiom A B) (pconst A (pcm_getElem B)).
Canonical Structure fpcm_pcmType (A B : pcmType) := Eval hnf in PCMType (fpcm_pcmMixin A B).

Definition ppair (A B : pcmType) (x:A) := Eval hnf in mk_fpcmX (@mpair_ne A B x) (pair1_mon x).

Lemma pcurry_ne (A B C : pcmType) (f:A * B =-> C) : nonexpansive (fun x => f << ppair _ x).
move => n x x' e y. simpl. apply: fnonexpansive. by split.
Qed.

Definition pcurryN (A B C : pcmType) (f:A * B =-> C) : metricCatType A (fpcm_pcmType B C) := Eval hnf in mk_fmet (pcurry_ne f).

Lemma pcurry_mono (A B C : pcmType) (f:A * B =-> C) : monotonic (pcurryN f).
move => x y l z. simpl. apply: fmonotonic. by split.
Qed.

Definition pcurry (A B C : pcmType) (f:A * B =-> C) : A =-> (fpcm_pcmType B C) := Eval hnf in mk_fpcm (pcurry_mono f).

Lemma spev_ne (B A:pcmType) : nonexpansive (fun (p:(fpcm_pcmType B A) * B) => mev B A (fst p : fmet_metricType B A,snd p)).
move => n. case => f x. case => f' x'. case. simpl. move => X Y.
apply Mrel_trans with (y:=f x') ; first by apply: fnonexpansive.
by apply X.
Qed.

Definition mpev B A : metricCatType ((fpcm_pcmType B A) * B)  A := Eval hnf in mk_fmet (@spev_ne B A).

Lemma mpev_mono B A : monotonic (@mpev B A).
case. simpl. move => f a. case ; simpl => f' a'.
move => X. apply Ole_trans with (y:=f' a). by apply (proj1 X a).
apply: fmonotonic. by apply (proj2 X).
Qed.

Definition pev (B A :pcmType) : ((fpcm_pcmType B A) * B) =-> A := Eval hnf in mk_fpcm (@mpev_mono B A).

Lemma pcmExpAxiom : CatExp.axiom (@pev) (@pcurry).
move => A B C f. split.
- by case => a b.
- move => h X a b. specialize (X (a,b)). by apply X.
Qed.

Canonical Structure pcmExpCatMixin := expCatMixin pcmExpAxiom.
Canonical Structure pcmExpCatType := Eval hnf in expCatType pcmExpCatMixin.

Lemma pcompMP (A B C:pcmType) : nonexpansive (fun (fg:((B -=> C) * (A -=> B))) => @pcomp A B C (fst fg) (snd fg)).
move => n. case => f g. case => f' g'. case. simpl => e e'.
move => x. apply Mrel_trans with (y:= f (g' x)) ; last by apply e. simpl.
apply: fnonexpansive. by apply e'.
Qed.

Definition pcompM (A B C:pcmType) : metricCatType ((B -=> C) * (A -=> B)) (A -=> C) := Eval hnf in mk_fmet (@pcompMP A B C).

Lemma pcomp_mono (A B C:pcmType) : monotonic (@pcompM A B C).
case => f g. case => f' g'. case. simpl. move => l l'.
move => x. simpl. apply Ole_trans with (y:=f (g' x)). apply: (fmonotonic f). by apply l'.
by apply l.
Qed.

Definition Pcomp A B C : ((B -=> C) * (A -=> B)) =-> A -=> C := Eval hnf in mk_fpcm (@pcomp_mono A B C).
Implicit Arguments Pcomp [A B C].

Lemma Pcomp_simpl A B C (f:B =-> C) (g:A =-> B) : (@Pcomp A B C (f,g)) = f << g.
by [].
Qed.

Lemma pev_simpl (D0 D1:pcmType) (f : D0 -=> D1) a : pev _ _ (f,a) = f a.
by [].
Qed.

Canonical Structure morphc_pcmType (A B:pcmType) := Eval hnf in @sub_cmetricType (morph_cmetricType A B) (@contractive _ _) (@contractive_complete A B).

Implicit Arguments morphc_pcmType [].

Definition morphc_morph A B (f:morphc_pcmType A B) := match f with exist f' _ => f' end.

Definition morphc_fun A B : (morphc_pcmType A B) -> A -> B := fun f x => match f with exist f' _ => f' x end.

Definition Fixp (M:pcmType) (f:morphc_pcmType M M) : M :=
match f with exist f c => fixp c (pcm_getElem M) end.

Lemma Fixp_nonexp (M:pcmType) : nonexpansive (fun f:morphc_pcmType M M => Fixp f).
move => n f f' e. simpl. case: f e => f c. case: f' => f' c' e. simpl. apply: fixp_ne.
by apply e.
Qed.

Definition FIXPx (M:pcmType) : (morphc_pcmType M M) =-> M := Eval hnf in mk_fmet (@Fixp_nonexp M).

Definition FIXP (M:pcmType) : (morphc_pcmType M M) =-> M := locked (FIXPx M).

Implicit Arguments FIXP [M].

Lemma FIXP_fp (M:pcmType) (f:morphc_pcmType M M) : FIXP f =-= morphc_fun f (FIXP f).
case:f => f C. simpl. unlock FIXP. simpl.
apply: fixp_eq.
Qed.

Lemma discrete_pcm_axiom T : PreCBUmet.axiom (@Ole (discrete_ordType (discrete_cmetricType T))).
split.
- move => x x' y y'. simpl. unfold tset_eq. simpl. move => e0 e1 e2. rewrite <- e0. rewrite e2. by apply e1.
- move => c c'. simpl. move => X. by apply: X.
Qed.

Definition discrete_pcmMixin T (x:T) := PCMMixin (@discrete_pcm_axiom T) x.
Definition discrete_pcmType T x := Eval hnf in @PCMType (discrete_cmetricType T) (@discrete_pcmMixin T x).

Implicit Arguments discrete_pcmType [].

Section IProd.
Variable I : Type.
Variable P : I -> pcmType.

Lemma prodI_pcmAxiom : @PreCBUmet.axiom (prodI_cmetricType P) (PreOrd.Ole (prodI_ordMixin (fun x => PreCBUmet.ordType (P x)))).
split.
- move => x x' y y' e e'. simpl. move => X i. specialize (X i). specialize (e i). specialize (e' i).
  by apply (pcm_respect e e' X).
- move => x y X i. apply Ole_trans with (y:=umet_complete (liftc (mproj P i) x)) ; first by [].
  apply Ole_trans with (y:=umet_complete (liftc (mproj P i) y)) ; last by [].
  apply pcm_chain_mono => n. by apply (X n).
Qed.

Canonical Structure prodI_pcmMixin := PCMMixin prodI_pcmAxiom (fun i => pcm_getElem (P i)).
Canonical Structure prodI_pcmType := Eval hnf in @PCMType (prodI_cmetricType P) prodI_pcmMixin.

Lemma mproj_mono i : monotonic (mproj P i:metricCatType prodI_pcmType (P i)).
move => x y e. by apply e.
Qed.

Definition pproj i : prodI_pcmType =-> P i := Eval hnf in mk_fpcm (mproj_mono i).

Variable C:pcmType.
Variable (f:forall i, C =-> P i).

Lemma mprodI_fun_mono : monotonic (mprodI_fun f:metricCatType C prodI_pcmType).
move => x y e i. by apply: (fmonotonic (f i)).
Qed.

Definition pprodI_fun : C =-> prodI_pcmType := Eval hnf in mk_fpcm mprodI_fun_mono.

End IProd.

Lemma pcmProdIAxiom : forall I:Type, @CatIProduct.axiom _ I (@prodI_pcmType I) (@pproj I) (@pprodI_fun I).
move => I A X f. split.
- by move => i x.
- move => m Z x i. simpl. specialize (Z i x). by apply Z.
Qed.

Canonical Structure pcmProdIMixin := prodICatMixin pcmProdIAxiom.
Canonical Structure pcmProdICat := Eval hnf in prodICatType pcmProdIMixin.

Lemma pprod_funS_ne (A B C:pcmType) : nonexpansive (fun (x:(A =-> B) * (A =-> C)) => pprod_fun (fst x) (snd x)).
move => n. case => f g. case => f' g'. case => e0 e1 x. simpl.
specialize (e0 x). specialize (e1 x). by split.
Qed.

Definition pprod_fun_ne (A B C:pcmType) : metricCatType ((A -=> B) * (A -=> C)) (A -=> B * C) := Eval hnf in mk_fmet (@pprod_funS_ne A B C).

Lemma pprod_funN_mono (A B C:pcmType) : monotonic (@pprod_fun_ne A B C).
case => f g. case => f' g'. case => l0 l1. move => x. simpl. specialize (l0 x). specialize (l1 x). by split.
Qed.

Definition Pprod_fun (A B C:pcmType) : ((A -=> B) * (A -=> C) =-> A -=> B * C) := Eval hnf in mk_fpcm (@pprod_funN_mono A B C).

Implicit Arguments Pprod_fun [A B C].
Implicit Arguments pprod_fun_ne [A B C].

Lemma unit_pcm_axiom : @PreCBUmet.axiom unit_cmetricType (@Ole _).
by [].
Qed.

Canonical Structure unit_pcmMixin := PCMMixin unit_pcm_axiom tt.
Canonical Structure unit_pcmType := Eval hnf in PCMType unit_pcmMixin.

Lemma pcmTerminalAxiom : CatTerminal.axiom unit_pcmType.
move => A f g.
by move => x.
Qed.

Canonical Structure pcmTerminalCatMixin := terminalCatMixin (fun X => pconst X tt) pcmTerminalAxiom.
Canonical Structure pcmTerminalCatType := Eval hnf in terminalCatType pcmTerminalCatMixin.

Lemma pid_simpl (T:pcmType) (x:T) : pid _ x = x.
by [].
Qed.

Section SubPCMetric.

Variable (M:pcmType) (P:M -> Prop) (C:@ccomplete M P).

Lemma sub_pcm_axiom : @PreCBUmet.axiom (sub_cmetricType C) (PreOrd.Ole (sub_ordMixin P)).
split.
- case => x Px. case => x' Px'. case => y Py. case => y' Py'. simpl. by apply: pcm_respect.
move => c c'; simpl => X. apply pcm_chain_mono => i. specialize (X i).
apply Ole_trans with (y:=mforget P (c i)) ; first by [].
apply Ole_trans with (y:=mforget P (c' i)) ; last by [].
move: X. case (c i) => x Px. by case: (c' i) => y Py e.
Qed.

Variable (x:M) (Px:P x).

Canonical Structure sub_pcmMixin := PreCBUmet.Mixin sub_pcm_axiom (exist (fun x => P x) x Px).
Canonical Structure sub_pcmType := Eval hnf in PCMType sub_pcmMixin.

Lemma mInheritFun_mono (N : pcmType) (f:N =-> M) (X:forall n, P (f n)) : monotonic (mInheritFun X:metricCatType N sub_pcmType).
move => y y' e. by apply:fmonotonic.
Qed.

Definition pInheritFun (N : pcmType) (f:N =-> M) (X:forall n, P (f n)) : N =-> sub_pcmType :=
  Eval hnf in mk_fpcm (@mInheritFun_mono N f X).

Lemma mforget_mono : monotonic (mforget P:metricCatType sub_pcmType M).
case => y Py ; by case.
Qed.

Definition pforget : sub_pcmType =-> M := Eval hnf in mk_fpcm mforget_mono.

Lemma pforget_mono (N:pcmType) (f:N =-> sub_pcmType) g : pforget << f =-= pforget << g -> f =-= g.
apply: mForget_mono.
Qed.

End SubPCMetric.

Require Import MetricRec.

Canonical Structure pcmECatMixin := @CmetricECatMixin _ pcmTerminalCatMixin _ _ (@Pcomp) (fun X Y Z m m' => tset_refl _).
Canonical Structure pcmECatType := Eval hnf in CmetricECatType pcmECatMixin.

Section Limit.

Variable T:Tower pcmECatType.

Definition limit_cond := (fun p : prodI_pcmType (tobjects T) =>
      forall i : nat, tmorphisms T i (pproj (tobjects T) i.+1 p) =-= pproj (tobjects T) i p).

Lemma limit_ccomplete : ccomplete limit_cond.
unfold limit_cond.
move => c IH. simpl. simpl in IH.
move => i.
have A:=nonexp_continuous (tmorphisms T i << (pproj (tobjects T) i.+1)) c.
apply (tset_trans A). clear A. rewrite -> (nonexp_continuous (pproj (tobjects T) i) c).
apply: umet_complete_ext => j. simpl. specialize (IH j i). by apply IH.
Qed.

Lemma limit_ne : limit_cond (fun n => t_nm T 0 n (pcm_getElem (tobjects T O))).
move => n. have a:= (t_nmProjection T 0 n (pcm_getElem (tobjects T O))).
simpl. simpl in a. by apply (tset_sym a).
Qed.

Definition cbult_c : Cone T.
exists (sub_pcmType limit_ccomplete limit_ne) (fun i => pproj (tobjects T) i << pforget limit_ccomplete limit_ne).
move => i. simpl. case => y Py. simpl. by apply: Py.
Defined.

Lemma t_nmLimitCond i x : limit_cond (pprodI_fun (t_nm T i) x).
move => n.
apply tset_trans with (y:=(t_nm T i n) x) ; last by [].
apply tset_trans with (y:=tmorphisms T n (t_nm T i n.+1 x)) ; first by [].
apply (tset_sym (t_nmProjection T i n x)).
Qed.

Definition cbult_cc : CoCone T.
exists (sub_pcmType limit_ccomplete limit_ne) (fun i:nat => pInheritFun limit_ccomplete limit_ne (@t_nmLimitCond i)).
move => i. simpl. move => y n. by apply (tset_sym (t_nmEmbedding T i n y)).
Defined.

Lemma comp_chain_left (A B C:pcmType) (f:B =-> C) (c:cchain (@cmetricMorph pcmECatType A B)) :
   f << (umet_complete c) =-= umet_complete (liftc (exp_fun Pcomp f) c).
by rewrite <- nonexp_continuous.
Qed.

Lemma comp_chain_right (A B C:pcmType) (f:A =-> B) (c:cchain (@cmetricMorph pcmECatType B C)) :
   (umet_complete c) << f =-= umet_complete (liftc (exp_fun (Pcomp << <|pi2,pi1|>) f) c).
by rewrite <- nonexp_continuous.
Qed.

Lemma limit_id : umet_complete (chainPE cbult_cc cbult_c) =-= Id.
refine (pforget_mono _).
apply tset_trans with (y:= pprodI_fun (fun i => (pproj (tobjects T) i << pforget limit_ccomplete limit_ne))) ;
  last by apply tset_sym ; refine (mprodI_fun_unique _) ; move => i.
apply: prodi_unique.
move => i. rewrite -> comp_assoc.
rewrite -> comp_chain_left.
rewrite -> (cut_complete_eq i _).
apply tset_trans with (y:= @umet_complete ((sub_pcmType limit_ccomplete limit_ne) -=> tobjects T i) (const_cchain (pproj _ i << pforget limit_ccomplete limit_ne))) ;
  last by rewrite -> umet_complete_const.
apply: umet_complete_ext => n.
have a:= coneCom_l cbult_c (leq_addr n i). simpl.
by apply (tset_sym a).
Qed.

Definition cbult_l : Limit T.
exists cbult_c (fun c => umet_complete (chainPE cbult_cc c)).
- move => A n.
  rewrite -> comp_chain_left.
  rewrite -> (cut_complete_eq n).
  apply tset_trans with (y:=umet_complete (const_cchain (mcone A n))) ; first by rewrite -> umet_complete_const.
  apply: umet_complete_ext. move => i. apply tset_trans with (y:=t_nm T (n + i) n << (mcone A (n + i))) ; last by [].
  have a:= @coneCom_l _ _ A (n+i) n (leq_addr i n). by rewrite <- a.
- move => A h C. apply tset_trans with (y:=umet_complete  (chainPE cbult_cc cbult_c) << h) ;
     first by rewrite -> (limit_id).
  rewrite -> comp_chain_right.
  apply: umet_complete_ext. move => i. specialize (C i).
  apply tset_trans with (y:= (mcocone cbult_cc i << mcone cbult_c i) << h) ; first by [].
  apply tset_trans with (y:=(mcocone cbult_cc i << mcone A i)) ; last by [].
  rewrite <- comp_assoc. by rewrite -> C.
Defined.

End Limit.

Section DInf.

Variable F : BiFunctor pcmECatType.

Definition F_start : unit_pcmType =-> ob F unit_pcmType unit_pcmType := pconst One (pcm_getElem (ob F One One)).

Variable C : forall A B C D : pcmType, contractive (morph F A B C D).

Definition DInf := Eval hnf in @DInf _ cbult_l F F_start C.
Definition Fold : ob F DInf DInf =-> DInf := Fold cbult_l F_start C.
Definition Unfold : DInf =-> ob F DInf DInf := Unfold cbult_l F_start C.

Lemma FU_iso : Fold << Unfold =-= Id.
by apply (FU_id cbult_l F_start C).
Qed.

Lemma UF_iso : Unfold << Fold =-= Id.
by apply (UF_id cbult_l F_start C).
Qed.

End DInf.

Lemma BiArrow_morphS_ne (A B C D:pcmType) : nonexpansive (fun (p:@prod cmetricProdCatType ((B -=> A)) ((C -=> D))) =>
    @Category.comp pcmCatType _ _ _ (exp_fun (Pcomp << <|pi2,pi1|>) (pfst _ _ p)) (exp_fun (@Pcomp A C D) (psnd _ _ p))).
move => n.
case => f g. case => f' g' [e e'] h x. simpl.
refine (Mrel_trans (e' _) _). simpl. do 2 apply: fnonexpansive. by apply e.
Qed.

Definition BiArrow_morph (A B C D:pcmType) : ((@prod cmetricProdCatType (B -=> A) (C -=> D)) =-> (((A -=> C) -=> (B -=> D)):pcmType)) := Eval hnf in mk_fmet (@BiArrow_morphS_ne A B C D).

Lemma BiArrow_morph_simpl A B C D (f:B =-> A) (g:C =-> D) h : BiArrow_morph A B C D (f,g) h = g << h << f.
by [].
Qed.

Definition BiArrow : BiFunctor pcmECatType.
exists (fun A B => (A -=> B)) (BiArrow_morph).
by move => A B C D E F f g h k x y.
by move => A B h x.
Defined.

Definition BiComp (BF:BiFunctor pcmECatType) (BG:BiFunctor pcmECatType) (BH:BiFunctor pcmECatType) : BiFunctor pcmECatType.
exists (fun D E => ob BH (ob BF E D) (ob BG D E))
 (fun D E F G => ((morph BH (ob BF F D) (ob BF G E) (ob BG D F) (ob BG E G)) <<
           (mprod_fun ((morph BF G F E D) << <| psnd _ _, pfst _ _ |>) (morph BG D E F G)))).
- move => A B C D E F f g h k. simpl. rewrite -> (morph_comp BH).
  by rewrite -> (morph_eq_compat BH (morph_comp BF k h g f) (morph_comp BG f g h k)).
- move => A B. simpl.
  rewrite -> (morph_eq_compat BH (morph_id BF B A) (morph_id BG A B)).
  by rewrite morph_id.
Defined.

Lemma comp_BF_contractive (BF:BiFunctor pcmECatType) (BG:BiFunctor pcmECatType) A B C D :
   contractive (morph BF D C B A) -> contractive (morph BG A B C D) -> contractive (morph (BiComp BF BG BiArrow) A B C D).
move => X Y n. case => x0 x1. case => y0 y1. case => e0 e1.
move => h x. simpl.
apply Mrel_trans with (y:=morph BG A B C D (x0,x1) (h (morph BF _ _ _ _ (y1,y0) x))) ; last by apply: Y.
do 2 apply: fnonexpansive. by apply: X.
Qed.

Require Import Finmap.

Section FinDom.

Variable T : compType.

Section Ord.
Variable O:pcmType.

Lemma findom_ord_axiom : PreOrd.axiom (fun (f f' : FinDom T O) => forall t m, f t = Some m -> exists m', f' t = Some m' /\ m =-= m').
move => f ; split ; clear.
- move => t m E. exists m. by split.
- move => g h X Y t m E.
  specialize (X t m E). destruct X as [m' [E' L']]. specialize (Y t m' E'). destruct Y as [m0 [E0 L0]].
  exists m0 ; split ; first by []. by apply (tset_trans L' L0).
Qed.

End Ord.

Variable M:pcmType.
Lemma findom_pcm_axiom : @PreCBUmet.axiom (findom_cmetricType T M) (PreOrd.Ole (OrdMixin (@findom_ord_axiom M))).
split.
- move => x x' y y'. simpl. move => e e' X t m E. have A:=proj2 e t. rewrite E in A.
  specialize (X t). have a:exists m', x t = Some m' /\ m =-= m'.
    rewrite (proj1 e) in A. rewrite findom_indom in A. rewrite E in A. specialize (A is_true_true).
    case: (x t) A ; last by []. move => s ee. exists s. split ; first by []. by apply (tset_sym ee).
  case: a => m' [xt ee]. specialize (X _ xt). case: X => yt [yte me]. have b:=proj2 e' t.
  rewrite -> me in ee. rewrite findom_indom in b. rewrite yte in b. specialize (b is_true_true).
  case: (y' t) b ; last by []. move => yt'. move => e0. exists yt'. split ; first by []. rewrite -> ee. by apply e0.
- move => c c'. simpl. move => X t m e. have e':umet_complete c t =-= Some m by rewrite e.
  rewrite -> findom_lub_eq in e'. have I:t \in dom (umet_complete c) by rewrite findom_indom ; rewrite e.
  rewrite dom_findom_lub in I. rewrite findom_indom in I. case: (c 1 t) I (X 1 t) ; last by [].
  move => s _ X'. specialize (X' _ (refl_equal _)). case: X' => c1' [e0 e1].
  have I:t \in dom (umet_complete c') by rewrite dom_findom_lub ; rewrite findom_indom ; rewrite e0.
  case_eq (umet_complete c' t) ; last by rewrite findom_indom in I ; move => e2 ; rewrite e2 in I.
  move => ct' e2. exists ct'. split ; first by []. apply: (proj1 (Mrefl _ _)) => n.
  case: (cumet_conv (liftc (findom_napp _ M t) c) n) => i xx. simpl in xx.
  have e3:umet_complete c' t =-= Some ct' by rewrite e2. rewrite -> findom_lub_eq in e3.
  case: (cumet_conv (liftc (findom_napp _ M t) c') n) => j yy. simpl in yy.
  specialize (xx (i+j)%N (leq_addr _ _)). specialize (yy (i+j)%N (leq_addl _ _)).
  have e4:=Mrel_trans xx (proj2 (Mrefl _ _) e' _).
  have e5:=Mrel_trans yy (proj2 (Mrefl _ _) e3 _). clear yy xx e3 e2 e e'.
  case: n e4 e5 ; first by []. move => n e2 e3. specialize (X (i+j)%N t).
  case: (c (i+j)%N t) X e2 ; last by []. move => ci X e2. specialize (X ci (refl_equal _)).
  case: X => ci' [e5 e6]. unfold Mrel in e2. simpl in e2. rewrite <- e2. rewrite -> (proj2 (Mrefl _ _) e6 _).
  rewrite e5 in e3. by apply e3.
Qed.

Canonical Structure findom_pcmMixin := PCMMixin findom_pcm_axiom (fdEmpty T M).
Canonical Structure findom_pcmType := Eval hnf in PCMType findom_pcmMixin.

End FinDom.

Section sspost.
Variable C:compType.
Variable T T':pcmType.

Lemma sspost1_ne (f:T =-> T') : nonexpansive (fun (p:findom_pcmType C T) => @post_comp C T T' (fun x => Some (f x)) p).
move => n g g' e.
case: n e ; first by []. move => n e.
split.
- simpl. do 2 rewrite dom_post_compS. by apply (proj1 e).
- move => i I I'. do 2 rewrite post_comp_simpl.  rewrite -> dom_post_compS in I,I'.
  move: (proj2 e _ I I'). rewrite -> findom_indom in I,I'.
  case: (g i) I ; last by []. case: (g' i) I' ; last by []. move => gi' _ gi _. simpl.
  move => A. apply: fnonexpansive. by apply A.
Qed.

Definition nspost1 f : metricCatType (findom_pcmType C T) (findom_pcmType C T')  := Eval hnf in mk_fmet (sspost1_ne f).

Lemma nspost1_mon (f:T =-> T') : monotonic (nspost1 f).
move => g g' l x. simpl. move => m. do 2 rewrite post_comp_simpl.
specialize (l x). case: (g x) l ; last by [].
move => gx l. specialize (l gx (refl_equal _)). simpl. case. move => e. case: l => gx' [e0 e1].
rewrite e0. simpl. exists (f gx'). split ; first by []. rewrite <- e. by apply: frespect.
Qed.

Definition spost1 f := Eval hnf in mk_fpcm (@nspost1_mon f).

Lemma spost_comp_ne : nonexpansive spost1.
case ; first by [].
move => n f f' e g. split ; first by simpl ; do 2 rewrite dom_post_compS.
move => i I I'. simpl. simpl in I,I'. rewrite -> dom_post_compS in I. clear I'.
rewrite findom_indom in I. do 2 rewrite post_comp_simpl.
case: (g i) I ; last by []. simpl. move => gi _. by apply (e gi).
Qed.

Definition ppost_comp : metricCatType (T -=> T') _ := Eval hnf in mk_fmet spost_comp_ne.

End sspost.

Section BiFunc.

Variable BF:BiFunctor pcmECatType.
Variable Ct:compType.

Definition findomBF : BiFunctor pcmECatType.
exists (fun A B => findom_pcmType Ct (ob BF A B))
       (fun A B C D => @Category.comp metricCatType _ _ _ (ppost_comp Ct _ _) (morph BF A B C D)).
- move => A B C D E F f g h k. simpl. move => x. simpl.
  split ; first by do 3 rewrite dom_post_compS.
  move => t. do 3 rewrite post_comp_simpl. move => _. simpl in x. case (x t) ; last by [].
  move => xt. simpl. unfold tset_eq. simpl. by apply: (morph_comp BF).
- move => A B x. simpl. split ; first by rewrite dom_post_compS.
  move => t _. rewrite post_comp_simpl. simpl in x. case: (x t) ; last by []. move => s. simpl. by apply: (morph_id BF).
Defined.

Lemma findom_BF_contractive A B C D : contractive (morph BF A B C D) -> contractive (morph findomBF A B C D).
move => X n. case => f g. case => f' g'. case => e0 e1. move => x.
split ; first by simpl ; do 2 rewrite dom_post_compS.
move => i I I'. simpl. do 2 rewrite post_comp_simpl. simpl in I. simpl in I'.
case: (x i) ; last by []. simpl. move => xi. specialize (X n (f,g) (f',g')). apply: X ; by split.
Qed.

End BiFunc.

Lemma halve_respect2 (M:metricType) n : setoid_respect2 (fun x y : M => match n with O => True | S n' => x = n' = y end).
split => z x y e; case:n ;  [by [] | move => n | by [] | move => n] ; split => E.
- by apply (Mrel_trans (Msym (proj2 (Mrefl _ _) e n)) E).
- by apply (Mrel_trans ((proj2 (Mrefl _ _) e n)) E).
- by apply (Mrel_trans E (proj2 (Mrefl _ _) e n)).
- by apply (Mrel_trans E ((proj2 (Mrefl _ _) (tset_sym e) n))).
Qed.

Lemma halve_metric_axiom (M:metricType) : Metric.axiom (fun n => (fun x y : M => match n with O => True | S n' => x = n' = y end)).
move => n x y z ; split ; last split ; last split ; last split ; simpl ; clear.
- split => X.
  + apply (proj1 (Mrefl x y)) => i. by apply (X (i.+1)).
  + case ; first by []. simpl. move => i. by apply (proj2 (Mrefl _ _) X i).
- move => X. case: n X ; first by []. simpl. move => n. by apply Msym.
- case: n ; first by move => a b.
  move => n. by apply: Mrel_trans.
- case: n ; first by []. move => n. by apply: Mmono.
- by [].
Qed.

Definition halve_metricMixin M := MetricMixin (@halve_metric_axiom M).
Definition halve_metricType (M:metricType) := Eval hnf in @MetricType M (@halve_metricMixin M).

Definition halve_chain (M:metricType) (c:cchain (halve_metricType M)) : cchain M.
exists (fun i => c i.+1:M).
move => n i j L L'. simpl. have C:=cchain_cauchy c. by apply (C n.+1 i.+1 j.+1 L L').
Defined.

Lemma halve_cmetric_axiom (M:cmetricType) : CMetric.axiom (fun c : cchain (halve_metricType M) => (@umet_complete M (halve_chain c))).
move => c n. case: n ; first by exists O. move => n. simpl.
destruct (cumet_conv (halve_chain c) n) as [m X].
exists m.+1. case ; first by [].
move => i L. by apply (X i L).
Qed.

Definition halve_cmetricMixin M := CMetricMixin (@halve_cmetric_axiom M).
Definition halve_cmetricType (M:cmetricType) := Eval hnf in @CMetricType (@halve_metricType M) (@halve_cmetricMixin M).

Lemma halve_pcm_axiom (P:pcmType) : @PreCBUmet.axiom (halve_cmetricType P) (@Ole (PreCBUmet.ordType P)).
split.
- move => x x' y y'. simpl. by apply: (pcm_respect).
- move => c n  C. simpl. simpl in C. apply: pcm_chain_mono => i. simpl. by apply C.
Qed.

Definition halve_pcmMixin P := PCMMixin (@halve_pcm_axiom P) (pcm_getElem P).
Definition halve_pcmType (P:pcmType) := Eval hnf in @PCMType (halve_cmetricType P) (@halve_pcmMixin P).

Section halve_BF.

Variable T:pcmType.

Variable BF:BiFunctor pcmECatType.

Lemma halve_morph_ne (A B:pcmType) : nonexpansive (fun (p : (A -=> B) * halve_pcmType A) => fst p (snd p) : halve_pcmType B).
case ; first by [].
move => n. case ; simpl => f x. case ; simpl => f' x'.
case => e e'. specialize (e x).
apply: (Mrel_trans (Mrel_mono (leqW (leqnn n)) e)). by apply: fnonexpansive.
Qed.

Definition halve_morphN A B : metricCatType ((A -=> B) * (halve_pcmType A)) (halve_pcmType B) := Eval hnf in mk_fmet (@halve_morph_ne A B).

Lemma halve_morphP (A B:pcmType) : monotonic (@halve_morphN A B).
case ; simpl => f x. case => f' x'. simpl. case. simpl => l l'.
specialize (l x). simpl in l. rewrite -> l. by apply: (fmonotonic f').
Qed.

Definition halve_morphX A B : ((A -=> B) * (halve_pcmType A)) =-> halve_pcmType B := Eval hnf in mk_fpcm (@halve_morphP A B).

Definition halve_morph A B := exp_fun (@halve_morphX A B).

Definition halveBF : BiFunctor pcmECatType.
exists (fun A B => halve_pcmType (ob BF A B)) (fun A B C D => @Category.comp metricCatType _ _ _ (halve_morph _ _) (morph BF A B C D)).
- move => A B C D E F f g h k x. simpl. by apply (morph_comp BF f g h k x).
- move => A B x. simpl. by apply: (morph_id BF).
Defined.

Lemma halve_morph_contractive A B C D: contractive (morph halveBF A B C D).
move => n f g e x. simpl. by apply: (fnonexpansive (morph BF A B C D) e).
Qed.

End halve_BF.

(*=downclosed *)
Definition downclosed T (p:nat * T -> Prop) := forall n k t, k < n -> p (n,t) -> p (k,t).
(*=End *)

Module UPred. Section upred.
 Variable T : Type.
 Record mixin_of (f:nat * T -> Prop) := Mixin { _ : downclosed f}.
  Notation class_of := mixin_of.

Structure type : Type := Pack {sort : nat * T -> Prop; _ : class_of sort; _ : nat * T -> Prop}.
Local Coercion sort : type >-> Funclass.
Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
  let: Pack T c _ := cT return K _ (class cT) in k _ c.
Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT.
Definition pack f m := @Pack f m f.
End upred.
Module Import Exports.
Coercion sort : type >-> Funclass.
Notation upred := type. (*CLEAR*)
Notation UPredMixin := Mixin.
Notation UPredType := pack.
(*CLEARED*)
End Exports.
End UPred.
(*=End *)
Export UPred.Exports.

Lemma upred_downclosed T (u:upred T) k k' t : (k <= k')%N -> u (k',t) -> u (k,t).
case_eq (k == k') => E. rewrite (eqP E). move => _. by apply id.
move => l. rewrite leq_eqVlt in l. rewrite E in l. simpl in l.
case: u => u. case => P. simpl. move => _. by apply P.
Qed.

Definition mk_upredM T (f : nat * T -> Prop) (D:downclosed f) := UPredMixin D.
Definition mk_upred T (f : nat * T -> Prop) (D:downclosed f) := UPred.Pack (mk_upredM D) f.

Lemma upred_setoid_axiom T : Setoid.axiom (fun a b : upred T => forall p, (a p <-> b p)).
split ; last split ; first by case.
- move => x y z. simpl. move => A B p. rewrite (A p). by apply (B p).
- move => x y. simpl. move => A p. by rewrite (A p).
Qed.

Canonical Structure upred_setoidMixin T := SetoidMixin (@upred_setoid_axiom T).
Canonical Structure upred_setoidType T := Eval hnf in SetoidType (upred_setoidMixin T).

Lemma upred_metric_axiom T : Metric.axiom (fun n => (fun a b : upred T =>
        forall k t, k < n -> (a (k,t) <-> b (k,t)))).
move => n x y z ; split ; last split ; last split ; last split ; clear.
- split => X. case => k t.
  + apply (X k.+1). by apply ltnSn.
  + move => n. move => k v l. by apply X.
- move => X ; simpl => k t l. by rewrite (X k t l).
- move => X Y ; simpl => k t l. rewrite (X k t l). by rewrite (Y k t l).
- move => X ; simpl => k t l. by apply (X k t (ltnW l)).
- by [].
Qed.

Canonical Structure upred_metricMixin T := MetricMixin (@upred_metric_axiom T).
Canonical Structure upred_metricType T := Eval hnf in MetricType (upred_metricMixin T).

Lemma upred_comp_down T (c:cchain (upred_metricType T)) : downclosed (fun p => (c (fst p).+1) p).
move => n k t L X. simpl. simpl in X.
have C:=cchain_cauchy c. specialize (C k.+1 n.+1 k.+1 (ltnW L) (ltnSn _)).
specialize (C k t (ltnSn _)). rewrite <- C.
apply: (upred_downclosed _ X). by apply ltnW.
Qed.

Definition upred_lub T (c:cchain (upred_metricType T)) := Eval hnf in mk_upred (@upred_comp_down _ c).

Lemma upred_comp_axiom T (c:cchain (upred_metricType T)) : mconverge c (upred_lub c).
move => n. exists n. move => i L. move => k v l. simpl.
have A:=cchain_cauchy c. specialize (A k.+1 k.+1 i (ltnSn _) (ssrnat.leq_trans l L) k v (ltnSn _)).
by rewrite A.
Qed.

Canonical Structure upred_cmetricMixin T := CMetricMixin (@upred_comp_axiom T).
Canonical Structure upred_cmetricType T := Eval hnf in CMetricType (@upred_cmetricMixin T).

Definition upred_less T (x y : upred_cmetricType T) : Prop := forall p, x p -> y p.

Lemma upred_ord_axiom T : PreOrd.axiom (@upred_less T).
move => x ; split ; clear ; first by case.
move => y z X Y. case => k t A. specialize (X (k,t) A). by specialize (Y (k,t) X).
Qed.

Lemma upred_pcm_axiom T : @PreCBUmet.axiom (@upred_cmetricType T) (PreOrd.Ole (OrdMixin (@upred_ord_axiom T))).
split.
- move => x x'. simpl. move => y y' e e'. move => X. case => k t Y. specialize (X (k,t)). specialize (e (k,t)).
  specialize (e' (k,t)). rewrite <- e'. apply X. rewrite e. by apply Y.
- move => c c'. simpl. move => X. case => k t. simpl. by apply (X k.+1).
Qed.

Lemma upredEmptyP T : downclosed (fun x : nat * T => False).
by [].
Qed.

Definition upredEmpty T : (upred T) := mk_upred (@upredEmptyP T).

Canonical Structure upred_pcmMixin T := PCMMixin (@upred_pcm_axiom T) (@upredEmpty T).
Definition upred_pcmType T := Eval hnf in PCMType (@upred_pcmMixin T).

Definition upred_empty T : upred_pcmType T := upredEmpty T.

Definition constBF (T:pcmType) : BiFunctor pcmECatType.
exists (fun (A B:pcmType) => T) (fun (A B C D:pcmType) => mconst ((B -=> A) * (C -=> D)) (@pid T)).
by move => A B C D E F f g h k x.
by move => A B x.
Defined.

Lemma constBF_contractive (T A B C D:pcmType) : contractive (morph (constBF T) A B C D).
move => n x y e a. simpl. by apply (proj2 (Mrefl _ _)).
Qed.

Section Product.
Variable BF BG:BiFunctor pcmECatType.

Section Map.
Variable A B C D : pcmType.

Lemma mprod_mapP : nonexpansive (fun (p:(A =-> B) * (C =-> D)) => <| fst p << pi1, snd p << pi2|>).
move => n x y. case => e0 e1. case => z0 z1. split ; by [apply: e0 | apply: e1].
Qed.

Definition mpprod_map : metricCatType ((A -=> B) * (C -=> D))  (A * C -=> B * D) := Eval hnf in mk_fmet mprod_mapP.

Lemma Pprod_mapP : monotonic mpprod_map.
case => x0 x1. case => y0 y1. case ; simpl => l0 l1. case => z0 z1. simpl. split ; simpl ; by [apply l0 | apply l1].
Qed.

Definition Fprod_map : (A -=> B) * (C -=> D) =-> (A * C -=> B * D) := Eval hnf in mk_fpcm Pprod_mapP.

End Map.

Definition prod_BF : BiFunctor pcmECatType.
exists (fun A B => (ob BF A B) * (ob BG A B)) (fun (A B C D:pcmType) => (((Fprod_map (ob BF A C) (ob BF B D) (ob BG A C) (ob BG B D)) : cmetricCatType _ _) << (<|morph BF A B C D, morph BG A B C D|>))).
- move => A B C D E F f g h k. simpl. rewrite prod_map_prod_fun.
  do 2 rewrite comp_assoc. rewrite -> (morph_comp BF). by rewrite -> (morph_comp BG).
- move => A B. simpl. do 2 rewrite morph_id. do 2 rewrite comp_idL.
  by apply: prod_unique ; [rewrite prod_fun_fst | rewrite prod_fun_snd] ; rewrite comp_idR.
Defined.

Lemma prod_BF_contractive A B C D : contractive (morph BF A B C D) -> contractive (morph BG A B C D) ->
                                    contractive (morph prod_BF A B C D).
move => X Y n. case => x0 x1. case => y0 y1. case => e0 e1. case => z0 z1.
simpl. split. by apply: X. by apply: Y.
Qed.

End Product.

Definition idBF : BiFunctor pcmECatType.
exists (fun A B => B) (fun A B C D => msnd _ _).
by move => A B C D E F f g h k x.
by move => A B x.
Defined.

Close Scope O_scope.
Close Scope M_scope.
Close Scope C_scope.


(* Full safety for STLC *)
(* values well-typed with respect to runtime environment *)
(* inversion lemma structure *)
(* subtyping (in addition to nano2.v) *)

(* copied from nano4-1, making the step to small-step *)

(* first step: substitution *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> ty -> ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tloc : id -> tm
  | tabs : tm -> tm (* \f x.y *)
  | tapp : tm -> tm -> tm (* f(x) *)
.

Inductive vl : Type :=
| vbool : bool -> vl
| vabs  : (*list vl -> *) tm -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

Definition vl2tm (v:vl): tm :=
  match v with
    | vbool true => ttrue
    | vbool false => tfalse
    | vabs ey => tabs ey
  end.

Inductive has_type : venv -> tenv -> tm -> ty -> Prop :=
| t_true: forall sto env,
           has_type sto env ttrue TBool
| t_false: forall sto env,
           has_type sto env tfalse TBool
| t_var: forall x sto env T1,
           index x env = Some T1 ->
           has_type sto env (tvar x) T1
| t_loc: forall x v sto env T1,
           index x sto = Some v ->
           has_type sto [] (vl2tm v) T1 ->
           has_type sto env (tloc x) T1
| t_abs: forall sto env y T1 T2,
           has_type sto (T1::(TFun T1 T2)::env) y T2 ->
           has_type sto env (tabs y) (TFun T1 T2)
| t_app: forall sto env f x T1 T2,
           has_type sto env f (TFun T1 T2) ->
           has_type sto env x T1 ->
           has_type sto env (tapp f x) T2
| t_sub: forall sto env t T1 T2,
           has_type sto env t T1->
           stp sto env T1 T2 ->
           has_type sto env t T2

with stp: venv -> tenv -> ty -> ty -> Prop :=
| stp_bool: forall S G,
    stp S G TBool TBool
| stp_fun: forall S G T1 T2 T3 T4,
    stp S G T3 T1 ->
    stp S G T2 T4 ->
    stp S G (TFun T1 T2) (TFun T3 T4)
.

Definition val_type S v T := has_type S [] (vl2tm v) T.

Inductive wf_sto : venv -> tenv -> Prop :=
| wfe_nil : wf_sto nil nil
| wfe_cons : forall v t vs ts,
    val_type (v::vs) v t ->
    wf_sto vs ts ->
    wf_sto (cons v vs) (cons t ts)
.

Fixpoint subst (a:tm) (t:tm) {struct t}: tm :=
  match t with
    | ttrue => ttrue
    | tfalse => tfalse
    | tvar i => if beq_nat i 0 then a else tvar (i-1)
    | tapp t1 t2 => tapp (subst a t1) (subst a t2)
    | tabs t1 => tabs (subst a t1)
    | tloc i => tloc i
  end.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v

Could use do-notation to clean up syntax.
 *)

(* TODO: store + substitution *)

Definition push sto (v:vl) := (v::sto, length sto).

Fixpoint teval(n: nat)(sto: venv)(t: tm){struct n}: option (option (venv * nat)) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (push sto (vbool true)))
        | tfalse     => Some (Some (push sto (vbool false)))
        | tvar x     => Some None
        | tloc x     => Some (Some (sto,x))
        | tabs y     => Some (Some (push sto (vabs y)))
        | tapp ef ex   =>
          match teval n sto ef with
            | None => None
            | Some None => Some None
            | Some (Some (sto1,lvf)) =>
              match teval n sto1 ex with
                | None => None
                | Some None => Some None
                | Some (Some (sto2, lvx)) =>
                  match index lvx sto2, index lvf sto1 with
                    | Some vx, Some (vabs ey) =>
                      teval n sto2 (subst (tloc lvx) (subst (tloc lvf) ey))
                    | _,_ => Some None
                  end
              end
          end
      end
  end.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.
Hint Constructors wf_sto.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.
Hint Unfold val_type.

Hint Resolve ex_intro.

Lemma wf_length : forall vs ts,
                    wf_sto vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  assert ((length (v::vs)) = 1 + length vs). constructor.
  assert ((length (t::ts)) = 1 + length ts). constructor.
  rewrite IHwf_sto in H1. auto.
Qed.

Hint Immediate wf_length.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  case_eq (beq_nat n (length vs)); intros E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

(*
Lemma index_hit {X}: forall x x1 (B:X) A G,
  index x ((x1,B)::G) = Some A ->
  fresh G <= x1 ->
  x = x1 ->
  B = A.
Proof.
  intros.
  unfold index in H.
  elim (le_xx (fresh G) x1 H0). intros.
  rewrite H2 in H.
  assert (beq_nat x x1 = true). eapply beq_nat_true_iff. eauto.
  rewrite H3 in H. inversion H. eauto.
Qed.
*)

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. reflexivity.
Qed.

Lemma stp_extend : forall vs ts v1 T1 T2,
                       stp vs ts T1 T2 ->
                       stp (v1::vs) ts T1 T2.
Proof.
  intros. induction H; eauto.
  econstructor.
  econstructor; eauto.
Qed.

Lemma stp_extendG : forall vs ts v1 T1 T2,
                       stp vs ts T1 T2 ->
                       stp vs (v1::ts) T1 T2.
Proof.
  intros. induction H; eauto.
  econstructor.
  econstructor; eauto.
Qed.

Lemma hastp_extend : forall vs ts v1 t T,
                       has_type vs ts t T ->
                       has_type (v1::vs) ts t T.
Proof.
  intros. induction H; eauto.
  econstructor. eapply index_extend; eauto. eauto. econstructor. eauto. eapply stp_extend. eauto.
Qed.

Lemma hastp_extendG : forall vs ts v1 t T,
                       has_type vs ts t T ->
                       has_type vs (v1::ts) t T.
Proof.
  intros. induction H; eauto.
  econstructor. eapply index_extend; eauto. eauto. econstructor. eauto. eauto. admit. admit.
Qed.

Lemma valtp_extend : forall vs v v1 T,
                       val_type vs v T ->
                       val_type (v1::vs) v T.
Proof. intros. eapply hastp_extend. eauto. Qed.

Lemma index_extend_mult : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a++vs) = Some T.

Proof. intros. induction a. eauto. eapply index_extend. eauto. Qed.

Lemma hastp_extend_mult : forall vs ts v1 t T,
                       has_type vs ts t T ->
                       has_type (v1++vs) ts t T.
Proof. intros. induction v1. eauto. eapply hastp_extend. eauto. Qed.

Lemma valtp_extend_mult : forall vs v v1 T,
                       val_type vs v T ->
                       val_type (v1++vs) v T.
Proof. intros. induction v1. eauto. eapply hastp_extend. eauto. Qed.

(*
Lemma index_safe_ex: forall H1 G1 TF i,
             wf_sto H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
       Case "nil". inversion H0.
       Case "cons". inversion H0.
         case_eq (beq_nat i (length ts)).
           SCase "hit".
             intros E.
             rewrite E in H3. inversion H3. subst t.
             assert (beq_nat i (length vs) = true). eauto.
             assert (index i (v :: vs) = Some v). eauto.  unfold index. rewrite H2. eauto.
             eauto.
           SCase "miss".
             intros E.
             assert (beq_nat i (length vs) = false). eauto.
             rewrite E in H3.
             assert (exists v0, index i vs = Some v0 /\ val_type vs v0 TF) as HI. eapply IHwf_env. eauto.
           inversion HI as [v0 HI1]. inversion HI1.
           eexists. econstructor. eapply index_extend; eauto. eapply valtp_extend; eauto.
Qed.
*)

Inductive res_type: venv -> option (venv * nat) -> ty -> Prop :=
| not_stuck: forall sto sto0 sto1 tenv x v T,
      index x sto = Some v ->
      val_type sto v T ->
      sto = sto1++sto0 ->
      wf_sto sto tenv ->
      res_type sto0 (Some (sto,x)) T.

Hint Constructors res_type.
Hint Resolve not_stuck.

(*
Lemma restp_extend_mult : forall vs v v1 T,
                       res_type vs v T ->
                       res_type (v1++vs) v T.
Proof.
  intros. inversion H. subst sto.
  eapply not_stuck. eauto. eauto.rewrite index_extend_mult. eapply index_extend_mult; eauto.  eauto. instantiate (1:= nil). simpl. eauto.
*)

(*
Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stp H1 T1 H2 T2 ->
  val_type H2 vf T2.
Proof.
  intros. inversion H; inversion H0; subst T2; subst; eauto. inversion H9. inversion H9.
  admit.
Qed.

Lemma invert_abs: forall venv vf vx T1 T2,
  val_type venv vf (TFun T1 T2) ->
  exists env tenv y T3 T4,
    vf = (vabs env y) /\
    wf_env env tenv /\
    has_type (T3::(TFun T3 T4)::tenv) y T4 /\
    stp venv T1 (vx::vf::env) T3 /\
    stp (vx::vf::env) T4 venv T2.
Proof.
  intros. inversion H. repeat eexists; repeat eauto. admit. admit.
Qed.
*)

(* if not a timeout, then result not stuck and well-typed *)

Lemma index_hit: forall {X: Type} vs (v:X),
  index (length vs) (v :: vs) = Some v.
Proof.
  intros. simpl.
  assert (beq_nat (length vs) (length vs) = true).
  eapply beq_nat_true_iff. eauto.
  rewrite H. eauto.
Qed.

Lemma index_hit0: forall {X: Type} vs (v:X),
  index 0 (vs++[v]) = Some v.
Proof.
  intros. induction vs. eauto.
  rewrite <-app_comm_cons. eapply index_extend. eauto.
Qed.

Lemma index_hit1: forall {X: Type} vs (v:X) x,
  index (S x) (vs++[v]) = index x vs.
Proof.
  intros. induction vs. eauto.
  rewrite <-app_comm_cons.
  remember (index x vs). destruct o.
  symmetry in Heqo. eapply index_extend in Heqo. eapply index_extend in IHvs.
  rewrite Heqo. rewrite IHvs. eauto.
  simpl. rewrite <-Heqo. rewrite IHvs.
  simpl. rewrite app_length. simpl.
  assert (length vs + 1 = S (length vs)). omega. rewrite H. eauto.
Qed.

Lemma hastp_subst: forall sto x T0 env0 t T,
  has_type sto [] (tloc x) T0 ->
  has_type sto env0 t T ->
  forall env,
    env0 = env ++ [T0] ->
    has_type sto env (subst (tloc x) t) T.
Proof.
  intros. revert env H1. induction H0; intros.
  - eauto.
  - eauto.
  - (* var *) simpl. destruct x0.
    + (* hit *) simpl. subst env. rewrite index_hit0 in H0. inversion H0. subst. eauto.
       remember (tloc x). remember []. induction H; inversion Heqt.
    + (* miss *) simpl. subst env0. rewrite index_hit1 in H6.
         assert (i - 0 = i) as E. omega. rewrite E. eauto.
  - (* loc *)
    simpl. eauto.
  - (* abs *)
    simpl. eauto.
  - (* app *)
    simpl. eauto.
Qed.

Lemma push_safe: forall sto tenv v T,
  wf_sto sto tenv ->
  val_type (v::sto) v T ->
  res_type sto (Some (push sto v)) T.
Proof.
  intros. eapply not_stuck. eapply index_hit. eauto. eauto.
  instantiate (1:= [v]). eauto. econstructor; eauto.
Qed.

Theorem full_safety : forall n e sto sto2 tenv2 res T,
  teval n (sto2++sto) e = Some res -> has_type sto [] e T -> wf_sto (sto2++sto) tenv2 ->
  res_type (sto2++sto) res T.

Proof.
  intros n. induction n.
  (* 0 *)   intros. inversion H.
  (* S n *) intros. destruct e; inversion H; inversion H0.

  - Case "True".  eapply push_safe; eauto.
  - Case "False". eapply push_safe; eauto.
  - Case "Var".
    inversion H6.
  - Case "Loc".
    subst.

    eapply not_stuck. eauto. eauto. eapply index_extend_mult; eauto.
    eapply valtp_extend_mult; eauto.
    rewrite app_nil_l. eauto. eauto.

  - Case "Abs".

    eapply push_safe; eauto. unfold val_type. unfold vl2tm. subst.
    eapply hastp_extend. eapply hastp_extend_mult. eauto.

  - Case "App".
    subst T.

    remember (teval n (sto2++sto) e1) as tf.
    destruct tf as [rf|]; try solve by inversion.
    assert (res_type (sto2++sto) rf (TFun T1 T2)) as HRF. SCase "HRF". subst. eapply IHn; eauto.
    inversion HRF as [? ? ? ? ? vf].

    subst.

    remember (teval n (sto4 ++ sto2 ++ sto) e2) as tx.
    destruct tx as [rx|]; try solve by inversion.
    assert (res_type (sto4 ++ sto2 ++ sto) rx T1) as HRX. SCase "HRX". subst. eapply IHn; eauto. eapply hastp_extend_mult; eauto.
    inversion HRX as [? ? ? ? ? vx].

    subst.

    rewrite H2 in H3.
    rewrite H8 in H3.

    (* inversion lemma for vf ? *)
    destruct vf. inversion H10; inversion H14; destruct b; inversion H5.
    (* now we know it's a closure, and we have has_type evidence *)

    inversion H10.

    assert (res_type ([] ++ sto3 ++ sto4 ++ sto2 ++ sto) res T2) as HRR.
    eapply IHn. eauto. eauto.
    eapply hastp_subst. eauto. eapply hastp_subst. eapply hastp_extend_mult. eauto.
    simpl. eauto. eapply hastp_extend_mult. eauto. eauto.

    inversion HRR as [? ? ? ? ? vr].

    eapply not_stuck. eauto. eauto. eauto. instantiate (1:= sto6 ++ [] ++ sto3 ++ sto4).
    simpl. rewrite H19. simpl. rewrite <- app_assoc. rewrite <- app_assoc. eauto.
    eauto.

Qed.

End STLC.


From Coq Require Import List Nat Bool Lia FunctionalExtensionality Lia Program FinFun Eqdep.
Import ListNotations.

From CasperCBC
Require Import Lib.ListExtras Lib.Preamble VLSM.Common VLSM.Composition VLSM.Equivocation.

(** * VLSM Subcomposition *)

Section sub_composition.

Context
  {message : Type}
  {index : Type}
  {IndEqDec : EqDecision index}
  (IM : index -> VLSM message)
  (sub_index_list : list index)
  (Hi0_sub : sub_index_list <> [])
  .

Definition sub_index_prop (i : index) : Prop := In i sub_index_list.

Local Instance sub_index_prop_dec
  (i : index)
  : Decision (sub_index_prop i).
Proof.
  apply in_dec. assumption.
Qed.

Definition sub_index : Type
  := dec_sig sub_index_prop.

Local Instance sub_index_i0 : Inhabited sub_index.
Proof.
  split.
  destruct (destruct_list sub_index_list) as [[x [tl Heq]]| n]
  ; [|elim Hi0_sub; assumption].
  exists x. apply bool_decide_eq_true.
  unfold sub_index_prop. subst sub_index_list. left. reflexivity.
Qed.

Local Instance sub_index_eq_dec : EqDecision sub_index.
Proof.
  apply dec_sig_eq_dec. assumption.
Qed.

Definition sub_IM
  (ei : sub_index)
  : VLSM message
  := IM (proj1_sig ei).

 Lemma sub_IM_state_update_eq
  (i : index)
  (s : composite_state sub_IM)
  (si : vstate (IM i))
  (e1 e2 : sub_index_prop i)
  : state_update sub_IM s (dec_exist _ i e1) si (dec_exist _ i e2) = si.
Proof.
  unfold dec_exist.
  assert
    (forall be1 be2, be1 = be2 -> state_update sub_IM s
      (exist _ i be1) si (exist _ i be2)
      = si).
  { intros. subst. apply state_update_eq. }
  apply H.
  apply bool_decide_eq_true_proof_irrelevance.
Qed.

Definition free_sub_vlsm_composition : VLSM message
  := free_composite_vlsm sub_IM.

Definition seeded_free_sub_composition
  (messageSet : message -> Prop)
  := pre_loaded_vlsm free_sub_vlsm_composition
      (fun m => messageSet m \/ composite_initial_message_prop IM m).

Local Lemma i0 : Inhabited index.
Proof.
  apply exists_last in Hi0_sub.
  destruct Hi0_sub as (_, (a, _)).
  constructor. exact a.
Qed.

Existing Instance i0.

Definition composite_state_sub_projection
  (s : composite_state IM)
  : composite_state sub_IM
  := fun (subi : sub_index) => s (proj1_sig subi) : vstate (sub_IM subi).

Lemma composite_initial_state_sub_projection
  (s : composite_state IM)
  (Hs : composite_initial_state_prop IM s)
  : composite_initial_state_prop sub_IM (composite_state_sub_projection s).
Proof.
  intros (i, Hi). apply Hs.
Qed.

Definition composite_transition_item_sub_projection
  (item : composite_transition_item IM)
  (i := projT1 (l item))
  (e : sub_index_prop i)
  (j : sub_index := dec_exist _ i e)
  : composite_transition_item sub_IM
  :=
  @Build_transition_item _ (composite_type sub_IM) (existT _ j (projT2 (l item))) (input item) (composite_state_sub_projection (destination item)) (output item).

Lemma composite_state_transition_item_sub_projection
  (item : composite_transition_item IM)
  (i := projT1 (l item))
  (e : sub_index_prop i)
  (j : sub_index := dec_exist _ i e)
  : composite_state_sub_projection (destination item)
  = destination (composite_transition_item_sub_projection item e).
Proof.
  destruct item. destruct l. simpl in *. reflexivity.
Qed.

Definition composite_transition_item_sub_projection_proof_irrelevance
  (item : composite_transition_item IM)
  (i := projT1 (l item))
  (e1 e2 : sub_index_prop i)
  : composite_transition_item_sub_projection item e1 = composite_transition_item_sub_projection item e2.
Proof.
  destruct item. destruct l. unfold i in *. clear i.
  unfold composite_transition_item_sub_projection.
  simpl in *. f_equal.
  apply (@dec_sig_sigT_eq _ sub_index_prop sub_index_prop_dec (fun i => vlabel (IM i))).
  reflexivity.
Qed.

Definition from_sub_projection
  (a : composite_transition_item IM)
  : Prop
  := sub_index_prop (projT1 (l a)).

Fixpoint finite_trace_sub_projection
  (trx : list (composite_transition_item IM))
  : list (composite_transition_item sub_IM)
  :=
  match trx with
  | [] => []
  | item :: trx =>
    let tail := finite_trace_sub_projection trx in
    match decide (from_sub_projection item) with
    | left e => composite_transition_item_sub_projection item e :: tail
    | _ => tail
    end
  end.

Definition finite_trace_sub_projection_alt
  (trx : list (composite_transition_item IM))
  (ftrx := (filter (fun a => bool_decide (from_sub_projection a)) trx))
  (Hall: Forall from_sub_projection ftrx := filter_Forall trx)
  :=
  List.map
    (fun item : {a : composite_transition_item IM | from_sub_projection a} =>
      let (item, e) := item in
      composite_transition_item_sub_projection item e
    )
  (list_annotate from_sub_projection ftrx Hall).

Lemma finite_trace_sub_projection_alt_iff
  (trx : list (composite_transition_item IM))
  : finite_trace_sub_projection_alt trx = finite_trace_sub_projection trx.
Proof.
  unfold finite_trace_sub_projection_alt.
  match goal with
  |- context [list_annotate _ _ ?H] => generalize H as Hall
  end.
  induction trx; intros; [reflexivity|].
  simpl. unfold bool_decide at 1. unfold decide.
  simpl in Hall. unfold bool_decide in Hall at 1.
  destruct (sub_index_prop_dec (projT1 (l a))) eqn:Ha.
  - rewrite list_annotate_unroll.
    rewrite map_cons.
    f_equal.
    +  apply composite_transition_item_sub_projection_proof_irrelevance.
    + apply IHtrx.
  - apply IHtrx.
Qed.

Section sub_projection_with_no_equivocation_constraints.

Existing Instance  IndEqDec.

Context
  (constraint : composite_label IM -> composite_state IM * option message -> Prop)
  (has_been_sent_capabilities : forall i : index, (has_been_sent_capability (IM i)))
  {index_listing : list index}
  (finite_index : Listing index_listing)
  (Free := free_composite_vlsm IM)
  (Sub_Free := free_composite_vlsm sub_IM)
  (X_has_been_sent_capability : has_been_sent_capability Free := composite_has_been_sent_capability IM (free_constraint IM) finite_index has_been_sent_capabilities)
  (X := composite_vlsm IM constraint)
  (Pre := pre_loaded_with_all_messages_vlsm (free_composite_vlsm IM))
  .

Lemma sub_has_been_sent_capabilities : forall i : sub_index, (has_been_sent_capability (sub_IM i)).
Proof.
  intros [i Hi]. apply has_been_sent_capabilities.
Qed.

Fixpoint select_sub_indices
  (l : list index)
  : list sub_index
  :=
  match l with
  | [] => []
  | h :: t =>
    let t' := select_sub_indices t in
    match decide (sub_index_prop h) with
    | left e => dec_exist _ h e :: t'
    | _ => t'
    end
  end.

Definition sub_index_listing : list sub_index := select_sub_indices index_listing.

Lemma in_select_sub_indices
  (a: index)
  (s: sub_index_prop a)
  (l: list index)
  : In (dec_exist sub_index_prop a s) (select_sub_indices l) <-> In a l.
Proof.
  induction l; [simpl; intuition|].
  simpl.
  destruct (decide (sub_index_prop a0)); [|rewrite IHl].
  - split; intros [Heq | H]; [left |right; apply IHl; assumption| left |right; apply IHl; assumption].
    + apply dec_sig_eq_iff in Heq. assumption.
    + apply dec_sig_eq_iff. assumption.
  - split; [intuition|].
    intros [Heq | H]; [|assumption].
    subst. contradiction.
Qed.

Lemma finite_sub_index : Listing sub_index_listing.
Proof.
  unfold sub_index_listing.
  clear -finite_index.
  destruct finite_index as [Hnodup Hfinite].
  split.
  - clear Hfinite finite_index. induction index_listing; [constructor|].
    inversion Hnodup. subst.
    simpl. spec IHl H2.
    destruct (decide (sub_index_prop a)); [|assumption].
    constructor; [|assumption].
    intro contra. elim H1. apply in_select_sub_indices in contra. assumption.
  - intros subi. unfold sub_index in subi. destruct_dec_sig subi i Hi Heq.
    subst. apply in_select_sub_indices. apply Hfinite.
Qed.

Local Instance Sub_Free_has_been_sent_capability
  : has_been_sent_capability Sub_Free
  :=
  composite_has_been_sent_capability sub_IM (free_constraint sub_IM) finite_sub_index sub_has_been_sent_capabilities.

Lemma finite_trace_sub_projection_empty
  (s : composite_state IM)
  (trx : list (composite_transition_item IM))
  (Htr : finite_protocol_trace_from X s trx)
  (Hempty : finite_trace_sub_projection trx = [])
  (t : (vtransition_item X))
  (Hin : In t trx)
  : forall j, In j sub_index_list -> destination t j = s j.
Proof.
  generalize dependent t.
  induction Htr; simpl; intros t Hin.
  - inversion Hin.
  - destruct l as [i l].
    destruct H as [[[_om Hs'] [[_s Hiom] Hvalid]] Htransition].
    unfold transition in Htransition; simpl in Htransition.
    destruct (vtransition (IM i) l (s' i, iom)) as [si' om'] eqn:Hteq.
    inversion Htransition; subst. clear Htransition.
    match type of Hempty with
      | finite_trace_sub_projection (?i :: _) = _ => remember i as item
    end.
    simpl in Hempty.
    destruct (decide (from_sub_projection item))
    ; [inversion Hempty|].
    specialize (IHHtr Hempty).
    rewrite Heqitem in n.
    unfold from_sub_projection in n.
    simpl in n.
    destruct Hin as [Heq | Hin]; intros j Hj.
    + subst. simpl. apply state_update_neq.
      intro contra. subst. contradiction.
    + assert (Hji : j <> i).
      { intro contra. subst. contradiction. }
      specialize (IHHtr _ Hin j Hj).
      rewrite state_update_neq in IHHtr; assumption.
Qed.

Lemma finite_trace_sub_projection_app
  (tr1 tr2 : list (composite_transition_item IM))
  : finite_trace_sub_projection (tr1 ++ tr2) =
    finite_trace_sub_projection tr1 ++ finite_trace_sub_projection tr2.
Proof.
  induction tr1;[reflexivity|].
  simpl.
  match goal with
  |- context [decide ?d] => destruct (decide d)
  end
  ; [|assumption].
  simpl. rewrite IHtr1. reflexivity.
Qed.

Lemma finite_trace_sub_projection_list_in
  (tr : list (composite_transition_item IM))
  (itemX : composite_transition_item IM)
  (HitemX : In itemX tr)
  (j := projT1 (l itemX))
  (Hj : sub_index_prop j)
  : In (composite_transition_item_sub_projection itemX Hj) (finite_trace_sub_projection tr).
Proof.
  apply in_split in HitemX.
  destruct HitemX as [pre [suf HitemX]].
  subst.
  change (itemX :: suf) with ([itemX] ++ suf).
  rewrite! finite_trace_sub_projection_app.
  apply in_app_iff. right. apply in_app_iff. left.
  simpl. destruct (decide (from_sub_projection itemX)); [|contradiction].
  left. apply composite_transition_item_sub_projection_proof_irrelevance.
Qed.

Lemma finite_trace_sub_projection_list_in_rev
  (tr : list (composite_transition_item IM))
  (j : index)
  (itemj : composite_transition_item sub_IM)
  (Hitemj : In itemj  (finite_trace_sub_projection tr))
  : exists
    (itemX : composite_transition_item IM)
    (HitemX : from_sub_projection itemX),
    In itemX tr /\ composite_transition_item_sub_projection itemX HitemX = itemj.
Proof.
  rewrite <- finite_trace_sub_projection_alt_iff in Hitemj.
  apply in_map_iff in Hitemj.
  destruct Hitemj as [(itemX, HitemX) [Heq Hin]].
  exists itemX, HitemX.
  split; [|assumption].
  apply in_list_annotate_forget in Hin.
  apply filter_In in Hin. apply Hin.
Qed.

Lemma preloaded_finite_trace_sub_projection_last_state
  (start : composite_state IM)
  (transitions : list (composite_transition_item IM))
  (Htr : finite_protocol_trace_from Pre start transitions)
  (lstx := finite_trace_last start transitions)
  (lstj := finite_trace_last
            (composite_state_sub_projection start)
            (finite_trace_sub_projection transitions)
            )
  : lstj = composite_state_sub_projection lstx.
Proof.
  unfold lstx. unfold lstj. clear lstx. clear lstj.
  induction Htr; [reflexivity|].
  match goal with
  |- context[finite_trace_sub_projection (?i :: _)] => remember i as item
  end.
  rewrite finite_trace_last_cons.
  simpl.
  destruct (decide (from_sub_projection item)).
  - rewrite finite_trace_last_cons.
    subst. simpl. assumption.
  - subst. simpl.
    rewrite <- IHHtr; clear IHHtr. f_equal.
    destruct H as [[[_om Hs'] [[_s Hiom] Hvalid]] Htransition].
    unfold transition in Htransition; simpl in Htransition.
    unfold vtransition in Htransition. simpl in Htransition.
    destruct l as (i, l).
    destruct (vtransition (IM i) l (s' i, iom)) as [si' om'] eqn:Hteq.
    inversion Htransition; subst. clear Htransition.
    unfold from_sub_projection in n. simpl in n.
    apply functional_extensionality_dep_good.
    intros (j, Hj). unfold composite_state_sub_projection.
    simpl. symmetry. apply (state_update_neq _ s').
    apply bool_decide_eq_true_1 in Hj.
    clear -n Hj; congruence.
Qed.

Lemma X_incl_Pre : VLSM_incl X Pre.
Proof.
  apply VLSM_incl_trans with (machine (free_composite_vlsm IM)).
  - apply (constraint_free_incl IM constraint).
  - apply vlsm_incl_pre_loaded_with_all_messages_vlsm.
Qed.

Lemma finite_trace_sub_projection_last_state
  (start : composite_state IM)
  (transitions : list (composite_transition_item IM))
  (Htr : finite_protocol_trace_from X start transitions)
  (lstx := finite_trace_last start transitions)
  (lstj := finite_trace_last
    (composite_state_sub_projection start)
    (finite_trace_sub_projection transitions))
  : lstj = composite_state_sub_projection lstx.
Proof.
  apply preloaded_finite_trace_sub_projection_last_state.
  apply VLSM_incl_finite_protocol_trace_from with (machine X); [|assumption].
  apply X_incl_Pre.
Qed.

Lemma transition_sub_projection
  l s om s' om'
  (Ht : composite_transition IM l  (s, om) = (s', om'))
  (Hsub : sub_index_prop (projT1 l))
  : composite_transition sub_IM
    (existT (fun n : sub_index => vlabel (sub_IM n))
      (dec_exist _ (projT1 l) Hsub)
      (projT2 l)
    )
    (composite_state_sub_projection s, om)
    = (composite_state_sub_projection s', om').
Proof.
  simpl. simpl in Ht.
  destruct l as (i, li).
  unfold vtransition. simpl.
  unfold composite_state_sub_projection at 1. simpl.
  destruct (vtransition (IM i) li (s i, om)) as (si', omi') eqn:Hti.
  inversion Ht. subst omi' s'. clear Ht.
  match goal with
  |- (let (_, _) := ?t in _) = _ =>
    replace t with (si', om')
  end.
  f_equal.
  apply functional_extensionality_dep.
  intro sub_j. unfold sub_index in sub_j.
  destruct_dec_sig sub_j j Hj Heqj.
  subst sub_j. unfold composite_state_sub_projection at 2.
  destruct (decide (j = i)).
  - subst.
    simpl. rewrite state_update_eq.
    apply sub_IM_state_update_eq.
  - rewrite! state_update_neq; [reflexivity|assumption|].
    intro contra. apply dec_sig_eq_iff in contra. contradiction.
Qed.

Lemma valid_sub_projection
  l s om
  (Hv : composite_valid IM l  (s, om))
  (Hsub : sub_index_prop (projT1 l))
  : composite_valid sub_IM
    (existT (fun n : sub_index => vlabel (sub_IM n))
      (dec_exist _ (projT1 l) Hsub)
      (projT2 l)
    )
    (composite_state_sub_projection s, om).
Proof.
  simpl. simpl in Hv.
  destruct l as (i, li).
  assumption.
Qed.

Definition composite_state_sub_projection_lift
  (ss : composite_state sub_IM)
  (i : index)
  :=
  match (decide (sub_index_prop i)) with
  | left e => ss (dec_exist _ i e)
  | _ => proj1_sig (composite_s0 IM) i
  end.

Definition sub_constraint
  (l : composite_label sub_IM)
  (som : composite_state sub_IM * option message)
  : Prop
  :=
  let i := proj1_sig (projT1 l) in
  let li := projT2 l in
  let lx : composite_label IM := (existT (fun i : index => vlabel (IM i)) i li) in
  let (ss, om) := som in
  let s := composite_state_sub_projection_lift ss in
  constraint lx (s, om).

Existing Instance X_has_been_sent_capability.

Context
  (seed : message -> Prop)
  (Hno_equiv : constraint_subsumption IM constraint (no_equivocations Free))
  (seeded_constraint : composite_label sub_IM -> composite_state sub_IM * option message -> Prop)
  (Xj := composite_no_equivocation_vlsm_with_pre_loaded sub_IM (free_constraint sub_IM) sub_has_been_sent_capabilities finite_sub_index seed)
  .

Lemma Xj_incl_Pre_Sub_Free
  : VLSM_incl Xj (pre_loaded_with_all_messages_vlsm Sub_Free).
Proof.
  subst Xj.
  unfold composite_no_equivocation_vlsm_with_pre_loaded.
  specialize
    (preloaded_constraint_subsumption_pre_loaded_with_all_messages_incl sub_IM
      (no_equivocations_additional_constraint_with_pre_loaded sub_IM
        (free_constraint sub_IM) sub_has_been_sent_capabilities
        finite_sub_index seed)
      (free_constraint sub_IM)
    ) as Hincl.
  spec Hincl; [intros s Hs l om H; exact I|].
  match goal with
  |- context [pre_loaded_vlsm ?v _] =>
    apply VLSM_incl_trans with (machine (pre_loaded_with_all_messages_vlsm v))
  end
  ; [| apply Hincl].
  clear Hincl.
  match goal with
  |- context [pre_loaded_with_all_messages_vlsm ?v] =>
    apply VLSM_incl_trans with (machine (pre_loaded_vlsm v (fun m => True)))
  end.
  - match goal with
    |- context [pre_loaded_vlsm ?v _] =>
      apply (pre_loaded_vlsm_incl v seed (fun m => True))
    end.
    intuition.
  - match goal with
    |- context [pre_loaded_with_all_messages_vlsm ?v] =>
      specialize (pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True v) as Hincl
    end.
    apply VLSM_eq_incl_iff in Hincl.
    apply proj2 in Hincl.
    assumption.
Qed.

(**
Property of a composite trace requiring that every message received in an
transition involving a machine in the chosen subset must either belong to
the set specified by [seed], or it must [have_been_sent] by some machine
in the chosen subset (prior to it being received).
*)
Definition trace_sub_item_input_is_seeded_or_sub_previously_sent
  (tr : list (composite_transition_item IM))
  : Prop
  :=
  forall pre item suf m,
    tr = pre ++ [item] ++ suf ->
    input item = Some m ->
    from_sub_projection item ->
    seed m \/ exists pre_item, In pre_item pre /\ output pre_item = Some m /\ from_sub_projection pre_item.

Definition state_sub_item_input_is_seeded_or_sub_previously_sent
  (s : composite_state IM)
  : Prop
  := forall is tr,
    finite_protocol_trace_init_to Pre is s tr ->
    trace_sub_item_input_is_seeded_or_sub_previously_sent tr.

Lemma finite_protocol_trace_sub_projection
  (s : composite_state IM)
  (tr : list (composite_transition_item IM))
  (Hmsg :  trace_sub_item_input_is_seeded_or_sub_previously_sent tr)
  (Htr : finite_protocol_trace X s tr)
  : finite_protocol_trace Xj (composite_state_sub_projection s) (finite_trace_sub_projection tr).
Proof.
  destruct Htr as [Htr His].
  apply (composite_initial_state_sub_projection s) in His.
  split; [|assumption].
  apply (initial_is_protocol Xj) in His as Hisp.
  induction tr using rev_ind; simpl
  ; [constructor; assumption|].
  apply finite_protocol_trace_from_app_iff in Htr.
  destruct Htr as [Htr Hx].
  spec IHtr.
  { intros pre item suf m Heq Hin_m Hitem.
    subst tr.
    specialize (Hmsg pre item (suf ++ [x]) m).
    rewrite! app_assoc in Hmsg.
    specialize (Hmsg eq_refl Hin_m Hitem).
    destruct Hmsg as [Hseed | Hmsg]
    ; [left | right] ; assumption.
  }
  spec IHtr Htr.
  rewrite finite_trace_sub_projection_app.
  apply finite_protocol_trace_from_app_iff.
  split; [assumption|].
  specialize (Hmsg tr x []).
  match goal with
  |- finite_protocol_trace_from _ ?l _ => remember l as lst
  end.
  assert (Hlst : protocol_state_prop Xj lst).
  { apply finite_ptrace_last_pstate in IHtr. subst. assumption. }
  simpl.
  destruct (decide (from_sub_projection x))
  ;[|constructor; assumption].
  apply (finite_ptrace_singleton Xj).
  inversion Hx. subst x tl. simpl in *.
  destruct H3 as [Hv Ht].
  specialize (transition_sub_projection _ _ _ _ _ Ht f)
    as Htj.
  destruct Hv as [_ [_ [Hv Hc]]].
  specialize (valid_sub_projection _ _ _ Hv f)
    as Hvj.
  rewrite <- H1 in Htj, Hvj.
  assert (Hlst' : composite_state_sub_projection s' = lst).
  { subst lst s'. symmetry.
    apply finite_trace_sub_projection_last_state. assumption.
  }
  rewrite Hlst' in Htj, Hvj.
  repeat split; [assumption | | assumption | | assumption].
  - destruct iom as [m|]; [|apply (option_protocol_message_None Xj)].
    apply (option_protocol_message_Some Xj).
    specialize (Hmsg m eq_refl eq_refl f).
    destruct Hmsg as [Hseed | [item [Hitem [Hout Hsub_item]]]]
    ; [apply (initial_message_is_protocol Xj); right; assumption|].
    specialize (finite_trace_sub_projection_list_in tr item Hitem Hsub_item)
      as Hin_sub.
    apply (protocol_trace_output_is_protocol Xj _ _ IHtr).
    apply Exists_exists. eexists _. split; [apply Hin_sub|].
    assumption.
  - apply Hno_equiv in Hc.
    destruct iom as [m|]; [|exact I].
    simpl in *.
    specialize (Hmsg m eq_refl eq_refl f).
    destruct Hmsg as [Hseed | [item [Hitem [Hout Hsub_item]]]]
    ; [right; right; assumption|].
    left.
    specialize (proper_sent Sub_Free lst) as Hproper.
    assert (Hlstp : protocol_state_prop (pre_loaded_with_all_messages_vlsm Sub_Free) lst).
    { apply VLSM_incl_protocol_state with (MX := machine Xj); [|assumption].
      apply Xj_incl_Pre_Sub_Free.
    }
    spec Hproper Hlstp.
    apply Hproper.
    apply has_been_sent_consistency; [apply Sub_Free_has_been_sent_capability| assumption| ].
    exists (composite_state_sub_projection s), (finite_trace_sub_projection tr).
    split.
    { split;[|assumption].
       apply (VLSM_incl_finite_protocol_trace_from_to _ _ Xj_incl_Pre_Sub_Free).
       apply ptrace_add_last.
       assumption.
       symmetry;assumption.
    }
    unfold trace_has_message.
    apply Exists_exists. exists (composite_transition_item_sub_projection item Hsub_item).
    split; [|assumption].
    apply finite_trace_sub_projection_list_in. assumption.
Qed.

Lemma protocol_state_sub_projection
  (s : state)
  (Hs : state_sub_item_input_is_seeded_or_sub_previously_sent s)
  (Hps : protocol_state_prop X s)
  : protocol_state_prop Xj (composite_state_sub_projection s).
Proof.
  apply protocol_state_has_trace in Hps.
  destruct Hps as [is [tr Htr]].
  specialize (Hs _ _ (VLSM_incl_finite_protocol_trace_init_to _ _ X_incl_Pre _ _ _ Htr)).
  apply ptrace_get_last in Htr as Hlst.
  apply ptrace_forget_last in Htr.
  specialize (finite_trace_sub_projection_last_state _ _ (proj1 Htr)) as Hlst'.
  apply (finite_protocol_trace_sub_projection _ _ Hs) in Htr as Hptr.
  - destruct Hptr as [Hptr _]. apply finite_ptrace_last_pstate in Hptr.
    simpl in *.
    rewrite Hlst' in Hptr.
    subst. assumption.
Qed.

Lemma finite_protocol_trace_from_sub_projection
  (s : composite_state IM)
  (tr : list (composite_transition_item IM))
  (lst := finite_trace_last s tr)
  (Hmsg : state_sub_item_input_is_seeded_or_sub_previously_sent lst)
  (Htr : finite_protocol_trace_from X s tr)
  : finite_protocol_trace_from Xj (composite_state_sub_projection s) (finite_trace_sub_projection tr).
Proof.
  apply finite_protocol_trace_from_complete_left in Htr.
  destruct Htr as [is [pre [Htr Hs]]].
  assert (Hpre := proj1 Htr).
  apply finite_protocol_trace_from_app_iff in Hpre.
  destruct Hpre as [Hpre _].
  specialize (finite_trace_sub_projection_last_state _ _ Hpre) as Hpre_lst.
  apply finite_protocol_trace_sub_projection in Htr.
  - destruct Htr as [Htr His].
    rewrite finite_trace_sub_projection_app in Htr.
    apply finite_protocol_trace_from_app_iff in Htr.
    destruct Htr as [_ Htr].
    subst s. simpl in *.
    rewrite Hpre_lst in Htr. assumption.
  - specialize (Hmsg is (pre ++ tr)).
    apply Hmsg.
    apply VLSM_incl_finite_protocol_trace_init_to;
    [apply X_incl_Pre|].
    apply ptrace_add_last.
    assumption.
    rewrite finite_trace_last_app.
    unfold lst. subst. reflexivity.
Qed.

Lemma in_futures_sub_projection
  (s1 s2 : state)
  (Hs2 : state_sub_item_input_is_seeded_or_sub_previously_sent s2)
  (Hfutures : in_futures X s1 s2)
  : in_futures Xj (composite_state_sub_projection s1) (composite_state_sub_projection s2).
Proof.
  destruct Hfutures as [tr Htr].
  apply ptrace_get_last in Htr as Heq_s2.
  apply ptrace_forget_last in Htr.
  subst s2.
  specialize (finite_protocol_trace_from_sub_projection s1 tr Hs2 Htr); intros Htrj.
  exists (finite_trace_sub_projection tr).
  apply ptrace_add_last;[assumption|].
  apply finite_trace_sub_projection_last_state.
  assumption.
Qed.

End sub_projection_with_no_equivocation_constraints.
End sub_composition.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleAdd.
 Variable w : Type.
 Variable w_0 : w.
 Variable w_1 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable w_W0 : w -> zn2z w.
 Variable ww_1 : zn2z w.
 Variable w_succ_c : w -> carry w.
 Variable w_add_c : w -> w -> carry w.
 Variable w_add_carry_c : w -> w -> carry w.
 Variable w_succ : w -> w.
 Variable w_add : w -> w -> w.
 Variable w_add_carry : w -> w -> w.

 Definition ww_succ_c x :=
  match x with
  | W0 => C0 ww_1
  | WW xh xl =>
    match w_succ_c xl with
    | C0 l => C0 (WW xh l)
    | C1 l =>
      match w_succ_c xh with
      | C0 h => C0 (WW h w_0)
      | C1 h => C1 W0
      end
    end
  end.

 Definition ww_succ x :=
  match x with
  | W0 => ww_1
  | WW xh xl =>
    match w_succ_c xl with
    | C0 l => WW xh l
    | C1 l => w_W0 (w_succ xh)
    end
  end.

 Definition ww_add_c x y :=
  match x, y with
  | W0, _ => C0 y
  | _, W0 => C0 x
  | WW xh xl, WW yh yl =>
    match w_add_c xl yl with
    | C0 l =>
      match w_add_c xh yh with
      | C0 h => C0 (WW h l)
      | C1 h => C1 (w_WW h l)
      end
    | C1 l =>
      match w_add_carry_c xh yh with
      | C0 h => C0 (WW h l)
      | C1 h => C1 (w_WW h l)
      end
    end
  end.

 Variable R : Type.
 Variable f0 f1 : zn2z w -> R.

 Definition ww_add_c_cont x y :=
  match x, y with
  | W0, _ => f0 y
  | _, W0 => f0 x
  | WW xh xl, WW yh yl =>
    match w_add_c xl yl with
    | C0 l =>
      match w_add_c xh yh with
      | C0 h => f0 (WW h l)
      | C1 h => f1 (w_WW h l)
      end
    | C1 l =>
      match w_add_carry_c xh yh with
      | C0 h => f0 (WW h l)
      | C1 h => f1 (w_WW h l)
      end
    end
  end.

 (* ww_add et ww_add_carry conserve la forme normale s'il n'y a pas
    de debordement *)
 Definition ww_add x y :=
  match x, y with
  | W0, _ => y
  | _, W0 => x
  | WW xh xl, WW yh yl =>
    match w_add_c xl yl with
    | C0 l => WW (w_add xh yh) l
    | C1 l => WW (w_add_carry xh yh) l
    end
  end.

 Definition ww_add_carry_c x y :=
  match x, y with
  | W0, W0 => C0 ww_1
  | W0, WW yh yl => ww_succ_c (WW yh yl)
  | WW xh xl, W0 => ww_succ_c (WW xh xl)
  | WW xh xl, WW yh yl =>
    match w_add_carry_c xl yl with
    | C0 l =>
      match w_add_c xh yh with
      | C0 h => C0 (WW h l)
      | C1 h => C1 (WW h l)
      end
    | C1 l =>
      match w_add_carry_c xh yh with
      | C0 h => C0 (WW h l)
      | C1 h => C1 (w_WW h l)
      end
    end
  end.

 Definition ww_add_carry x y :=
  match x, y with
  | W0, W0 => ww_1
  | W0, WW yh yl => ww_succ (WW yh yl)
  | WW xh xl, W0 => ww_succ (WW xh xl)
  | WW xh xl, WW yh yl =>
    match w_add_carry_c xl yl with
    | C0 l => WW (w_add xh yh) l
    | C1 l => WW (w_add_carry xh yh) l
    end
  end.

 (*Section DoubleProof.*)
  Variable w_digits : positive.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[+| c |]" :=
   (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99).
  Notation "[-| c |]" :=
   (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99).

  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).
  Notation "[+[ c ]]" :=
   (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, c at level 99).
  Notation "[-[ c ]]" :=
   (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c)
   (at level 0, c at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_w_1   : [|w_1|] = 1.
  Variable spec_ww_1   : [[ww_1]] = 1.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
  Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1.
  Variable spec_w_add_c  : forall x y, [+|w_add_c x y|] = [|x|] + [|y|].
  Variable spec_w_add_carry_c :
         forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1.
  Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB.
  Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB.
  Variable spec_w_add_carry :
	 forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB.

  Lemma spec_ww_succ_c : forall x, [+[ww_succ_c x]] = [[x]] + 1.
  Proof.
   destruct x as [ |xh xl];simpl. apply spec_ww_1.
   generalize (spec_w_succ_c xl);destruct (w_succ_c xl) as [l|l];
    intro H;unfold interp_carry in H. simpl;rewrite H;ring.
   rewrite <- Z.add_assoc;rewrite <- H;rewrite Z.mul_1_l.
   assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega.
   rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h];
    intro H1;unfold interp_carry in H1.
   simpl;rewrite H1;rewrite spec_w_0;ring.
   unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB.
   assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega.
   rewrite H2;ring.
  Qed.

  Lemma spec_ww_add_c  : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]].
  Proof.
   destruct x as [ |xh xl];trivial.
   destruct y as [ |yh yl]. rewrite Z.add_0_r;trivial.
   simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]))
   with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring.
   generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
    intros H;unfold interp_carry in H;rewrite <- H.
   generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
    intros H1;unfold interp_carry in *;rewrite <- H1. trivial.
   repeat rewrite Z.mul_1_l;rewrite spec_w_WW;rewrite wwB_wBwB; ring.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh)
    as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1.
   simpl;ring.
   repeat rewrite Z.mul_1_l;rewrite wwB_wBwB;rewrite spec_w_WW;ring.
  Qed.

  Section Cont.
   Variable P : zn2z w -> zn2z w -> R -> Prop.
   Variable x y : zn2z w.
   Variable spec_f0 : forall r, [[r]] = [[x]] + [[y]] -> P x y (f0 r).
   Variable spec_f1 : forall r, wwB + [[r]] = [[x]] + [[y]] -> P x y (f1 r).

   Lemma spec_ww_add_c_cont  : P x y (ww_add_c_cont x y).
   Proof.
    destruct x as [ |xh xl];trivial.
    apply spec_f0;trivial.
    destruct y as [ |yh yl].
    apply spec_f0;rewrite Z.add_0_r;trivial.
    simpl.
    generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
     intros H;unfold interp_carry in H.
    generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
     intros H1;unfold interp_carry in *.
    apply spec_f0. simpl;rewrite H;rewrite H1;ring.
    apply spec_f1. simpl;rewrite spec_w_WW;rewrite H.
    rewrite Z.add_assoc;rewrite wwB_wBwB. rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r.
    rewrite Z.mul_1_l in H1;rewrite H1;ring.
    generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh)
     as [h|h]; intros H1;unfold interp_carry in *.
    apply spec_f0;simpl;rewrite H1. rewrite Z.mul_add_distr_r.
    rewrite <- Z.add_assoc;rewrite H;ring.
    apply spec_f1. rewrite spec_w_WW;rewrite wwB_wBwB.
    rewrite Z.add_assoc; rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r.
    rewrite Z.mul_1_l in H1;rewrite H1. rewrite Z.mul_add_distr_r.
    rewrite <- Z.add_assoc;rewrite H; simpl; ring.
   Qed.

  End Cont.

  Lemma spec_ww_add_carry_c :
         forall x y, [+[ww_add_carry_c x y]] = [[x]] + [[y]] + 1.
  Proof.
   destruct x as [ |xh xl];intro y.
   exact (spec_ww_succ_c y).
   destruct y as [ |yh yl].
   rewrite Z.add_0_r;exact (spec_ww_succ_c (WW xh xl)).
   simpl; replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1)
   with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring.
   generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl)
    as [l|l];intros H;unfold interp_carry in H;rewrite <- H.
   generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h];
    intros H1;unfold interp_carry in H1;rewrite <- H1. trivial.
   unfold interp_carry;repeat rewrite Z.mul_1_l;simpl;rewrite wwB_wBwB;ring.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh)
    as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial.
   unfold interp_carry;rewrite spec_w_WW;
   repeat rewrite Z.mul_1_l;simpl;rewrite wwB_wBwB;ring.
  Qed.

  Lemma spec_ww_succ : forall x, [[ww_succ x]] = ([[x]] + 1) mod wwB.
  Proof.
   destruct x as [ |xh xl];simpl.
   rewrite spec_ww_1;rewrite Zmod_small;trivial.
   split;[intro;discriminate|apply wwB_pos].
   rewrite <- Z.add_assoc;generalize (spec_w_succ_c xl);
   destruct (w_succ_c xl) as[l|l];intro H;unfold interp_carry in H;rewrite <-H.
   rewrite Zmod_small;trivial.
   rewrite wwB_wBwB;apply beta_mult;apply spec_to_Z.
   assert ([|l|] = 0). clear spec_ww_1 spec_w_1 spec_w_0.
    assert (H1:= spec_to_Z l); assert (H2:= spec_to_Z xl); omega.
   rewrite H0;rewrite Z.add_0_r;rewrite <- Z.mul_add_distr_r;rewrite wwB_wBwB.
   rewrite Z.pow_2_r; rewrite Zmult_mod_distr_r;try apply lt_0_wB.
   rewrite spec_w_W0;rewrite spec_w_succ;trivial.
  Qed.

  Lemma spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB.
  Proof.
   destruct x as [ |xh xl];intros y.
   rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial.
   destruct y as [ |yh yl].
   change [[W0]] with 0;rewrite Z.add_0_r.
   rewrite Zmod_small;trivial.
    exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)).
   simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]))
   with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring.
   generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l];
   unfold interp_carry;intros H;simpl;rewrite <- H.
   rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial.
  Qed.

  Lemma spec_ww_add_carry :
	 forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB.
  Proof.
   destruct x as [ |xh xl];intros y.
   exact (spec_ww_succ y).
   destruct y as [ |yh yl].
   change [[W0]] with 0;rewrite Z.add_0_r. exact (spec_ww_succ (WW xh xl)).
   simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1)
   with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring.
   generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl)
   as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z.
   rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial.
   rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r.
   rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial.
  Qed.

(* End DoubleProof. *)
End DoubleAdd.


From iris.proofmode Require Import tactics.
From stdpp Require Import sets list.
From cap_machine Require Import addr_reg region.

Lemma disjoint_mono_l A C `{ElemOf A C} (X Y Z: C) : X ⊆ Y → Y ## Z → X ## Z.
Proof. intros * HXY. rewrite !elem_of_disjoint. eauto. Qed.

Lemma disjoint_mono_r A C `{ElemOf A C} (X Y Z: C) : X ⊆ Y → Z ## Y → Z ## X.
Proof. intros * HXY. rewrite !elem_of_disjoint. eauto. Qed.

Definition ByReflexivity (P: Prop) :=
  P.
Hint Extern 1 (ByReflexivity _) => reflexivity : disj_regions.

Definition AddrRegionRange (l: list Addr) (b e: Addr) :=
  ∀ a, a ∈ l → (b <= a)%a ∧ (a < e)%a.

Lemma AddrRegionRange_singleton a :
  ByReflexivity (eqb_addr a top = false) →
  AddrRegionRange [a] a (^(a+1))%a.
Proof.
  unfold eqb_addr. unfold ByReflexivity. cbn. intros ?%Z.eqb_neq.
  intros a' ->%elem_of_list_singleton. solve_addr.
Qed.
Hint Resolve AddrRegionRange_singleton : disj_regions.

Lemma AddrRegionRange_region_addrs b e :
  AddrRegionRange (region_addrs b e) b e.
Proof.
  intros a ?%elem_of_region_addrs. solve_addr.
Qed.
Hint Resolve AddrRegionRange_region_addrs : disj_regions.

Definition AddrRegionsRange (ll: list (list Addr)) (b e: Addr) :=
  ∀ l a, l ∈ ll → a ∈ l → (b <= a)%a ∧ (a < e)%a.

Lemma AddrRegionsRange_single l b e :
  AddrRegionRange l b e →
  AddrRegionsRange [l] b e.
Proof.
  intros Hl l' a ->%elem_of_list_singleton ?%Hl. solve_addr.
Qed.
Hint Resolve 1 AddrRegionsRange_single : disj_regions.

Lemma AddrRegionsRange_cons l ll b e b' e' :
  AddrRegionRange l b e →
  AddrRegionsRange ll b' e' →
  AddrRegionsRange (l :: ll) (min b b') (max e e').
Proof.
  intros Hl Hll l' a [->|H]%elem_of_cons.
  - intros ?%Hl. solve_addr.
  - intros ?%Hll; auto. solve_addr.
Qed.
Hint Resolve 10 AddrRegionsRange_cons : disj_regions.

Instance Empty_list {A}: Empty (list A). exact []. Defined.
Instance Union_list {A}: Union (list A). exact app. Defined.
Instance Singleton_list {A}: Singleton A (list A). exact (λ a, [a]). Defined.

Lemma addr_range_union_incl_range (ll: list (list Addr)) (b e: Addr):
  AddrRegionsRange ll b e →
  ⋃ ll ⊆ region_addrs b e.
Proof.
  revert b e. induction ll as [| l ll].
  - intros. cbn. unfold subseteq, list_subseteq. unfold empty, Empty_list.
    inversion 1.
  - intros b e HInd. cbn. unfold union, Union_list, subseteq, list_subseteq.
    intros x. intros [Hx|Hx]%elem_of_app.
    + specialize (HInd l x ltac:(constructor) Hx). apply elem_of_region_addrs.
      solve_addr.
    + assert (HI: AddrRegionsRange ll b e).
      { intros ? ? ? ?. eapply HInd. apply elem_of_list_further; eassumption.
        auto. }
      specialize (IHll _ _ HI).
      rewrite elem_of_subseteq in IHll |- * => IHll.
      by apply IHll.
Qed.

Lemma AddrRegionRange_iff_incl_region_addrs l b e :
  AddrRegionRange l b e ↔ (l ⊆ region_addrs b e).
Proof.
  unfold AddrRegionRange, subseteq, list_subseteq.
  split.
  - intros H **. rewrite elem_of_region_addrs. by apply H.
  - intros H **. rewrite -elem_of_region_addrs. by apply H.
Qed.

Lemma addr_range_disj_union_empty (l: list Addr) :
  l ## ⋃ [].
Proof.
  cbn. unfold empty, Empty_list, disjoint_list, disjoint.
  unfold set_disjoint. intros * ? ?%elem_of_nil. auto.
Qed.
Hint Resolve 1 addr_range_disj_union_empty : disj_regions.

Lemma addr_range_disj_range_union (l: list Addr) ll b e b' e':
  AddrRegionRange l b e →
  AddrRegionsRange ll b' e' →
  ByReflexivity ((e <=? b') || (e' <=? b) = true)%a →
  l ## ⋃ ll.
Proof.
  intros Hl Hll. unfold ByReflexivity.
  rewrite orb_true_iff /leb_addr !Z.leb_le.
  intros.
  rewrite AddrRegionRange_iff_incl_region_addrs in Hl |- * => Hl.
  eapply disjoint_mono_l; eauto.
  eapply disjoint_mono_r. eapply addr_range_union_incl_range; eauto.
  unfold disjoint, disjoint_list, set_disjoint.
  intro. rewrite !elem_of_region_addrs. solve_addr.
Qed.
Hint Resolve 10 addr_range_disj_range_union : disj_regions.

Lemma addr_disjoint_list_empty : ## ([]: list (list Addr)).
Proof. constructor. Qed.
Hint Resolve addr_disjoint_list_empty : disj_regions.

Lemma addr_disjoint_list_cons (l: list Addr) ll :
  l ## ⋃ ll →
  ## ll →
  ## (l :: ll).
Proof. intros. rewrite disjoint_list_cons; auto. Qed.
Hint Resolve addr_disjoint_list_cons : disj_regions.

Ltac disj_regions :=
  once (typeclasses eauto with disj_regions).