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

Require Export Categories PredomCore NSetoid.

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

(** printing T0 %\ensuremath{T_0}% *)
(** printing T1 %\ensuremath{T_1}% *)
(** printing T2 %\ensuremath{T_2}% *)
(** printing T3 %\ensuremath{T_3}% *)
(** printing T4 %\ensuremath{T_4}% *)
(** printing T5 %\ensuremath{T_5}% *)
(** printing T6 %\ensuremath{T_6}% *)

Open Scope C_scope.

(*=Enriched *)
Module BaseCat.
  Record mixin_of (O:Type) (M:O -> O -> cppoType) := Mixin
  { catm :> Category.mixin_of M;
    terminal :> CatTerminal.mixin_of (Category.Pack catm O);
    comp : forall X Y Z : O, M Y Z * M X Y =-> M X Z;
    comp_comp : forall X Y Z m m', comp X Y Z (m,m') =-= Category.tcomp catm m m'
  }. (*CLEAR*)
  Notation class_of := mixin_of (only parsing).
(*CLEARED*)
  Section ClassDef.
  Definition base2 T (M:T -> T -> cppoType) (c:class_of M) := CatTerminal.Class c. (*CLEAR*)
  Local Coercion base2 : class_of >-> CatTerminal.class_of.

  Structure cat := Pack {object; morph : object -> object -> cppoType ; _ : class_of morph; _ : Type}.
  Local Coercion object : cat >-> Sortclass.
  Local Coercion morph : cat >-> Funclass.
  Definition class cT := let: Pack _ _ c _ := cT return class_of (@morph cT) in c.
  Definition unpack (K:forall O (M:O -> O -> cppoType) (c:class_of M), Type)
              (k : forall O (M: O -> O -> cppoType) (c : class_of M), K _ _ c) (cT:cat) :=
    let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
  Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
  Definition pack T M c := @Pack T M c T.
 (*CLEARED*)
  Definition terminalCat (cT:cat) : terminalCat := CatTerminal.Pack (class cT) cT.
  Definition catType (cT:cat) : catType := Category.Pack (class cT) cT. (*CLEAR*)
  Definition ordType (cT:cat) (X Y:cT) : ordType := PreOrd.Pack (CPPO.class (morph X Y)) (cT X Y).
  Definition cpoType (cT:cat) (X Y:cT) : cpoType := CPO.Pack (CPPO.class (morph X Y)) (cT X Y).
(*CLEARED*)
  Definition cppoType (cT:cat) (X Y:cT) : cppoType :=
               CPPO.Pack (CPPO.class (morph X Y)) (cT X Y). (*CLEAR*)
  Definition pointedType (cT:cat) (X Y:cT) : pointedType := Pointed.Pack (CPPO.class (morph X Y)) (cT X Y).
  End ClassDef.
  Module Import Exports.
  Coercion terminalCat : cat >-> CatTerminal.cat.
Coercion base2 : class_of >-> CatTerminal.class_of.
Coercion object : cat >-> Sortclass.
  Coercion morph : cat >-> Funclass.
Canonical Structure BaseCat.terminalCat.
Canonical Structure BaseCat.catType.
Canonical Structure BaseCat.ordType.
Canonical Structure BaseCat.cpoType.
Canonical Structure BaseCat.pointedType.
Canonical Structure BaseCat.cppoType.
Notation cppoMorph := BaseCat.cppoType. (*CLEAR*)
Notation cppoECat := BaseCat.cat.
Notation CppoECatMixin := BaseCat.Mixin.
(*CLEARED*)
Notation CppoECatType := BaseCat.pack.
(*CLEARED*)
End Exports.
End BaseCat. (*CLEAR*)
Export BaseCat.Exports.
(*CLEARED*)
(*=End *)

Definition getmorph (C:cppoECat) (X Y : C) (f:CPPO.cpoType (@BaseCat.cppoType C X Y)) : C X Y := f.
Coercion getmorph : cppoECat >-> Funclass.

Definition ccomp (cT:cppoECat) (X Y Z : cT) : cppoMorph Y Z * cppoMorph X Y =-> cppoMorph X Z := BaseCat.comp (BaseCat.class cT) X Y Z.

Lemma ccomp_eq (cT:cppoECat) (X Y Z : cT) (f : cT Y Z) (f' : cT X Y) : ccomp X Y Z (f,f') =-= f << f'.
unfold Category.comp. unfold ccomp. simpl. case:cT X Y Z f f'. simpl.
move => O M. case. simpl.
move => C T comp ce T' X Y Z f g. by apply: ce.
Qed.

Add Parametric Morphism (M:cppoECat) (X Y Z:M) : (@Category.comp M X Y Z)
  with signature (@Ole (cppoMorph Y Z)) ++> (@Ole (cppoMorph X Y)) ++> (@Ole (cppoMorph X Z))
  as comp_le_compat.
move => f f' l g g' l'.
have e:= (ccomp_eq f g).  have e':=ccomp_eq f' g'. rewrite <- e. rewrite <- e'. apply: fmonotonic.
by split.
Qed.

Section Msolution.
Variable M:cppoECat.

Open Scope C_scope.
Open Scope S_scope.

(*=BiFunctor *)
Record BiFunctor : Type := mk_functor
{ ob : M -> M -> M ;
  morph : forall (T0 T1 T2 T3 : M), (cppoMorph T1 T0) * (cppoMorph T2 T3) =->
                                    (cppoMorph (ob T0 T2) (ob T1 T3)) ;
  morph_comp: forall T0 T1 T2 T3 T4 T5 (f:M T4 T1) (g:M T3 T5) (h:M T1 T0)
    (k:M T2 T3), getmorph (morph T1 T4 T3 T5 (f,g)) << (morph T0 T1 T2 T3 (h, k)) =-=
                                            morph _ _ _ _ (h << f, g << k) ;
  morph_id : forall T0 T1, morph T0 T0 T1 T1 (Id:M _ _, Id:M _ _) =-= (Id : M _ _)}.
(*=End *)

Definition eppair T0 T1 (f:M T0 T1) (g:M T1 T0) :=
      g << f =-= Id /\ f << g <= @Category.id M _.

(*=Tower *)
Record Tower : Type := mk_tower
{ tobjects : nat -> M;
  tmorphisms : forall i, (tobjects (S i)) =-> (tobjects i);
  tmorphismsI : forall i, (tobjects i) =-> (tobjects (S i));
  teppair : forall i, eppair (tmorphismsI i) (tmorphisms i)}.
(*=End *)

(*=Cone *)
Record Cone (To:Tower) : Type := mk_basecone
{ tcone :>  M;
  mcone : forall i, tcone =-> (tobjects To i);
  mconeCom : forall i, tmorphisms To i << mcone (S i) =-= mcone i }.
(*=End *)

Record CoCone (To:Tower) : Type := mk_basecocone
{ tcocone :> M;
  mcocone : forall i, (tobjects To i) =-> tcocone;
  mcoconeCom : forall i, mcocone (S i) << tmorphismsI To i =-= mcocone i }.

(*=CoLimit *)
Record CoLimit (To:Tower) : Type := mk_basecolimit
{ lcocone :> CoCone To;
  colimitExists : forall (A:CoCone To), (tcocone lcocone) =-> (tcocone A) ;
  colimitCom : forall (A:CoCone To), forall n, mcocone A n =-= colimitExists A << mcocone lcocone n;
  colimitUnique : forall (A:CoCone To) (h: (tcocone lcocone) =-> (tcocone A))
     (C:forall n, mcocone A n =-= h << mcocone lcocone n), h =-= colimitExists A }.
(*=End *)

(*=Limit *)
Record Limit (To:Tower) : Type := mk_baselimit
{lcone :> Cone To;
 limitExists : forall (A:Cone To), (tcone A) =-> (tcone lcone);
 limitCom : forall (A:Cone To), forall n, mcone A n =-= mcone lcone n << limitExists A;
 limitUnique : forall (A:Cone To) (h: (tcone A) =-> (tcone lcone))
    (C:forall n, mcone A n =-= mcone lcone n << h), h =-= limitExists A }.

Variable L:forall T:Tower, Limit T.
(*=End *)

Section RecursiveDomains.

Variable F : BiFunctor.

Add Parametric Morphism C X Y Z W : (fun (x: Y =-> X) (y: Z =-> W) => @morph C X Y Z W (pair x y))
  with signature (@tset_eq _) ==> (@tset_eq _) ==> (@tset_eq _)
  as morph_eq_compat.
move => x x' e y y' e'. apply: fmon_stable. by split ; split ;case: e ; case: e'.
Qed.

Lemma BiFuncRtoR: forall (T0 T1:M) (f: T0 =-> T1) (g: T1 =-> T0), eppair f g ->
          eppair (morph F _ _ _ _ (g,f)) (morph F _ _ _ _ (f,g)).
move => A B f g. case => e r. split.
- rewrite -> (morph_comp F f g g f). rewrite -> (morph_eq_compat F e e).
  by rewrite morph_id.
- rewrite morph_comp. rewrite -> (pair_le_compat r r). by rewrite morph_id.
Qed.

Section Tower.

Variable DTower : Tower.

Lemma lt_gt_dec n m : (n < m) + (m = n) + (m < n).
case: (ltngtP m n) => e.
- by right.
- left. by left.
- left. by right.
Qed.

Lemma leqI m n : (m <= n)%N = false -> n <= m.
move => I. have t:=(leq_total m n). rewrite I in t. by apply t.
Qed.

Lemma lt_subK n m : m < n -> n = (n - m + m)%N.
move => l. apply sym_eq. apply subnK. have x:= (leqnSn m). by apply (leq_trans x l).
Qed.

(*=Projections *)
Definition Diter_coercion n m : n = m ->
             M (tobjects DTower n) (tobjects DTower m) :=
  fun e => eq_rect_r (fun n : nat => M (tobjects DTower n) _) Id e.

Fixpoint Projection_nm m (n:nat) :
          (tobjects DTower (n+m)) =-> (tobjects DTower m) :=
match n with
| O => Id
| S n => Projection_nm m n << tmorphisms DTower (n+m)%N
end.

Fixpoint Injection_nm m (n:nat) :
          (tobjects DTower m) =-> (tobjects DTower (n+m)) :=
match n with
| O => Id
| S n => tmorphismsI DTower (n+m) << Injection_nm m n
end.

Definition t_nm n m : (tobjects DTower n) =-> (tobjects DTower m) :=
match (lt_gt_dec m n) with
| inl (inl ee) =>
     (Projection_nm m (n - m)%N) << (Diter_coercion (lt_subK ee))
| inl (inr ee) => Diter_coercion ee
| inr ee => Diter_coercion (sym_eq (lt_subK ee)) << Injection_nm n (m - n)
end.
(*=End *)

Lemma Diter_coercion_simpl: forall n (Eq:n = n), Diter_coercion Eq = Id.
intros n Eq. by rewrite (eq_irrelevance Eq (refl_equal _)).
Qed.

Lemma Proj_left_comp : forall k m, Projection_nm m (S k) =-=
                      tmorphisms DTower m << Projection_nm (S m) k << Diter_coercion (sym_eq (addnS k m)).
elim.
- move => m. simpl.
  rewrite comp_idL. rewrite comp_idR.
  rewrite (Diter_coercion_simpl). by rewrite -> comp_idR.
- move => n IH m. simpl. simpl in IH. rewrite -> IH.
  have P:=(sym_eq (addnS n m)). rewrite (eq_irrelevance (sym_eq (addnS n m)) P).
  have Q:=(sym_eq (addnS n.+1 m)). rewrite (eq_irrelevance (sym_eq (addnS n.+1 m)) Q).
  move: P Q. unfold addn. simpl. fold addn. move => P. generalize P. rewrite P. clear P.
  move => P Q. do 2 rewrite Diter_coercion_simpl.
  do 2 rewrite comp_idR. clear P Q. by rewrite comp_assoc.
Qed.

Lemma Inject_right_comp: forall k m, Injection_nm m (S k) =-=
           Diter_coercion (addnS k m) << Injection_nm (S m) k << tmorphismsI DTower m.
elim.
- move => m. simpl. do 2 rewrite comp_idR. rewrite (Diter_coercion_simpl). by rewrite -> comp_idL.
- move => n IH m. simpl. simpl in IH. rewrite -> IH. clear IH.
  have P:= (addnS n.+1 m). have Q:=(addnS n m). rewrite -> (eq_irrelevance _ P).
  rewrite -> (eq_irrelevance _ Q). move: P Q. unfold addn. simpl. fold addn.
  move => P Q. generalize P Q. rewrite <- Q. clear P Q. move => P Q. do 2 rewrite Diter_coercion_simpl.
  do 2 rewrite comp_idL. by rewrite comp_assoc.
Qed.

Lemma Diter_coercion_comp: forall x y z (Eq1:x = y) (Eq2 : y = z),
     Diter_coercion Eq2 << Diter_coercion Eq1 =-= Diter_coercion (trans_equal Eq1 Eq2).
intros x y z Eq1. generalize Eq1. rewrite Eq1. clear x Eq1.
intros Eq1 Eq2. generalize Eq2. rewrite <- Eq2. clear Eq2. intros Eq2.
repeat (rewrite Diter_coercion_simpl). by rewrite -> comp_idL.
Qed.

