Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e221m3_7limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


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

(***
Modulus : 2^414 - 17
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 13%nat;
    base := 32;
    bitwidth := 32;
    s := 2^414;
    c := [(1, 17)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    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.


Require Import Coq.Program.Equality.
Require Import GDTC.
Require Import CaseStudy.Arith.
Require Import CaseStudy.Lambda.
Require Import CaseStudy.Names.
Require Import CaseStudy.PNames.

Section Lambda_Arith.

  Variable D : Set -> Set.
  Context `{spf_D : SPF D}.
  Context {Sub_AType_D : AType :<: D}.
  Context {Sub_LType_D : LType :<: D}.
  Context {WF_Sub_AType_D : WF_Functor _ _ Sub_AType_D}.
  Context {WF_Sub_LType_D : WF_Functor _ _ Sub_LType_D}.

  Variable E : Set -> Set -> Set.
  Context {fun_E : forall A, Functor (E A)}.
  Context {pfun_E: forall A, PFunctor (E A)}.
  Context {spf_E : forall A, SPF (E A)}.
  Context {Sub_Arith_E : forall A, Arith :<: (E A)}.

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

  Variable V : Set -> Set.
  Context `{spf_V : SPF V}.
  Context {Sub_NatValue_V : NatValue :<: V}.
  Context {Sub_BotValue_V : BotValue :<: V}.
  Context {Sub_ClosValue_V : ClosValue E :<: V}.

  Variable WFV : (WFValue_i D V -> Prop) -> WFValue_i D V -> Prop.
  Context `{spfWFV : iSPF _ WFV}.

  Context {Dis_VI_Clos : Distinct_Sub_Functor NatValue (ClosValue E) V}.
  Context {WF_Sub_ClosValue_V : WF_Functor (ClosValue E) V Sub_ClosValue_V}.
  Context {WF_Sub_NatValue_V : WF_Functor NatValue V Sub_NatValue_V}.

  Context {Sub_WFV_VI_WFV : Sub_iFunctor (WFValue_VI D V) WFV}.
  Context {Dis_LType_AType : Distinct_Sub_Functor LType AType D}.

  Global Instance PAlgebra_WF_invertClos_VI typeof_rec :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P D E V EQV_E WFV typeof_rec) (WFValue_VI D V).
  Proof.
    constructor; unfold iAlgebra, WF_invertClos_P.
    inversion 1; subst; simpl; split.
    - apply (inject_i (subGF := Sub_WFV_VI_WFV)); constructor.
    - intros ? ? Heq; discriminate_inject Heq.
  Qed.

  Global Instance PAlgebra_WF_invertClos'_VI typeof_rec :
    iPAlgebra WF_invertClos'_Name (WF_invertClos'_P D E V EQV_E WFV typeof_rec) (WFValue_VI D V).
  Proof.
    constructor; unfold iAlgebra, WF_invertClos_P.
    inversion 1; subst; simpl; split.
    - apply (inject_i (subGF := Sub_WFV_VI_WFV)); constructor.
    - intros ? Heq; discriminate_inject Heq.
  Qed.

  (* ============================================== *)
  (* EQUIVALENCE OF ARITHMETIC EXPRESSIONS          *)
  (* ============================================== *)

  Inductive Arith_eqv (A B : Set) (C : eqv_i E A B -> Prop) : eqv_i E A B -> Prop :=
  | Lit_eqv : forall (gamma : Env _) gamma' n,
    Arith_eqv A B C (mk_eqv_i _ _ _ gamma gamma' (lit (E A) n) (lit (E B) n))
  | Add_eqv : forall (gamma : Env _) gamma' a b a' b',
    C (mk_eqv_i _ _ _ gamma gamma' a a') ->
    C (mk_eqv_i _ _ _ gamma gamma' b b') ->
    Arith_eqv A B C (mk_eqv_i _ _ _ gamma gamma' (add (E _) a b) (add (E _) a' b')).

  Lemma Arith_eqv_impl_NP_eqv A B C i :
    Arith_eqv A B C i -> NP_Functor_eqv E Arith A B C i.
  Proof.
    intros; destruct H.
    unfold lit in *; simpl in *.
    constructor 1 with (np := fun D => Lit D n); auto.
    simpl; intros; dependent destruction p; auto.
    constructor 3 with (a := a) (a' := a') (b := b) (b' := b') (np := Add); auto.
    simpl; intros; dependent destruction p; auto.
    simpl; congruence.
  Qed.

End Lambda_Arith.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e130m5_5limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(**

Syntax of the simply typed lambda calculus as a multisorted signature.

Written by: Anders Mörtberg, 2017

version for simplified notion of HSS by Ralph Matthes (2022, 2023)
the file is identical to the homonymous file in the parent directory, except for importing files from the present directory

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Slice.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.slicecat.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.
Require Import UniMath.SubstitutionSystems.MonadsMultiSorted.
Require Import UniMath.SubstitutionSystems.MultiSorted.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MultiSortedMonadConstruction.

Local Open Scope cat.

(** * The simply typed lambda calculus from a multisorted binding signature *)
Section Lam.

Variable (sort : hSet) (arr : sort → sort → sort).

(** A lot of notations, upstream? *)
Local Infix "::" := (@cons _).
Local Notation "[]" := (@nil _) (at level 0, format "[]").
Local Notation "C / X" := (slice_cat C X).
Local Notation "a + b" := (setcoprod a b) : set.

Local Definition HSET_over_sort : category.
Proof.
exists (HSET / sort).
now apply has_homsets_slice_precat.
Defined.

Let HSET_over_sort2 := [HSET/sort,HSET_over_sort].

Local Lemma BinProducts_HSET_over_sort2 : BinProducts HSET_over_sort2.
Proof.
apply BinProducts_functor_precat, BinProducts_slice_precat, PullbacksHSET.
Defined.

Local Lemma Coproducts_HSET_over_sort2 : Coproducts ((sort × sort) + (sort × sort))%set HSET_over_sort2.
Proof.
apply Coproducts_functor_precat, Coproducts_slice_precat, CoproductsHSET.
apply setproperty.
Defined.

(** The signature of the simply typed lambda calculus *)
Definition STLC_Sig : MultiSortedSig sort.
Proof.
use make_MultiSortedSig.
- apply ((sort × sort) + (sort × sort))%set. (* todo: fix this once level of × is fixed *)
- intros H; induction H as [st|st]; induction st as [s t].
  + exact ((([],,arr s t) :: ([],,s) :: nil),,t).
  + exact (((cons s [],,t) :: []),,arr s t).
Defined.

(** The signature with strength for the simply typed lambda calculus *)
Definition STLC_Signature : Signature (HSET / sort) _ _:=
  MultiSortedSigToSignature sort STLC_Sig.

Let Id_H := Id_H _ (BinCoproducts_HSET_slice sort).

Definition STLC_Functor : functor HSET_over_sort2 HSET_over_sort2 :=
  Id_H STLC_Signature.

Lemma STLC_Functor_Initial : Initial (FunctorAlg STLC_Functor).
Proof.
apply SignatureInitialAlgebraSetSort.
apply is_omega_cocont_MultiSortedSigToSignature.
apply slice_precat_colims_of_shape, ColimsHSET_of_shape.
Defined.

Definition STLC_Monad : Monad (HSET / sort) :=
  MultiSortedSigToMonad sort STLC_Sig.

(** Extract the constructors of the stlc from the initial algebra *)
Definition STLC : HSET_over_sort2 :=
  alg_carrier _ (InitialObject STLC_Functor_Initial).

Let STLC_mor : HSET_over_sort2⟦STLC_Functor STLC,STLC⟧ :=
  alg_map _ (InitialObject STLC_Functor_Initial).

Let STLC_alg : algebra_ob STLC_Functor :=
  InitialObject STLC_Functor_Initial.

Local Lemma BP : BinProducts [HSET_over_sort,HSET].
Proof.
apply BinProducts_functor_precat, BinProductsHSET.
Defined.

Local Notation "'1'" := (functor_identity HSET_over_sort).
Local Notation "x ⊗ y" := (BinProductObject _ (BP x y)).

(** The variables *)

Definition var_map : HSET_over_sort2⟦1,STLC⟧ :=
  BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · STLC_mor.

(** The source of the application constructor *)
Definition app_source (s t : sort) (X : HSET_over_sort2) : HSET_over_sort2 :=
  ((X ∙ proj_functor sort (arr s t)) ⊗ (X ∙ proj_functor sort s)) ∙ hat_functor sort t.

(** The application constructor *)
Definition app_map (s t : sort) : HSET_over_sort2⟦app_source s t STLC,STLC⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (ii1 (s,, t)))
    · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
    · STLC_mor.

(** The source of the lambda constructor *)
Definition lam_source (s t : sort) (X : HSET_over_sort2) : HSET_over_sort2 :=
  (sorted_option_functor sort s ∙ X ∙ proj_functor sort t) ∙ hat_functor sort (arr s t).

Definition lam_map (s t : sort) : HSET_over_sort2⟦lam_source s t STLC,STLC⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (ii2 (s,,t)))
    · BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _)
    · STLC_mor.

Definition make_STLC_Algebra X (fvar : HSET_over_sort2⟦1,X⟧)
  (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧)
  (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) :
    algebra_ob STLC_Functor.
Proof.
apply (tpair _ X).
use (BinCoproductArrow _ fvar).
use CoproductArrow.
intro b; induction b as [st|st]; induction st as [s t].
- apply (fapp s t).
- apply (flam s t).
Defined.

(** The recursor for the stlc *)
Definition foldr_map X (fvar : HSET_over_sort2⟦1,X⟧)
  (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧)
  (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) :
  algebra_mor _ STLC_alg (make_STLC_Algebra X fvar fapp flam).
Proof.
apply (InitialArrow STLC_Functor_Initial (make_STLC_Algebra X fvar fapp flam)).
Defined.

(** The equation for variables *)
Lemma foldr_var X (fvar : HSET_over_sort2⟦1,X⟧)
  (fapp : ∏ s t, HSET_over_sort2⟦app_source s t X,X⟧)
  (flam : ∏ s t, HSET_over_sort2⟦lam_source s t X,X⟧) :
  var_map · foldr_map X fvar fapp flam = fvar.
Proof.
assert (F := maponpaths (λ x, BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · x)
                        (algebra_mor_commutes _ _ _ (foldr_map X fvar fapp flam))).
rewrite assoc in F.
eapply pathscomp0; [apply F|].
rewrite assoc.
eapply pathscomp0; [eapply cancel_postcomposition, BinCoproductOfArrowsIn1|].
rewrite <- assoc.
eapply pathscomp0; [eapply maponpaths, BinCoproductIn1Commutes|].
apply id_left.
Defined.

(* TODO: how to define the equations for app and lam? *)

End Lam.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Export AuxStateDataType.
Require        CalRealPT.
Require Import Constant.
Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Import CommonTactic.
(*Require Import XOmega.*)

Section WithRealParamsOps.

  Context `{real_params_ops : RealParamsOps}.
  (** mem_init *)

  Class RealParams
  : Prop :=
    {
      real_valid_mm: MM_valid real_mm real_size;
      real_correct_mm: MM_correct real_mm real_size;
      real_valid_mm_kern: MM_kern real_mm real_size;
      real_valid_mm_size: 0< real_size <= Int.max_unsigned;
      real_vmxinfo_range: forall vmxinfo_idx, 1 <= vmxinfo_idx <= 14 -> 0 <= ZMap.get vmxinfo_idx real_vmxinfo <= Int.max_unsigned
    }.

  Section AT_and_NPS.

    Function maxs_at_i (i: Z) (mm: MMTable) : Z :=
      match ZMap.get i mm with
        | MMValid s l _ => (s + l) / PgSize + 1
        | _ => 0
      end.

    Fixpoint Calculate_nps (i: nat) (mm: MMTable) (size: Z) : Z :=
      match i with
        | O => maxs_at_i (Z.of_nat i) mm
        | S k => let (recnps, newnps) := (Calculate_nps k mm size, maxs_at_i (Z.of_nat (S k)) mm)
                 in if Z_lt_dec recnps newnps then newnps else recnps
      end.

    Definition real_nps := Calculate_nps (Z.to_nat (real_size - 1)) real_mm real_size.

    Fixpoint Calculate_AT (n:nat) (nps: Z) (mm:MMTable) (size:Z) (At: ATable) : ATable :=
      match n with
        | O => ZMap.set (Z.of_nat n) (ATValid false ATKern 0) At
        | S k => if Z_le_dec kern_low (Z.of_nat (S k))
                 then if Z_lt_dec (Z.of_nat (S k)) (Z.min kern_high nps)
                      then if MM_kern_valid_dec mm (Z.of_nat (S k)) size
                           then ZMap.set (Z.of_nat (S k)) (ATValid false ATNorm 0) (Calculate_AT k nps mm size At)
                           else ZMap.set (Z.of_nat (S k)) (ATValid false ATResv 0) (Calculate_AT k nps mm size At)
                      else  ZMap.set (Z.of_nat (S k)) (ATValid false ATKern 0) (Calculate_AT k nps mm size At)
                 else  ZMap.set (Z.of_nat (S k)) (ATValid false ATKern 0) (Calculate_AT k nps mm size At)
      end.

    Definition real_AT (AT: ATable) := Calculate_AT (Z.to_nat (real_nps-1)) real_nps real_mm real_size AT.

    Fixpoint Calculate_LAT (n:nat) (nps: Z) (mm:MMTable) (size:Z) (At: LATable) : LATable :=
      match n with
        | O => ZMap.set (Z.of_nat n) (LATValid false ATKern nil) At
        | S k => if Z_le_dec kern_low (Z.of_nat (S k))
                 then if Z_lt_dec (Z.of_nat (S k)) (Z.min kern_high nps)
                      then if MM_kern_valid_dec mm (Z.of_nat (S k)) size
                           then ZMap.set (Z.of_nat (S k)) (LATValid false ATNorm nil) (Calculate_LAT k nps mm size At)
                           else ZMap.set (Z.of_nat (S k)) (LATValid false ATResv nil) (Calculate_LAT k nps mm size At)
                      else  ZMap.set (Z.of_nat (S k)) (LATValid false ATKern nil) (Calculate_LAT k nps mm size At)
                 else  ZMap.set (Z.of_nat (S k)) (LATValid false ATKern nil) (Calculate_LAT k nps mm size At)
      end.

    Definition real_LAT (AT: LATable) := Calculate_LAT (Z.to_nat (real_nps-1)) real_nps real_mm real_size AT.

    Lemma real_relate_LATable:
      forall a1 a2,
        (*(forall i t n, ZMap.get i a1 = ATValid false t n -> n = 0) ->*)
        relate_LATable a1 a2 ->
        relate_LATable (real_AT a1) (real_LAT a2).
    Proof.
      intros.
      unfold real_AT, real_LAT.
      generalize (Z.to_nat (real_nps - 1)).
      induction n.
      - simpl.
        intros i.
        destruct (zeq i 0) as [ -> |];
          [ rewrite 2 ZMap.gss; auto using RELATE_VALID
          | rewrite 2 ZMap.gso; auto ].
      - simpl.
        remember (Z.pos (Pos.of_succ_nat n)) as n'.
        destruct (Z_le_dec 262144 n');
          [ destruct (Z_lt_dec n' (Z.min 983040 real_nps));
            [ destruct (MM_kern_valid_dec real_mm n' real_size) |] |];
          intros i;
          destruct (zeq i n') as [ -> |];
          solve [ rewrite 2 ZMap.gss; auto using RELATE_VALID
                | rewrite 2 ZMap.gso; auto ].
    Qed.

    (*Fixpoint Calculate_pperm (n:nat) (pperm: PPermT) : PPermT :=
      match n with
        | O => ZMap.set (Z.of_nat n) PGUndef pperm
        | S k => ZMap.set (Z.of_nat (S k)) PGUndef (Calculate_pperm k pperm)
      end.

    Definition real_pperm (pperm: PPermT) := Calculate_pperm (Z.to_nat (real_nps-1)) pperm.*)

    Context `{real_params: RealParams}.

    Lemma max_unsigned_val: Int.max_unsigned  = 4294967295.
    Proof.
      repeat autounfold; reflexivity.
    Qed.

    Lemma max_signed_val: Int.max_signed = 2147483647.
    Proof.
      repeat autounfold; reflexivity.
    Qed.

    Ltac Caseeq H := generalize H; apply or_ind; clear H.

    Lemma real_nps_range: kern_low <= real_nps <= maxpage.
    Proof.
      generalize max_unsigned_val; intro muval.
      generalize real_valid_mm_size; intro mmsize.
      generalize real_valid_mm; intro mmvalid.
      generalize real_valid_mm_kern; intro mmkern.
      unfold MM_valid in mmvalid.
      unfold MM_range in mmvalid.
      unfold MM_kern in mmkern.
      unfold MM_kern_range in mmkern.
      unfold MM_kern_valid in mmkern.
      unfold real_nps.
      assert(mmkern': exists i0 s l : Z,
                        0 <= i0 < real_size /\
                        ZMap.get i0 real_mm = MMValid s l MMUsable /\
                        s <= 262143 * 4096 /\ l + s >= 262144 * 4096).
      assert(tmp: 0 <= 262143 < kern_low) by omega.
      generalize (mmkern 262143 tmp); intro tmpH.
      simpl in *.
      assumption.
      clear mmkern.
      replace real_size with (real_size - 1 + 1) in mmvalid, mmkern' by omega.
      rewrite <- Z2Nat.id with (real_size - 1) in mmvalid, mmkern'; try omega.
      split.
      clear mmvalid.
      induction (Z.to_nat (real_size - 1)).
      rewrite Nat2Z.inj_0 in *.
      simpl in *.
      unfold maxs_at_i.
      do 5 (destruct mmkern' as [? mmkern']).
      destruct mmkern'.
      replace x with 0 in * by omega.
      rewrite H0.
      assert((x0 + x1) / 4096 >= 262144 * 4096 / 4096).
      apply Z_div_ge; omega.
      rewrite Z_div_mult_full in H3; try omega.

      Opaque Z.of_nat.
      simpl.
      destruct (Z_lt_dec (Calculate_nps n real_mm real_size)).
      do 5 (destruct mmkern' as [? mmkern']).
      destruct mmkern'.
      assert(icase: x = Z.of_nat (S n) \/ x <> Z.of_nat (S n)) by omega.
      Caseeq icase; intro.
      rewrite H3 in *.
      unfold maxs_at_i.
      rewrite H0.
      assert((x0 + x1) / 4096 >= 262144 * 4096 / 4096).
      apply Z_div_ge; omega.
      rewrite Z_div_mult_full in H4; try omega.
      rewrite Nat2Z.inj_succ in *.
      unfold Z.succ in *.
      assert(262144 <= Calculate_nps n real_mm real_size).
      apply IHn.
      intros.
      exists x, x0, x1.
      split.
      omega.
      auto.
      omega.
      assert(Calculate_nps n real_mm real_size >= maxs_at_i (Z.of_nat (S n)) real_mm) by omega.
      do 5 (destruct mmkern' as [? mmkern']).
      destruct mmkern'.
      assert(icase: x = Z.of_nat (S n) \/ x <> Z.of_nat (S n)) by omega.
      Caseeq icase; intro.
      rewrite H4 in *.
      assert(kern_low <= maxs_at_i (Z.of_nat (S n)) real_mm).
      unfold maxs_at_i.
      rewrite H1.
      assert((x0 + x1) / 4096 >= 262144 * 4096 / 4096).
      apply Z_div_ge; omega.
      rewrite Z_div_mult_full in H5; try omega.
      omega.
      rewrite Nat2Z.inj_succ in *.
      unfold Z.succ in *.
      assert(262144 <= Calculate_nps n real_mm real_size).
      apply IHn.
      exists x, x0, x1.
      split.
      omega.
      auto.
      omega.

      clear mmkern'.
      induction (Z.to_nat (real_size - 1)).
      simpl.
      rewrite Nat2Z.inj_0 in *.
      simpl in *.
      unfold maxs_at_i.
      assert(tmp: 0 <= 0 < 1) by omega.
      generalize (mmvalid 0 tmp); intro tmpH.
      do 5 (destruct tmpH as [? tmpH]).
      destruct tmpH.
      rewrite H.
      assert((x + x0) / 4096 <= 4294967294 / 4096).
      apply Z_div_le; omega.
      change (4294967294 / 4096) with 1048575 in H3.
      omega.

      Opaque Z.of_nat.
      simpl.
      destruct (Z_lt_dec (Calculate_nps n real_mm real_size)).
      assert(Calculate_nps n real_mm real_size <= 1048576).
      rewrite Nat2Z.inj_succ in *.
      unfold Z.succ in *.
      apply IHn.
      intros.
      apply mmvalid.
      omega.
      assert(tmp: 0 <= Z.of_nat (S n) < Z.of_nat (S n) + 1) by omega.
      generalize (mmvalid (Z.of_nat (S n)) tmp); intro tmpH.
      do 5 (destruct tmpH as [? tmpH]).
      destruct tmpH.
      unfold maxs_at_i.
      rewrite H0.
      assert((x + x0) / 4096 <= 4294967294 / 4096).
      apply Z_div_le; omega.
      change (4294967294 / 4096) with 1048575 in H4.
      omega.
      apply IHn.
      intros.
      apply mmvalid.
      rewrite Nat2Z.inj_succ in *.
      unfold Z.succ in *.
      omega.
    Qed.

    Definition Cal_at_Well (x:Z) :=
      forall n m i nps mm size AT,
        0 <= i
        -> i<= n <= m
        -> m - n = x
        -> ZMap.get i (Calculate_AT (Z.to_nat n) nps mm size AT)
           = ZMap.get i (Calculate_AT (Z.to_nat (m)) nps mm size AT).

    Lemma cal_at_correct':
      forall x, 0<= x-> Cal_at_Well x.
    Proof.
      apply natlike_rec2.
      unfold Cal_at_Well.
      intros.
      assert(HP: m = n).
      omega.
      subst m.
      trivial.

      intros.
      unfold Cal_at_Well in *.
      intros.
      specialize (H0 n (Z.pred m) i nps mm size AT).
      assert(HM: i <= n <= m-1).
      omega.
      assert(HN: Z.pred m -n = z).
      omega.
      specialize (H0 H1 HM HN).
      rewrite H0.
      unfold Calculate_AT.
      case_eq (Z.to_nat m).
      intros.
      assert(HZM: (Z.to_nat (Z.pred m)) = 0%nat).
      rewrite Z2Nat.inj_pred.
      rewrite H4.
      reflexivity.
      rewrite HZM.
      trivial.
      fold Calculate_AT.

      intros.
      assert(HZM: Z.to_nat (Z.pred m) = n0).
      rewrite Z2Nat.inj_pred.
      rewrite H4; reflexivity.
      rewrite HZM.
      assert(HNOT:   i <> Z.of_nat (S n0)).
      red.
      rewrite <- H4.
      erewrite Z2Nat.id.
      intros.
      omega.
      omega.

      destruct ( Z_le_dec kern_low (Z.of_nat (S n0))).
      destruct ( Z_lt_dec (Z.of_nat (S n0)) (Z.min kern_high nps)).
      destruct (MM_kern_valid_dec mm (Z.of_nat (S n0)) size).
      erewrite ZMap.gso; trivial.

      erewrite ZMap.gso; trivial.

      erewrite ZMap.gso; trivial.

      erewrite ZMap.gso; trivial.
    Qed.

    Lemma real_at_kern_valid:
      forall AT, AT_kern (real_AT AT) real_nps.
    Proof.
      generalize real_nps_range; intro.
      unfold AT_kern.
      intros.
      specialize (cal_at_correct' (real_nps-1 -i)).
      intros.
      assert(0 <= real_nps - 1 - i) by omega.
      unfold real_AT.
      specialize (H1 H2).
      unfold Cal_at_Well in H1.
      specialize (H1 i (real_nps -1) i real_nps real_mm real_size AT).

      destruct H0 as [HH |HH].
      rewrite <- H1; try omega.
      clear H1.
      unfold Calculate_AT.
      case_eq (Z.to_nat i).
      intros.
      assert(HI: i = 0).
      case_eq (Z_eq_dec i 0).
      intros.
      trivial.
      intros.
      assert(HI: 0< i).
      omega.
      specialize (Z2Nat.inj_lt 0 i).
      intros.
      assert(HI1: 0<=0).
      omega.
      assert(HI2:0<=i).
      omega.
      specialize (H3 HI1 HI2).
      inv H3.
      specialize (H4 HI).
      rewrite H0 in H4.
      change (0%nat) with (Z.to_nat 0) in H0.
      apply Z2Nat.inj in H0.
      assumption.
      omega.
      omega.

      subst i.
      rewrite Nat2Z.inj_0.
      apply ZMap.gss.

      fold Calculate_AT.
      intros.
      rewrite <- H0.
      rewrite Z2Nat.id; try omega.
      case_eq (Z_le_dec kern_low i).
      intros.
      omega.
      intros.
      apply ZMap.gss.

      rewrite <- H1; try omega.
      clear H2.
      unfold Calculate_AT.
      case_eq (Z.to_nat i).
      intros.
      specialize (Z2Nat.inj_lt 0 i).
      intros.
      assert(HI1: 0<=0).
      omega.
      assert(HI2:0<=i).
      omega.
      specialize (H2 HI1 HI2).
      inv H2.
      assert(HI: 0< i).
      omega.
      specialize (H3 HI).
      rewrite H0 in H3.
      change (Z.to_nat 0) with 0%nat in H3.
      omega.

      fold Calculate_AT.
      intros.
      rewrite <- H0.
      rewrite Z2Nat.id; try omega.
      case_eq (Z_le_dec kern_low i).
      intros.
      case_eq (Z_lt_dec i (Z.min kern_high real_nps)).
      intros.
      case_eq (Z_le_dec kern_high real_nps).
      intros.
      assert(HP: Z.min kern_high real_nps = kern_high).
      rewrite Z.min_l; trivial.
      omega.

      intros.
      omega.

      intros.
      apply ZMap.gss.

      intros.
      omega.
    Qed.

    Lemma real_at_usr_valid:
      forall AT,
        AT_usr (real_AT AT) real_nps.
    Proof.
      generalize real_nps_range; intro.
      unfold AT_usr.
      intros.
      assert(HIN: i < real_nps).
      case_eq (Z_le_dec kern_high real_nps).
      intros.
      rewrite Z.min_l in H0; trivial.
      omega.

      intros.
      rewrite Z.min_r in H0; omega.

      specialize (cal_at_correct' (real_nps-1 -i)).
      intros.
      assert(HT: 0 <= real_nps - 1 - i).
      omega.
      specialize (H1 HT).
      unfold Cal_at_Well in H1.
      specialize (H1 i (real_nps -1) i real_nps real_mm real_size AT).
      unfold real_AT.

      rewrite <- H1; try omega.
      clear H1.
      exists false.
      unfold Calculate_AT.
      case_eq (Z.to_nat i).
      intros.
      specialize (Z2Nat.inj_lt 0 i).
      intros.
      assert(HI1: 0<=0).
      omega.
      assert(HI2:0<=i).
      omega.
      specialize (H2 HI1 HI2).
      inv H2.
      assert(HI: 0< i).
      omega.
      specialize (H3 HI).
      rewrite H1 in H3.
      change (Z.to_nat 0) with 0%nat in H3.
      omega.

      fold Calculate_AT.
      intros.
      rewrite <- H1.
      rewrite Z2Nat.id; try omega.
      case_eq (Z_le_dec kern_low i).
      intros.
      case_eq (Z_lt_dec i (Z.min kern_high real_nps)).
      intros.
      destruct (MM_kern_valid_dec real_mm i real_size).
      left.
      exists 0. apply ZMap.gss.
      right.
      apply ZMap.gss.

      intros.
      omega.
      intros.
      omega.
    Qed.

    Lemma real_pperm_valid:
      forall AT,
        consistent_ppage (real_AT AT) (ZMap.init PGUndef) real_nps.
    Proof.
      unfold consistent_ppage; intros.
      generalize real_nps_range; intro.
      assert(HIN: i < real_nps) by omega.
      assert(HT: 0 <= real_nps - 1 - i) by omega.
      specialize (cal_at_correct' _ HT).
      unfold Cal_at_Well.
      intros HCal.
      specialize (HCal i (real_nps -1) i real_nps real_mm real_size AT).
      unfold real_AT.

      rewrite <- HCal; try omega.
      clear HCal.
      unfold Calculate_AT.
      case_eq (Z.to_nat i); simpl.
      - intros.
        destruct (zeq i 0); subst.
        + change (Z.of_nat 0) with 0.
          rewrite ZMap.gss. rewrite ZMap.gi.
          split; intros.
          elim H2; trivial.
          inv H2.
        + specialize (Z2Nat.inj_lt 0 i).
          intros.
          assert(HI1: 0<=0) by omega.
          assert(HI2: 0<=i) by omega.
          specialize (H2 HI1 HI2).
          rewrite H1 in H2. simpl in H2.
          inv H2. exploit H3. omega.
          intros HF. inv HF.
      - fold Calculate_AT.
        intros.
        rewrite <- H1.
        rewrite Z2Nat.id; try omega.
        rewrite ZMap.gi.
        destruct (Z_le_dec 262144 i);
          [destruct (Z_lt_dec i (Z.min 983040 real_nps))|];
          [destruct (MM_kern_valid_dec real_mm i real_size)| | ];
          rewrite ZMap.gss; split; intros; try (elim H2; trivial; fail); inv H2.
    Qed.

    Definition Cal_lat_Well (x:Z) :=
      forall n m i nps mm size AT,
        0 <= i
        -> i<= n <= m
        -> m - n = x
        -> ZMap.get i (Calculate_LAT (Z.to_nat n) nps mm size AT)
           = ZMap.get i (Calculate_LAT (Z.to_nat (m)) nps mm size AT).

    Lemma cal_lat_correct':
      forall x, 0<= x-> Cal_lat_Well x.
    Proof.
      apply natlike_rec2.
      unfold Cal_lat_Well.
      intros.
      assert(HP: m = n).
      omega.
      subst m.
      trivial.

      intros.
      unfold Cal_lat_Well in *.
      intros.
      specialize (H0 n (Z.pred m) i nps mm size AT).
      assert(HM: i <= n <= m-1).
      omega.
      assert(HN: Z.pred m -n = z).
      omega.
      specialize (H0 H1 HM HN).
      rewrite H0.
      unfold Calculate_LAT.
      case_eq (Z.to_nat m).
      intros.
      assert(HZM: (Z.to_nat (Z.pred m)) = 0%nat).
      rewrite Z2Nat.inj_pred.
      rewrite H4.
      reflexivity.
      rewrite HZM.
      trivial.
      fold Calculate_LAT.

      intros.
      assert(HZM: Z.to_nat (Z.pred m) = n0).
      rewrite Z2Nat.inj_pred.
      rewrite H4; reflexivity.
      rewrite HZM.
      assert(HNOT:   i <> Z.of_nat (S n0)).
      red.
      rewrite <- H4.
      erewrite Z2Nat.id.
      intros.
      omega.
      omega.

      destruct ( Z_le_dec kern_low (Z.of_nat (S n0))).
      destruct ( Z_lt_dec (Z.of_nat (S n0)) (Z.min kern_high nps)).
      destruct (MM_kern_valid_dec mm (Z.of_nat (S n0)) size).
      erewrite ZMap.gso; trivial.

      erewrite ZMap.gso; trivial.

      erewrite ZMap.gso; trivial.

      erewrite ZMap.gso; trivial.
    Qed.

    Lemma real_lat_kern_valid:
      forall AT, LAT_kern (real_LAT AT) real_nps.
    Proof.
      generalize real_nps_range; intro.
      unfold LAT_kern.
      intros.
      specialize (cal_lat_correct' (real_nps-1 -i)).
      intros.
      assert(0 <= real_nps - 1 - i) by omega.
      unfold real_LAT.
      specialize (H1 H2).
      unfold Cal_lat_Well in H1.
      specialize (H1 i (real_nps -1) i real_nps real_mm real_size AT).

      destruct H0 as [HH |HH].
      rewrite <- H1; try omega.
      clear H1.
      unfold Calculate_LAT.
      case_eq (Z.to_nat i).
      intros.
      assert(HI: i = 0).
      case_eq (Z_eq_dec i 0).
      intros.
      trivial.
      intros.
      assert(HI: 0< i).
      omega.
      specialize (Z2Nat.inj_lt 0 i).
      intros.
      assert(HI1: 0<=0).
      omega.
      assert(HI2:0<=i).
      omega.
      specialize (H3 HI1 HI2).
      inv H3.
      specialize (H4 HI).
      rewrite H0 in H4.
      change (0%nat) with (Z.to_nat 0) in H0.
      apply Z2Nat.inj in H0.
      assumption.
      omega.
      omega.

      subst i.
      rewrite Nat2Z.inj_0.
      apply ZMap.gss.

      fold Calculate_LAT.
      intros.
      rewrite <- H0.
      rewrite Z2Nat.id; try omega.
      case_eq (Z_le_dec kern_low i).
      intros.
      omega.
      intros.
      apply ZMap.gss.

      rewrite <- H1; try omega.
      clear H2.
      unfold Calculate_LAT.
      case_eq (Z.to_nat i).
      intros.
      specialize (Z2Nat.inj_lt 0 i).
      intros.
      assert(HI1: 0<=0).
      omega.
      assert(HI2:0<=i).
      omega.
      specialize (H2 HI1 HI2).
      inv H2.
      assert(HI: 0< i).
      omega.
      specialize (H3 HI).
      rewrite H0 in H3.
      change (Z.to_nat 0) with 0%nat in H3.
      omega.

      fold Calculate_LAT.
      intros.
      rewrite <- H0.
      rewrite Z2Nat.id; try omega.
      case_eq (Z_le_dec kern_low i).
      intros.
      case_eq (Z_lt_dec i (Z.min kern_high real_nps)).
      intros.
      case_eq (Z_le_dec kern_high real_nps).
      intros.
      assert(HP: Z.min kern_high real_nps = kern_high).
      rewrite Z.min_l; trivial.
      omega.

      intros.
      omega.

      intros.
      apply ZMap.gss.

      intros.
      omega.
    Qed.

    Lemma real_lat_usr_valid:
      forall AT,
        LAT_usr (real_LAT AT) real_nps.
    Proof.
      generalize real_nps_range; intro.
      unfold LAT_usr.
      intros.
      assert(HIN: i < real_nps).
      case_eq (Z_le_dec kern_high real_nps).
      intros.
      rewrite Z.min_l in H0; trivial.
      omega.

      intros.
      rewrite Z.min_r in H0; omega.

      specialize (cal_lat_correct' (real_nps-1 -i)).
      intros.
      assert(HT: 0 <= real_nps - 1 - i).
      omega.
      specialize (H1 HT).
      unfold Cal_lat_Well in H1.
      specialize (H1 i (real_nps -1) i real_nps real_mm real_size AT).
      unfold real_LAT.

      rewrite <- H1; try omega.
      clear H1.
      exists false.
      unfold Calculate_LAT.
      case_eq (Z.to_nat i).
      intros.
      specialize (Z2Nat.inj_lt 0 i).
      intros.
      assert(HI1: 0<=0).
      omega.
      assert(HI2:0<=i).
      omega.
      specialize (H2 HI1 HI2).
      inv H2.
      assert(HI: 0< i).
      omega.
      specialize (H3 HI).
      rewrite H1 in H3.
      change (Z.to_nat 0) with 0%nat in H3.
      omega.

      fold Calculate_LAT.
      intros.
      rewrite <- H1.
      rewrite Z2Nat.id; try omega.
      case_eq (Z_le_dec kern_low i).
      intros.
      case_eq (Z_lt_dec i (Z.min kern_high real_nps)).
      intros.
      destruct (MM_kern_valid_dec real_mm i real_size).
      left.
      exists nil. apply ZMap.gss.
      right.
      apply ZMap.gss.

      intros.
      omega.
      intros.
      omega.
    Qed.

    Lemma Lreal_pperm_valid:
      forall AT,
        Lconsistent_ppage (real_LAT AT) (ZMap.init PGUndef) real_nps.
    Proof.
      unfold Lconsistent_ppage; intros.
      generalize real_nps_range; intro.
      assert(HIN: i < real_nps) by omega.
      assert(HT: 0 <= real_nps - 1 - i) by omega.
      specialize (cal_lat_correct' _ HT).
      unfold Cal_lat_Well.
      intros HCal.
      specialize (HCal i (real_nps -1) i real_nps real_mm real_size AT).
      unfold real_LAT.

      rewrite <- HCal; try omega.
      clear HCal.
      unfold Calculate_LAT.
      case_eq (Z.to_nat i); simpl.
      - intros.
        destruct (zeq i 0); subst.
        + change (Z.of_nat 0) with 0.
          rewrite ZMap.gss. rewrite ZMap.gi.
          split; intros.
          elim H2; trivial.
          inv H2.
        + specialize (Z2Nat.inj_lt 0 i).
          intros.
          assert(HI1: 0<=0) by omega.
          assert(HI2: 0<=i) by omega.
          specialize (H2 HI1 HI2).
          rewrite H1 in H2. simpl in H2.
          inv H2. exploit H3. omega.
          intros HF. inv HF.
      - fold Calculate_LAT.
        intros.
        rewrite <- H1.
        rewrite Z2Nat.id; try omega.
        rewrite ZMap.gi.
        destruct (Z_le_dec 262144 i);
          [destruct (Z_lt_dec i (Z.min 983040 real_nps))|];
          [destruct (MM_kern_valid_dec real_mm i real_size)| | ];
          rewrite ZMap.gss; split; intros; try (elim H2; trivial; fail); inv H2.
    Qed.

    (*Lemma real_lat_domain:
      forall ptp a,
        consistent_lat_domain ptp (real_LAT a) real_nps.
    Proof.

    Qed.*)

    Lemma real_LAT_all_valid_false_nil :
        forall a v, 0 < v < real_nps -> exists t,
          ZMap.get v (real_LAT a) = LATValid false t nil.
    Proof.
      unfold real_LAT.
      destruct real_nps in |- * at 1 2.
      - intros ? ? [ H0 H1 ].
        contradiction (Z.lt_irrefl _ (Z.lt_trans _ _ _ H0 H1)).
      - generalize dependent p.
        refine (Pos.peano_ind _ _ _).
        { (* base case, p = 1, is impossible because 0 < v < p *)
          intros ? ? [ H0 H1 ].
          rewrite <- Z.le_succ_l in H0.
          contradiction (Zle_not_lt _ _ H0 H1).
        }
        intros.
        rewrite Pos2Z.inj_succ in H0 |- *.
        change (Z.succ (Z.pos p) - 1) with (Z.pred (Z.succ (Z.pos p))).
        rewrite Z.pred_succ.

        (* force unfold one level of [Calculate_LAT] *)
        destruct (Z.to_nat (Z.pos p)) eqn:p_to_nat_eq; simpl.
        { (* [Z.to_nat (Z.pos p) = 0] is impossible *)
          simpl in p_to_nat_eq.
          destruct (Pos2Nat.is_succ p) as [ n eq_S_n ].
          rewrite eq_S_n in p_to_nat_eq; discriminate p_to_nat_eq.
        }
        rewrite <- p_to_nat_eq.
        rewrite Z2Nat.id; try discriminate.

        destruct (zeq v (Z.pos p)) as [ -> |].
        + destruct (Z_le_dec 262144 (Z.pos p));
            [ destruct (Z_lt_dec (Z.pos p) (Z.min 983040 real_nps)) |];
            [ destruct (MM_kern_valid_dec real_mm (Z.pos p) real_size) | |];
            rewrite ZMap.gss; eexists; reflexivity.
        + change (Z.pos p - 1) with (Z.pred (Z.pos p)) in H.
          rewrite Z2Nat.inj_pred, p_to_nat_eq in H.
          change (pred (S n)) with n in H.
          assert (0 < v < Z.pos p).
          { destruct H0; split; try assumption.
            rewrite Z.lt_succ_r in H1.
            apply Z.lt_eq_cases in H1.
            destruct H1; [ assumption | contradiction ].
          }
          destruct (Z_le_dec 262144 (Z.pos p));
            [ destruct (Z_lt_dec (Z.pos p) (Z.min 983040 real_nps)) |];
            [ destruct (MM_kern_valid_dec real_mm (Z.pos p) real_size) | |];
            rewrite ZMap.gso; auto.
      - intros ? ? [ H0 H1 ].
        assert (H2 := Z.lt_trans _ _ _ H0 H1).
        discriminate H2.
    Qed.

    Lemma Calculate_LAT_outside_small :
      forall n v nps mm size a,
        v < 0 -> ZMap.get v (Calculate_LAT n nps mm size a) = ZMap.get v a.
    Proof.
      induction n; simpl; intros; cases; zmap_solve; omega.
    Qed.

    Lemma Calculate_LAT_outside :
      forall n v nps mm size a,
        Z.of_nat n < v -> nps <= v -> ZMap.get v (Calculate_LAT n nps mm size a) = ZMap.get v a.
    Proof.
      induction n; simpl; intros; cases; zmap_solve; try omega;
        rewrite IHn; auto; rewrite Nat2Z.inj_succ in H; omega.
    Qed.

    Lemma Calculate_LAT_0 :
      forall n nps mm size a,
        Z.of_nat n < nps -> ZMap.get 0 (Calculate_LAT n nps mm size a) = LATValid false ATKern nil.
    Proof.
      induction n; simpl; intros; cases; zmap_solve; try omega;
        try solve [rewrite IHn; auto; rewrite Nat2Z.inj_succ in H; omega].
      contradiction n; auto.
    Qed.

    Lemma real_LAT_outside :
      forall v a,
        v < 0 \/ real_nps <= v -> ZMap.get v (real_LAT a) = ZMap.get v a.
    Proof.
      unfold real_LAT; intros v a Hcases; destruct Hcases.
      apply Calculate_LAT_outside_small; auto.
      apply Calculate_LAT_outside; auto.
      assert (Hrange:= real_nps_range); rewrite Z2Nat.id; omega.
    Qed.

    Lemma real_LAT_0_false_nil :
        forall a, ZMap.get 0 (real_LAT a) = LATValid false ATKern nil.
    Proof.
      unfold real_LAT; intros; apply Calculate_LAT_0.
      assert (Hrange:= real_nps_range); rewrite Z2Nat.id; omega.
    Qed.

    Lemma Lreal_at_consistent_lat_domain:
      forall p a,
        consistent_lat_domain (CalRealPT.real_pt p) (real_LAT a) real_nps.
    Proof.
      intros ? a ? v_range ?.
      destruct (real_LAT_all_valid_false_nil a _ v_range) as [ ? -> ];
        discriminate.
    Qed.

  End AT_and_NPS.

  Section AC.

    Definition real_quota_AT := unused_pages_AT (real_AT (ZMap.init ATUndef)) (Z.to_nat (real_nps-1)).
    Definition real_quota := unused_pages (real_LAT (ZMap.init LATUndef)) (Z.to_nat (real_nps-1)).
    Definition real_AC := ZMap.set 0 (mkContainer real_quota 0 0 nil true) (ZMap.init Container_unused).

    Lemma real_AT_unused_pages :
      forall n nps mm size AT AT',
        unused_pages_AT (Calculate_AT n nps mm size AT) n =
        unused_pages_AT (Calculate_AT n nps mm size AT') n.
    Proof.
      induction n; simpl; intros; auto.
      simpl; change (Z.pos (Pos.of_succ_nat n)) with (Z_of_nat (S n)) in *.
      rewrite Nat2Z.inj_succ in *; rewrite <- Z.add_1_r in *.
      repeat match goal with
      | [ |- appcontext [if ?cmp then _ else _] ] => destruct cmp
      end; repeat rewrite ZMap.gss; f_equal;
      repeat rewrite unused_pages_AT_outside; auto; omega.
    Qed.

    Lemma real_LAT_unused_pages :
      forall n nps mm size lat lat',
        unused_pages (Calculate_LAT n nps mm size lat) n =
        unused_pages (Calculate_LAT n nps mm size lat') n.
    Proof.
      induction n; simpl; intros; auto.
      simpl; change (Z.pos (Pos.of_succ_nat n)) with (Z_of_nat (S n)) in *.
      rewrite Nat2Z.inj_succ in *; rewrite <- Z.add_1_r in *.
      repeat match goal with
      | [ |- appcontext [if ?cmp then _ else _] ] => destruct cmp
      end; repeat rewrite ZMap.gss; f_equal;
      repeat rewrite unused_pages_outside; auto; omega.
    Qed.

    Lemma real_quota_unused_pages_AT :
      forall AT,
        unused_pages_AT (real_AT AT) (Z.to_nat (real_nps - 1)) = real_quota_AT.
    Proof.
      unfold real_AT, real_quota; intro; eapply real_AT_unused_pages.
    Qed.

    Lemma real_quota_unused_pages :
      forall lat,
        unused_pages (real_LAT lat) (Z.to_nat (real_nps - 1)) = real_quota.
    Proof.
       unfold real_LAT, real_quota; intro; eapply real_LAT_unused_pages.
    Qed.

    Lemma real_quota_convert : real_quota = real_quota_AT.
    Proof.
      unfold real_quota, real_quota_AT; apply unused_pages_relate.
      apply real_relate_LATable.
      intro; rewrite 2 ZMap.gi; constructor.
    Qed.

    Lemma unused_pages_AT_range :
      forall n AT,
        0 <= unused_pages_AT AT n <= Z.of_nat n.
    Proof.
      induction n; simpl; intros; try omega.
      change (Z.pos (Pos.of_succ_nat n)) with (Z_of_nat (S n)) in *.
      rewrite Nat2Z.inj_succ in *; rewrite <- Z.add_1_r in *.
      specialize (IHn AT); destruct (ZMap.get (Z.of_nat n + 1) AT) as [[|] [| |]|]; omega.
    Qed.

    Lemma unused_pages_range :
      forall n lat,
        0 <= unused_pages lat n <= Z.of_nat n.
    Proof.
      induction n; simpl; intros; try omega.
      change (Z.pos (Pos.of_succ_nat n)) with (Z_of_nat (S n)) in *.
      rewrite Nat2Z.inj_succ in *; rewrite <- Z.add_1_r in *.
      specialize (IHn lat); destruct (ZMap.get (Z.of_nat n + 1) lat) as [[|] [| |]|]; omega.
    Qed.

    Context `{real_params: RealParams}.

    Lemma real_quota_AT_range_nps :
      0 <= real_quota_AT <= real_nps - 1.
    Proof.
      assert (Hrange:= real_nps_range).
      rewrite <- (Z2Nat.id (real_nps-1)); try omega.
      apply unused_pages_AT_range.
    Qed.

    Lemma real_quota_range_nps :
      0 <= real_quota <= real_nps - 1.
    Proof.
      assert (Hrange:= real_nps_range).
      rewrite <- (Z2Nat.id (real_nps-1)); try omega.
      apply unused_pages_range.
    Qed.

    Lemma real_quota_AT_range :
      0 <= real_quota_AT <= maxpage.
    Proof.
      assert (H1:= real_nps_range); assert (H2:= real_quota_AT_range_nps); omega.
    Qed.

    Lemma real_quota_range :
      0 <= real_quota <= maxpage.
    Proof.
      assert (H1:= real_nps_range); assert (H2:= real_quota_range_nps); omega.
    Qed.

  End AC.

End WithRealParamsOps.


Set Implicit Arguments.
Require Import TLC.LibTactics.
(* Load the CFML library, with time credits. *)
Require Import CFML.CFLibCredits.
Require Pervasives_ml.
Require Array_ml.
Require Import Pervasives_proof.
Require Import ArrayCredits_proof.
(* Load the big-O library. *)
Require Import Dominated.
Require Import UltimatelyGreater.
Require Import Monotonic.
Require Import LibZExtra.
(* Load the custom CFML tactics with support for big-Os *)
Require Import CFMLBigO.

(* FIXME: coq bug *)
Lemma L: forall A B (x : (A * B)%type) (f g : A -> B -> Z),
             f (fst x) (snd x) = g (fst x) (snd x) ->
             (let (y,z) := x in f y z) = (let (y,z) := x in g y z).
Proof. intros ? ? x_ ? ? ?. destruct x_. simpl in *. assumption. Qed.

Goal
  specO
    (product_filterType Z_filterType Z_filterType) eq
    (fun _ => True)
    (fun '(n,m) => 0).
Proof.
  xspecO. admit.
  unfold cleanup_cost. splits.
  intro x. unfold costf. eapply L. (* simpl. *)
Abort.

(* For later: what to think about the following unification problem:

   x + y = ?f(x,y) + ?g(x,y)

   Coq doesn't know how to solve it (and there are at least two different
   solutions, (eg inserting a let or using projections)).

   Is it a feature? Is it a limitation that may be lifted in the future?
 *)


(* Formalization of Hyperledger Fabric transaction flow as a transition system *)

Require Import Entities.
Require Import List.
Require Import MyUtils.

Inductive same_val : val -> val -> Prop :=
  Same_PrimVal :
    forall (n : nat), same_val (PrimVal n) (PrimVal n) |
  Same_CompVal :
    forall mp1 mp2, mp1 = mp2 -> same_val (CompVal mp1) (CompVal mp2).

Definition peer_add_trans_propose_msg
           (pn : peer_node) (pmsg : trans_propose_msg) : peer_node
  := upd_peer_pmsgs pn (pn.(peer_pmsgs) ++ (pmsg :: nil)).

Definition cli_add_pending_propose_msg
           (cli : client) (pmsg : trans_propose_msg) : client
  :=
    upd_cli_pending_proposals cli
                              (cli.(cli_pending_proposals) ++ (pmsg :: nil)).

Definition add_pmsg_for_peers
           (pmsg : trans_propose_msg) (peer_mp : mp_tp peer_id peer_node)
           (pn_ids : list peer_id)
  : mp_tp peer_id peer_node :=
  fold_left
    (fun cur_peers idx =>
       func_upd peer_id (option peer_node) beq_peer_id_dec cur_peers idx
                (match cur_peers idx with
                   Some pr =>
                   Some (peer_add_trans_propose_msg pr pmsg)
                 | None => None
                 end))
    pn_ids peer_mp.

Definition cli_add_endorsed_msg cli emsg tid :=
  upd_cli_received_eds
    cli (func_upd hash (list trans_endorsed_msg) beq_hash_dec cli.(cli_received_eds)
                  tid (cli.(cli_received_eds) tid ++ (emsg :: nil))).

Definition rset_of_emsg emsg : read_set :=
  match emsg with
    Trans_endorsed_msg (TxProposal _ _ _ _ rs _) _ => rs
  end.

Definition wset_of_emsg emsg : write_set :=
  match emsg with
    Trans_endorsed_msg (TxProposal _ _ _ _ _ ws) _ => ws
  end.

Definition same_rwsets_lst
           (emsgs : list trans_endorsed_msg) rs ws : Prop :=
  forall i emsg,
    0 <= i -> i < length emsgs ->
    nth_error emsgs i = Some emsg ->
    (rset_of_emsg emsg = rs /\ wset_of_emsg emsg = ws).

Definition client_clear_emsgs (cli : client) (tid : hash) : client :=
  upd_cli_received_eds
    cli
    (func_upd hash (list trans_endorsed_msg) beq_hash_dec cli.(cli_received_eds)
              tid nil).

Definition ccid_of_txfield tx : chaincode_id :=
  match tx with TxField _ cc_id _ _ => cc_id end.

Definition oper_of_txfield tx : operation :=
  match tx with TxField _ _ op _ => op end.

Definition os_record_new_blk os blk :=
  upd_os_blks_created os
    match os.(os_blks_created) with
      blks_mp => mp_upd nat block beq_nat_dec blks_mp (blk_no blk) blk
    end.

(* update the ledger by appending the new block blk
   and updating the world states for chaincodes by wsc *)
Definition peer_update_ledger
           pn blk (wsc : chaincode_id -> option world_state) : peer_node
  := upd_peer_ledger
       pn
       (match pn.(peer_ledger) with
          (Ledger (BC blks) _) =>
          (Ledger (BC (blks ++ (blk :: nil))) wsc)
        end).

(* processing of a single transaction that updates the world state
   and generates a validity flag *)
Inductive trans_validate :
  transaction -> endorsement_pol -> world_state -> world_state -> bool -> Prop :=

  Trans_valid :
    forall trans cc_id op ed_pol rset wset ws emsgs ws',
      trans = Trans cc_id op (rset, wset) emsgs ->
      (* the endorsements contain the same read and write sets *)
      same_rwsets_lst emsgs rset wset ->
      (* the endorsement policy is satisfied *)
      ed_pol
        (map (fun emsg => match emsg with Trans_endorsed_msg _ sig => sig end) emsgs)
      = true ->
      (* the versions for key according to the read set agree with those
         according to the world state *)
      (forall k vr, rset k = Some vr -> (exists vl, ws k = Some (vl, vr))) ->
      (* update the world state ws to ws' *)
      (forall k, (wset k = None /\ ws' k = ws k) \/
                 (exists vl vl' vr, (wset k = Some (Val_or_del1 vl') /\
                                     ws k = Some (vl, Ver vr) /\
                                     ws' k = Some (vl', Ver (S vr)))) \/
                 (exists vl vr, (wset k = Some Val_or_del2 /\
                                 ws k = Some (vl, Ver vr) /\
                                 ws' k = None))) ->
      trans_validate trans ed_pol ws ws' true |

  Trans_invalid :
    forall trans cc_id op ed_pol rset wset ws emsgs,
      trans = Trans cc_id op (rset, wset) emsgs ->
      (~same_rwsets_lst emsgs rset wset \/
       ed_pol
         (map (fun emsg => match emsg with Trans_endorsed_msg _ sig => sig end) emsgs)
         = false \/
       (exists k vr, rset k = Some vr /\ (forall vl, ws k <> Some (vl, vr)))
      ) ->
      trans_validate trans ed_pol ws ws false.

(* processing of a list of transactions that
   updates the world states for the chaincodes and
   generates a list of validity flags for the processed transactions *)
Inductive trans_lst_validate :
  list transaction ->
  (mp_tp chaincode_id endorsement_pol) ->
  (mp_tp chaincode_id world_state) ->
  (mp_tp chaincode_id world_state) ->
  list bool -> Prop :=
  Trans_lst_val_empty :
    forall ep_mp wsc,
      trans_lst_validate nil ep_mp wsc wsc nil |
  Trans_lst_val_inc :
    forall ep_mp wsc wsc' flg flgs tx txs ws ws' cc_id ed_pol,
      cc_id = tx_ccid tx ->
      ep_mp cc_id = Some ed_pol ->
      wsc cc_id = Some ws ->
      trans_validate tx ed_pol ws ws' flg ->
      trans_lst_validate
        txs ep_mp
        (mp_upd chaincode_id world_state beq_cc_id_dec wsc cc_id ws') wsc' flgs ->
      trans_lst_validate (tx :: txs) ep_mp wsc wsc' (flg :: flgs).

Inductive action : Type :=
  Act_cli_prop: client_id -> list peer_id -> action |
  Act_peer_resp: peer_id -> client_id -> action |
  Act_peer_drop_prop: peer_id -> action |
  Act_cli_send_trans: client_id -> action |
  Act_cli_drop_prop: client_id -> action |
  Act_ord_crt_blk: action |
  Act_peer_add_blk: peer_id -> action.

Inductive step
          (h : hash_func)
          (clients : mp_tp client_id client) (peers : mp_tp peer_id peer_node)
          (os : ordering_service)
          (clients' : mp_tp client_id client) (peers' : mp_tp peer_id peer_node)
          (os' : ordering_service)
  : action -> Prop :=

  (* a client sends a transaction proposal to a number of peers *)
  Step_cli_prop :
    forall cli_id cli (target_pn_idxs : list peer_id) ccode_id pmsg
           (op : operation),
      (* the client is on the channel for the transaction proposal *)
      clients cli_id = Some cli ->
      (* target_pn_idxs contains the indicies of a subset of peers
         on the channel identified by ch_id *)
      (forall idx, List.In idx target_pn_idxs -> (exists p, (peers idx = Some p))) ->
      (* build the transaction proposal message pmsg *)
      pmsg = ProposeMsg (TxField cli_id ccode_id op (cli.(cli_timestamp))) ->
      (* add pmsg to the pending transaction proposals for the client cli *)
      clients' = mp_upd client_id client beq_cli_id_dec clients cli_id
                        (inc_cli_timestamp (cli_add_pending_propose_msg cli pmsg)) ->
      (* add pmsg to the pending trans proposals for all peers with indices in
         target_pn_idxs *)
      peers' = add_pmsg_for_peers pmsg peers target_pn_idxs ->
      os' = os ->
      step h clients peers os clients' peers' os'
           (Act_cli_prop cli_id target_pn_idxs) |

  (* a peer sends a transaction proposal response to the client
     with the corresponding proposal *)
  Step_peer_resp :
    forall peer_id cli_id emsg (tid : hash) epsig pn pmsg_idx
           tx ccode_id ts prop rset wset cli bc wsmp ws op ep op_lst,
      (* peer pn has "ProposeMsg tx" from client cli_id for channel chan_id *)
      peers peer_id = Some pn ->
      pn.(peer_ledger) = Ledger bc wsmp ->
      (* select a transaction proposal in the pending list to be processed *)
      nth_error pn.(peer_pmsgs) pmsg_idx = Some (ProposeMsg tx) ->
      tx = TxField cli_id ccode_id op ts ->
      (* create hash tid of the transaction proposal
         as a unique identifier of the proposal *)
      tid = h tx_field tx ->
      (* the operation invoked exists (in a smart contract) on the channel *)
      (pn.(peer_ep_cc)) ccode_id = Some (ep, Chaincode op_lst) ->
      List.In op op_lst ->
      (* evaluate the operation invoked to generate the rwset *)
      wsmp ccode_id = Some ws ->
      (rset, wset) = pn.(peer_interp_oper) op ws ->
      prop = TxProposal peer_id tid ccode_id op rset wset ->
      (* create endorsement *)
      epsig = Sig (pn.(peer_public_key)) (h tx_proposal_field prop) ->
      emsg = Trans_endorsed_msg prop epsig ->
      clients cli_id = Some cli ->
      (* add endorsement to the originating client for the transaction with hash tid *)
      clients' = mp_upd client_id client beq_cli_id_dec clients cli_id
                        (cli_add_endorsed_msg cli emsg tid) ->
      (* remove the transaction proposal that has been handled from the peer *)
      peers' = mp_upd (Entities.peer_id) peer_node beq_peer_id_dec peers peer_id
                      (upd_peer_pmsgs
                         pn
                         ((firstn pmsg_idx pn.(peer_pmsgs))
                            ++ (skipn (S pmsg_idx) pn.(peer_pmsgs)))) ->
      os' = os ->
      step h clients peers os clients' peers' os' (Act_peer_resp peer_id cli_id) |

  (* a peer drops the proposal because it is unable to endorse it *)
  Step_peer_drop_prop :
    forall peer_id pn pmsg pmsg_idx,
      peers peer_id = Some pn ->
      nth_error pn.(peer_pmsgs) pmsg_idx = Some pmsg ->
      peers' = mp_upd Entities.peer_id peer_node beq_peer_id_dec peers peer_id
                      (upd_peer_pmsgs
                         pn
                         ((firstn pmsg_idx pn.(peer_pmsgs))
                            ++ (skipn (S pmsg_idx) pn.(peer_pmsgs)))) ->
      clients' = clients ->
      os' = os ->
      step h clients peers os clients' peers' os' (Act_peer_drop_prop peer_id) |

  (* a client sends a transaction to the ordering service after having collected
     sufficient endorsements on a transaction proposal *)
  Step_client_send_trans :
    forall cli_id cli pn1_id pn1 ed_pol ccode ccode_id prop_idx tx tid
           emsgs epsigs cli_no_prop trans,
      clients cli_id = Some cli ->
      peers pn1_id = Some pn1 ->
      (* the transaction proposal on which endorsement is checked is ProposeMsg tx *)
      nth_error cli.(cli_pending_proposals) prop_idx = Some (ProposeMsg tx) ->
      (* the chaincode id of tx is ccode_id *)
      ccid_of_txfield tx = ccode_id ->
      (* the endorsement policy of the chaincode is ed_pol *)
      (pn1.(peer_ep_cc)) ccode_id = Some (ed_pol, ccode) ->
      (* the transaction identifier obtained by hashing tx is tid *)
      h tx_field tx = tid ->
      cli.(cli_received_eds) tid = emsgs ->
      (* obtain the list of signatures on the endorsement messages and
         verify the endorsement policy using the chan     nel config and the signatures *)
      epsigs = map (fun emsg => match emsg with Trans_endorsed_msg _ sig => sig end)
                   emsgs ->
      ed_pol epsigs = true ->
      (exists rs ws,
          (* the currently received endorsements on the transaction proposal
             have the same readsets and writesets *)
          same_rwsets_lst emsgs rs ws /\
          (* form the transaction *)
          trans = Trans ccode_id (oper_of_txfield tx) (rs, ws) emsgs
      ) ->
      (* update the client by inc the timestamp, removing the transaction proposal
         already handled, and clearing the list of endorsements for that proposal *)
      cli_no_prop = upd_cli_pending_proposals cli
                      (firstn prop_idx cli.(cli_pending_proposals) ++
                       skipn (prop_idx + 1) cli.(cli_pending_proposals)) ->
      clients' = mp_upd client_id client beq_cli_id_dec clients cli_id
                        (client_clear_emsgs cli_no_prop tid) ->
      peers' = peers ->
      (* send the transaction to the ordering service *)
      os' = upd_os_pending_trans os (os.(os_pending_trans) ++ (trans :: nil)) ->
      step h clients peers os clients' peers' os' (Act_cli_send_trans cli_id) |

  (* a client drops a transaction proposal *)
  Step_client_drop_prop :
    forall cli_id cli prop_idx tx tid cli_no_prop,
      clients cli_id = Some cli ->
      (* the transaction proposal on which endorsement is checked is ProposeMsg tx *)
      nth_error cli.(cli_pending_proposals) prop_idx = Some (ProposeMsg tx) ->
      h tx_field tx = tid ->
      cli_no_prop = upd_cli_pending_proposals cli
                      (firstn prop_idx cli.(cli_pending_proposals) ++
                       skipn (prop_idx+1) cli.(cli_pending_proposals)) ->
      clients' = mp_upd client_id client beq_cli_id_dec clients cli_id
                        (client_clear_emsgs cli_no_prop tid) ->
      peers' = peers ->
      os' = os ->
      step h clients peers os clients' peers' os' (Act_cli_drop_prop cli_id) |

  (* the ordering service creates a new block for a channel *)
  Step_orderers_create_blk :
    forall blk ord_trans hdr cur_blk_hash os'' last_blk_no,
      ord_trans = os.(os_pending_trans) ->
      (* there are enough pending transactions to be grouped into a block *)
      length ord_trans >= os.(os_blk_size) ->
      (* collect the transactions and compute the hash for the new block *)
      cur_blk_hash = (h (list transaction) (firstn os.(os_blk_size) ord_trans)) ->
      os.(os_last_blk_num) = last_blk_no ->
      os.(os_blks_created) (S last_blk_no) = None ->
      (* construct the header of the new block *)
      hdr = Blk_header (S last_blk_no) cur_blk_hash (os.(os_last_blk_hash)) ->
      (* construct the new block *)
      blk = Blk hdr (firstn os.(os_blk_size) ord_trans) nil ->
      clients' = clients ->
      peers' = peers ->
      (* remove the transactions that have been assembled in a block
         from the list of pending transactions *)
      os'' = upd_os_pending_trans os (skipn os.(os_blk_size) ord_trans) ->
      (* update the sequence number and hash of the last block as recorded
         in the orderers, and add the new block into the list of newly created blocks *)
      os' = os_record_new_blk
              (upd_os_last_blk_hash (inc_os_blk_num os'') cur_blk_hash) blk ->
      step h clients peers os clients' peers' os' (Act_ord_crt_blk) |

  (* a peer validate a block and each transaction in the block, and
     add the validated block to the ledger *)
  Step_peer_add_block :
    forall peer_id pn new_blk new_hdr new_trans_lst new_valid_lst
           blks wsc wsc' flags new_blk',
      peers peer_id = Some pn ->
      (* new_blk is a pending block for validation *)
      (os.(os_blks_created)) (blk_no new_blk) = Some new_blk ->
      new_blk = Blk new_hdr new_trans_lst new_valid_lst ->
      (* blks is the list of blocks in the current blockchain in pn for chan_id *)
      pn.(peer_ledger) = Ledger (BC blks) wsc ->
      ((length blks = 0 -> blk_no new_blk = 0)
       /\
       (length blks > 0 ->
        forall last_blk,
          (* last_blk is currently the last block in the blockchain *)
          (nth_error blks ((length blks) - 1) = Some last_blk ->
           (* the new block has matching header information to the current last block *)
           (blk_no new_blk = S (blk_no last_blk) /\
            blk_prev_hash new_blk = blk_hash last_blk)))
      ) ->
      (* the individual transactions in the new block are validated,
         with the validity flags set, and
         the world states for chaincodes updated correspodingly *)
      trans_lst_validate
        new_trans_lst
        (fun ccid => match (pn.(peer_ep_cc) ccid) with
                       Some (a, b) => Some a | _ => None end)
        wsc wsc' flags ->
      (* update the validity flags of the new block to be appended to the ledger *)
      new_blk' = Blk new_hdr new_trans_lst flags ->
      clients' = clients ->
      peers' = mp_upd Entities.peer_id peer_node beq_peer_id_dec peers peer_id
                      (peer_update_ledger pn new_blk' wsc') ->
      os' = os ->
      step h clients peers os clients' peers' os' (Act_peer_add_blk peer_id).

Hint Constructors step.

Require Import SfLib.

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "STEP_CLI_PROP" | Case_aux c "STEP_PEER_RESPONSE" |
    Case_aux c "STEP_PEER_DROP" | Case_aux c "STEP_CLI_TRANS" |
    Case_aux c "STEP_CLI_DROP" | Case_aux c "STEP_ORD_BLK" |
    Case_aux c "STEP_PEER_BLK"
  ].

Definition config := prod (mp_tp client_id client)
                          (prod (mp_tp peer_id peer_node) ordering_service).

Definition step_rel_act (hf : hash_func) : action -> config -> config -> Prop :=
  fun act (conf conf' : config) => (
      exists clients peers os clients' peers' os',
        conf = (clients, (peers, os)) /\
        conf' = (clients', (peers', os')) /\
        step hf clients peers os clients' peers' os' act
    ).


Require Export paconotation pacotac pacodef pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 12
*)

(** 1 Mutual Coinduction *)

Section Arg12_1.

Definition monotone12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf: rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) :=
  forall x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 r r' (IN: gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) (LE: r <12= r'), gf r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.
Variable T9 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7), Type.
Variable T10 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8), Type.
Variable T11 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8) (x10: @T10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9), Type.
Variable gf : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11.
Implicit Arguments gf [].

Theorem paco12_acc: forall
  l r (OBG: forall rr (INC: r <12= rr) (CIH: l <_paco_12= rr), l <_paco_12= paco12 gf rr),
  l <12= paco12 gf r.
Proof.
  intros; assert (SIM: paco12 gf (r \12/ l) x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) by eauto.
  clear PR; repeat (try left; do 13 paco_revert; paco_cofix_auto).
Qed.

Theorem paco12_mon: monotone12 (paco12 gf).
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_mult_strong: forall r,
  paco12 gf (paco12 gf r \12/ r) <12= paco12 gf r.
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Corollary paco12_mult: forall r,
  paco12 gf (paco12 gf r) <12= paco12 gf r.
Proof. intros; eapply paco12_mult_strong, paco12_mon; eauto. Qed.

Theorem paco12_fold: forall r,
  gf (paco12 gf r \12/ r) <12= paco12 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco12_unfold: forall (MON: monotone12 gf) r,
  paco12 gf r <12= gf (paco12 gf r \12/ r).
Proof. unfold monotone12; intros; destruct PR; eauto. Qed.

End Arg12_1.

Hint Unfold monotone12.
Hint Resolve paco12_fold.

Implicit Arguments paco12_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].

Instance paco12_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11->_) r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 : paco_class (paco12 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) :=
{ pacoacc    := paco12_acc gf;
  pacomult   := paco12_mult gf;
  pacofold   := paco12_fold gf;
  pacounfold := paco12_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg12_2.

Definition monotone12_2 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf: rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) :=
  forall x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) (LE_0: r_0 <12= r'_0)(LE_1: r_1 <12= r'_1), gf r'_0 r'_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.
Variable T9 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7), Type.
Variable T10 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8), Type.
Variable T11 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8) (x10: @T10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9), Type.
Variable gf_0 gf_1 : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].