Lemma Diter_coercion_eq n m (e e': n = m) : Diter_coercion e =-= Diter_coercion e'.
by rewrite (eq_irrelevance e e').
Qed.

Lemma lt_gt_dec_lt n m : n < m -> exists e, lt_gt_dec n m = inl _ (inl _ e).
move => e. case_eq (lt_gt_dec n m) ; first case.
- move => i _. by exists i.
- move => f. rewrite f in e. by rewrite ltnn in e.
- move => f. have a:=leq_trans (leqnSn _) f. have Ff:=leq_ltn_trans a e. by rewrite ltnn in Ff.
Qed.

Lemma lt_gt_dec_gt n m : m < n -> exists e, lt_gt_dec n m = (inr _ e).
move => e. case_eq (lt_gt_dec n m) ; first case.
- move => i _. have a:=leq_trans (leqnSn _) i. have Ff:=leq_ltn_trans a e. by rewrite ltnn in Ff.
- move => f. rewrite f in e. by rewrite ltnn in e.
- move => i _. by exists i.
Qed.

Lemma lt_gt_dec_eq n m : forall e : m = n, lt_gt_dec n m = (inl _ (inr _ e)).
move => e ; generalize e ; rewrite e. clear e m => e.
case_eq (lt_gt_dec n n) ; first case.
- move => i _. have f:=i. by rewrite ltnn in f.
- move => f _. by rewrite (eq_irrelevance e f).
- move => i _. have f:=i. by rewrite ltnn in f.
Qed.

Lemma t_nmProjection: forall n m, t_nm n m =-= tmorphisms DTower m << t_nm n (S m).
move => n m. unfold t_nm. case (lt_gt_dec m n) ; first case.
- case (lt_gt_dec m.+1 n) ; first case.
  + move => l l'. rewrite comp_assoc.
    have X:=Proj_left_comp (n - m.+1) m. have XX:= addnS (n - m.+1) m.
    have Y:=comp_eq_compat X (tset_refl (Diter_coercion XX)).
    repeat (rewrite <- comp_assoc in Y). rewrite -> Diter_coercion_comp in Y.
    rewrite Diter_coercion_simpl in Y. rewrite -> comp_idR in Y. rewrite <- Y.
    rewrite <- comp_assoc. rewrite Diter_coercion_comp.
    have P:=(trans_equal (lt_subK l) XX). have Q:=(lt_subK l').
    rewrite -> (eq_irrelevance _ P). rewrite -> (eq_irrelevance _ Q).
    move: P Q.
    have ee:(n - m).-1 = (n - m.+1) by rewrite <- subnSK.
    rewrite <- ee. clear ee. rewrite <- subn_gt0 in l'.
    have AA:((n - m).-1 + m).+1 = ((n - m).-1.+1 + m) %N by [].
    move => P. have PP:n = ((n - m).-1.+1 + m)%N by [].
    rewrite (eq_irrelevance P PP). move: PP. rewrite (ltn_predK l'). clear. move => PP Q.
    by rewrite (eq_irrelevance Q PP).
  + move => e. generalize e. rewrite e. clear n e. move => e i. have x:= subSnn m.
    have a:=(lt_subK (n:=m.+1) (m:=m) i). rewrite (eq_irrelevance (lt_subK (n:=m.+1) (m:=m) i) a).
    move: a. rewrite x. clear x. move => a. rewrite (eq_irrelevance e a). simpl. by rewrite comp_idL.
  + move => i j. have Ff:=leq_trans i j. by rewrite ltnn in Ff.
- move => e. generalize e. rewrite e. clear n e. move => e. destruct (lt_gt_dec_gt (leqnn (S m))) as [p A].
  rewrite A. clear A.
  have ee:=subSnn m. have x:=(sym_eq (lt_subK (n:=m.+1) (m:=m) p)).
  rewrite <- (eq_irrelevance x (sym_eq (lt_subK (n:=m.+1) (m:=m) p))). move: x. rewrite ee. simpl.
  move => x. do 2 rewrite (Diter_coercion_simpl). rewrite comp_idL. rewrite comp_idR.
  unfold addn. simpl. by rewrite -> (proj1 (teppair DTower m)).
- move => i. have l:=leq_trans i (leqnSn m). destruct (lt_gt_dec_gt l) as [p A]. rewrite A. clear A l.
  have x:=(sym_eq (lt_subK (n:=m.+1) (m:=n) p)). rewrite (eq_irrelevance (sym_eq (lt_subK (n:=m.+1) (m:=n) p)) x).
  move: x. rewrite subSn ; last by [].
  simpl. move => x. do 2 rewrite comp_assoc.
  refine (comp_eq_compat _ (tset_refl (Injection_nm n (m-n)))).
  have y:=(sym_eq (lt_subK (n:=m) (m:=n) i)).
  rewrite (eq_irrelevance (sym_eq (lt_subK (n:=m) (m:=n) i)) y).
  have a:=(trans_eq (sym_eq (addSn _ _)) x).
  rewrite (eq_irrelevance x a). clear x.
  apply tset_trans with (y:=(tmorphisms DTower m << Diter_coercion a) << tmorphismsI DTower (m - n + n)) ; last by [].
  move: a. generalize y. rewrite -> y. clear. move => y a. do 2 rewrite Diter_coercion_simpl.
  rewrite comp_idR. by rewrite (proj1 (teppair DTower m)).
Qed.

Lemma t_nn_ID: forall n, t_nm n n =-= Id.
intros n.
unfold t_nm. rewrite (lt_gt_dec_eq (refl_equal n)). by rewrite Diter_coercion_simpl.
Qed.

Lemma t_nmProjection2 n m : (m <= n) % nat -> t_nm (S n) m =-= (t_nm n m) << tmorphisms DTower n.
move => nm.
assert (exists x, n - m = x) as X by (exists (n - m) ; auto).
destruct X as [x X]. elim: x n m X nm.
- move => n m E EE. have e:=eqn_leq n m. rewrite EE in e. have l:(n <= m)%N. unfold leq. by rewrite E.
  rewrite l in e. have ee:=eqP e. rewrite ee. rewrite t_nn_ID. rewrite comp_idL.
  rewrite -> t_nmProjection. rewrite t_nn_ID. by rewrite comp_idR.
- move => nm IH. case ; first by []. move => n m e l. have ll:n.+1 - m > 0 by rewrite e. rewrite subn_gt0 in ll.
  rewrite subSn in e ; last by []. specialize (IH n m). have ee: n - m = nm by auto.
  rewrite -> (IH ee ll).
  clear IH. have l0:=leq_trans ll (leqnSn _). destruct (lt_gt_dec_lt l0) as [p A].
  unfold t_nm. rewrite A. clear A. case_eq (lt_gt_dec m n) ; first case.
  + move => p' _. have x:=(lt_subK (n:=n.+2) (m:=m) p). rewrite (eq_irrelevance (lt_subK (n:=n.+2) (m:=m) p) x).
    move: x. have x:n.+2 - m = (n-m).+2. rewrite subSn ; last by []. rewrite subSn ; by [].
    rewrite x. clear x. move => x. simpl. do 4 rewrite <- comp_assoc.
    refine (comp_eq_compat (tset_refl (Projection_nm m _)) _).
    have x':=(lt_subK (n:=n) (m:=m) p'). rewrite (eq_irrelevance (lt_subK (n:=n) (m:=m) p') x').
    have x1:((n - m).+2 + m)%N = ((n - m) + m).+2 by [].
    have x2:=trans_eq x x1.
    apply tset_trans with (y:=tmorphisms DTower (n - m + m) << (tmorphisms DTower (S(n - m + m)) << Diter_coercion x2)) ;
    first by simpl ; rewrite (eq_irrelevance x2 x).
    move: x2. generalize x' ; rewrite <- x'. clear x' x x1 p p'. move => x x'. do 2 rewrite (Diter_coercion_simpl).
    rewrite comp_idR. by rewrite -> comp_idL.
  + move => e'. generalize e'. move: p. rewrite e'. clear e' n l ll e l0 ee. move => p e _.
    rewrite (Diter_coercion_simpl). rewrite comp_idL.
    have x:=(lt_subK (n:=m.+2) (m:=m) p).
    have ee:(m.+2 - m) = (m - m).+2. rewrite subSn ; last by []. rewrite subSn ; by [].
    rewrite (eq_irrelevance (lt_subK (n:=m.+2) (m:=m) p) x). generalize x. rewrite ee. clear ee. rewrite subnn.
    move => xx. clear x e p. simpl. rewrite comp_idL.
    rewrite (Diter_coercion_simpl). by rewrite -> comp_idR.
  + move => f. have lx:=leq_trans f ll. by rewrite ltnn in lx.
Qed.

Lemma t_nmEmbedding: forall n i, t_nm n i =-= (t_nm (S n) i) << tmorphismsI DTower n.
intros n m. unfold t_nm. case (lt_gt_dec m n) ; first case.
- move => i. have l:=leq_trans i (leqnSn _). destruct (lt_gt_dec_lt l) as [p A]. rewrite A. clear A l.
  have x:=((lt_subK p)). rewrite (eq_irrelevance ((lt_subK p)) x).
  move: x. rewrite subSn ; last by []. simpl. move => x. do 2 rewrite <- comp_assoc.
  refine (comp_eq_compat (tset_refl (Projection_nm _ _)) _). have y:=((lt_subK i)).
  rewrite (eq_irrelevance ((lt_subK i)) y). have a:=(trans_eq x ((addSn _ _))).
  rewrite (eq_irrelevance x a).
  apply tset_trans with (y:=tmorphisms DTower (n - m + m) << (Diter_coercion a << tmorphismsI DTower n)) ; last by [].
  move: a. generalize y. rewrite <- y. clear. move => y a. do 2 rewrite Diter_coercion_simpl.
  rewrite comp_idL. by rewrite <- (proj1 (teppair DTower n)).
- move => e. generalize e. rewrite e. clear n e. move => e. destruct (lt_gt_dec_lt (leqnn (S m))) as [p A].
  rewrite A. clear A.
  have ee:=subSnn m. have x:=((lt_subK (n:=m.+1) (m:=m) p)).
  rewrite <- (eq_irrelevance x ((lt_subK (n:=m.+1) (m:=m) p))). move: x. rewrite ee. simpl.
  move => x. do 2 rewrite (Diter_coercion_simpl). rewrite comp_idR. rewrite comp_idL.
  by rewrite -> (proj1 (teppair DTower m)).
- case (lt_gt_dec m n.+1) ; first case.
  + move => i j. have Ff:=leq_trans i j. by rewrite ltnn in Ff.
  + move => e. generalize e. rewrite <- e. clear m e. move => e i. have x:= subSnn n.
    have a:=(lt_subK i). rewrite (eq_irrelevance (lt_subK i) a).
    move: a. rewrite x. clear x. move => a. rewrite (eq_irrelevance (sym_eq a) e).
    simpl. by rewrite comp_idR.
  + move => l l'. rewrite <- comp_assoc. have X:=Inject_right_comp (m - n.+1) n. have XX:= sym_eq (addnS (m - n.+1) n).
    have Y:=comp_eq_compat (tset_refl (Diter_coercion XX)) X. rewrite -> comp_assoc in Y.
    rewrite -> (comp_assoc (Injection_nm _ _)) in Y. rewrite -> Diter_coercion_comp in Y.
    rewrite Diter_coercion_simpl in Y. rewrite -> comp_idL in Y. rewrite <- Y.
    rewrite comp_assoc. rewrite Diter_coercion_comp.
    have ee:=(trans_equal XX (sym_eq (lt_subK l))). rewrite -> (eq_irrelevance _ ee).
    clear XX X Y. have e:m - n.+1 = (m - n).-1 by rewrite subnS.
    move: ee. rewrite -> e. generalize l'. have LL:=l'. rewrite <- subn_gt0 in l'.
    have PP:((m - n).-1.+1 + n)%N = m. rewrite -> (ltn_predK l').
       by rewrite subnK ; [by [] |apply ltnW]. clear LL l'.
    move => l' Q.
    rewrite (eq_irrelevance Q PP). move: PP. have P:=(sym_eq (lt_subK l')). rewrite -> (eq_irrelevance _ P).
    move: P. clear Q. clear e. move => P Q. move: P.
    have QQ:=l'. rewrite <- subn_gt0 in QQ.
    rewrite -{1 2 3 4} (ltn_predK QQ).
    move => P. by rewrite (eq_irrelevance P Q).
Qed.

Lemma t_nmEmbedding2: forall n m, (n <= m) % nat -> t_nm n (S m) =-= tmorphismsI DTower m << t_nm n m.
move => n m nm.
assert (exists x, m - n = x) as X by (eexists ; apply refl_equal).
destruct X as [x X]. elim: x n m X nm.
- move => n m E EE. have e:=eqn_leq n m. rewrite EE in e. have l:(m <= n)%N. unfold leq. by rewrite E.
  rewrite l in e. have ee:=eqP e. rewrite ee. rewrite -> t_nn_ID. rewrite comp_idR.
  rewrite -> t_nmEmbedding. rewrite t_nn_ID. by rewrite comp_idL.
- move => nm IH. move => n. case ; first by []. move => m e l. have ll:m.+1 - n > 0 by rewrite e. rewrite subn_gt0 in ll.
  rewrite subSn in e ; last by []. specialize (IH n m). have ee:m - n = nm by auto.
  rewrite (IH ee ll). clear IH. have l0:=leq_trans ll (leqnSn _). destruct (lt_gt_dec_gt l0) as [p A].
  unfold t_nm. rewrite A. clear A. case_eq (lt_gt_dec m n) ; first case.
  + move => f. have lx:=leq_trans f ll. by rewrite ltnn in lx.
  + move => e'. generalize e'. move: p. rewrite e'. clear e' n l ll e l0 ee. move => p e _.
    rewrite (Diter_coercion_simpl). rewrite comp_idR. have x:=(lt_subK p).
    have ee:(m.+2 - m) = (m - m).+2. rewrite subSn ; last by []. rewrite subSn ; by [].
    rewrite (eq_irrelevance (lt_subK (n:=m.+2) (m:=m) p) x). generalize x. rewrite ee. clear ee. rewrite subnn.
    move => xx. clear x e p. simpl. rewrite (Diter_coercion_simpl). rewrite -> comp_idL. by rewrite comp_idR.
  + move => p' _. have x:=(lt_subK p). rewrite (eq_irrelevance (lt_subK p) x).
    move: x. have x:m.+2 - n = (m-n).+2. rewrite subSn ; last by []. rewrite subSn ; by [].
    rewrite x. clear x. move => x. simpl. do 4 rewrite -> comp_assoc. refine (comp_eq_compat _ (tset_refl (Injection_nm _ _))).
    have x':=sym_eq(lt_subK p'). rewrite (eq_irrelevance (sym_eq (lt_subK _)) x').
    have x1:((m - n).+2 + n)%N = ((m - n) + n).+2 by [].
    have x2:=sym_eq (trans_eq x x1).
    apply tset_trans with (y:=(Diter_coercion x2 << tmorphismsI DTower (S (m - n + n))) << tmorphismsI DTower ((m - n + n))) ;
    first by simpl ; rewrite (eq_irrelevance x2 (sym_eq x)).
    move: x2. generalize x' ; rewrite x'. clear x' x x1 p p'. move => x x'. do 2 rewrite (Diter_coercion_simpl).
    rewrite -> comp_idR. by rewrite comp_idL.
Qed.

Lemma t_nm_EP i n : (i <= n)%N -> eppair (t_nm i n) (t_nm n i).
have e:exists x, x == n - i by eexists.
case: e => x e. elim: x i n e.
- move => i n e l. have ee:i = n. apply anti_leq. rewrite l. simpl. unfold leq. by rewrite <- (eqP e).
  rewrite -> ee. split.
  + rewrite t_nn_ID. by rewrite comp_idL.
  + apply Oeq_le. rewrite t_nn_ID. by rewrite comp_idL.
- move => x IH i. case ; first by rewrite sub0n.
  move => n e l. have ll:(i <= n)%N. have aa:0 < n.+1 - i. by rewrite <- (eqP e). rewrite subn_gt0 in aa. by apply aa.
  clear l. specialize (IH i n). rewrite (subSn ll) in e. specialize (IH e ll). split.
  + rewrite (t_nmProjection2 ll). rewrite -> (t_nmEmbedding2 ll). rewrite comp_assoc.
    rewrite <- (comp_assoc (tmorphismsI _ _)). rewrite (proj1 (teppair DTower n)). rewrite comp_idR. by apply (proj1 IH).
  + rewrite -> (t_nmEmbedding2 ll). rewrite (t_nmProjection2 ll).
    rewrite comp_assoc. rewrite <- (comp_assoc (t_nm n i)).
    rewrite -> (comp_le_compat (comp_le_compat (Ole_refl _) (proj2 IH)) (Ole_refl _)).
    rewrite comp_idR. by rewrite -> (proj2 (teppair DTower n)).
Qed.

Definition coneN (n:nat) : Cone DTower.
exists (tobjects DTower n) (t_nm n).
move => m. simpl. by rewrite  ->(t_nmProjection n m).
Defined.

Lemma coneCom_l (X:Cone DTower) n i : (i <= n)%nat -> mcone X i =-= t_nm n i << mcone X n.
move => l.
assert (exists x, n - i = x) as E by (eexists ; auto).
destruct E as [x E]. elim: x n i l E.
- move => n i l E. have A:=@anti_leq n i. rewrite l in A.  unfold leq in A. rewrite E in A.
  rewrite andbT in A. specialize (A (eqtype.eq_refl _)). rewrite A. clear l E A n.
  rewrite t_nn_ID. by rewrite comp_idL.
- move => x IH n i l E. rewrite -> (comp_eq_compat (t_nmProjection n i) (tset_refl _)).
  rewrite <- comp_assoc. specialize (IH n i.+1). have l0:i < n by rewrite <- subn_gt0 ; rewrite E.
  have ee:n - i.+1 = x. have Y:= subn_gt0 i n. rewrite E in Y. rewrite subnS. by rewrite E.
  specialize (IH l0 ee). rewrite <- IH.
  by rewrite -> (mconeCom X i).
Qed.

Lemma coconeCom_l (X:CoCone DTower) n i : (n <= i)%nat -> mcocone X n =-= mcocone X i << (t_nm n i).
move => l.
assert (exists x, i - n = x) as E by (eexists ; auto).
destruct E as [x E]. elim: x n i l E.
- move => n i l E. have A:=@anti_leq n i. rewrite l in A. unfold leq in A. rewrite E in A.
  specialize (A is_true_true). rewrite A. rewrite -> t_nn_ID. by rewrite comp_idR.
- move => x IH n i l E. rewrite -> t_nmEmbedding.
  rewrite -> comp_assoc. specialize (IH n.+1 i).
  have ll:n < i by rewrite <- subn_gt0 ; rewrite E.
  have ee:i - n.+1 = x by have Y:= subn_gt0 n i ; rewrite E in Y ;
    rewrite subnS ; by rewrite E.
  rewrite <- (IH ll ee). by apply (tset_sym (mcoconeCom X n)).
Qed.

Lemma chainPEm (C:CoCone DTower) (C':Cone DTower) : monotonic (fun n => (mcocone C n << mcone C' n) : cppoMorph _ _).
move => i j l.
have E:exists x, j - i = x by exists (j - i).
case: E l => x. elim: x i j.
- move => i j e l. have l':(j <= i)%N. unfold leq. by rewrite e.
  have ee: j <= i <= j. rewrite l'. by apply l.
  by rewrite (anti_leq ee).
- move => x IH i. case ; first by rewrite sub0n.
  move => j l _. specialize (IH i.+1 j.+1). rewrite subSS in IH. rewrite <- IH.
  + have EE:= comp_eq_compat (mcoconeCom C i) (mconeCom C' i).
    rewrite <- comp_assoc in EE. rewrite -> (comp_assoc (mcone C' _)) in EE.
    have ll:= (proj2 (teppair DTower i)).
    rewrite -> (proj2 EE).
    apply: comp_le_compat ; first by [].
    rewrite  -> (comp_le_compat ll (Ole_refl _)). by rewrite comp_idL.
  + clear IH. have ll:(i < j.+1)%N. rewrite <- subn_gt0. by rewrite l.
    rewrite (@subSn i j ll) in l. by auto.
  + have ll:(i < j.+1)%N. rewrite <- subn_gt0. by rewrite l. by apply ll.
Qed.

Definition chainPE (C:CoCone DTower) (C':Cone DTower) : natO =-> cppoMorph _ _ := mk_fmono (@chainPEm C C').

End Tower.

(*=Diter *)
Fixpoint Diter (n:nat) :=
    match n return M with | O => One | S n => ob F (Diter n) (Diter n) end.
Fixpoint Injection (n:nat) : (Diter n) =-> (Diter (S n)) :=
match n with
| O => PBot
| S n => morph F _ _ _ _ (Projection n, Injection n)
end with Projection (n:nat) : (Diter (S n)) =-> (Diter n) :=
match n with
| O => terminal_morph _
| S n => morph F _ _ _ _ (Injection n,Projection n)
end.
Variable comp_left_strict : forall (X Y Z:M) (f:M X Y),
   (PBot:Y =-> Z) << f =-= (PBot:X =-> Z).
Lemma eppair_IP: forall n, eppair (Injection n) (Projection n).
(*=End *)
elim.
- split ; first by apply:terminal_unique.
  simpl. rewrite -> (comp_left_strict _ (terminal_morph _)). by apply: leastP.
- move => n IH. split.
  + simpl. rewrite -> (morph_comp F (Injection n) (Projection n) (Projection n) (Injection n)).
    rewrite -> (morph_eq_compat F (proj1 IH) (proj1 IH)). by rewrite morph_id.
  + simpl. rewrite morph_comp.
    rewrite -> (pair_le_compat (proj2 IH) (proj2 IH)). by rewrite morph_id.
Qed.

(*=DTower *)
Definition DTower := mk_tower eppair_IP.
(*=End *)

(*=DInf *)
Definition DInf : M := tcone (L DTower).
(*=End *)

Definition Embeddings n : (tobjects DTower n) =-> DInf := limitExists (L DTower) (coneN DTower n).

Definition Projections n : DInf =-> Diter n := mcone (L DTower) n.

Lemma coCom i : Embeddings i.+1 << Injection i =-= Embeddings i.
unfold Embeddings.
rewrite -> (limitUnique (h:=(Embeddings (S i) << Injection _ :  (tcone (coneN DTower i)) =-> DInf))) ; first by [].
move => m. simpl. unfold Embeddings. rewrite -> comp_assoc. have e:= (limitCom (L DTower) (coneN DTower i.+1) m).
simpl in e. rewrite <- e. by rewrite -> (t_nmEmbedding DTower).
Qed.

Definition DCoCone : CoCone DTower := @mk_basecocone _ DInf Embeddings coCom.

Lemma retract_EP n : Projections n << Embeddings n =-= Id.
unfold eppair.
unfold Projections. unfold Embeddings.
- rewrite <- (limitCom (L DTower) (coneN DTower n) n). simpl. by rewrite -> t_nn_ID.
Qed.

Lemma emp: forall i j, Projections i << Embeddings j =-= t_nm DTower j i.
intros i j. have A:= leq_total i j. case_eq (i <= j)%N ; move => X ; rewrite X in A.
- unfold Projections. rewrite -> (comp_eq_compat (coneCom_l (L DTower) X) (tset_refl _)).
  rewrite <- comp_assoc. rewrite -> (comp_eq_compat (tset_refl _) (retract_EP j)). by rewrite -> comp_idR.
- simpl in A. have e:= (coconeCom_l DCoCone A). simpl in e. rewrite -> e.
  rewrite -> comp_assoc. rewrite -> (retract_EP i). by rewrite comp_idL.
Qed.

Definition chainPEc (C:CoCone DTower) : natO =-> (cppoMorph DInf (tcocone C)) := chainPE C (L DTower).

Lemma lub_comp_left (X Y:M) (f:X =-> Y) Z (c:natO =-> cppoMorph Y Z) :
   (lub c:M _ _) << f =-= lub ( (exp_fun (ccomp _ _ _ << <|pi2,pi1|>) f:ordCatType _ _) << c).
rewrite <- (ccomp_eq (lub c) f). by rewrite <- (lub_comp_eq _ c).
Qed.

Lemma lub_comp_right (Y Z:M) (f:Y =-> Z) X (c:natO =-> cppoMorph X Y) :
   f << lub c =-= lub ( (exp_fun (ccomp _ _ _) f:ordCatType _ _) << c).
rewrite <- (ccomp_eq f (lub c)). by rewrite <- lub_comp_eq.
Qed.

Lemma lub_comp_both (X Y Z:M) (c:natO =-> cppoMorph X Y) (c':natO =-> cppoMorph Y Z) :
  (lub c':M _ _) << lub c =-= lub ((ccomp _ _ _ : ordCatType _ _) << <|c', c|>).
rewrite <- lub_comp_eq.
rewrite {3} /lub. simpl. unfold prod_lub. rewrite prod_fun_fst. rewrite prod_fun_snd.
by rewrite -> ccomp_eq.
Qed.

Lemma EP_id : (lub (chainPEc DCoCone) : M _ _) =-= Id.
rewrite <- (tset_sym (@limitUnique _ (L DTower) (L DTower) Id (fun n => tset_sym (comp_idR _)))).
apply: limitUnique. move => n. rewrite -> lub_comp_right.
rewrite -> (lub_lift_left _ n). apply: Ole_antisym. rewrite <- (le_lub _ O). simpl. rewrite addn0.
have e:= comp_eq_compat (retract_EP n) (tset_refl (mcone (L DTower) n)).
rewrite -> comp_idL in e. unfold Projections in e. rewrite <- comp_assoc in e.
rewrite ccomp_eq. by rewrite e.

apply: lub_le. move => i. simpl. rewrite ccomp_eq. rewrite -> comp_assoc.
rewrite -> (emp n (n+i)). by rewrite (coneCom_l _ (leq_addr i n)).
Qed.

Lemma chainPE_simpl X n : chainPEc X n = mcocone X n << Projections n.
by [].
Qed.

Definition DCoLimit : CoLimit DTower.
exists DCoCone (fun C => lub (chainPEc C)).
- move => C n. simpl. rewrite -> lub_comp_left. apply Ole_antisym.
  + apply: (Ole_trans _ (le_lub _ n)).
    simpl. rewrite -> ccomp_eq.
    have e:= comp_eq_compat (tset_refl (mcocone C n)) (emp n n). rewrite -> t_nn_ID in e.
    rewrite -> comp_idR in e. rewrite -> comp_assoc in e. by rewrite -> e.
  + rewrite -> (lub_lift_left _ n). apply: lub_le => k.
    simpl. rewrite -> ccomp_eq.
    have e:=comp_eq_compat (tset_refl (mcocone C (n+k))) (emp (n+k) n). rewrite -> comp_assoc in e.
    rewrite <- (coconeCom_l C (leq_addr k n)) in e. by rewrite e.
- move => C h X. rewrite <- (comp_idR h). rewrite <- (EP_id).
  apply tset_trans with (y:=exp_fun (ccomp _ _ _) h (lub (chainPEc DCoCone))) ; first by  apply: (tset_sym (ccomp_eq _ _)).
  rewrite -> (@lub_comp_eq _ _ ( (exp_fun (ccomp _ _ _) h)) (chainPEc DCoCone)).
  apply: lub_eq_compat. apply fmon_eq_intro => n. simpl. specialize (X n).
  rewrite ccomp_eq.
  rewrite comp_assoc. by rewrite <- X.
Defined.

Definition ECoCone : CoCone DTower.
exists (ob F DInf DInf) (fun i => (morph F _ _ _ _ (Projections i, Embeddings i):M _ _) << Injection i).
move => i. simpl. rewrite -> (morph_comp F (Projections i.+1) (Embeddings i.+1) (Projection i) (Injection i)).
by rewrite -> (morph_eq_compat F (mconeCom (L DTower) i) (mcoconeCom DCoCone i)).
Defined.

Definition FCone : Cone DTower.
exists (ob F DInf DInf) (fun n => Projection n << morph F _ _ _ _ (Embeddings n, Projections n)).
move => i. refine (comp_eq_compat (tset_refl _) _). unfold Projections.
rewrite <- (morph_eq_compat F (coCom i) (mconeCom (L DTower) i)). simpl.
apply: morph_comp.
Defined.

Definition chainFPE (C:CoCone DTower) := chainPE C FCone.

Lemma subS_leq j i m : j.+1 - i == m.+1 -> i <= j.
move => X. have a:=subn_gt0 i (j.+1). have x:=ltn0Sn m.
rewrite <- (eqP X) in x. rewrite a in x. by [].
Qed.

Lemma morph_tnm n m : morph F _ _ _ _ (t_nm DTower m n, t_nm DTower n m) =-= t_nm DTower n.+1 m.+1.
have t:= (leq_total n m). case_eq (n <= m)%N ; move => l ; rewrite l in t.
clear t. have M':exists x, m - n == x by eexists ; by []. destruct M' as [x M'].
elim: x m n l M'.
- move => j i l e. rewrite subn_eq0 in e.
  have A:= @anti_leq i j. rewrite l in A. rewrite e in A. specialize (A is_true_true).
  rewrite A. rewrite -> (morph_eq_compat F (t_nn_ID DTower j) (t_nn_ID DTower j)).
  rewrite -> morph_id. by rewrite -> t_nn_ID.
- move => m IH. case.
  + move=> i l e. rewrite leqn0 in l. have ee:=eqP l. rewrite ee.
    rewrite -> (morph_eq_compat F (t_nn_ID DTower O) (t_nn_ID DTower O)).
    rewrite -> morph_id. by rewrite -> t_nn_ID.
  + move => j i e l. specialize (IH j i). have l':=l. have l0:=subS_leq l'. rewrite (subSn l0) in l.
    specialize (IH l0 l). clear l l' e.
    have e:= morph_eq_compat F (t_nmProjection2 DTower l0) (t_nmEmbedding2 DTower l0).
    rewrite <- morph_comp in e. rewrite -> e. rewrite -> IH. clear e.
    have a:= (tset_sym (t_nmEmbedding2 DTower _)).
    specialize (a i.+1 j.+1 l0). by apply a.
simpl in t. clear l.
have M':exists x, n - m == x by eexists ; by []. destruct M' as [x M'].
elim: x m n t M'.
- move => j i l e. rewrite subn_eq0 in e.
  have A:= @anti_leq i j. rewrite l in A. rewrite e in A. specialize (A is_true_true).
  rewrite A. rewrite -> (morph_eq_compat F (t_nn_ID DTower j) (t_nn_ID DTower j)).
  rewrite -> morph_id. by rewrite -> t_nn_ID.
- move => m IH i. case.
  + move=> l e. rewrite leqn0 in l. have ee:=eqP l. rewrite ee.
    rewrite -> (morph_eq_compat F (t_nn_ID DTower O) (t_nn_ID DTower O)).
    rewrite -> morph_id. by rewrite -> t_nn_ID.
  + move => j e l. specialize (IH i j). have l':=l. have l0:=subS_leq l'. rewrite (subSn l0) in l.
    specialize (IH l0 l). clear l l' e.
    have e:= morph_eq_compat F (t_nmEmbedding2 DTower l0) (t_nmProjection2 DTower l0).
    rewrite <-morph_comp in e. rewrite -> e. simpl. rewrite -> IH.
    clear e. have a:= (tset_sym (t_nmProjection2 DTower _)).
    specialize (a j.+1 i.+1 l0). by apply a.
Qed.

Lemma ECoLCom : forall (A : CoCone DTower) (n : nat),
   mcocone A n =-= (lub (chainFPE A):M _ _) << mcocone ECoCone n.
move => C n. simpl.
  rewrite -> lub_comp_left. apply Ole_antisym.
  * rewrite <- (le_lub _ n). simpl. rewrite -> ccomp_eq. do 2 rewrite comp_assoc.
    rewrite <- (comp_assoc (morph F _ _ _ _ _ : M _ _)).
    rewrite -> (morph_comp F (Embeddings n) (Projections n) (Projections n) (Embeddings n)).
    rewrite -> (morph_eq_compat F (tset_trans (emp n n) (t_nn_ID _ _))
                                                   (tset_trans (emp n n) (t_nn_ID _ _))).
    rewrite -> morph_id. rewrite comp_idR. rewrite <- comp_assoc. rewrite -> (proj1 (teppair DTower n)).
    by rewrite comp_idR.
  * rewrite -> (lub_lift_left _ n). apply: lub_le => k. simpl. apply Oeq_le.
    rewrite -> ccomp_eq. do 2 rewrite comp_assoc. rewrite <- (comp_assoc (morph F _ _ _ _ _:M _ _)).
    rewrite -> (morph_comp F (Embeddings (n+k)) (Projections (n+k)) (Projections n) (Embeddings n)).
    rewrite -> (morph_eq_compat F  (emp n (n+k)) (emp (n+k) n)).
    rewrite morph_tnm. rewrite <- comp_assoc. rewrite <- (t_nmEmbedding DTower n (n+k).+1).
    rewrite <- comp_assoc. rewrite <- (t_nmProjection DTower n (n+k)).
    by rewrite <- (coconeCom_l C (leq_addr k n)).
Qed.

Open Scope D_scope.
Open Scope C_scope.

Lemma pair_lub (D E:cpoType) (c:natO =-> D) (c':natO =-> E) : @tset_eq (CPO.setoidType _) (lub c,lub c') (lub (<|c,c'|>)).
rewrite {3} /lub. simpl. unfold prod_lub.
split ; split ; simpl ; apply lub_le_compat ; apply Oeq_le ; try (by rewrite prod_fun_fst) ; by rewrite prod_fun_snd.
Qed.

Lemma CoLimitUnique : forall (A : CoCone DTower) h,
   (forall n : nat, mcocone A n =-= h << mcocone ECoCone n) ->
   h =-= lub (chainFPE A).
move => C h X. rewrite <- (comp_idR h).
  have a:= morph_eq_compat F EP_id EP_id. rewrite -> morph_id in a.
  rewrite <- a. clear a.
  have b:= (pair_lub (chainPEc DCoCone) (chainPEc DCoCone)).
  have S:= (fmon_stable (morph F _ _ _ _) b). rewrite -> (Oeq_trans S (lub_comp_eq _ _)).
  clear b S. rewrite -> lub_comp_right. rewrite -> (lub_lift_left (chainFPE C) 1).
  apply: lub_eq_compat. apply fmon_eq_intro => n. simpl.
  rewrite -> (ccomp_eq h (morph F _ _ _ _ (Embeddings n << mcone (L DTower) n,
                                            Embeddings n << mcone (L DTower) n))).
  specialize (X n.+1). simpl in X.
  rewrite -> X. rewrite (morph_comp F (Projections n.+1) (Embeddings n.+1) (Projection n) (Injection n)).
  rewrite -> (morph_comp F (Injection n) (Projection n) (Embeddings (1 + n)) (Projections (1 + n))).
  rewrite -> (morph_eq_compat F (mconeCom (L DTower) n) (mcoconeCom DCoCone n)).
  rewrite -> (morph_eq_compat F (mcoconeCom DCoCone n) (mconeCom (L DTower) n)).
  rewrite <- comp_assoc.
  by rewrite -> (morph_comp F (mcone (L DTower) n) (mcocone DCoCone n) (mcocone DCoCone n) (mcone (L DTower) n)).
Qed.

Definition ECoLimit : CoLimit DTower.
exists ECoCone (fun C => lub (chainFPE C)).
by apply ECoLCom.
by apply CoLimitUnique.
Defined.

(*=Iso *)
Definition Fold : (ob F DInf DInf) =-> DInf := (* ... *) (*CLEAR*) colimitExists ECoLimit DCoCone. (*CLEARED*)
Definition Unfold : DInf =-> (ob F DInf DInf) := (*CLEAR*) colimitExists DCoLimit ECoCone. (*CLEARED*)

Lemma FU_id : Fold << Unfold =-= Id. Proof.
apply tset_trans with (y:=colimitExists DCoLimit DCoLimit).
- refine (@colimitUnique _ DCoLimit DCoLimit _ _). move => i. unfold Fold. unfold Unfold.
  simpl. rewrite -> lub_comp_both. rewrite -> lub_comp_left. apply Ole_antisym.
  * apply: (Ole_trans _ (le_lub _ i)).
    simpl. apply Oeq_le. rewrite ccomp_eq. rewrite ccomp_eq.
    do 3 rewrite comp_assoc. rewrite <- (comp_assoc (morph F _ _ _ _ _ :M _ _)).
    rewrite -> (morph_comp F (Embeddings i) (Projections i) (Projections i) (Embeddings i)).
    rewrite -> (morph_eq_compat F (tset_trans (emp i i) (t_nn_ID _ _)) (tset_trans (emp i i) (t_nn_ID _ _))).
    rewrite -> morph_id. rewrite comp_idR. rewrite <- (comp_assoc (Injection i)).
    rewrite -> (proj1 (teppair DTower i)). rewrite comp_idR. rewrite <- comp_assoc.
    rewrite -> (emp i i). rewrite t_nn_ID. by rewrite comp_idR.
  * rewrite -> (lub_lift_left _ i). apply: lub_le => k. simpl.
    apply Oeq_le. rewrite -> ccomp_eq. rewrite ccomp_eq.
    do 3 rewrite comp_assoc. rewrite <- (comp_assoc (morph F _ _ _ _ _:M _ _)).
    rewrite -> (morph_comp F (Embeddings (i + k)) (Projections (i + k)) (Projections (i + k)) (Embeddings (i + k))).
    rewrite (morph_eq_compat F (tset_trans (emp _ _) (t_nn_ID _ _)) (tset_trans (emp _ _) (t_nn_ID _ _))).
    rewrite -> morph_id. rewrite comp_idR. rewrite <- (comp_assoc (Injection (i+k))).
    rewrite -> (proj1 (teppair DTower (i+k))). rewrite comp_idR. rewrite <- comp_assoc.
    rewrite -> (emp (i+k) (i)).
    by apply (tset_sym (@coconeCom_l DTower DCoCone _ _ (leq_addr k i))).
- apply tset_sym. apply: (@colimitUnique _ DCoLimit DCoLimit _ _). move => n. simpl. by rewrite -> comp_idL.
Qed.
Lemma UF_id : Unfold << Fold =-= Id.
Proof.
apply tset_trans with (y:=colimitExists ECoLimit ECoLimit).
- apply (@colimitUnique _ ECoLimit ECoLimit). move => i. unfold Fold. unfold Unfold.
  simpl. rewrite -> lub_comp_both. rewrite -> lub_comp_left. apply Ole_antisym.
  * apply: (Ole_trans _ (le_lub _ i)).
    apply Oeq_le. simpl. do 2 rewrite -> ccomp_eq. simpl.
    do 3 rewrite comp_assoc. rewrite <- (comp_assoc (Embeddings i)).
    rewrite (emp i i). rewrite t_nn_ID. rewrite comp_idR.
    rewrite <- (comp_assoc (morph F _ _ _ _ _:M _ _)).
    rewrite -> (morph_comp F (Embeddings i) (Projections i)(Projections i) (Embeddings i)).
    rewrite -> (morph_eq_compat F (tset_trans (emp i i) (t_nn_ID _ _)) (tset_trans (emp i i) (t_nn_ID _ _))).
    rewrite -> morph_id. rewrite comp_idR. rewrite <- (comp_assoc (Injection i)).
    rewrite -> (proj1 (teppair DTower i)). by rewrite comp_idR.
  * rewrite -> (lub_lift_left _ i). apply: lub_le => k. simpl.
    apply Oeq_le. do 2 rewrite ccomp_eq.
    do 3 rewrite comp_assoc. rewrite <- (comp_assoc (Embeddings (i+k))).
    rewrite (emp _ _). rewrite t_nn_ID. rewrite comp_idR.
    rewrite <- (comp_assoc (morph F _ _ _ _ _:M _ _)).
    rewrite -> (morph_comp F (Embeddings (i + k)) (Projections (i + k)) (Projections i) (Embeddings i)).
    rewrite -> (morph_eq_compat F (emp i (i+k)) (emp (i+k) i)).
    rewrite -> morph_tnm. rewrite <- comp_assoc. rewrite <- (t_nmEmbedding DTower i (i + k).+1).
    rewrite <- comp_assoc. rewrite <- (t_nmProjection DTower i (i+k)). rewrite <- comp_assoc.
    rewrite <- (t_nmEmbedding2 DTower (leq_addr k i)). rewrite t_nmEmbedding. rewrite comp_assoc.
    rewrite <- morph_tnm.
    rewrite -> (morph_comp F (Projections (i+k)) (Embeddings (i+k)) (t_nm DTower (i+k) i) (t_nm DTower i (i+k))).
    by rewrite <- (morph_eq_compat F (@coneCom_l DTower (L DTower) _ _ (leq_addr k i)) (@coconeCom_l DTower DCoCone _ _ (leq_addr k i))).
- apply tset_sym. apply (@colimitUnique _ ECoLimit ECoLimit). move => n. by rewrite -> comp_idL.
Qed.
(*=End *)

Add Parametric Morphism C X Y Z W : (@morph C X Y Z W)
  with signature (@Ole ((cppoMorph Y X) * (cppoMorph Z W))) ==> (@Ole _)
  as morph_le_compat.
case => x x'. case => y y' e.
by apply: fmonotonic.
Qed.

Lemma delta_mon : monotonic (fun e => Fold << morph F _ _ _ _ (e,e) << Unfold).
move => e e' X. simpl.
by apply: (comp_le_compat (comp_le_compat (Ole_refl _) (morph_le_compat F (pair_le_compat X X))) (Ole_refl _)).
Qed.

Definition deltat : ordCatType (cppoMorph DInf DInf) (cppoMorph DInf DInf) := Eval hnf in mk_fmono delta_mon.

Lemma comp_lub_eq (D0 D1 D2 :M) (f:D1 =-> D2) (c:natO =-> cppoMorph D0 D1) :
   f << lub c =-= lub ((exp_fun (ccomp D0 D1 D2) f : ordCatType _ _) << c).
have a:=@lub_comp_eq _ _ ( (exp_fun (ccomp _ _ _) f)).
specialize (a D0 c). simpl in a. rewrite <- a. by rewrite ccomp_eq.
Qed.

Lemma lub_comp (D0 D1 D2 : M) (f:D0 =-> D1) (c:natO =-> cppoMorph D1 D2) :
   (lub c : M _ _) << f =-= lub ((exp_fun (ccomp D0 D1 D2 << <|pi2,pi1|>) f : ordCatType _ _) << c).
have a:=@lub_comp_eq _ _ ( (exp_fun (ccomp _ _ _ << <|pi2,pi1|>) f)).
specialize (a D2 c). rewrite <- a. simpl. by rewrite ccomp_eq.
Qed.

Lemma delta_cont : continuous deltat.
move => c. simpl. have S:=fmon_stable (morph F _ _ _ _).
specialize (S _ _ _ _ _ _ (pair_lub c c)).
rewrite -> (@lub_comp_eq _ _ ( (morph F _ _ _ _)) (<|c:natO =-> cppoMorph _ _,c|>)) in S.
rewrite -> S. clear S. rewrite comp_lub_eq. rewrite lub_comp.
apply: lub_le_compat => n. simpl. rewrite -> ccomp_eq. by rewrite ccomp_eq.
Qed.

Definition delta : (cppoMorph DInf DInf) =-> (cppoMorph DInf DInf) :=
  Eval hnf in mk_fcont delta_cont.
(*=Delta *)
Lemma delta_simpl e : delta e = Fold << morph F _ _ _ _ (e,e) << Unfold.
(*CLEAR*)
by [].
Qed. (*CLEARED*)
(*=End *)

Require Import PredomFix.

Definition retract (C:catType) (A B : C) (f: A =-> B) (g : B =-> A) := f << g =-= Id.

Lemma retract_eq (C:catType) (X Y Z : C) (f:X =-> Y) g h (k:Z =-> X) : retract g f -> h =-= f << k -> g << h =-= k.
move => R A.
have B:=comp_eq_compat (tset_refl g) A. rewrite -> comp_assoc in B. rewrite -> R in B.
by rewrite -> comp_idL in B.
Qed.

Lemma delta_iter_id k : iter delta k <= (@Category.id M _:cppoMorph _ _).
elim:k ; first by apply: leastP.
move => n IH. simpl.
rewrite -> (comp_le_compat (comp_le_compat (Ole_refl (Fold:cppoMorph _ _))
                (morph_le_compat F (pair_le_compat IH IH))) (Ole_refl (Unfold:cppoMorph _ _))).
rewrite -> morph_id. rewrite comp_idR. by rewrite FU_id.
Qed.

Lemma delta_id_id : delta (@Category.id M _:cppoMorph DInf DInf) =-= @Category.id M _.
rewrite delta_simpl. rewrite morph_id. rewrite comp_idR. by rewrite FU_id.
Qed.

(*=FIXDelta *)
Lemma id_min : (FIXP delta : M _ _) =-= Id.
(*=End *)
rewrite <- EP_id.
apply: (tset_trans (@limitUnique DTower (L DTower) (L DTower) _ _) _).
- move => n. simpl. unfold fixp. rewrite -> lub_comp_right. apply Ole_antisym.
  + rewrite <- (le_lub _ n). simpl. rewrite ccomp_eq.
    elim: n. simpl. apply Oeq_le. have a:= terminal_unique. specialize (a M). by apply: a.
    move => n IH. simpl. unfold Unfold. unfold Fold. simpl.
    rewrite <- (comp_le_compat (Ole_refl (Projections n.+1:cppoMorph _ _)) (comp_le_compat (comp_le_compat (le_lub (chainFPE DCoCone) n.+1) (Ole_refl (morph F _ _ _ _ (iter_ delta n, iter_ delta n)))) (le_lub (chainPEc ECoCone) n.+1))).
    simpl. repeat rewrite comp_assoc. rewrite -> (emp n.+1 n.+1). rewrite t_nn_ID. rewrite comp_idL.
    rewrite morph_comp. rewrite -> (morph_eq_compat F (mcoconeCom (DCoCone) n) (mconeCom (L DTower) n)).
    rewrite morph_comp. rewrite <- (comp_assoc (morph F _ _ _ _ (Projection n, Injection n):M _ _)).
    rewrite morph_comp. rewrite -> (morph_eq_compat F (mconeCom (L DTower) n) (mcoconeCom DCoCone n)).
    rewrite morph_comp.
    have a:= (Ole_trans _ (comp_le_compat (morph_le_compat F (pair_le_compat ((Oeq_le (tset_sym (comp_assoc _ (iter_ delta n:M _ _) _)))) (Ole_refl _))) (Ole_refl _))). apply: a.
    have aa:= (comp_le_compat (morph_le_compat F (pair_le_compat (comp_le_compat IH (Ole_refl _)) (comp_le_compat IH (Ole_refl _)))) (Ole_refl _)). rewrite <- aa. clear aa.
    rewrite (emp n n). rewrite t_nn_ID. rewrite morph_id. by rewrite comp_idL.
  + apply: lub_le => k. simpl.
    rewrite ccomp_eq.
    rewrite -> (comp_le_compat (Ole_refl _) (delta_iter_id k)). by rewrite comp_idR.
- apply tset_sym. apply limitUnique. move => n.
  rewrite EP_id. by rewrite comp_idR.
Qed.

End RecursiveDomains.

End Msolution.


Require Import Coq.Sets.Ensembles Bedrock.Platform.AutoSep.

Require Import Bedrock.Platform.Malloc Bedrock.Platform.Facade.examples.TupleF Bedrock.Platform.MoreArrays.

Module Type ADT.
  Parameter tuple : list W -> W -> HProp.

  Axiom tuple_fwd : forall ls c, tuple ls c ===> [| c <> 0 |] * [| freeable c (length ls) |] * array ls c.
  Axiom tuple_bwd : forall ls (c : W), [| c <> 0 |] * [| freeable c (length ls) |] * array ls c ===> tuple ls c.
End ADT.

Module Adt : ADT.
  Open Scope Sep_scope.

  Definition tuple (ls : list W) (c : W) : HProp := [| c <> 0 |] * [| freeable c (length ls) |] * array ls c.

  Theorem tuple_fwd : forall ls c, tuple ls c ===> [| c <> 0 |] * [| freeable c (length ls) |] * array ls c.
  Proof.
    unfold tuple; sepLemma.
  Qed.

  Theorem tuple_bwd : forall ls (c : W), [| c <> 0 |] * [| freeable c (length ls) |] * array ls c ===> tuple ls c.
  Proof.
    unfold tuple; sepLemma.
  Qed.
End Adt.

Import Adt.
Export Adt.

Definition hints : TacPackage.
  prepare (tuple_fwd, allocate_array) (tuple_bwd, free_array).
Defined.

Definition newS := newS tuple 7.
Definition deleteS := deleteS tuple 6.
Definition copyS := copyS tuple 11.
Definition getS := getS tuple 0.
Definition setS := setS tuple 0.

Definition agreeUpto (ls1 ls2 : list W) (pos : nat) :=
  forall i, (i < pos)%nat -> Array.selN ls1 i = Array.selN ls2 i.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS] ]]
  bmodule "ArrayTuple" {{
    bfunction "new"("extra_stack", "len") [newS]
      "len" <-- Call "malloc"!"malloc"(0, "len")
      [PRE[V, R] R =?> wordToNat (V "len") * [| R <> 0 |] * [| freeable R (wordToNat (V "len")) |]
       POST[R'] Ex ls, tuple ls R' * [| length ls = wordToNat (V "len") |]];;

      Note [make_array];;
      Return "len"
    end

    with bfunction "delete"("extra_stack", "self", "len") [deleteS]
      Note [dissolve_array];;

      Call "malloc"!"free"(0, "self", "len")
      [PRE[_] Emp
       POST[R] [| R = $0 |] ];;

      Return 0
    end

    with bfunction "copy"("extra_stack", "self", "len", "copy", "i", "tmp", "tmp2") [copyS]
      "copy" <-- Call "malloc"!"malloc"(0, "len")
      [Al ls,
       PRE[V, R] tuple ls (V "self") * [| length ls = wordToNat (V "len") |]
         * R =?> wordToNat (V "len") * [| R <> 0 |] * [| freeable R (wordToNat (V "len")) |]
       POST[R'] tuple ls (V "self") * tuple ls R'];;

      Note [make_array];;
      "i" <- 0;;
      [Al ls1, Al ls2,
       PRE[V] tuple ls1 (V "self") * tuple ls2 (V "copy") * [| agreeUpto ls1 ls2 (wordToNat (V "i")) |]
         * [| length ls1 = wordToNat (V "len") |] * [| length ls2 = wordToNat (V "len") |]
       POST[R] [| R = V "copy" |] * tuple ls1 (V "self") * tuple ls1 (V "copy")]
      While ("i" < "len") {
        Assert [Al ls1, Al ls2,
                PRE[V] tuple ls1 (V "self") * tuple ls2 (V "copy") * [| agreeUpto ls1 ls2 (wordToNat (V "i")) |]
                  * [| length ls1 = wordToNat (V "len") |] * [| length ls2 = wordToNat (V "len") |]
                  * [| (V "i" < natToW (length ls1))%word |] * [| (V "i" < natToW (length ls2))%word |]
                POST[R] [| R = V "copy" |] * tuple ls1 (V "copy") * tuple ls1 (V "self")];;

        "tmp" <- 4 * "i";;
        "tmp2" <-* "self" + "tmp";;
        "copy" + "tmp" *<- "tmp2";;
        "i" <- "i" + 1
      };;

      Return "copy"
    end

    with bfunction "get"("extra_stack", "self", "pos") [getS]
      "pos" <- 4 * "pos";;
      "pos" <-* "self" + "pos";;
      Return "pos"
    end

    with bfunction "set"("extra_stack", "self", "pos", "val") [setS]
      "pos" <- 4 * "pos";;
      "self" + "pos" *<- "val";;
      Return 0
    end
  }}.

Local Hint Extern 1 (@eq W _ _) => words.

Lemma agreeUpto_O : forall ls1 ls2, agreeUpto ls1 ls2 0.
Proof.
  unfold agreeUpto; intros; omega.
Qed.

Hint Resolve agreeUpto_O.

Lemma freeable_cong : forall p n n',
  freeable p n'
  -> n = n'
  -> freeable p n.
Proof.
  congruence.
Qed.

Hint Immediate freeable_cong.

Lemma selN_updN_ne : forall v a n n',
  n <> n'
  -> Array.selN (Array.updN a n v) n' = Array.selN a n'.
Proof.
  induction a; destruct n, n'; simpl; intuition.
Qed.

Lemma agreeUpto_S : forall ls1 ls2 n,
  agreeUpto ls1 ls2 (wordToNat n)
  -> n < natToW (length ls2)
  -> goodSize (length ls2)
  -> agreeUpto ls1 (Array.upd ls2 n (Array.sel ls1 n)) (wordToNat (n ^+ $1)).
Proof.
  unfold agreeUpto; intros.
  rewrite wordToNat_wplus in H2.
  change (wordToNat $1) with 1 in H2.
  assert (i < wordToNat n \/ i = wordToNat n)%nat by omega; intuition subst.
  rewrite H by assumption.

  unfold Array.upd.
  rewrite selN_updN_ne by omega; auto.

  unfold Array.upd.
  rewrite selN_updN_eq; auto.
  apply lt_goodSize'; auto.
  unfold natToW; rewrite natToWord_wordToNat; auto.
  change (wordToNat $1) with 1.
  eapply goodSize_weaken; eauto.

  assert (wordToNat n < length ls2)%nat; try omega.
  apply lt_goodSize'; auto.
  unfold natToW; rewrite natToWord_wordToNat; auto.
Qed.

Hint Extern 1 (agreeUpto _ (Array.upd _ _ _) _) =>
  eapply agreeUpto_S; [ eassumption | eassumption | solve [ eauto 7 ] ].

Lemma bound_nat : forall i len n,
  i < len
  -> n = wordToNat len
  -> i < natToW n.
Proof.
  intros; subst.
  unfold natToW; rewrite natToWord_wordToNat; auto.
Qed.

Hint Immediate bound_nat.

Lemma agreeUpto_total : forall ls1 ls2 (i : W) len,
  agreeUpto ls1 ls2 (wordToNat i)
  -> len <= i
  -> length ls1 = wordToNat len
  -> length ls2 = wordToNat len
  -> ls1 = ls2.
Proof.
  induction ls1; destruct ls2; simpl; intuition.

  assert (Hgt : (wordToNat i > 0)%nat).
  unfold wlt in H0.
  destruct (wordToNat i) eqn:Heq.
  rewrite wordToN_nat in H0.
  rewrite Heq in H0; simpl in H0.
  exfalso; apply H0.
  rewrite wordToN_nat.
  destruct (wordToNat len); nomega.
  omega.

  assert (Hle : $1 <= i).
  unfold wlt.
  change (wordToN $1) with 1%N.
  nomega.

  assert (Hlen : $1 <= len).
  unfold wlt.
  change (wordToN $1) with 1%N.
  pre_nomega.
  change (Pos.to_nat 1) with 1.
  destruct (wordToNat len); omega.

  f_equal.

  specialize (H 0); intuition idtac.

  apply IHls1 with (i ^- $1) (len ^- $1).
  do 2 intro.
  specialize (H (S i0)).
  apply H.
  rewrite wordToNat_wminus in H3 by assumption.
  change (wordToNat $1) with 1 in *.
  omega.

  unfold wlt; intro.
  apply Nlt_out in H3.
  autorewrite with N in *.
  repeat rewrite wordToNat_wminus in H3 by assumption.
  nomega.

  rewrite wordToNat_wminus by assumption.
  change (wordToNat $1) with 1; omega.
  rewrite wordToNat_wminus by assumption.
  change (wordToNat $1) with 1; omega.
Qed.

Lemma agreeUpto_total_himp : forall ls1 ls2 (i : W) len specs p,
  agreeUpto ls1 ls2 (wordToNat i)
  -> len <= i
  -> length ls1 = wordToNat len
  -> length ls2 = wordToNat len
  -> himp specs (array ls2 p) (array ls1 p).
Proof.
  intros.
  replace ls2 with ls1.
  reflexivity.
  eauto using agreeUpto_total.
Qed.

Hint Immediate agreeUpto_total_himp.

Theorem ok : moduleOk m.
Proof.
  vcgen; abstract (sep hints; eauto).
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Rounding to nearest, ties to even: existence, unicity... *)
Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_rnd.
Require Import Fcore_generic_fmt.
Require Import Fcore_float_prop.
Require Import Fcore_ulp.

Notation ZnearestE := (Znearest (fun x => negb (Zeven x))).

Section Fcore_rnd_NE.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.

Context { valid_exp : Valid_exp fexp }.

Notation format := (generic_format beta fexp).
Notation canonic := (canonic beta fexp).

Definition NE_prop (_ : R) f :=
  exists g : float beta, f = F2R g /\ canonic g /\ Zeven (Fnum g) = true.

Definition Rnd_NE_pt :=
  Rnd_NG_pt format NE_prop.

Definition DN_UP_parity_pos_prop :=
  forall x xd xu,
  (0 < x)%R ->
  ~ format x ->
  canonic xd ->
  canonic xu ->
  F2R xd = round beta fexp Zfloor x ->
  F2R xu = round beta fexp Zceil x ->
  Zeven (Fnum xu) = negb (Zeven (Fnum xd)).

Definition DN_UP_parity_prop :=
  forall x xd xu,
  ~ format x ->
  canonic xd ->
  canonic xu ->
  F2R xd = round beta fexp Zfloor x ->
  F2R xu = round beta fexp Zceil x ->
  Zeven (Fnum xu) = negb (Zeven (Fnum xd)).

Lemma DN_UP_parity_aux :
  DN_UP_parity_pos_prop ->
  DN_UP_parity_prop.
Proof.
intros Hpos x xd xu Hfx Hd Hu Hxd Hxu.
destruct (total_order_T 0 x) as [[Hx|Hx]|Hx].
(* . *)
exact (Hpos x xd xu Hx Hfx Hd Hu Hxd Hxu).
elim Hfx.
rewrite <- Hx.
apply generic_format_0.
(* . *)
assert (Hx': (0 < -x)%R).
apply Ropp_lt_cancel.
now rewrite Ropp_involutive, Ropp_0.
destruct xd as (md, ed).
destruct xu as (mu, eu).
simpl.
rewrite <- (Bool.negb_involutive (Zeven mu)).
apply f_equal.
apply sym_eq.
rewrite <- (Zeven_opp mu), <- (Zeven_opp md).
change (Zeven (Fnum (Float beta (-md) ed)) = negb (Zeven (Fnum (Float beta (-mu) eu)))).
apply (Hpos (-x)%R _ _ Hx').
intros H.
apply Hfx.
rewrite <- Ropp_involutive.
now apply generic_format_opp.
now apply canonic_opp.
now apply canonic_opp.
rewrite round_DN_opp, F2R_Zopp.
now apply f_equal.
rewrite round_UP_opp, F2R_Zopp.
now apply f_equal.
Qed.

Class Exists_NE :=
  exists_NE : Zeven beta = false \/ forall e,
  ((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e).

Context { exists_NE_ : Exists_NE }.

Theorem DN_UP_parity_generic_pos :
  DN_UP_parity_pos_prop.
Proof with auto with typeclass_instances.
intros x xd xu H0x Hfx Hd Hu Hxd Hxu.
destruct (ln_beta beta x) as (ex, Hexa).
specialize (Hexa (Rgt_not_eq _ _ H0x)).
generalize Hexa. intros Hex.
rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex.
destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe].
(* small x *)
assert (Hd3 : Fnum xd = Z0).
apply F2R_eq_0_reg with beta (Fexp xd).
change (F2R xd = R0).
rewrite Hxd.
apply round_DN_small_pos with (1 := Hex) (2 := Hxe).
assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))).
apply canonic_unicity with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, ln_beta_bpow.
now apply valid_exp.
rewrite <- F2R_change_exp.
rewrite F2R_bpow.
apply sym_eq.
rewrite Hxu.
apply sym_eq.
apply round_UP_small_pos with (1 := Hex) (2 := Hxe).
now apply valid_exp.
rewrite Hd3, Hu3.
rewrite Zmult_1_l.
simpl.
destruct exists_NE_ as [H|H].
apply Zeven_Zpower_odd with (2 := H).
apply Zle_minus_le_0.
now apply valid_exp.
rewrite (proj2 (H ex)).
now rewrite Zminus_diag.
exact Hxe.
(* large x *)
assert (Hd4: (bpow (ex - 1) <= Rabs (F2R xd) < bpow ex)%R).
rewrite Rabs_pos_eq.
rewrite Hxd.
split.
apply (round_DN_pt beta fexp x).
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
omega.
apply Hex.
apply Rle_lt_trans with (2 := proj2 Hex).
apply (round_DN_pt beta fexp x).
rewrite Hxd.
apply (round_DN_pt beta fexp x).
apply generic_format_0.
now apply Rlt_le.
assert (Hxe2 : (fexp (ex + 1) <= ex)%Z) by now apply valid_exp.
assert (Hud: (F2R xu = F2R xd + ulp beta fexp x)%R).
rewrite Hxu, Hxd.
now apply ulp_DN_UP.
destruct (total_order_T (bpow ex) (F2R xu)) as [[Hu2|Hu2]|Hu2].
(* - xu > bpow ex  *)
elim (Rlt_not_le _ _ Hu2).
rewrite Hxu.
apply round_bounded_large_pos...
(* - xu = bpow ex *)
assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))).
apply canonic_unicity with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
now rewrite F2R_bpow, ln_beta_bpow.
now apply valid_exp.
rewrite <- Hu2.
apply sym_eq.
rewrite <- F2R_change_exp.
apply F2R_bpow.
exact Hxe2.
assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)).
assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))).
unfold F2R. simpl.
rewrite Z2R_minus.
unfold Rminus.
rewrite Rmult_plus_distr_r.
rewrite Z2R_Zpower, <- bpow_plus.
ring_simplify (ex - fexp ex + fexp ex)%Z.
rewrite Hu2, Hud.
unfold ulp, canonic_exp.
rewrite ln_beta_unique with beta x ex.
unfold F2R.
simpl. ring.
rewrite Rabs_pos_eq.
exact Hex.
now apply Rlt_le.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
apply canonic_unicity with (1 := Hd) (3 := H).
apply (f_equal fexp).
rewrite <- H.
apply sym_eq.
now apply ln_beta_unique.
rewrite Hd3, Hu3.
unfold Fnum.
rewrite Zeven_mult. simpl.
unfold Zminus at 2.
rewrite Zeven_plus.
rewrite eqb_sym. simpl.
fold (negb (Zeven (beta ^ (ex - fexp ex)))).
rewrite Bool.negb_involutive.
rewrite (Zeven_Zpower beta (ex - fexp ex)). 2: omega.
destruct exists_NE_.
rewrite H.
apply Zeven_Zpower_odd with (2 := H).
now apply Zle_minus_le_0.
apply Zeven_Zpower.
specialize (H ex).
omega.
(* - xu < bpow ex *)
revert Hud.
unfold ulp, F2R.
rewrite Hd, Hu.
unfold canonic_exp.
rewrite ln_beta_unique with beta (F2R xu) ex.
rewrite ln_beta_unique with (1 := Hd4).
rewrite ln_beta_unique with (1 := Hexa).
intros H.
replace (Fnum xu) with (Fnum xd + 1)%Z.
rewrite Zeven_plus.
now apply eqb_sym.
apply sym_eq.
apply eq_Z2R.
rewrite Z2R_plus.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
rewrite H.
simpl. ring.
apply Rgt_not_eq.
apply bpow_gt_0.
rewrite Rabs_pos_eq.
split.
apply Rle_trans with (1 := proj1 Hex).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
exact Hu2.
apply Rlt_le.
apply Rlt_le_trans with (1 := H0x).
rewrite Hxu.
apply (round_UP_pt beta fexp x).
Qed.

Theorem DN_UP_parity_generic :
  DN_UP_parity_prop.
Proof.
apply DN_UP_parity_aux.
apply DN_UP_parity_generic_pos.
Qed.

Theorem Rnd_NE_pt_total :
  round_pred_total Rnd_NE_pt.
Proof.
apply satisfies_any_imp_NG.
now apply generic_format_satisfies_any.
intros x d u Hf Hd Hu.
generalize (proj1 Hd).
unfold generic_format.
set (ed := canonic_exp beta fexp d).
set (md := Ztrunc (scaled_mantissa beta fexp d)).
intros Hd1.
case_eq (Zeven md) ; [ intros He | intros Ho ].
right.
exists (Float beta md ed).
unfold Fcore_generic_fmt.canonic.
rewrite <- Hd1.
now repeat split.
left.
generalize (proj1 Hu).
unfold generic_format.
set (eu := canonic_exp beta fexp u).
set (mu := Ztrunc (scaled_mantissa beta fexp u)).
intros Hu1.
rewrite Hu1.
eexists ; repeat split.
unfold Fcore_generic_fmt.canonic.
now rewrite <- Hu1.
rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)).
simpl.
now rewrite Ho.
exact Hf.
unfold Fcore_generic_fmt.canonic.
now rewrite <- Hd1.
unfold Fcore_generic_fmt.canonic.
now rewrite <- Hu1.
rewrite <- Hd1.
apply Rnd_DN_pt_unicity with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unicity with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_monotone :
  round_pred_monotone Rnd_NE_pt.
Proof.
apply Rnd_NG_pt_monotone.
intros x d u Hd Hdn Hu Hun (cd, (Hd1, Hd2)) (cu, (Hu1, Hu2)).
destruct (Req_dec x d) as [Hx|Hx].
rewrite <- Hx.
apply sym_eq.
apply Rnd_UP_pt_idempotent with (1 := Hu).
rewrite Hx.
apply Hd.
rewrite (DN_UP_parity_aux DN_UP_parity_generic_pos x cd cu) in Hu2 ; try easy.
now rewrite (proj2 Hd2) in Hu2.
intros Hf.
apply Hx.
apply sym_eq.
now apply Rnd_DN_pt_idempotent with (1 := Hd).
rewrite <- Hd1.
apply Rnd_DN_pt_unicity with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
apply Rnd_UP_pt_unicity with (1 := Hu).
now apply round_UP_pt.
Qed.

Theorem Rnd_NE_pt_round :
  round_pred Rnd_NE_pt.
split.
apply Rnd_NE_pt_total.
apply Rnd_NE_pt_monotone.
Qed.

Lemma round_NE_pt_pos :
  forall x,
  (0 < x)%R ->
  Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x Hx.
split.
now apply round_N_pt.
unfold NE_prop.
set (mx := scaled_mantissa beta fexp x).
set (xr := round beta fexp ZnearestE x).
destruct (Req_dec (mx - Z2R (Zfloor mx)) (/2)) as [Hm|Hm].
(* midpoint *)
left.
exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (canonic_exp beta fexp xr)).
split.
apply round_N_pt...
split.
unfold Fcore_generic_fmt.canonic. simpl.
apply f_equal.
apply round_N_pt...
simpl.
unfold xr, round, Znearest.
fold mx.
rewrite Hm.
rewrite Rcompare_Eq. 2: apply refl_equal.
case_eq (Zeven (Zfloor mx)) ; intros Hmx.
(* . even floor *)
change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true).
destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr].
rewrite (Rle_antisym _ _ Hr).
unfold scaled_mantissa.
rewrite Rmult_0_l.
change R0 with (Z2R 0).
now rewrite (Ztrunc_Z2R 0).
rewrite <- (round_0 beta fexp Zfloor).
apply round_le...
now apply Rlt_le.
rewrite scaled_mantissa_DN...
now rewrite Ztrunc_Z2R.
(* . odd floor *)
change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true).
destruct (ln_beta beta x) as (ex, Hex).
specialize (Hex (Rgt_not_eq _ _ Hx)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex.
destruct (Z_lt_le_dec (fexp ex) ex) as [He|He].
(* .. large pos *)
assert (Hu := round_bounded_large_pos _ _ Zceil _ _ He Hex).
assert (Hfc: Zceil mx = (Zfloor mx + 1)%Z).
apply Zceil_floor_neq.
intros H.
rewrite H in Hm.
unfold Rminus in Hm.
rewrite Rplus_opp_r in Hm.
elim (Rlt_irrefl 0).
rewrite Hm at 2.
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 2).
destruct (proj2 Hu) as [Hu'|Hu'].
(* ... u <> bpow *)
unfold scaled_mantissa.
rewrite canonic_exp_fexp_pos with (1 := conj (proj1 Hu) Hu').
unfold round, F2R. simpl.
rewrite canonic_exp_fexp_pos with (1 := Hex).
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
rewrite Ztrunc_Z2R.
fold mx.
rewrite Hfc.
now rewrite Zeven_plus, Hmx.
(* ... u = bpow *)
rewrite Hu'.
unfold scaled_mantissa, canonic_exp.
rewrite ln_beta_bpow.
rewrite <- bpow_plus, <- Z2R_Zpower.
rewrite Ztrunc_Z2R.
case_eq (Zeven beta) ; intros Hr.
destruct exists_NE_ as [Hs|Hs].
now rewrite Hs in Hr.
destruct (Hs ex) as (H,_).
rewrite Zeven_Zpower.
exact Hr.
omega.
assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx.
replace (Zfloor mx) with (Zceil mx + -1)%Z by omega.
rewrite Zeven_plus.
apply eqb_true.
unfold mx.
replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)).
rewrite Zeven_Zpower_odd with (2 := Hr).
easy.
omega.
apply eq_Z2R.
rewrite Z2R_Zpower. 2: omega.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
unfold Zminus.
rewrite bpow_plus.
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r.
pattern (fexp ex) ; rewrite <- canonic_exp_fexp_pos with (1 := Hex).
now apply sym_eq.
apply Rgt_not_eq.
apply bpow_gt_0.
generalize (proj1 (valid_exp ex) He).
omega.
(* .. small pos *)
assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx.
unfold mx, scaled_mantissa.
rewrite canonic_exp_fexp_pos with (1 := Hex).
now rewrite mantissa_DN_small_pos.
(* not midpoint *)
right.
intros g Hg.
destruct (Req_dec x g) as [Hxg|Hxg].
rewrite <- Hxg.
apply sym_eq.
apply round_generic...
rewrite Hxg.
apply Hg.
set (d := round beta fexp Zfloor x).
set (u := round beta fexp Zceil x).
apply Rnd_N_pt_unicity with (d := d) (u := u) (4 := Hg).
now apply round_DN_pt.
now apply round_UP_pt.
2: now apply round_N_pt.
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
unfold d, u, round, F2R. simpl. fold mx.
rewrite <- 2!Rmult_minus_distr_r.
intros H.
apply Rmult_eq_reg_r in H.
apply Hm.
apply Rcompare_Eq_inv.
rewrite Rcompare_floor_ceil_mid.
now apply Rcompare_Eq.
contradict Hxg.
apply sym_eq.
apply Rnd_N_pt_idempotent with (1 := Hg).
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
fold mx.
rewrite <- Hxg.
change (Z2R (Zfloor mx) * bpow (canonic_exp beta fexp x))%R with d.
now eapply round_DN_pt.
apply Rgt_not_eq.
apply bpow_gt_0.
Qed.