Theorem paco12_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <12= rr) (CIH: l <_paco_12= rr), l <_paco_12= paco12_2_0 gf_0 gf_1 rr r_1),
  l <12= paco12_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco12_2_0 gf_0 gf_1 (r_0 \12/ l) r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) by eauto.
  clear PR; repeat (try left; do 13 paco_revert; paco_cofix_auto).
Qed.

Theorem paco12_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <12= rr) (CIH: l <_paco_12= rr), l <_paco_12= paco12_2_1 gf_0 gf_1 r_0 rr),
  l <12= paco12_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco12_2_1 gf_0 gf_1 r_0 (r_1 \12/ l) x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) by eauto.
  clear PR; repeat (try left; do 13 paco_revert; paco_cofix_auto).
Qed.

Theorem paco12_2_0_mon: monotone12_2 (paco12_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_2_1_mon: monotone12_2 (paco12_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_2_0_mult_strong: forall r_0 r_1,
  paco12_2_0 gf_0 gf_1 (paco12_2_0 gf_0 gf_1 r_0 r_1 \12/ r_0) (paco12_2_1 gf_0 gf_1 r_0 r_1 \12/ r_1) <12= paco12_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_2_1_mult_strong: forall r_0 r_1,
  paco12_2_1 gf_0 gf_1 (paco12_2_0 gf_0 gf_1 r_0 r_1 \12/ r_0) (paco12_2_1 gf_0 gf_1 r_0 r_1 \12/ r_1) <12= paco12_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Corollary paco12_2_0_mult: forall r_0 r_1,
  paco12_2_0 gf_0 gf_1 (paco12_2_0 gf_0 gf_1 r_0 r_1) (paco12_2_1 gf_0 gf_1 r_0 r_1) <12= paco12_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco12_2_0_mult_strong, paco12_2_0_mon; eauto. Qed.

Corollary paco12_2_1_mult: forall r_0 r_1,
  paco12_2_1 gf_0 gf_1 (paco12_2_0 gf_0 gf_1 r_0 r_1) (paco12_2_1 gf_0 gf_1 r_0 r_1) <12= paco12_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco12_2_1_mult_strong, paco12_2_1_mon; eauto. Qed.

Theorem paco12_2_0_fold: forall r_0 r_1,
  gf_0 (paco12_2_0 gf_0 gf_1 r_0 r_1 \12/ r_0) (paco12_2_1 gf_0 gf_1 r_0 r_1 \12/ r_1) <12= paco12_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco12_2_1_fold: forall r_0 r_1,
  gf_1 (paco12_2_0 gf_0 gf_1 r_0 r_1 \12/ r_0) (paco12_2_1 gf_0 gf_1 r_0 r_1 \12/ r_1) <12= paco12_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco12_2_0_unfold: forall (MON: monotone12_2 gf_0) (MON: monotone12_2 gf_1) r_0 r_1,
  paco12_2_0 gf_0 gf_1 r_0 r_1 <12= gf_0 (paco12_2_0 gf_0 gf_1 r_0 r_1 \12/ r_0) (paco12_2_1 gf_0 gf_1 r_0 r_1 \12/ r_1).
Proof. unfold monotone12_2; intros; destruct PR; eauto. Qed.

Theorem paco12_2_1_unfold: forall (MON: monotone12_2 gf_0) (MON: monotone12_2 gf_1) r_0 r_1,
  paco12_2_1 gf_0 gf_1 r_0 r_1 <12= gf_1 (paco12_2_0 gf_0 gf_1 r_0 r_1 \12/ r_0) (paco12_2_1 gf_0 gf_1 r_0 r_1 \12/ r_1).
Proof. unfold monotone12_2; intros; destruct PR; eauto. Qed.

End Arg12_2.

Hint Unfold monotone12_2.
Hint Resolve paco12_2_0_fold.
Hint Resolve paco12_2_1_fold.

Implicit Arguments paco12_2_0_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_1_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_0_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_1_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_0_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_1_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_0_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_1_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_0_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_1_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_0_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_2_1_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].

Instance paco12_2_0_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf_0 gf_1 : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11->_) r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 : paco_class (paco12_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) :=
{ pacoacc    := paco12_2_0_acc gf_0 gf_1;
  pacomult   := paco12_2_0_mult gf_0 gf_1;
  pacofold   := paco12_2_0_fold gf_0 gf_1;
  pacounfold := paco12_2_0_unfold gf_0 gf_1 }.