Theorem round_NE_opp :
  forall x,
  round beta fexp ZnearestE (-x) = (- round beta fexp ZnearestE x)%R.
Proof.
intros x.
unfold round. simpl.
rewrite scaled_mantissa_opp, canonic_exp_opp.
rewrite Znearest_opp.
rewrite <- F2R_Zopp.
apply (f_equal (fun v => F2R (Float beta (-v) _))).
set (m := scaled_mantissa beta fexp x).
unfold Znearest.
case Rcompare ; trivial.
apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)).
rewrite Bool.negb_involutive.
rewrite Zeven_opp.
rewrite Zeven_plus.
now rewrite eqb_sym.
Qed.

Theorem round_NE_pt :
  forall x,
  Rnd_NE_pt x (round beta fexp ZnearestE x).
Proof with auto with typeclass_instances.
intros x.
destruct (total_order_T x 0) as [[Hx|Hx]|Hx].
apply Rnd_NG_pt_sym.
apply generic_format_opp.
unfold NE_prop.
intros _ f ((mg,eg),(H1,(H2,H3))).
exists (Float beta (- mg) eg).
repeat split.
rewrite H1.
now rewrite F2R_Zopp.
now apply canonic_opp.
simpl.
now rewrite Zeven_opp.
rewrite <- round_NE_opp.
apply round_NE_pt_pos.
now apply Ropp_0_gt_lt_contravar.
rewrite Hx, round_0...
apply Rnd_NG_pt_refl.
apply generic_format_0.
now apply round_NE_pt_pos.
Qed.

End Fcore_rnd_NE.

(** Notations for backward-compatibility with Flocq 1.4. *)
Notation rndNE := ZnearestE (only parsing).


(** Some decision procedures and implementations. *)
From oadt.lang_oadt Require Import
     base syntax semantics infrastructure admissible values.
Import syntax.notations semantics.notations.

(** * Decision procedures *)
Section dec.

(** The use of [abstract] is quite important for performance when we run it
within Coq. *)
Ltac t :=
  solve [ repeat
            (try solve [ left; abstract (econstructor; eauto using oval)
                       | right; abstract (inversion 1; subst;
                                          try contradiction;
                                          repeat oval_inv) ];
             try match reverse goal with
                 | H : sumbool _ _ |- _ => destruct H
                 end) ].

#[global]
Instance otval_dec ω : Decision (otval ω).
Proof.
  hnf. induction ω; try t; try case_label; try t.
Defined.

#[global]
Instance oval_dec v : Decision (oval v).
Proof.
  hnf. induction v; try t; try case_label; try t.

  match goal with
  | H : context [ oval ?ω ] |- context [<{ [inj@_<(?ω)> _] }>] =>
    clear H; destruct (decide (otval ω)); try t
  end.
Defined.

#[global]
Instance wval_dec v : Decision (wval v).
Proof.
  hnf. induction v; try t; try case_label; try t.
  match goal with
  | H : context [ wval ?v] |- context [<{ ~if ?v then _ else _ }>] =>
      clear H; destruct v; try t
  end.
  all:
    match goal with
    | |- context [ wval ?e ] =>
        destruct (decide (oval e)); t
    end.