Instance paco12_2_1_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf_0 gf_1 : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11->_) r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 : paco_class (paco12_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) :=
{ pacoacc    := paco12_2_1_acc gf_0 gf_1;
  pacomult   := paco12_2_1_mult gf_0 gf_1;
  pacofold   := paco12_2_1_fold gf_0 gf_1;
  pacounfold := paco12_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg12_3.

Definition monotone12_3 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf: rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11) :=
  forall x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) (LE_0: r_0 <12= r'_0)(LE_1: r_1 <12= r'_1)(LE_2: r_2 <12= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.
Variable T9 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7), Type.
Variable T10 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8), Type.
Variable T11 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8) (x10: @T10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9), Type.
Variable gf_0 gf_1 gf_2 : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 -> rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].
Implicit Arguments gf_2 [].

Theorem paco12_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <12= rr) (CIH: l <_paco_12= rr), l <_paco_12= paco12_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <12= paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco12_3_0 gf_0 gf_1 gf_2 (r_0 \12/ l) r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) by eauto.
  clear PR; repeat (try left; do 13 paco_revert; paco_cofix_auto).
Qed.

Theorem paco12_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <12= rr) (CIH: l <_paco_12= rr), l <_paco_12= paco12_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <12= paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco12_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \12/ l) r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) by eauto.
  clear PR; repeat (try left; do 13 paco_revert; paco_cofix_auto).