Defined.

#[global]
Instance woval_dec v : Decision (woval v).
Proof.
  hnf. induction v; try t; try case_label; try t.
  match goal with
  | H : context [ woval ?v] |- context [<{ ~if ?v then _ else _ }>] =>
      clear H; destruct v; try t
  end.
  all:
    match goal with
    | |- context [ woval ?e ] =>
        destruct (decide (oval e)); t
    end.
Defined.

#[global]
Instance val_dec v : Decision (val v).
Proof.
  hnf. induction v; try t; try case_label; try t.
  all:
    match goal with
    | |- context [ val ?e ] =>
        destruct (decide (oval e)); t
    end.
Defined.

End dec.

(** * A naive implementation of [step] *)

Section step.

(** ** Definitions *)

Context (Σ : gctx).

Fixpoint ovalty_ (ω : expr) : option expr :=
  match ω with
  | <{ 𝟙 }> => mret <{ () }>
  | <{ ~𝔹 }> => mret <{ [true] }>
  | <{ ω1 ~* ω2 }> => v1 <- ovalty_ ω1; v2 <- ovalty_ ω2; mret <{ ~(v1, v2) }>
  | <{ ω1 ~+ ω2 }> =>
      guard (otval ω2); v <- ovalty_ ω1; mret <{ [inl<ω1 ~+ ω2> v] }>
  | _ => None
  end.