Qed.

Theorem paco12_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <12= rr) (CIH: l <_paco_12= rr), l <_paco_12= paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <12= paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \12/ l) x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) by eauto.
  clear PR; repeat (try left; do 13 paco_revert; paco_cofix_auto).
Qed.

Theorem paco12_3_0_mon: monotone12_3 (paco12_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_3_1_mon: monotone12_3 (paco12_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_3_2_mon: monotone12_3 (paco12_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_3_0_mult_strong: forall r_0 r_1 r_2,
  paco12_3_0 gf_0 gf_1 gf_2 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2) <12= paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_3_1_mult_strong: forall r_0 r_1 r_2,
  paco12_3_1 gf_0 gf_1 gf_2 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2) <12= paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Theorem paco12_3_2_mult_strong: forall r_0 r_1 r_2,
  paco12_3_2 gf_0 gf_1 gf_2 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2) <12= paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 13 paco_revert; paco_cofix_auto). Qed.

Corollary paco12_3_0_mult: forall r_0 r_1 r_2,
  paco12_3_0 gf_0 gf_1 gf_2 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <12= paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco12_3_0_mult_strong, paco12_3_0_mon; eauto. Qed.

Corollary paco12_3_1_mult: forall r_0 r_1 r_2,
  paco12_3_1 gf_0 gf_1 gf_2 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <12= paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco12_3_1_mult_strong, paco12_3_1_mon; eauto. Qed.

Corollary paco12_3_2_mult: forall r_0 r_1 r_2,
  paco12_3_2 gf_0 gf_1 gf_2 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <12= paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco12_3_2_mult_strong, paco12_3_2_mon; eauto. Qed.

Theorem paco12_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2) <12= paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco12_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2) <12= paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco12_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2) <12= paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco12_3_0_unfold: forall (MON: monotone12_3 gf_0) (MON: monotone12_3 gf_1) (MON: monotone12_3 gf_2) r_0 r_1 r_2,
  paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <12= gf_0 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2).
Proof. unfold monotone12_3; intros; destruct PR; eauto. Qed.

Theorem paco12_3_1_unfold: forall (MON: monotone12_3 gf_0) (MON: monotone12_3 gf_1) (MON: monotone12_3 gf_2) r_0 r_1 r_2,
  paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <12= gf_1 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2).
Proof. unfold monotone12_3; intros; destruct PR; eauto. Qed.

Theorem paco12_3_2_unfold: forall (MON: monotone12_3 gf_0) (MON: monotone12_3 gf_1) (MON: monotone12_3 gf_2) r_0 r_1 r_2,
  paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <12= gf_2 (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_0) (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_1) (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \12/ r_2).
Proof. unfold monotone12_3; intros; destruct PR; eauto. Qed.