Fixpoint step_ (e : expr) : option expr :=
  match e with
  | <{ e1 e2 }> =>
    if decide (wval e1)
    then if decide (wval e2)
         then match e1 with
              | <{ \:{_}_ => e }> => mret <{ e^e2 }>
              | <{ ~if [b] then v1 else v2 }> =>
                  mret <{ ~if [b] then v1 e2 else v2 e2 }>
              | _ => None
              end
         else e2' <- step_ e2; mret <{ e1 e2' }>
    else e1' <- step_ e1; mret <{ e1' e2 }>
  | <{ X@e }> =>
    if decide (wval e)
    then match Σ !! X with
         | Some (DOADT _ e') => mret <{ e'^e }>
         | _ => None
         end
    else e' <- step_ e; mret <{ X@e' }>
  | <{ let e1 in e2 }> =>
    if decide (wval e1)
    then mret <{ e2^e1 }>
    else e1' <- step_ e1; mret <{ let e1' in e2 }>
  | <{ gvar x }> =>
    match Σ !! x with
    | Some (DFun _ e) => mret e
    | _ => None
    end
  | <{ s𝔹 e }> =>
    if decide (wval e)
    then match e with
         | <{ lit b }> => mret <{ [b] }>
         | <{ ~if [b] then v1 else v2 }> =>
           mret <{ ~if [b] then s𝔹 v1 else s𝔹 v2 }>
         | _ => None
         end
    else e' <- step_ e; mret <{ s𝔹 e' }>
  | <{ if e0 then e1 else e2 }> =>
    if decide (wval e0)
    then match e0 with
         | <{ lit b }> => mret <{ ite b e1 e2 }>
         | <{ ~if [b] then v1 else v2 }> =>
           mret <{ ~if [b] then (if v1 then e1 else e2)
                           else (if v2 then e1 else e2) }>
         | _ => None
         end
    else e0' <- step_ e0; mret <{ if e0' then e1 else e2 }>
  | <{ τ1 ~* τ2 }> =>
    if decide (otval τ1)
    then τ2' <- step_ τ2; mret <{ τ1 ~* τ2' }>
    else τ1' <- step_ τ1; mret <{ τ1' ~* τ2 }>
  | <{ (e1, e2){l} }> =>
    if decide (wval e1)
    then e2' <- step_ e2; mret <{ (e1, e2'){l} }>
    else e1' <- step_ e1; mret <{ (e1', e2){l} }>
  | <{ π@b e }> =>
    if decide (wval e)
    then match e with
         | <{ (v1, v2) }> => mret <{ ite b v1 v2 }>
         | <{ ~if [b'] then v1 else v2 }> =>
          mret <{ ~if [b'] then π@b v1 else π@b v2 }>
         | _ => None
         end
    else e' <- step_ e; mret <{ π@b e' }>
  | <{ ~π@b e }> =>
    if decide (wval e)
    then match e with
         | <{ ~(v1, v2) }> => mret <{ ite b v1 v2 }>
         | _ => None
         end
    else e' <- step_ e; mret <{ ~π@b e' }>
  | <{ τ1 ~+ τ2 }> =>
    if decide (otval τ1)
    then τ2' <- step_ τ2; mret <{ τ1 ~+ τ2' }>
    else τ1' <- step_ τ1; mret <{ τ1' ~+ τ2 }>
  | <{ inj@b<τ> e }> => e' <- step_ e; mret <{ inj@b<τ> e' }>
  | <{ ~inj@b<τ> e }> =>
    if decide (otval τ)
    then if decide (oval e)
         then mret <{ [inj@b<τ> e] }>
         else e' <- step_ e; mret <{ ~inj@b<τ> e' }>
    else τ' <- step_ τ; mret <{ ~inj@b<τ'> e }>
  | <{ case e0 of e1 | e2 }> =>
    if decide (wval e0)
    then match e0 with
         | <{ inj@b<_> v }> => mret <{ ite b (e1^v) (e2^v) }>
         | <{ ~if [b] then v1 else v2 }> =>
           mret <{ ~if [b] then (case v1 of e1 | e2) else (case v2 of e1 | e2) }>
         | _ => None
         end
    else e0' <- step_ e0; mret <{ case e0' of e1 | e2 }>
  | <{ ~case e0 of e1 | e2 }> =>
    if decide (wval e0)
    then match e0 with
         | <{ [inj@b<ω1 ~+ ω2> v] }> =>
           v1 <- ovalty_ ω1; v2 <- ovalty_ ω2;
           mret <{ ~if [b] then (ite b (e1^v) (e1^v1))
                           else (ite b (e2^v2) (e2^v)) }>
         | _ => None
         end
    else e0' <- step_ e0; mret <{ ~case e0' of e1 | e2 }>
  | <{ fold<X> e }> => e' <- step_ e; mret <{ fold<X> e' }>
  | <{ unfold<X> e }> =>
    if decide (wval e)
    then match e with
         | <{ fold <_> v }> => mret v
         | <{ ~if [b] then v1 else v2 }> =>
           mret <{ ~if [b] then unfold<X> v1 else unfold<X> v2 }>
         | _ => None
         end
    else e' <- step_ e; mret <{ unfold<X> e' }>
  | <{ tape e }> =>
    if decide (woval e)
    then match e with
         | <{ ~if [b] then v1 else v2 }> =>
           mret <{ mux [b] (tape v1) (tape v2) }>
         | _ => mret e
         end
    else e' <- step_ e; mret <{ tape e' }>
  | <{ mux e0 e1 e2 }> =>
    if decide (wval e0)
    then if decide (wval e1)
         then if decide (wval e2)
              then match e0 with
                   | <{ [b] }> => mret <{ ite b e1 e2 }>
                   | _ => None
                   end
              else e2' <- step_ e2; mret <{ mux e0 e1 e2' }>
         else e1' <- step_ e1; mret <{ mux e0 e1' e2 }>
    else e0' <- step_ e0; mret <{ mux e0' e1 e2 }>
  | <{ ~if e0 then e1 else e2 }> =>
    if decide (wval e0)
    then if decide (wval e1)
         then e2' <- step_ e2; mret <{ ~if e0 then e1 else e2' }>
         else e1' <- step_ e1; mret <{ ~if e0 then e1' else e2 }>
    else e0' <- step_ e0; mret <{ ~if e0' then e1 else e2 }>
  | _ => None
  end.

Fixpoint mstep_ (n : nat) (e : expr) : expr :=
  match n with
  | 0 => e
  | S n =>
      match step_ e with
      | Some e' => mstep_ n e'
      | None => e
      end
  end.

(** ** Correctness *)

#[local]
Set Default Proof Using "Type".

Lemma ovalty_sound ω : forall e,
  ovalty_ ω = Some e ->
  ovalty e ω.
Proof.
  induction ω; simpl; intros; try case_label; simplify_eq; simplify_option_eq;
    eauto using ovalty.
Qed.

Lemma step_sound e : forall e',
  step_ e = Some e' ->
  e -->! e'.
Proof.
  induction e; intros ? H; simplify_eq; simpl in H;
    repeat case_decide;
    repeat
      match goal with
      | H : match ?e with _ => _ end = _ |- _ =>
          sdestruct e; simplify_eq
      end; try wval_inv; try woval_inv; try oval_inv;
    (* Remove induction hypotheses when they are not needed to avoid unnecessary
    subgoals from [simplify_option_eq]. *)
    repeat
      match goal with
      | IH : forall _, step_ ?e = _ -> _ -->! _ |- _ =>
          assert_fails is_var e; clear IH
      end;
    simplify_option_eq;
    try solve [ eauto using step, oval, oval_wval | solve_ctx ].

  eauto using step, ovalty_sound.
Qed.

Lemma mstep_sound n : forall e e',
  mstep_ n e = e' ->
  e -->* e'.
Proof.
  induction n; simpl; intros; subst; try reflexivity.
  case_split; try reflexivity.
  eapply rtc_l; eauto using step_sound.
Qed.

End step.


Require Import Nijn.Prelude.
Require Import Nijn.Syntax.
Require Import Coq.Program.Equality.
Require Import Lia.
Require Import List.

(** * Rule selecting *)