End Arg12_3.

Hint Unfold monotone12_3.
Hint Resolve paco12_3_0_fold.
Hint Resolve paco12_3_1_fold.
Hint Resolve paco12_3_2_fold.

Implicit Arguments paco12_3_0_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_1_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_2_acc            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_0_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_1_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_2_mon            [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_0_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_1_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_2_mult_strong    [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_0_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_1_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_2_mult           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_0_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_1_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_2_fold           [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_0_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_1_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].
Implicit Arguments paco12_3_2_unfold         [ T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 ].

Instance paco12_3_0_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf_0 gf_1 gf_2 : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 : paco_class (paco12_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) :=
{ pacoacc    := paco12_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco12_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco12_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco12_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco12_3_1_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf_0 gf_1 gf_2 : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 : paco_class (paco12_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) :=
{ pacoacc    := paco12_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco12_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco12_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco12_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco12_3_2_inst  T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 (gf_0 gf_1 gf_2 : rel12 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11->_) r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 : paco_class (paco12_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) :=
{ pacoacc    := paco12_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco12_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco12_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco12_3_2_unfold gf_0 gf_1 gf_2 }.


(** * Summary of the main results as in Section 3.1 *)
Require Import RL.Utilities.Rpos.
Require Import RL.hr.Rterm.
Require Import RL.hr.term.
Require Import RL.hr.Rsemantic.
Require Import RL.hr.semantic.
Require Import RL.hr.semantic_Rsemantic_eq.
Require Import RL.hr.hseq.
Require Import RL.hr.completeness.
Require Import RL.hr.soundness.
Require Import RL.hr.interpretation.
Require Import RL.hr.hr.
Require Import RL.hr.invertibility.
Require Import RL.hr.M_elim.
Require Import RL.hr.can_elim.
Require Import RL.hr.decidability.

Require Import Reals.
Require Import Lra.
Require Import Lia.

Require Import RL.OLlibs.List_more.

(** Theorem 3.9 *)
Lemma HR_soundness P : forall G,
    HR P G ->
    R_zero <R= toRterm (sem_hseq G).
Proof.
  intros G pi.
  change (R_zero /\R (toRterm (sem_hseq G))) with (toRterm (HR_zero /\S sem_hseq G)).
  change (R_zero) with (toRterm HR_zero).
  apply semantic_to_Rsemantic.
  apply hr_sound with P.
  apply pi.
Qed.

(** Theorem 3.10 *)
Lemma HR_completeness : forall G,
    G <> nil ->
    R_zero <R= toRterm (sem_hseq G) ->
    HR_M_can G.
Proof.
  intros G Hnnil H.
  apply hr_complete; [ apply Hnnil | ].
  transitivity (NNF (R_zero /\R toRterm (sem_hseq G))).
  - simpl.
    rewrite NNF_toRterm.
    reflexivity.
  - change HR_zero with (NNF (R_zero)).
    apply Rsemantic_to_semantic.
    apply H.
Qed.

(** Theorem 3.11 *)
Lemma HR_plus_inv : forall G T A B r, HR_T_M ((vec r (A +S B) ++ T) :: G) -> HR_T_M ((vec r A ++ vec r B ++ T) :: G).
Proof.
  apply hrr_plus_inv.
Qed.

Lemma HR_Z_inv : forall G T r, HR_T_M ((vec r HR_zero ++ T) :: G) -> HR_T_M (T :: G).
Proof.
  apply hrr_Z_inv.
Qed.

Lemma HR_mul_inv : forall G T A r0 r, HR_T_M ((vec r (r0 *S A) ++ T) :: G) -> HR_T_M ((vec (mul_vec r0 r) A ++ T) :: G).
Proof.
  apply hrr_mul_inv.
Qed.

Lemma HR_max_inv : forall G T A B r, HR_T_M ((vec r (A \/S B) ++ T) :: G) -> HR_T_M ((vec r B ++ T) :: (vec r A ++ T) :: G).
Proof.
  apply hrr_max_inv.
Qed.

Lemma HR_min_inv_l : forall G T A  B r, HR_T_M ((vec r (A /\S B) ++ T) :: G) -> HR_T_M ((vec r A ++ T) :: G).
Proof.
  apply hrr_min_inv_l.
Qed.

Lemma HR_min_inv_r : forall G T A  B r, HR_T_M ((vec r (A /\S B) ++ T) :: G) -> HR_T_M ((vec r B ++ T) :: G).
Proof.
  apply hrr_min_inv_r.
Qed.

(** Theorem 3.12 *)
Lemma HR_M_elim : forall G, HR_T_M G -> HR_T G.
Proof.
  apply hrr_M_elim.
Qed.

(** Theorem 3.13 *)
Lemma HR_can_elim : forall G, HR_full G -> HR_T_M G.
Proof.
  apply hrr_can_elim.
Qed.

(** Theorem 3.15 *)
(** Proposition 3.16 *)
Lemma HR_without_T_CAN_not_complete :
  { G : _ & HR_zero <== sem_hseq G & (HR_M G -> False) }.
Proof.
  apply HR_M_not_complete.
Qed.

(** Theorem 3.17 *)
Lemma HR_is_decidable : forall G,
    (HR_full G) + (HR_full G -> False).
Proof.
  apply HR_decidable.
Qed.


Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.integers
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.dec_fields
  HoTT.Classes.orders.dec_fields
  HoTT.Classes.theory.rationals
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.theory.premetric
  HoTT.Classes.implementations.assume_rationals
  HoTT.HIT.surjective_factor
  HoTTClasses.cauchy_completion.

Require Export
  HoTTClasses.cauchy_reals.base
  HoTTClasses.cauchy_reals.abs
  HoTTClasses.cauchy_reals.order
  HoTTClasses.cauchy_reals.metric
  HoTTClasses.cauchy_reals.ring
  HoTTClasses.cauchy_reals.full_order.

Local Set Universe Minimization ToSet.

Definition Qpos_upper_recip (e:Q+) : real -> real
  := lipschitz_extend _ (rat ∘ ((/) ∘ pr1 ∘ (Qpos_upper_inject e))) _.

Instance Qpos_upper_recip_lipschitz : forall e,
  Lipschitz (Qpos_upper_recip e) _
  := _.
Typeclasses Opaque Qpos_upper_recip.

Definition pos_back : (exists e : Q+, exists x : real, rat (' e) <= x) ->
  exists x : real, 0 < x.
Proof.
intros s;exists (s.2.1).
apply R_lt_le_trans with (rat (' s.1)).
- apply rat_lt_preserving;solve_propholds.
- apply s.2.2.
Defined.

Lemma Qpos_upper_recip_respects : forall (x : exists (e : Q+) (x : real), rat (' e) ≤ x)
  (y : exists (e : Q+) (x0 : real), rat (' e) ≤ x0),
  pos_back x = pos_back y ->
  Qpos_upper_recip x.1 (x.2).1 = Qpos_upper_recip y.1 (y.2).1.
Proof.
intros [e1 [x Ex]] [e2 [y Ey]] E.
apply (ap pr1) in E. simpl in E.
simpl.
destruct E.
pose proof (join_le _ _ _ Ex Ey) as E;clear Ex Ey.
rewrite <-E;clear E.
revert x. apply (unique_continuous_extension _ _ _).
intros q. unfold Qpos_upper_recip;simpl.
change (rat ((dec_recip ∘ pr1 ∘ Qpos_upper_inject e1) ((' e1 ⊔ ' e2) ⊔ q)) =
rat ((dec_recip ∘ pr1 ∘ Qpos_upper_inject e2) ((' e1 ⊔ ' e2) ⊔ q))).
apply (ap rat). unfold Compose;simpl.
apply ap.
rewrite <-(simple_associativity (f:=join)),(commutativity (f:=join) q).
rewrite (simple_associativity (f:=join)),(commutativity (f:=join) _ (' e1)).
rewrite (simple_associativity (f:=join)),(idempotency _ _).
set (LEFT := (' e1 ⊔ ' e2) ⊔ q) at 1.
rewrite <-(simple_associativity (f:=join)),(commutativity (f:=join) q).
rewrite (simple_associativity (f:=join)).
rewrite <-(simple_associativity (f:=join) (' e1)),(idempotency join (' e2)).
reflexivity.
Qed.

Lemma Qpos_upper_recip_invariant : forall x e e',
    rat (' e) <= x -> rat (' e') <= x ->
    Qpos_upper_recip e x = Qpos_upper_recip e' x.
Proof.
  intros x e e' E1 E2.
  apply (Qpos_upper_recip_respects (e; (x; E1)) (e'; (x; E2))).
  unfold pos_back. simpl.
  apply Sigma.path_sigma_hprop. simpl. reflexivity.
Qed.

Lemma pos_back_issurj0 : IsSurjection pos_back.
Proof.
apply BuildIsSurjection. intros s.
generalize s.2. apply (Trunc_ind _).
intros [q [r [E1 [E2 E3]]]].
apply tr. simple refine (existT _ _ _).
+ simple refine (existT _ _ _).
  * exists r. apply le_lt_trans with q;trivial. apply rat_le_reflecting;trivial.
  * simpl. exists s.1. unfold cast;simpl. trivial.
+ simpl. unfold pos_back. simpl. apply Sigma.path_sigma_hprop. reflexivity.
Defined.

Definition pos_back_issurj@{} : IsSurjection pos_back
  := Eval unfold pos_back_issurj0 in pos_back_issurj0@{Uhuge Ularge Ularge}.
Existing Instance pos_back_issurj.

Definition R_pos_recip@{} : (exists x : real, 0 < x) -> real.
Proof.
simple refine (surjective_factor@{UQ UQ UQ Uhuge Ularge
  Ularge Ularge Ularge UQ Ularge
  UQ Uhuge Ularge} _ pos_back _).
- intros s. exact (Qpos_upper_recip s.1 s.2.1).
- simpl. exact Qpos_upper_recip_respects.
Defined.

Lemma R_pos_recip_pr@{} : forall x, Qpos_upper_recip x.1 (x.2).1 = R_pos_recip (pos_back x).
Proof.
  apply surjective_factor_pr.
Qed.

Lemma R_pos_recip_rat : forall q (Eq : 0 < rat q),
  R_pos_recip (existT _ (rat q) Eq) = rat (/ q).
Proof.
  intros q; apply (Trunc_ind _);intros [r [s [E1 [E2 E3]]]].
  set (xq := (rat q; _)).
  generalize (center _ (pos_back_issurj xq)). apply (Trunc_ind _).
  intros [[e [x a]] b]. rewrite <-b.
  rewrite <-R_pos_recip_pr. simpl.
  unfold pos_back in b. simpl in b. apply (ap pr1) in b. simpl in b.
  rewrite b in a |- *.
  change ((rat ∘ (/)) (join q (' e)) = (rat ∘ (/)) q).
  apply ap. apply join_l.
  apply rat_le_reflecting;trivial.
Qed.

Instance Rrecip : Recip real.
Proof.
intros [x [E|E]].
- apply negate,R_pos_recip;exists (- x). apply flip_neg_negate. trivial.
- apply R_pos_recip;exists x;trivial.
Defined.

Lemma Rrecip_rat@{} : forall q (Eq : apart (rat q) 0),
  // (existT (fun y => apart y 0) (rat q) Eq) = rat (/ q).
Proof.
simpl;intros q [Eq|Eq];unfold recip;simpl.
- change (- rat q) with (rat (- q)). rewrite R_pos_recip_rat@{Uhuge Ularge}.
  apply (ap rat).
  rewrite dec_recip_negate@{UQ Ularge},involutive. trivial.
- apply R_pos_recip_rat@{Uhuge Ularge}.
Qed.

Lemma Rneg_strong_ext : StrongExtensionality (negate (A:=real)).
Proof.
hnf. intros x y [E|E];[right|left];apply Rneg_lt_flip,E.
Defined.

Instance Rneg_strong_injective : StrongInjective (negate (A:=real)).
Proof.
split;try apply Rneg_strong_ext.
intros x y [E|E];[right|left];apply Rneg_lt_flip;rewrite !involutive;trivial.
Defined.

Definition R_apartzero_neg : ApartZero real -> ApartZero real.
Proof.
intros x. exists (- x.1).
destruct (x.2) as [E|E];[right|left].
- apply flip_neg_negate;trivial.
- apply flip_pos_negate;trivial.
Defined.

Lemma Rrecip_neg : forall x, - (// x) = // (R_apartzero_neg x).
Proof.
intros [x [E|E]];unfold recip;simpl.
- apply involutive.
- apply ap. apply ap. apply Sigma.path_sigma_hprop. simpl.
  symmetry;apply involutive.
Qed.

Lemma R_recip_upper_recip : forall x e, rat (' e) <= x ->
  forall (E : apart x 0),
  // (existT (fun y => apart y 0) x E)
    = Qpos_upper_recip e x.
Proof.
intros x e E1 [E2|E2].
- destruct (irreflexivity lt x).
  transitivity 0;trivial. apply R_lt_le_trans with (rat (' e));trivial.
  apply rat_lt_preserving;solve_propholds.
- unfold recip;simpl. revert E2;apply (Trunc_ind _);intros [q [r [E2 [E3 E4]]]].
  set (X := (x;_)).
  generalize (center _ (pos_back_issurj X)). apply (Trunc_ind _).
  intros [[e' [y a]] b].
  rewrite <-b, <-R_pos_recip_pr.
  apply (ap pr1),symmetry in b;simpl in b. destruct b.
  simpl. clear X.
  apply Qpos_upper_recip_invariant;trivial.
Qed.

Instance real_nontrivial : PropHolds (apart (A:=real) 1 0).
Proof.
right. apply rat_lt_preserving;solve_propholds.
Defined.

Lemma R_pos_recip_inverse : forall x E, x // (existT _ x (inr E)) = 1 :> real.
Proof.
intros x E.
apply (merely_destruct (Rlt_exists_pos_plus_le _ _ E)). intros [e E1].
rewrite plus_0_l in E1.
rewrite (R_recip_upper_recip@{Uhuge Ularge} _ _ E1).
rewrite <-E1. clear E E1;revert x.
apply (unique_continuous_extension _).
- change (Continuous (uncurry mult ∘
    map2 (join (rat (' e))) (Qpos_upper_recip e ∘ (join (rat (' e)))) ∘
  BinaryDup)).
  repeat apply continuous_compose;apply _.
- apply _.
- intros q.
  change (rat ((' e ⊔ q) * (dec_recip ∘ pr1 ∘ Qpos_upper_inject e) (' e ⊔ q)) =
    rat 1).
  apply (ap rat).
  unfold Compose;simpl.
  rewrite (commutativity (f:=join) _ (' e)),(simple_associativity (f:=join)).
  rewrite (idempotency _ _).
  apply dec_recip_inverse.
  apply lt_ne_flip.
  apply lt_le_trans with (' e).
  + solve_propholds.
  + apply join_ub_l.
Unshelve. exact 1.
Qed.

Lemma R_recip_inverse@{} : forall x, x.1 // x = 1 :> real.
Proof.
intros [x [E|E]];simpl.
- rewrite <-negate_mult_negate,Rrecip_neg. unfold R_apartzero_neg. simpl.
  apply R_pos_recip_inverse.
- apply R_pos_recip_inverse.
Qed.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Bishop.Trv.
Require Import Blech.Bishop.Mt.
Require Import Blech.Category.
Require Import Blech.Functor.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.
Import FunctorNotations.

Open Scope category_scope.
Open Scope bishop_scope.

Close Scope nat.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
 Definition Opt (C: Category): Category := {|
  Obj := option C ;
  Mor A B :=
    match A with
    | Some A' =>
      match B with
      | Some B' => A' ~> B'
      | _ => mt
      end
    | _ =>
      match B with
      | Some B' => mt
      | _ => trv
      end
    end ;

  id A := match A with
          | Some _ => id _
          | None => I
          end ;
|}.

Next Obligation.
Proof.
  destruct A, B.
  - apply Mor_Setoid.
  - apply (@Bishop_Setoid mt).
  - apply (@Bishop_Setoid mt).
  - apply (@Bishop_Setoid trv).
Defined.

Next Obligation.
Proof.
  destruct A, B, C0.
  all: try contradiction.
  all: try (apply I).
  apply (X ∘ X0).
Defined.

Next Obligation.
Proof.
  destruct A, B, C0, D.
  all: cbn in *.
  all: try contradiction.
  2: apply I.
  apply compose_assoc.
Qed.

Next Obligation.
Proof.
  destruct A, B.
  all: cbn in *.
  all: try contradiction.
  2: apply I.
  apply compose_id_left.
Qed.

Next Obligation.
Proof.
  destruct A, B.
  all: cbn in *.
  all: try contradiction.
  2: apply I.
  apply compose_id_right.
Qed.

Next Obligation.
Proof.
  intros ? ? p ? ? q.
  destruct A, B, C0.
  all: cbn in *.
  all: try contradiction.
  2: apply I.
  rewrite p, q.
  reflexivity.
Qed.