(** When one uses rule removal, one needs to select the rules that will be removed. In this file, we define such predicates and we give several combinators for them.

Note that we use a predicate on the positions rather than a predicate on all possible rewrite rules. This way we don't need to compare rewrite rules when applying rule removal. *)
Section RuleSelector.
  Context {B F : Type}
          (X : afs B F).

  Record selector : Type :=
    {
      pred :> pos (list_of_rewriteRules X) -> Prop ;
      dec_pred : forall (i : pos (list_of_rewriteRules X)), dec (pred i)
    }.

  Definition select_all : selector :=
    {|
      pred i := True ;
      dec_pred i := dec_True
    |}.

  Definition select_none : selector :=
    {|
      pred i := False ;
      dec_pred i := dec_False
    |}.

  Definition select_not (P : selector) : selector :=
    {|
      pred i := ~(P i) ;
      dec_pred i := dec_not (dec_pred P i)
    |}.

  Definition select_and (P Q : selector) : selector :=
    {|
      pred i := P i /\ Q i ;
      dec_pred i := dec_and (dec_pred P i) (dec_pred Q i)
    |}.

  Definition select_or (P Q : selector) : selector :=
    {|
      pred i := P i \/ Q i ;
      dec_pred i := dec_or (dec_pred P i) (dec_pred Q i)
    |}.

  Definition select_pos (i : pos (list_of_rewriteRules X)) : selector :=
    {|
      pred j := i = j ;
      dec_pred j := dec_eq i j
    |}.

  Fixpoint select_list (i : list (pos (list_of_rewriteRules X))) : selector :=
    match i with
    | nil => select_none
    | i :: tl_i => select_or (select_pos i) (select_list tl_i)
    end.

  Definition select_list_nats
             (ns : list nat)
             (H : included (list_of_rewriteRules X) ns)
    : selector
    := select_list (list_nat_to_list_pos ns H).
End RuleSelector.

Arguments dec_pred {B F X} _ i.

(** If we have decidable equality on the base types and function symbols, then every rule selector gives rise to a decidable predicate on the rewrite rules. *)
Definition selector_members
           {B F : Type}
           `{decEq B}
           `{decEq F}
           {X : afs B F}
           (P : selector X)
           (r : rewriteRules X)
  : Prop
  := P (isMember_to_pos (in_to_isMember (member_isEl r))).

Definition dec_selector_members
           {B F : Type}
           `{decEq B}
           `{decEq F}
           {X : afs B F}
           (P : selector X)
           (r : rewriteRules X)
  : dec (selector_members P r).
Proof.
  apply (dec_pred P).
Defined.

Proposition all_selector_members
            {B F : Type}
            `{decEq B}
            `{decEq F}
            (X : afs B F)
            (Q : rewriteRules X -> Prop)
            (P : selector X)
            (HQ : forall (i : pos (list_of_rewriteRules X)), P i -> Q (listAtMembers i))
            (r : rewriteRules X)
            (Hr : selector_members P r)
  : Q r.
Proof.
  destruct r as [ r k ].
  pose (HQ (isMember_to_pos (in_to_isMember k)) Hr).
  refine (transport Q _ q).
  apply eq_MakeMem.
  apply isMember_listAt.
Qed.

(** ** Filter and removing rules from an AFS using a rule selector *)
Definition filter_rewrite_rules
           {B F : Type}
           (X : afs B F)
           (P : selector X)
  : list (rewriteRule (arity X))
  := filter_list (list_of_rewriteRules X) P (dec_pred P).

Definition filter_afs
           {B F : Type}
           (X : afs B F)
           (P : selector X)
  : afs B F
  := make_afs
       (arity X)
       (filter_rewrite_rules X P).

Definition remove_rewrite_rules
           {B F : Type}
           (X : afs B F)
           (P : selector X)
  : list (rewriteRule (arity X))
  := remove_list (list_of_rewriteRules X) P (dec_pred P).

Definition remove_afs
           {B F : Type}
           (X : afs B F)
           (P : selector X)
  : afs B F
  := make_afs
       (arity X)
       (remove_rewrite_rules X P).

Local Open Scope srp.

(** ** Rule selectors and strong reduction pairs *)

(** In the theorem for rule removal, two conditions need to be satisfied. These are expressed in the definition [respects_selector]. *)
Definition respects_selector
           {B F : Type}
           `{decEq B}
           `{decEq F}
           (X : afs B F)
           (A : strong_reduction_pair (arity X))
           (P : selector X)
  : Prop
  := (forall (r : rewriteRules X),
      selector_members P r
      -> lhs r ≺[ A ] rhs r)
     /\
     forall (r : rewriteRules X),
     ~(selector_members P r)
     -> lhs r ≼[ A ] rhs r.


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L.Datatypes Require Import LNat LTerm LBool LProd List.List_enc LOptions.

(* ** Extracted encoding of natural numbers *)

#[global]
Instance term_nat_enc : computable (enc (X:= nat)).
Proof.
  unfold enc;cbn. extract.
Qed.

(* ** Extracted term encoding *)

#[global]
Instance term_term_enc : computable (enc (X:=term)).
Proof.
  unfold enc;cbn. extract.
Qed.

#[global]
Instance bool_enc :computable (enc (X:=bool)).
Proof.
  unfold enc;cbn. extract.
Qed.

(* ** Extracted tuple encoding *)

#[global]
Instance term_prod_enc X Y (R1:encodable X) (R2:encodable Y)
         {HX : computable (enc (X := X))} {HY : computable (enc (X := Y))}
  :computable (enc (X:=X*Y)).
Proof.
  unfold enc;cbn.
  extract.
Qed.

#[global]
Instance term_list_enc X (R:encodable X)
         {HX : computable (enc (X := X))}
  :computable (enc (X:=list X)).
Proof.
  unfold enc;cbn.
  extract.
Qed.

Import LOptions.

#[global]
Instance term_option_enc X (R:encodable X)
         {HX : computable (enc (X := X))}
  :computable (enc (X:=option X)).
Proof.
  unfold enc;cbn.
  extract.
Qed.


Require Import List.
Require Import FunctionalExtensionality.
Require Import FJ_tactics.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import PNames.
Require Import EffPure.
Require Import EffState.
Require Import EffReader.

Section ESoundRS.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.

  Variable E : Set -> Set -> Set.
  Context {Fun_F : forall A, Functor (E A)}.

  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.

  Context {eq_DType_DT : forall T, FAlgebra eq_DTypeName T (eq_DTypeR D) D}.
  Context {eq_DType_eq_DT : PAlgebra eq_DType_eqName D D (UP'_P (eq_DType_eq_P D))}.
  Context {eq_DType_neq_D : PAlgebra eq_DType_neqName D D (UP'_P (eq_DType_neq_P D))}.

  Variable (MT : Set -> Set).
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  Context {Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable (ME : Set -> Set). (* Evaluation Monad. *)
  Context {Fun_M : Functor ME}.
  Context {Mon_M : Monad ME}.
  Context {Environment_ME : Environment ME (list (Names.Value V))}.
  Context {StateM_ME : StateM ME (list (Names.Value V))}.
  Context {FailME : FailMonad ME}.

  Context {evalM_E : FAlgebra EvalName (Exp (E nat)) (evalMR V ME) (E nat)}.

  Context {Typeof_E : forall T, FAlgebra TypeofName T (typeofR D MT) (E (DType D))}.

  Variable EQV_E : forall A B, (eqv_i E A B -> Prop) -> eqv_i E A B -> Prop.
  Context {funEQV_E : forall A B, iFunctor (EQV_E A B)}.

  Variable TypContext : Set.
  Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
  Context {TypContextCE : ConsExtensionC TypContext}.
  Context {GammaTypContext : GammaTypContextC D TypContext}.
  Context {TypContext_GCE : GammaConsExtensionC D TypContext _ _}.
  Context {TypContext_S : SigTypContextC D TypContext}.
  Context {TypContext_SCE : SigConsExtensionC D TypContext _ _}.
  Context {TypContext_WFE : WF_EnvC V TypContext}.
  Context {TypContext_SWFE : Sig_WF_EnvC D V TypContext WFV _ _}.

  Context {funWFV : iFunctor WFV}.

  Variable WFVM : (WFValueM_i D V MT ME TypContext -> Prop) -> WFValueM_i D V MT ME TypContext-> Prop.
  Context {funWFVM : iFunctor WFVM}.

  Context {Sub_WFVM_Base_WFVM : Sub_iFunctor (WFValueM_base D V MT ME _ WFV) WFVM}.
  Context {Sub_WFVM_Environment_WFVM : Sub_iFunctor (WFValueM_Environment D MT V ME _ WFV) WFVM}.
  Context {Sub_WFVM_Bot_WFVM : Sub_iFunctor (WFValueM_Bot D V MT ME _) WFVM}.
  Context {Sub_WFVM_State_WFVM : Sub_iFunctor (WFValueM_State D V MT ME TypContext) WFVM}.

  Context {WFV_Weaken_WFV : iPAlgebra WFValue_Weaken_Name (WFValue_Weaken_P D V _ WFV) WFV}.
  Context {WFV_proj1_b_WFV : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV) WFV}.

  Context {wfvm_bind_alg :
    iPAlgebra wfvm_bind_Name (wfvm_bind_P D V MT ME _ WFV WFVM (TypContextCE := TypContextCE)) WFVM}.

  Context {EQV_proj1_EQV_E :
    forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P E EQV_E A B) (EQV_E _ _)}.

  Class SigGammaTypContextC (TypContext : Set)
    {SigTypContext : SigTypContextC D TypContext}
    {GammaTypContext : GammaTypContextC D TypContext} : Set :=
    {SigLookup_GammaSet : forall Sigma env n,
      SigLookup (SigTypContextC := SigTypContext) D (GammaSet D Sigma env) n =
      SigLookup (SigTypContextC := SigTypContext) D Sigma n}.

  Context {SigGammaTypContext : SigGammaTypContextC TypContext}.

  Section State_Sound_X_Sec.

    Variable WFV' : (WFValue_i D V (list (Names.DType D) * list (Names.DType D)) -> Prop) ->
      WFValue_i D V (list (Names.DType D) * list (Names.DType D)) -> Prop.
    Context {funWFV' : iFunctor WFV'}.
    Variable WFVM' : (WFValueM_i D V MT ME (list (Names.DType D) * list (Names.DType D)) -> Prop) ->
      WFValueM_i D V MT ME (list (Names.DType D) * list (Names.DType D)) -> Prop.
    Variable funWFVM' : iFunctor WFVM'.

    Global Instance SigGamma_GammaTypContext : GammaTypContextC D (list (DType D) * list (DType D)) :=
      {| Gamma := @snd _ _;
        GammaSet := fun Sigma env => (fst Sigma, env);
        GammaInsert := fun T Sigma => (fst Sigma, insert _ T (snd Sigma))|}.
    Proof.
      unfold id; simpl; intros; auto.
      intros; destruct Sigma; auto.
      intros; destruct Sigma; simpl in *|-*; subst; auto.
    Defined.

    Global Instance SigGamma_GammaTypContextCE : ConsExtensionC (list (DType D) * list (DType D)) :=
      {| ConsExtension := fun gamma' gamma =>
        (forall n T, lookup (fst gamma) n = Some T -> lookup (fst gamma') n = Some T ) /\
        snd gamma = snd gamma' |}.
    Proof.
      (* ConsExtension_id *)
      intros; destruct Sigma; eauto.
      (* ConsExtension_trans *)
      intros; destruct Sigma; destruct Sigma'; destruct Sigma''; simpl in *|-*;
        split; eauto; destruct H; destruct H0; eauto; congruence.
    Defined.

    Global Instance SigGamma_GammaTypContextGCE :
      GammaConsExtensionC D (list (DType D) * list (DType D)) (SigGamma_GammaTypContextCE)
      (SigGamma_GammaTypContext).
    Proof.
      econstructor; eauto; intros; destruct Sigma; destruct Sigma'; simpl.
      destruct H; simpl in *|-*; auto.
    Defined.

  Global Instance SigGamma_WF_EnvC : WF_EnvC V (list (Names.DType D) * list (Names.DType D)) :=
    {| WF_Env := fun env Sigma =>
      P2_Env (WFValueC _ _ _ WFV' Sigma) env (fst Sigma) |}.

  Global Instance SigGamma_S : SigTypContextC D (list (Names.DType D) * list (Names.DType D)) :=
    {| SigLookup := fun Sigma => lookup (fst Sigma);
      SigInsert := fun T Sigma => (insert _ T (fst Sigma), snd Sigma)|}.

    Global Instance SigGamma_SCE : SigConsExtensionC D (list (Names.DType D) * list (Names.DType D)) _ _.
    Proof.
      constructor.
    (* ConsExtension_SigLookup *)
      destruct Sigma; destruct Sigma'; simpl; intros; eapply H; auto.
    (* ConsExtension_SigInsert *)
      simpl; intros; split; auto.
      intros; erewrite lookup_Some_insert; eauto.
    Qed.

    Global Instance SigGamma_SigGammaTypContextC :
      @SigGammaTypContextC (list (Names.DType D) * list (Names.DType D))
      SigGamma_S SigGamma_GammaTypContext.
    Proof.
      econstructor.
      intros; simpl; auto.
    Qed.

  Context {WFV_Weaken_WFV' : iPAlgebra WFValue_Weaken_Name (WFValue_Weaken_P D V _ WFV') WFV'}.
  Context {WFV_Weaken'_WFV' : iPAlgebra WFValue_Weaken'_Name (WFValue_Weaken'_P _ _ _ WFV') WFV'}.

  Global Instance SigGamma_Sig_WF_EnvC : Sig_WF_EnvC D V
     (list (DType D) * list (DType D)) WFV' SigGamma_WF_EnvC SigGamma_S.
  Proof.
    constructor; simpl; intros.
      (* WF_EnvLookup *)
    apply (P2_Env_lookup' _ _ _ _ _ H); auto.
      (* WF_EnvInsertLookup *)
    unfold Value, DType, Names.DType in *.
    rewrite (P2_Env_length _ _ _ _ _ H); apply lookup_insert.
      (* WF_EnvInsert *)
    apply P2_Env_insert; eauto.
    eapply P2_Env_P_P'; eauto.
    intros; apply (WFV_Weaken D V _ WFV' _ _ H1); simpl; split; auto.
    simpl; intros; erewrite lookup_Some_insert; eauto.
      (* WF_EnvReplace *)
    eapply P2_Env_replace_el; eauto.
  Qed.

  Definition State_Sound_X_P (i : WFValueM_i D V MT ME _ ) :=
    forall T gamma'' env
      (WF_env : WF_Environment _ _ _ WFV' (wfvm_S _ _ _ _ _ i) env (fst (wfvm_S _ _ _ _ _ i)))
      (WF_gamma'' : WF_Environment _ _ _ WFV' (wfvm_S _ _ _ _ _ i) gamma'' (snd (wfvm_S _ _ _ _ _ i))),
      wfvm_T _ _ _ _ _ i = return_ T ->
      (exists env', put env >> local (fun _ => gamma'') (wfvm_v _ _ _ _ _ i) = put env' >> fail) \/
        exists v : Value V,
          exists env' : Env (Value V),
          exists Sigma' : list (DType D) * list (DType D),
            ConsExtension Sigma' (wfvm_S _ _ _ _ _ i) /\
            (put env) >> local (fun _ => gamma'') (wfvm_v _ _ _ _ _ i) = (put env') >> return_ (M := ME) v /\
          WFValueC _ _ _ WFV' Sigma' v T /\
          WF_Environment D V _ WFV' Sigma' env' (fst Sigma').

  Context {WF_MAlg_typeof : WF_MAlgebra Typeof_E}.

  Inductive State_Sound_X_Name := state_sound_X_name.

  Context {soundness_X'_alg :
    forall eval_rec,
      iPAlgebra soundness_X'_Name
      (soundness_X'_P D V E MT ME _ EQV_E WFVM' (fun e => typeof _ _ MT (proj1_sig e)) eval_rec
        (f_algebra (FAlgebra := Typeof_E _))
        (f_algebra (FAlgebra := evalM_E))) (EQV_E _ _)}.
  Context {State_Sound_X_WFVM : iPAlgebra State_Sound_X_Name State_Sound_X_P WFVM'}.

  Context {WFV_proj1_b_WFV' : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV') WFV'}.
  Context {Sub_WFVM_Bot_WFVM' : Sub_iFunctor (WFValueM_Bot _ _ _ _ _) WFVM'}.

  Theorem eval_State_Sound_X :
    forall (n : nat) Sigma gamma gamma' gamma'' e' e'',
      E_eqvC E EQV_E gamma' gamma e'' e' ->
      forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
        exists T, lookup gamma b = Some T)
      (WF_gamma'' : WF_Environment _ _ _ WFV' Sigma gamma'' gamma)
      (WF_gamma2 : List.length gamma = List.length gamma')
      (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
      (WF_Sigma : Gamma _ Sigma = gamma) (T : DType D)
      (env : Env (Names.Value V))
      (WF_env : WF_Environment _ _ _ WFV' Sigma env (fst Sigma)),
      typeof D (E (DType D)) MT (Typeof_E := Typeof_E) (proj1_sig e') = return_ T ->
      (exists env', put env >>
        local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') = put env' >> fail) \/
        exists v : Value V,
          exists env' : Env (Value V),
          exists Sigma' : list (DType D) * list (DType D),
            ConsExtension Sigma' Sigma /\
          put env >> local (M := ME) (fun _ => gamma'') (bevalM V E ME n e'') =
          put env' >> return_ (M := ME) v /\ WFValueC _ _ _ WFV' Sigma' v T
          /\ WF_Environment D V _ WFV' Sigma' env' (fst Sigma').
  Proof.
    intros.
    intros; eapply (ifold_ WFVM' _ (ip_algebra (iPAlgebra := State_Sound_X_WFVM))
      _ (eval_soundness_X' D V E MT ME _ EQV_E WFVM' n _ _ _ _ H Sigma WF_gamma WF_gamma2 WF_gamma' WF_Sigma));
    simpl in *|-*; unfold DType in *|-*; eauto;
      simpl in H0; auto.
    rewrite WF_Sigma; auto.
  Qed.

  Global Instance State_Sound_WFVM_base :
    iPAlgebra State_Sound_X_Name State_Sound_X_P (WFValueM_base D V MT ME _ WFV').
  Proof.
    econstructor.
    unfold iAlgebra; intros; apply ind_alg_WFVM_base with (WFV := WFV')
      (Fail_MT := _) (Monad_ME := _);
      try assumption; unfold Pure_Sound_X_P; intros; right.
    (* WFVM_Return' *)
    simpl; rewrite local_return; exists v; exists env; exists Sigma; repeat split; simpl in *; auto.
    destruct H1 as [mt' mt'_eq]; subst.
    destruct (MT_eq_dec _ mt') as [[s mt'_eq] | mt'_eq]; subst.
    rewrite fmap_return in H2; apply inj_return in H2; subst.
    destruct s as [T0 T0_UP']; simpl in *.
    destruct T0; apply (WFV_proj1_b D V _ WFV' _ _ H0); simpl; auto.
    rewrite fmap_fail in H2.
    elimtype False; eapply (FailMonad_Disc MT _ _ T0 (fail (A := Fix D)));
      unfold wbind; rewrite bind_fail; eauto with typeclass_instances.
      (* WFVM_Untyped' *)
    simpl in H0; apply sym_eq in H0.
    elimtype False; eapply (FailMonad_Disc MT _ _ T mt); auto.
  Qed.

  Global Instance State_Sound_X_WFVM_Environment :
    iPAlgebra State_Sound_X_Name State_Sound_X_P (WFValueM_Environment D MT V ME _ WFV').
  Proof.
    econstructor.
    unfold iAlgebra; intros; apply ind_alg_WFVM_Environment with (WFV := WFV')
      (TypContextCE := SigGamma_GammaTypContextCE) (Fun_MT := Fun_MT) (Mon_MT := Mon_MT)
      (GammaTypContext := SigGamma_GammaTypContext)
      (Environment_ME := Environment_ME); try eassumption;
        unfold State_Sound_X_P; simpl; intros.
      (* WFVM_Local *)
    destruct (H0 gamma'' WF_gamma'' _ _ env WF_env WF_gamma'' H1) as
      [[env' eval_fail] | [v [env' [Sigma' [Sub_Sig'_Sig [eval_k [WF_v_T0 WF_env'_Sigma']]]]]]].
    left; exists env'; generalize ask_query; unfold wbind; intro ask_query'.
    rewrite local_bind, local_ask, ask_query', <- left_unit; auto.
    right; exists v; exists env'; exists Sigma'; repeat split; auto.
    apply Sub_Sig'_Sig.
    apply Sub_Sig'_Sig.
    generalize ask_query; unfold wbind; intro ask_query'.
    rewrite local_bind, local_ask, ask_query', <- left_unit.
    apply eval_k; auto.
      (* WFVM_Ask *)
    rewrite local_bind, local_local; unfold Basics.compose.
    destruct Sigma; simpl in *|-*.
    assert (WF_Environment D V (list (Names.DType D) * list (Names.DType D)) WFV'
         (l, Gamma') env l) as WF_Sigma_env by
    (eapply P2_Env_P_P'; try eassumption; intros;
      generalize (WFV_Weaken' _ _ _ WFV' _ H4 Gamma'); simpl; auto).
    destruct (H1 _ _ _ WF_Sigma_env (H0 _ WF_gamma'') (refl_equal _)) as
      [[env' eval_fail] | [v [env' [Sigma' [Sub_Sig'_Sig [eval_m [WF_v_T' WF_env'_Sigma']]]]]]].
    left; exists env'; unfold DType, Value in *|-*; unfold wbind, Env in *|-*;
      rewrite associativity, eval_fail, <- associativity, bind_fail; auto.
    destruct Sub_Sig'_Sig as [Sub_Sig'_Sig Sig'_eq].
    assert (WFValueC D V (list (Names.DType D) * list (Names.DType D)) WFV'
      (fst Sigma', l0) v T') as WF_v_T'' by
    (generalize (WFV_Weaken' _ _ _ WFV' _ WF_v_T' l0); simpl; auto).
    assert (WF_Environment D V (list (Names.DType D) * list (Names.DType D)) WFV'
    (fst Sigma', l0) env' (fst (fst Sigma', l0))) as WF_env''_Sigma'
    by (eapply P2_Env_P_P'; try eassumption; intros;
      generalize (WFV_Weaken' _ _ _ WFV' _ H4 l0); simpl; auto).
    assert (ConsExtension (fst Sigma', l0) (l, l0)) as Sub_Sig'_Sig'' by
      (constructor; simpl; auto).
    destruct (H2 (fst Sigma', l0) _ (conj Sub_Sig'_Sig (refl_equal _)) WF_v_T'' _ _ _ WF_env''_Sigma'
      (WF_Environment_Weaken D V _ WFV' _ _ _ WF_gamma'' _ Sub_Sig'_Sig'') H3)
    as [eval_fail | [v' [env'' [Sigma'' [Sub_Sig''_Sig' [eval_k [WF_v'_T0 WF_env''_Sigma'']]]]]]].
    left; unfold DType, Value in *|-*; unfold wbind, Env in *|-*;
      rewrite associativity; rewrite eval_m, <- associativity, <- left_unit; auto.
    right; exists v'; exists env''; exists Sigma''; repeat split; auto.
    intros; eapply Sub_Sig''_Sig'; auto.
    apply Sub_Sig''_Sig'.
    unfold wbind, Env in *|-*;
      rewrite associativity; rewrite eval_m, <- associativity, <- left_unit; auto.
  Qed.

  Variable put_local : forall (A : Set) sigma f (m : ME A),
    put (M := ME) sigma >> (local f m) = local f (put sigma >> m).

  Global Instance State_Sound_X_WFVM_State' :
    iPAlgebra State_Sound_X_Name State_Sound_X_P (WFValueM_State D V MT ME _).
  Proof.
    econstructor.
    unfold iAlgebra; intros; apply ind_alg_WFVM_State with
      (TypContextCE := SigGamma_GammaTypContextCE) (TypContext_WFE := SigGamma_WF_EnvC)
      (State_M := StateM_ME);
      try eassumption; unfold State_Sound_X_P; simpl; intros.
    (* WFVM_Get *)
    destruct (H0 env WF_env _ _ _ WF_env WF_gamma'' H1 ) as
      [[env' eval_fail] | [v [env' [Sigma' [Sub_Sig'_Sig [eval_k [WF_v_T0 WF_env'_Sigma']]]]]]].
    left; exists env'; rewrite put_local, <- eval_fail.
    generalize put_get as put_get'; intros; unfold wbind in *|-*;
      rewrite associativity, put_get', <- associativity, put_local;
        apply f_equal; apply f_equal; apply functional_extensionality;
          intros; rewrite <- left_unit; auto.
    right; exists v; exists env'; exists Sigma'; repeat split; auto.
    eapply Sub_Sig'_Sig.
    eapply Sub_Sig'_Sig.
    generalize put_get as put_get'; intros; unfold wbind in *|-*;
      rewrite put_local, associativity, put_get', <- associativity, <- put_local, <- eval_k;
        apply f_equal; apply functional_extensionality;
          intros; rewrite <- left_unit; auto.
    (* WFVM_Put *)
    assert (WF_Environment D V (list (Names.DType D) * list (Names.DType D)) WFV'
      Sigma' gamma'' (snd Sigma')) as WF_gamma''' by
    (destruct H1 as [H1' H1]; rewrite <- H1; eapply (WF_Environment_Weaken D V _ WFV');
      eauto; split; eauto).
    destruct (H2 _ _ _ H0 WF_gamma'''  H3) as
      [[env' eval_fail] | [v [env' [Sigma'' [Sub_Sig''_Sig' [eval_k [WF_v_T0 WF_env'_Sigma'']]]]]]].
    left; exists env'; rewrite put_local.
    generalize put_put as put_put'; intros; unfold wbind in *|-*.
      rewrite associativity, put_put', <- put_local, <- eval_fail; auto.
    right; exists v; exists env'; exists Sigma''; repeat split; auto.
    intros; eapply Sub_Sig''_Sig'; eapply H1; eauto.
    rewrite <- (proj2 Sub_Sig''_Sig'); eapply H1.
    generalize put_put as put_put'; intros; unfold wbind in *|-*;
      rewrite put_local, associativity, put_put', <- put_local; auto.
  Qed.

  Context {FailEnvM : FailEnvironmentMonad (Env (Value V)) ME}.

  Global Instance State_Sound_X_WFVM_Bot :
    iPAlgebra State_Sound_X_Name State_Sound_X_P (WFValueM_Bot D V MT ME _).
  Proof.
    econstructor.
    unfold iAlgebra; intros; eapply ind_alg_WFVM_Bot;
      try eassumption; unfold State_Sound_X_P; simpl; intros.
    (* WFVM_fail *)
    left; exists env; rewrite local_fail; auto.
  Qed.

  End State_Sound_X_Sec.

End ESoundRS.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^336 - 3
Base: 25 + 11/13
***)

Definition curve : CurveParameters :=
  {|
    sz := 13%nat;
    base := 25 + 11/13;
    bitwidth := 32;
    s := 2^336;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 13); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.