(* まとめのまとめ。

Mathcomp では、型をつぎのように構成している。
(eqType) ライプニッツのeqとブールのeqのリフレクションできる型。eqMixin

(choiceType) 可算選択公理 (axiom of countable choice) が成り立つこと。choiceMixin
(countType) n番め要素が(あれば)一意に決まる(countable)こと。 countMixin

(finType) 型の要素の列挙(enum)が、eqTypeの意味でユニークである型。finMixin
(tuple) サイズの決まったseq。
(finfun) ファントムタイプによって finType -> Type の関数に見えるが、
実際はタプルであり、fintypeの全要素の個数のサイズのタプル。
(finset) 特性関数（要素かどうか決める関数）がfinfunである集合

fintypeを要素とするtupleはfintypeなので、コドメインがfintypeであるfinfunは、fintypeである。

Mathcomp で理解するべきなのは、Propとbooleanのリフレクションである。
(eqP) eqType では、 == と =
(allP) seq では、(∀x, x \in s -> a x) と (all a s).
(forallP) finType では、[forall x, P] と (forall x, P)
(ffunP) finFun では、=1 と = (関数どうしの等しさ)
(setP) finSet では、=i と = (集合どうしの等しさ)
(permP) perm では、集合とおなじ。本文に記載なし。

それを以下にまとめる。

@suharahiromichi 2017/08/14
 *)

From mathcomp Require Import all_ssreflect.
From mathcomp Require Import perm.

(* Mathcomp book まとめ *)
(* Mathcomp の数学体系 --- Perm まで *)

(* ************************ *)
(* 5.3 Records as relations *)
(* ************************ *)
Definition bool_eqMixin' := @EqMixin bool eqb eqbP.
Canonical  bool_eqType'  := EqType bool bool_eqMixin'.

Definition nat_eqMixin'  := @EqMixin nat eqn (@eqnP).
Canonical  nat_eqType'   := EqType nat nat_eqMixin'.

Definition seq_eqMixin' (T : eqType) := @EqMixin (seq T) (@eqseq T) (@eqseqP T).
Canonical  seq_eqType'  (T : eqType) := EqType (seq T) (seq_eqMixin' T).

Definition prod_eqMixin' (T1 T2 : eqType) :=
  @EqMixin (T1 * T2) (pair_eq T1 T2) (@pair_eqP T1 T2).
Canonical  prod_eqType'  (T1 T2 : eqType) :=
  EqType (T1 * T2) (prod_eqMixin' T1 T2).

(* ************************* *)
(* 6.2.1 subtype kit (p.160) *)
(* eqtype.v                  *)
(* ************************* *)
(*
Section MySubTypeKit.
  Variables (T : Type) (P : pred T).

  Structure subType' : Type :=
    SubType' {
        sub_sort :> Type;                   (* projector *)
        val : sub_sort -> T;                (* constructor *)
        Sub : forall x, P x -> sub_sort;    (* constructor *)
        (* elimination rule for sub_sort *)
        _: forall K (_ : forall x Px, K (@Sub x Px)) u, K u;
        _: forall x Px, val (@Sub x Px) = x
      }.
End MySubTypeKit.

(* Implicit Arguments SubType' [T P]. *)

Notation "[ 'subType_' 'for' v ]" :=
  (SubType' _ v _
            (fun K K_S u => let (x, Px) as u return K u := u in K_S x Px)
            (fun x px => erefl x))
    (at level 0).
*)

(* ********************************* *)
(* 6.3 Finite types and their theory *)
(* ********************************* *)

Notation count_mem x := (count [pred y | y == x]).
Module finite.
  Definition axiom (T : eqType) (e : seq T) :=
    forall x : T, count_mem x e = 1.

  Record mixin_of (T : eqType) :=
    Mixin {
        enum : seq T;
        _ : axiom T enum;
      }.

(*
The axiom asserts that any inhabitant of T occurs exactly once in the enumeration e.

この公理は、Tの任意な要素が、列挙eに1回づづ出現すると主張している。
*)

  Check @card_uniqP :
    forall (T : finType) (s : seq T), reflect (#|s| = size s) (uniq s).
  Check @forallP :
    forall (T : finType) (P : pred T), reflect (forall x : T, P x) [forall x, P x].
  (* XXX_finType に関して、(forall x, P x) と [forall x, P x] のリフレクションができる。 *)

  (* is a boolean expression, it enables reasoning by excluded middle
  and also combines well with other boolean connectives. *)
  (* bool式であり、排中律などのboolenaな論理演算との組み合わせも可能である *)
End finite.

(* ******************************* *)
(* 6.4 The ordinal subtype (p.164) *)
(* ******************************* *)
Definition ordinal_eqMixin' (n : nat) := [eqMixin of (ordinal n) by <:].
(* (@val_eqP nat_eqType (fun x : nat => x < n) (ordinal_subType n)) *)
Canonical  ordinal_eqType'  (n : nat) := EqType (ordinal n) (ordinal_eqMixin' n).

(* 重複がないこと、漏れがないこと、から定義する。 *)
Definition ordinal_finMixin' (n : nat) :=
  @UniqFinMixin _ (ord_enum n) (ord_enum_uniq n) (@mem_ord_enum n).
Canonical  ordinal_finType'  (n : nat) :=
  FinType (ordinal n) (ordinal_finMixin' n).

(* finType に関して、uniq s と #|s|=size s のリフレクションができる。 *)
Goal forall s : seq (ordinal_finType' 3), size s = 3 -> uniq s.
  move=> s H.
  apply/card_uniqP.
  (* #|s| = size s *)
  Admitted.

Compute val (@Ordinal 4 3 (leqnn 3)).       (* 3 *)
Goal forall n, map val (ord_enum n) = iota 0 n.
Proof.
  move=> n.
  rewrite pmap_filter.
  + apply/all_filterP/allP => i. by rewrite mem_iota isSome_insub.
  + by apply: insubK.
Qed.

(* finType に関して、(forall x, P x) と [forall x, P x] のリフレクションができる。 *)
Goal [forall a : ordinal_finType' 3, a < 3].
    by apply/forallP.
Qed.

(* ************ *)
(* 6.1 n-tuples *)
(* ************ *)
Structure tuple_of' (n : nat) (T : Type) := (* サイズnのseq *)
  Tuple' {
      tval' :> seq T;
      _     : size tval' == n
    }.
Notation "n .-TUPLE" := (tuple_of' n) (at level 2, format "n .-TUPLE").
Check tval' : forall (n : nat) (T : Type), n.-TUPLE T -> seq T.

Print Canonical Projections.
Canonical tuple_subType' (n : nat) (T : Type) := [subType for tval' n T].
(* オリジナルの [subType for _] を使用している。 *)
Print Canonical Projections.
(*
tuple_subType' を subType のカノニカルインスタンスにする。
つまりsubType型を求める引数に、tuple_subType'を推論できるようになる。
tuple_of' <- sub_sort ( tuple_subType' )
tval'     <- val ( tuple_subType' )
Tuple'    <- Sub ( tuple_subType' )
*)
Check sub_sort : forall (T : Type) (P : pred T), subType (T:=T) P -> Type.
Check @val     : forall (T : Type) (P : pred T) (s : subType (T:=T) P), s -> T.
Check @Sub     : forall (T : Type) (P : pred T) (s : subType (T:=T) P) (x : T), P x -> s.
Check tval     : forall (n : nat) (T : Type), n.-tuple T -> seq T.
Check Tuple    : forall (n : nat) (T : Type) (tval : seq T), size tval == n -> n.-tuple T.
Print tval.  (* fun (n : nat) (T : Type) (t : n.-tuple T) => let (tval, _) := t in tval *)
Print Tuple. (* Tuple { tval : seq T;  _ : is_true (size tval == n) } *)

Definition tuple_eqMixin' (n : nat) (T : finType) := [eqMixin of n.-TUPLE T by <:].
(* (@val_eqP (seq_eqType T) (fun x : seq T => size x == n) (tuple_subType n T)) *)
Canonical  tuple_eqType'  (n : nat) (T : finType) :=
  EqType (n.-TUPLE T) (tuple_eqMixin' n T).

(* countType と enum (seq) から定義する。 *)
Definition tuple_finMixin' (n : nat) (T : finType) :=
  @FinMixin (tuple_countType n T) (FinTuple.enum n T) (@FinTuple.enumP n T).
Canonical  tuple_finType' (n : nat) (T : finType) :=
  FinType (tuple_countType n T) (tuple_finMixin' n T).

(* **************************** *)
(* 6.5 Finite functions (p.165) *)
(* **************************** *)
Inductive finfun_type' (aT : finType) (rT : Type) : predArgType :=
  Finfun' of #|aT|.-TUPLE rT.
Definition finfun_of' (aT : finType) (rT : Type) of phant (aT -> rT) :=
  finfun_type'.

Identity Coercion type_of_finfun' : finfun_of >-> finfun_type.

Definition fgraph' (aT : finType) (rT : Type) (f : finfun_type' aT rT) :=
  let: Finfun' t := f in t.
Canonical finfun_subType' (aT : finType) (rT : Type) :=
  [newType for fgraph' aT rT].
Print Canonical Projections.
(*
finfun_type' <- sub_sort ( finfun_subType' )
fgraph'      <- val ( finfun_subType' )
 *)

Notation "{ 'FFUN' fT }" := (finfun_type' fT).
(*
テキストの記載：

The actual definition in the Mathematical Components library is slightly
more complex to statically check that the domain is finite
using the tricks ex- plained in 5.11.
I.e. Coq rejects {ffun nat -> nat} but accepts {ffun ’I_7 -> nat}
 *)
(*
Inductive finfun' (aT : finType) (rT : Type) : Type :=
  Finfun' of #|aT|.-TUPLE rT.
Notation "{ 'FFUN' fT }" := (finfun' fT).
Definition fgraph' (aT : finType) (rT : Type) (f : {FFUN aT} rT) :=
  let: Finfun' t := f in t.
(* match f with | Finfun' t => t end. *)

Check fgraph' : forall (aT : finType) (rT : Type), { FFUN aT} rT -> #|aT|.-TUPLE rT.
Canonical  finfun_subType' (aT : finType) (rT : Type) := [newType for fgraph' aT rT].
*)

Definition finfun_eqMixin' (aT rT : finType) := [eqMixin of {FFUN aT} rT by <:].
(* (@val_eqP (tuple_eqType #|aT| rT) xpredT (finfun_subType aT rT)) *)
Canonical  finfun_eqType'  (aT rT : finType) := EqType ({FFUN aT} rT) (finfun_eqMixin' aT rT).

Definition finfun_finMixin' (aT rT : finType) := [finMixin of finfun_type aT rT by <:].
Canonical  finfun_finType'  (aT rT : finType) :=
  FinType (finfun_type aT rT) (finfun_finMixin' aT rT).

(*
In standard mathematics functions that are point wise equal are
considered as equal. This principle, that we call functional
extensionality, is compatible with the Calculus of Inductive
Constructions but is not built-in.

functional extension はCICとコンパチブルだがCoqに組み込まれていない。

as expected, finite functions validate extensionality.
finfun では、それが成立する。

定義域の全てで値が(=)で等しいなら(=1)、関数として等しい(=)。逆も成立する。
*)

Definition eqfun {A B : Type} (f g : B -> A) : Prop := forall x, f x = g x. (* ssrfun.v *)
Notation "f1 =1 f2" := (eqfun f1 f2).
Check ffunP :
  forall (aT : finType) (rT : Type) (f1 f2 : {ffun aT -> rT}),
    f1 =1 f2 <-> f1 = f2.

(* ********** *)
(* 6.6 FinSet *)
(* ********** *)
Inductive set_type' (T : finType) : Type :=
  FinSet' of {ffun pred T}.                 (* FFUN XXXX *)
Notation "{ 'SET' T }" := (set_type' T).
Definition finfun_of_set' (T : finType) (A : {SET T}) :=
  let: FinSet' f := A in f.
(* match A with | FinSet' t => t end. *)
Check finfun_of_set' : forall T : finType, {SET T} -> {ffun pred T}. (* XXXX *)

Canonical  set_subType'     (T : finType) (A : {SET T}) := [newType for finfun_of_set' T].

Definition set_eqMixin'     (T : finType) := [eqMixin of {set T} by <:]. (* SET XXX *)
(* (@val_eqP (finfun_of_eqType T bool_eqType) xpredT (set_subType T)) *)
Canonical  set_eqType'      (T : finType) := EqType {set T} (set_eqMixin' T).

Definition set_finMixin'    (T     : finType) := [finMixin of {set T} by <:].
Canonical  set_finType'     (T     : finType) :=
  FinType {set T} (set_finMixin' T).

(* 集合の要素どうしが(=)で等しいなら(=i)、おなじ集合(=)。逆も成立する。 *)
Locate "_ =i _".                            (* eq_mem (mem A) (mem B) *)
Check setP : forall (T : finType) (A B : {set T}), A =i B <-> A = B. (* ssrbool.v *)

(* ******** *)
(* 6.7 Perm *)
(* ******** *)
Inductive perm_of' (T : finType) : Type :=
  Perm' (pval' : {ffun T -> T}) : injectiveb pval' -> perm_of' T.
(* Perm' (pval' : {ffun T -> T}) of injectiveb pval'. *)
(* Perm' : forall pval' : {ffun T -> T},
    injectiveb pval' -> perm_of' T. *)
(* Perm' (pval' : {ffun T -> T}) & injectiveb pval'. *)

Notation "{ 'PERM' T }" := (perm_of' T).
Definition pval' (T : finType) (p : {PERM T}) :=
  let : Perm' f _ := p in f.
Check pval' : forall T : finType, { PERM T} -> {ffun T -> T}.

Canonical perm_subType' (T : finType) := [subType for pval' T].

Definition perm_eqMixin'   (T : finType) := [eqMixin of {PERM T} by <:].
(* (@val_eqP (finfun_of_eqType T T)
      (fun x : {ffun T -> T} => injectiveb (aT:=T) (rT:=T) x)
      (perm_subType T)) *)
Canonical  perm_eqType'    (T : finType) := EqType {PERM T} (perm_eqMixin' T).

Definition perm_finMixin'   (T     : finType) := [finMixin of {perm T} by <:]. (* PERM XXXX *)
Canonical  perm_finType'    (T     : finType) :=
  FinType {perm T} (perm_finMixin' T).

(* Q.E.D. *)
Check tuple_subType   : forall (n : nat) (T : Type), subType (T:=seq T) (fun x : seq T => size x == n).
Check ordinal_subType : forall n : nat, subType (T:=nat) (fun x : nat => x < n).
Check perm_subType    : forall T : finType,
       subType (T:={ffun T -> T})
         (fun x : {ffun T -> T} => injectiveb (aT:=T) (rT:=T) x).
Check finfun_subType  : forall (aT : finType) (rT : Type), subType (T:=#|aT|.-tuple rT) xpredT.
Check set_subType     : forall T : finType, subType (T:={ffun pred T}) xpredT.

(* Canonical tuple_subType = [subType for tval]  がカノニカルだからできること。 *)
Set Printing Implicit Defensive.
Check tuple_subType 3 nat.
Check tuple_of 3 nat.
Variable tt : (tuple_subType 3 nat).
Variable t : (tuple_of 3 nat).

Check valP.
Check @valP _ _ (tuple_subType 3 nat) tt.
Check @valP (seq nat) (fun x => size x == 3) (tuple_subType 3 nat).
Check @valP (seq nat) (fun x => size x == 3) (tuple_subType 3 nat) tt.
Check @valP (seq nat) (fun x => size x == 3) (tuple_subType 3 nat) t. (* これ！ *)
Check valP tt.
Check valP t.                               (* これ！ *)


(** This file defines a groupoid quotient HIT and derives some recursion/induction principles for it. *)
Require Import HoTT.
Require Import Category.
From GR Require Import
     general.
From GR.basics Require Export
     globe_over path_over square.
From GR.groupoid.grpd_bicategory Require Import
     grpd_bicategory.

(** * The groupoid quotient over a type. *)
(** Given a type [A] and a groupoid [G], we construct a type [gquot G] such that
    we have [A -> gquot A G] and the equality of [gquot A G] is described by [G].
    We use the standard method to define the HIT
    <<
    HIT gquot G :=
     | gcl : A -> gquot G
     | gcleq : Π(a₁ a₂ : A), hom G a₁ a₂ -> gcl a₁ = gcl a₂
     | ge : Π(a : A), gcleq (e a) = idpath
     | ginv : Π(a₁ a₂ : A) (g : hom G a₁ a₂), gcleq g⁻¹ = (gcleq g)^
     | gconcat : Π(a₁ a₂ a₃ : A) (g₁ : hom G a₁ a₂) (g₂ : hom G a₂ a₃),
               gcleq (g₁ × g₂) = gcleq g₁ @ gcleq g₂
     | gtrunc : Is-1-Type (gquot G)
    >>
*)
Module Export rezk.
  Local Open Scope category.

  Private Inductive rezk (C : PreCategory) :=
  | rcl : C -> rezk C.

  Axiom rcleq
    : forall (C : PreCategory) {x y : C} (g : x <~=~> y),
      rcl C x = rcl C y.

  Axiom re
    : forall (C : PreCategory) (x : C),
      rcleq C (isomorphic_refl C x) = idpath.

  Axiom rconcat
    : forall (C : PreCategory)
             {x y z : C}
             (g : y <~=~> z) (f : x <~=~> y),
      rcleq C (isomorphic_trans f g) = rcleq C f @ rcleq C g.

  Axiom rtrunc
    : forall (C : PreCategory), IsTrunc 1 (rezk C).

  Instance gquot_istrunct (C : PreCategory) : IsTrunc 1 (rezk C).
  Proof.
    apply rtrunc.
  Defined.

  Section rezk_ind.
    Variable (C : PreCategory)
             (Y : rezk C -> Type)
             (rclY : forall (x : C), Y(rcl C x))
             (rcleqY : forall (x y : C) (f : x <~=~> y),
                 path_over Y (rcleq C f) (rclY x) (rclY y))
             (reY : forall (x : C), globe_over Y
                                               (path_to_globe (re C x))
                                               (rcleqY x x (isomorphic_refl C x))
                                               (path_over_id (rclY x)))
             (rconcatY : forall (x y z : C)
                                (g : y <~=~> z) (f : x <~=~> y),
                 globe_over Y
                            (path_to_globe (rconcat C g f))
                            (rcleqY x z (isomorphic_trans f g))
                            (path_over_concat (rcleqY x y f)
                                              (rcleqY y z g)))
             (truncY : forall (x : rezk C), IsTrunc 1 (Y x)).

    Fixpoint rezk_ind (x : rezk C) : Y x
      := (match x with
         | rcl a => fun _ _ _ _ => rclY a
          end) rcleqY reY rconcatY truncY.

    Axiom rezk_ind_beta_rcleq : forall {x y : C} (f : x <~=~> y),
        apd_po rezk_ind (rcleq C f)
        =
        rcleqY x y f.
  End rezk_ind.
End rezk.

Arguments rezk_ind {C} Y rclY rcleqY reY rconcatY truncY.


Require Import Base.
Require Import DeclarativeTypingList.

Import Base.
Import DeclarativeTypingList.
Import DeclarativeTyping𝔗𝔄.

Lemma contains_𝔗_var : forall Γ x T, m𝔊.contains Γ x T -> Γ ⊩ 𝔱id x | T.
Proof.
  intros. induction H.
  - subst s. apply T𝔗.Var.
  - inversion IHcontains. rewrite -> m𝔊.append_commut_weak. apply T𝔗.Var. auto.
Qed.

Definition x : 𝔵 := 𝔵id 1.
Definition y : 𝔵 := 𝔵id 2.
Definition z : 𝔵 := 𝔵id 3.

Definition f : 𝔵 := 𝔵id 4.
Definition g : 𝔵 := 𝔵id 5.

Definition Γ1 : 𝔊 := m𝔊.append m𝔊.empty x Unit.

Example example_𝔗_duplicate : forall T1 T2,
  (m𝔊.append (m𝔊.append Γ1 f (Unit → T1)) g (Unit → T2)) ⊩ 𝔱pair (𝔱app (𝔱id f) (𝔱id x)) (𝔱app (𝔱id g) (𝔱id x)) | (T1 × T2).
Proof.
  intros. apply T𝔗.𝔗mult_I; eapply T𝔗.𝔗impl_E; apply contains_𝔗_var.
  - apply m𝔊.contains_append_set. eapply m𝔊.contains_append. reflexivity. intros [=].
  - apply m𝔊.contains_append_set. apply m𝔊.contains_append_set. unfold Γ1. eapply m𝔊.contains_append. reflexivity.
    intros [=]. intros [=].
  - eapply m𝔊.contains_append. reflexivity.
  - apply m𝔊.contains_append_set. apply m𝔊.contains_append_set. unfold Γ1. eapply m𝔊.contains_append. reflexivity.
    intros [=]. intros [=].
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e196m15_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e189m25_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


(**
Here we show how to interpret the syntactic data in univalent categories.
 *)
Require Import prelude.all.
Require Import syntax.hit_signature.

Open Scope cat.

(**
We first show how to interpret all syntactic elements in precategories with a certain structure.
`F` is needed to interpret the constant polynomial, and `el` for the constant constructor term.
 *)
Section Semantics.
  Variable (C : precategory)
           (F : HSET ⟶ C)
           (prod_C : BinProducts C)
           (coprod_C : BinCoproducts C)
           (HC : has_homsets C)
           (el : ∏ (T : hSet) (t : T) (G : C ⟶ C), G ⟹ constant_functor C C (F T)).

  Definition sem_poly
             (P : poly_code)
    : C ⟶ C.
  Proof.
    induction P as [T | | P IHP Q IHQ | P IHP Q IHQ].
    - exact (constant_functor _ _ (F T)).
    - exact (functor_identity C).
    - exact (BinCoproduct_of_functors _ _ coprod_C IHP IHQ).
    - exact (BinProduct_of_functors _ _ prod_C IHP IHQ).
  Defined.

  Local Notation "⟦ P ⟧" := (sem_poly P).

  Definition prealgebras
             (P : poly_code)
    : precategory
    := FunctorAlg (⟦ P ⟧) HC.

  Definition prealgebra_carrier
             (P : poly_code)
    : prealgebras P ⟶ C
    := forget_algebras (⟦ P ⟧) _.

  Definition constr_nat_trans
             (P : poly_code)
    : prealgebra_carrier P ∙ (⟦ P ⟧) ⟹ prealgebra_carrier P ∙ (⟦ I ⟧).
  Proof.
    use make_nat_trans.
    - exact (alg_map _).
    - intros X Y f ; cbn in *.
      exact (!(pr2 f)).
  Defined.

  Definition sem_endpoint
             {A P Q : poly_code}
             (e : endpoint A P Q)
    : prealgebra_carrier A ∙ (⟦ P ⟧) ⟹ prealgebra_carrier A ∙ ⟦ Q ⟧.
  Proof.
    induction e as [P | P Q R e₁ IHe₁ e₂ IHe₂
                    | P Q | P Q | P Q | P Q | P Q R e₁ IHe₁ e₂ IHe₂ | P T t | X Y f | ].
    - exact (nat_trans_id _).
    - exact (nat_trans_comp _ _ _ IHe₁ IHe₂).
    - exact (pre_whisker _ (coproduct_nat_trans_in1 _ _ _ _ _)).
    - exact (pre_whisker _ (coproduct_nat_trans_in2 _ _ _ _ _)).
    - exact (pre_whisker _ (binproduct_nat_trans_pr1 _ _ _ _ _)).
    - exact (pre_whisker _ (binproduct_nat_trans_pr2 _ _ _ _ _)).
    - exact (pair_nat_trans _ IHe₁ IHe₂).
    - exact (pre_whisker _ (el _ t _)).
    - refine (pre_whisker _ _).
      use make_nat_trans.
      + exact (λ _, #F f).
      + intros Z₁ Z₂ g ; cbn.
        exact (id_left _ @ !(id_right _)).
    - exact (constr_nat_trans A).
  Defined.
End Semantics.

(**
We show this gives rise to a univalent category of prealgebras.
 *)
Definition univalent_prealgebras
           (C : univalent_category)
           (F : HSET ⟶ C)
           (prod_C : BinProducts C)
           (coprod_C : BinCoproducts C)
           (P : poly_code)
  : univalent_category.
Proof.
  use make_univalent_category.
  - use (prealgebras C) ; try assumption.
    apply C.
  - exact (is_univalent_FunctorAlg _ _).
Defined.

(**
Projections of prealgebras
 *)
Section PrealgebraProjections.
  Context {C : univalent_category}
          {F : HSET ⟶ C}
          {prod_C : BinProducts C}
          {coprod_C : BinCoproducts C}
          {P : poly_code}.
  Variable (X : univalent_prealgebras C F prod_C coprod_C P).

  Definition prealg_carrier
    : C
    := pr1 X.

  Definition prealg_operation
    : sem_poly C F prod_C coprod_C P (pr1 X) --> pr1 X
    := pr2 X.
End PrealgebraProjections.


(* http://www.ne.jp/asahi/fmsci/fmmath/coqp/vvof/Intui.v *)

Theorem Syllog : forall A B C : Prop, (A -> B) -> (B -> C) -> (A -> C).
Proof.
  intros.
  apply H0.
  apply H.
  apply H1.
Qed.

Theorem Syllogeq : forall A B C:Prop, (A <-> B) -> (B <-> C) -> (A <-> C).
Proof.
  intros.
  elim H.
  elim H0.
  intros.
  split.
  apply (Syllog A B C).
  apply H3.
  apply H1.
  apply (Syllog C B A).
  apply H2.
  apply H4.
Qed.

Theorem InDN : forall A:Prop, A -> ~~A.
Proof.
  intros.
  intro.
  apply H0.
  apply H.
Qed.

Theorem Andell:forall A B:Prop, A /\ B -> A.
Proof.
  intros.
  destruct H.
  apply H.
Qed.

Theorem Andelr:forall A B:Prop, A /\ B -> B.
Proof.
  intros.
  destruct H.
  apply H0.
Qed.

Theorem AndABAB:forall A B:Prop, (A <-> B) -> (A -> B).
Proof.
  intros.
  destruct H.
  apply (H H0).
Qed.

Theorem AndABBA:forall A B:Prop, (A <-> B) -> (B -> A).
Proof.
  intros.
  apply


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e189m25_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e194m33_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e189m25_3limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e174m17_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Set Implicit Arguments.

Local Open Scope bool_scope.
Local Notation "! b" := (negb b) (at level 35).

Require Import Bedrock.Word.
Import NArith.BinNat.
Local Open Scope N_scope.

Definition is_good_size (n : nat) :=
  match N.of_nat n ?= Npow2 32 with
    | Datatypes.Lt => true
    | _ => false
  end.

Require Import Platform.Cito.SyntaxModule.

Fixpoint is_arg_len_ok s :=
  match s with
    | Syntax.Call _ _ args => is_good_size (2 + length args)
    | Syntax.Skip => true
    | Syntax.Seq a b => is_arg_len_ok a && is_arg_len_ok b
    | Syntax.If _ a b => is_arg_len_ok a && is_arg_len_ok b
    | Syntax.While _ body => is_arg_len_ok body
    | Syntax.Assign _ _ => true
    | Syntax.Label _ _ => true
  end.

Require Import Platform.Cito.GetLocalVars.
Require Import Coq.Lists.List.
Require Import Platform.Cito.ListFacts3.
Require Import Platform.Cito.NoUninitDec.
Require Import Platform.Cito.Depth.

Definition is_good_func f :=
  let body := Body f in
  let local_vars := get_local_vars body (ArgVars f) (RetVar f) in
  let all_vars := ArgVars f ++ local_vars in
  is_no_dup (ArgVars f) &&
            is_no_uninited f &&
            is_arg_len_ok body &&
            is_good_size (length local_vars + depth body).

Definition is_good_funcs fs := forallb is_good_func fs.

Require Import Platform.Cito.NameDecoration.

Definition is_good_module (m : Module) :=
  is_good_module_name (SyntaxModule.Name m) &&
                      is_good_funcs (map Core (SyntaxModule.Functions m)) &&
                      is_no_dup (map SyntaxFunc.Name (SyntaxModule.Functions m)).


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Logic.MinimumLogic.DeepEmbedded.MinimumLanguage.

Local Open Scope logic_base.
Local Open Scope syntax.

Section MinimumLogic.

Context (Var: Type).

Instance L: Language := MinimumLanguage.L Var.
Instance minL: MinimumLanguage L := MinimumLanguage.minL Var.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z)).

Instance GP: Provable L := Build_Provable L provable.

Instance GD: Derivable L := Provable2Derivable.

Instance AX: NormalAxiomatization L GP GD := Provable2Derivable_Normal.

Instance minAX: MinimumAxiomatization L GP.
Proof.
  constructor.
  + apply modus_ponens.
  + apply axiom1.
  + apply axiom2.
Qed.

Instance SC: NormalSequentCalculus L GP GD := Axiomatization2SequentCalculus_SC.

Instance bSC: BasicSequentCalculus L GD := Axiomatization2SequentCalculus_bSC.

Instance fwSC: FiniteWitnessedSequentCalculus L GD := Axiomatization2SequentCalculus_fwSC.

Instance minSC: MinimumSequentCalculus L GD := Axiomatization2SequentCalculus_minSC.

End MinimumLogic.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e198m17_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Maps.
Require Import String Ascii.
Require Import Compare_dec.
Require Import OrderedType.
Require Import SepAlg.
(* This requires the Containers library from
   http://coq.inria.fr/pylons/contribs/view/Containers/v8.4 *)
Require Import MapInterface MapFacts.

Definition ascii_lt a b := nat_of_ascii a <<< nat_of_ascii b.
Definition ascii_compare a b := nat_compare (nat_of_ascii a) (nat_of_ascii b).

Instance StrictOrderAscii : StrictOrder ascii_lt eq.
Proof.
  split.
  + intros a b c Hab Hac. unfold ascii_lt in *. etransitivity; eassumption.
  + intros a b H Hab. unfold ascii_lt in H. rewrite Hab in H. apply lt_antirefl in H. assumption.
Qed.

Lemma nat_of_ascii_inj (a b : ascii) (H : nat_of_ascii a = nat_of_ascii b) : a = b.
Proof.
  assert (ascii_of_nat(nat_of_ascii a) = ascii_of_nat(nat_of_ascii b)) as H1
         by (rewrite H; reflexivity).
  do 2 rewrite ascii_nat_embedding in H1. assumption.
Qed.

Instance OrderedTypeAscii : OrderedType ascii := {
   _eq := Equivalence.equiv;
   _lt := ascii_lt;
   _cmp := ascii_compare
}.
Proof.
  intros x y.
  unfold ascii_compare, ascii_lt.
  destruct (compare_dec (nat_of_ascii x) (nat_of_ascii y)).
  + assert (nat_compare (nat_of_ascii x) (nat_of_ascii y) = Lt) as H1 by (apply nat_compare_lt; assumption).
    rewrite H1. apply compare_spec_lt. assumption.
  + assert (nat_compare (nat_of_ascii x) (nat_of_ascii y) = Eq) as H1 by (apply nat_compare_eq_iff; assumption).
    rewrite H1. apply compare_spec_eq. apply nat_of_ascii_inj. assumption.
  + assert (nat_compare (nat_of_ascii x) (nat_of_ascii y) = Gt) as H1 by (apply nat_compare_gt; assumption).
    rewrite H1. apply compare_spec_gt. assumption.
Qed.

Inductive string_lt : string -> string -> Prop :=
| s_emp a s : string_lt EmptyString (String a s)
| s_neq a b s t : a <<< b -> string_lt (String a s) (String b t)
| s_eq a b s t : a === b -> string_lt s t -> string_lt (String a s) (String b t).

Fixpoint string_compare s t :=
  match s, t with
      | EmptyString, EmptyString => Eq
      | EmptyString, String _ _ => Lt
      | String _ _, EmptyString => Gt
      | String a s, String b t =>
        match a =?= b with
          | Eq => string_compare s t
          | c => c
        end
  end.

Lemma string_lt_empty a s (H: string_lt (String a s) "") : False.
Proof.
  remember (String a s) as s'; remember EmptyString as e. destruct H.
  + inversion Heqs'.
  + inversion Heqe.
  + inversion Heqe.
Qed.

Inductive stringEq : string -> string -> Prop :=
| s_empty : stringEq EmptyString EmptyString
| s_cons a b s t : a === b -> stringEq s t -> stringEq (String a s) (String b t).

Instance StringEqEquiv : Equivalence stringEq.
Proof.
  split.
  + unfold Reflexive; intros x; induction x.
    apply s_empty. apply s_cons; [reflexivity | assumption].
  + unfold Symmetric; intros x y Hxy.
    induction Hxy. apply s_empty.
    apply s_cons; [symmetry|]; assumption.
  + unfold Transitive; intros x y z Hxy Hyz. generalize dependent z;
    induction Hxy; intros; inversion Hyz.
    apply s_empty.
    inversion Hyz; subst.
    apply s_cons. transitivity b; assumption.
    apply IHHxy. assumption.
Qed.

Instance StrictOrderString : StrictOrder string_lt stringEq.
Proof.
  split.
  + intros a b c Hab Hac. generalize dependent c. induction Hab.
    * intros c Hac. destruct c. apply string_lt_empty in Hac. destruct Hac.
      apply s_emp.
    * intros c Hac. destruct c. apply string_lt_empty in Hac. destruct Hac.
      inversion Hac; subst.
      - apply s_neq. etransitivity; eassumption.
      - apply s_neq. rewrite H3 in H. assumption.
    * intros c Hac. destruct c.  apply string_lt_empty in Hac. destruct Hac.
      inversion Hac; subst.
      - apply s_neq. rewrite <- H in H1. assumption.
      - apply s_eq. etransitivity; eassumption. apply IHHab; assumption.
  + intros x y Hxy H; induction Hxy.
    * inversion H.
    * inversion H; subst; rewrite H4 in H0. apply lt_antirefl in H0. destruct H0.
    * apply IHHxy. inversion H; subst. apply H6.
Qed.

Instance OrderedTypeString : OrderedType string := {
   _eq := stringEq;
   _lt := string_lt;
   _cmp := string_compare
}.
Proof.
  intros x. induction x.
  + intros y. destruct y; simpl; try (repeat constructor).
  + intros y. destruct y; simpl; try (repeat constructor).
    destruct (compare_dec a a0).
    * apply compare_spec_lt. apply s_neq. assumption.
    * eapply compare_spec_ind; [| | | apply IHx]; intros H1.
      - apply compare_spec_lt. apply s_eq; assumption.
      - apply compare_spec_eq. apply s_cons; assumption.
      - apply compare_spec_gt. apply s_eq; [symmetry|]; assumption.
    * apply compare_spec_gt. apply s_neq; assumption.
Qed.

Section SepAlgMap.
  Context {K} `{H: FMap K}.
  Context `{Spec: FMapSpecs K}.

  Global Instance MapSepAlgOps A : SepAlgOps (Map [K, A]) := {
    sa_unit := empty A;
    sa_mul :=  fun a b c =>
                 forall k, match find k c with
                             | Some y  => (MapsTo k y a /\ ~ In k b) \/
                                          (MapsTo k y b /\ ~ In k a)
                             | None => ~ In k a /\ ~ In k b
                           end
  }.

  Lemma sa_mul_add {A : Type} {a b c : Map [K, A]} {k : K} {y : A}
    (Habc : sa_mul a b c) (Hnotin : ~ In k b) :
      sa_mul (add k y a) b (add k y c).
  Proof.
    simpl in *; intros l.
    destruct (eqb_dec k l) as [e | e].
    rewrite add_eq_o; [|assumption].
    left; split.
    rewrite find_mapsto_iff. rewrite add_eq_o; [reflexivity | assumption].
    rewrite <- e. assumption.
    rewrite add_neq_o; [|assumption].
    specialize (Habc l); destruct (find l c).
    destruct Habc as [Habc | Habc].
    left. rewrite add_neq_mapsto_iff; assumption.
    right. rewrite add_neq_in_iff; assumption.
    rewrite add_neq_in_iff; assumption.
  Qed.

  Lemma sa_mul_inL {A : Type} {a b c : Map [K, A]} {k : K}
        (Habc : sa_mul a b c) (Hin: In k a) : ~ In k b /\ In k c.
  Proof.
    simpl in Habc.
    specialize (Habc k).
    remember (find k c) as o; destruct o; intuition.
    rewrite in_find_iff. rewrite <- Heqo. congruence.
  Qed.

  Lemma sa_mul_inR {A : Type} {a b c : Map [K, A]} {k : K}
        (Habc : sa_mul a b c) (Hin: In k c) :
    (In k a /\ ~ In k b) \/ (In k b /\ ~ In k a).
  Proof.
    simpl in Habc. specialize (Habc k).
    rewrite in_find_iff in Hin.
    destruct (find k c); [|intuition].
    destruct Habc as [[H2 H3] | [H2 H3]]; [left | right]; split; try assumption;
    rewrite in_find_iff;
    rewrite find_mapsto_iff in H2; rewrite H2; intuition.
  Qed.

  Lemma sa_mul_mapstoR {A : Type} {a b c : Map [K, A]} {k : K} {y : A}
        (Habc: sa_mul a b c) (Hc: MapsTo k y c) :
    (MapsTo k y a /\ ~ In k b) \/ (MapsTo k y b /\ ~ In k a).
  Proof.
    simpl in Habc.
    specialize (Habc k).
    rewrite find_mapsto_iff in Hc. destruct (find k c); inversion Hc; subst.
    assumption.
  Qed.

  Lemma map_sa_mul_notinR {A : Type} {a b c : Map [K, A]} {k : K}
        (Habc: sa_mul a b c) (Hc: ~ In k c) :
    ~ In k a /\ ~ In k b.
  Proof.
    simpl in Habc.
    specialize (Habc k).
    rewrite in_find_iff in Hc. assert (find k c = None) by admit.
    destruct (find k c); inversion H2; subst.
    assumption.
  Qed.

  Lemma find_fold_none A x (a b : dict K A) :
    find x (fold add a b) = None <->
    find x a = None /\ find x b = None.
  Proof.
    apply fold_rec_weak.
    intros. rewrite <- H2. apply H3.
    rewrite empty_o. intuition.
    intros.
    repeat rewrite add_o.
    destruct (k == x);
    intuition congruence.
  Qed.

 Lemma find_fold_some_left A x (a b : dict K A) y :
   find x (fold add a b) = Some y ->
   find x a = Some y \/ find x b = Some y.
 Proof.
   apply fold_rec_weak.
   intros. rewrite <- H2. apply H3. apply H4.
   rewrite empty_o. intuition.
   intros. rewrite add_o.
   destruct (eq_dec k x). rewrite add_eq_o in H4; intuition.
   rewrite add_neq_o in H4; intuition.
 Qed.

 Lemma find_fold_some_right A x (a b : dict K A) y :
   (find x a = Some y /\ find x b = None) \/
   (find x b = Some y /\ find x a = None) ->
   find x (fold add a b) = Some y.
 Proof.
   apply fold_rec.
   + intros m Hm [[H2 H3] | [H2 H3]].
     unfold Empty in Hm.
     assert False. eapply Hm. rewrite find_mapsto_iff. apply H2. destruct H4.
     apply H2.
   + intros k e c m' m'' Ha Hm' Hm'' IH [[H2 H3] | [H2 H3]];
     unfold Add in Hm''; rewrite find_mapsto_iff in Ha;
     rewrite add_o; destruct (eq_dec k x).
     * rewrite Hm'' in H2. rewrite add_eq_o in H2; assumption.
     * rewrite Hm'' in H2. rewrite add_neq_o in H2; intuition.
     * rewrite Hm'' in H3. rewrite add_eq_o in H3. inversion H3. assumption.
     * apply IH; rewrite Hm'' in H3. rewrite add_neq_o in H3; intuition.
 Qed.

 Ltac SepOpSolve :=
    match goal with
      | H : (match find ?k ?d with | Some _ => _ | None => _ end) |- _ =>
        let e := fresh "e" in let y := fresh "y" in remember (find k d) as e;
            destruct e as [y |]; SepOpSolve
      | H : _ \/ _ |- _ => destruct H as [H | H]; SepOpSolve
      | H : _ /\ _ |- _ => let H1 := fresh "H" in destruct H as [H H1]; SepOpSolve
      | |- context [match find ?x (fold add ?a ?b) with | Some _ => _ | None => _ end] =>
        let e := fresh "e" in
        let H := fresh "Heq" e in
        remember (find x (fold add a b)) as e;
        symmetry in H; destruct e;
        [apply find_fold_some_left in H |
         rewrite find_fold_none in H]; SepOpSolve
      | H : forall x : K, _ |- _ =>
                   match goal with
                       | x : K |- _ => specialize (H x)
                   end; SepOpSolve
      | |- context [find _ (fold add _ _) = None] =>
        rewrite find_fold_none; SepOpSolve
      | |- context [MapsTo _ _ _] => repeat rewrite find_mapsto_iff; SepOpSolve
      | |- context [In _ _] => repeat rewrite in_find_iff; SepOpSolve
      | H : context [MapsTo _ _ _] |- _ => rewrite find_mapsto_iff in H; SepOpSolve
      | H : context [In _ _] |- _ => rewrite in_find_iff in H; SepOpSolve
      | |- context [find _ (fold add _ _) = Some _] =>
        first [intuition congruence |
        try (erewrite find_fold_some_right; intuition congruence)]
      | _ => subst; try intuition congruence
    end.

 Require Import SepAlg Equiv.

  Global Instance MapEquiv A : Equiv (Map [K, A]) | 0 := Equal.

  Global Instance MapSepAlg A : SepAlg (Map [K, A]).
  Proof.
    split; simpl.
    + apply _.
    + intros * H2 H3 k; SepOpSolve.
    + intros * H2 H3 k; SepOpSolve.
    + intros * H2 k. SepOpSolve.
    + intros * H2 H3.
      exists (fold add b c).
      split; intro x; SepOpSolve.
      right.
      erewrite find_fold_some_right.
      intuition congruence. left.
      rewrite H3 in Heqe0. inversion Heqe0. subst.
      split. assumption. admit. (* find decidable *)
      right. erewrite find_fold_some_right.
      intuition congruence.
      right. split; [assumption|].
      admit.
    + intros *; remember (find k a) as e; destruct e; simpl;
      repeat rewrite find_mapsto_iff; repeat rewrite in_find_iff;
      rewrite empty_o; intuition.
  Qed.

End SepAlgMap.


(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2019, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import BinPos Reals List.
From Coquelicot Require Import Coquelicot.

Require Import Coquelicot.
Require Import Xreal.
Require Import Interval.
Require Import Priority.

Section IterUntil.

(* iteratively call [step] on [v] until [done] is true or [n] calls have been made;
   [cache_step] is called every 2^k approximately to precompute some data for [done] *)
Fixpoint iter_until {T} n (step : T -> T) (cache_step : T -> T) (done : T -> bool) v :=
  match n with
  | xH => step v
  | xO n =>
    let v := iter_until n step cache_step done v in
    if done v then v else
    let v := cache_step v in
    iter_until n step (fun x => x) done v
  | xI n =>
    let v := step v in
    if done v then v else
    let v := iter_until n step cache_step done v in
    if done v then v else
    let v := cache_step v in
    iter_until n step (fun x => x) done v
  end.

Theorem iter_until_correct :
  forall {T} (P : T -> Prop) n step slow_step done,
  (forall v : T, P v -> P (step v)) ->
  (forall v : T, P v -> P (slow_step v)) ->
  forall v : T, P v -> P (iter_until n step slow_step done v).
Proof.
intros T P n step slow_step done H Hs.
revert slow_step Hs.
induction n as [n IH|n IH|] ; intros slow_step Hs v Hv ; simpl.
- case done.
  now apply H.
  apply H in Hv.
  apply IH with (1 := Hs) in Hv.
  case done.
  exact Hv.
  apply IH.
  easy.
  now apply Hs.
- apply IH with (1 := Hs) in Hv.
  case done.
  exact Hv.
  apply IH.
  easy.
  now apply Hs.
- now apply H.
Qed.

End IterUntil.

Definition valid (f : R -> R) (uf vf : (R -> Prop) -> Prop) yi :=
  (yi <> Inan -> ex_RInt_gen f uf vf) /\
  contains yi (Xreal (RInt_gen f uf vf)).

Lemma valid_Inan :
  forall f uf vf, valid f uf vf Inan.
Proof.
intros f uf vf.
now split.
Qed.

Module IntegralRefiner (I : IntervalOps).

Module J := IntervalExt I.

Inductive integral_bound := IBu | IBv | IBp (x : I.bound_type).

Section Bounds.

Variable uf vf : (R -> Prop) -> Prop.
Context (Fuf : ProperFilter' uf) (Fvf : ProperFilter' vf).

Definition convert b :=
  match b with
  | IBu => uf
  | IBv => vf
  | IBp x => at_point (proj_val (I.convert_bound x))
  end.

Local Instance filter_convert :
  forall b, ProperFilter' (convert b).
Proof.
intros [| |p] ; simpl ; try easy.
apply Proper_StrongProper.
apply at_point_filter.
Qed.

Definition valid f u v i :=
  valid f (convert u) (convert v) (I.convert i).

Inductive piece :=
  Piece (u v : integral_bound) (i : I.type).

Fixpoint invariant_aux h l (u : integral_bound) :=
  match h with
  | Piece u' v i => u = u' /\
    match l with
    | nil => v = IBv
    | h :: t =>
      match v with IBp _ => invariant_aux h t v | _ => False end
    end
  end.

Definition exact_sum (f : R -> R) l :=
  fold_right (fun r s => Rplus s
    match r with
    | Piece ur vr _ => RInt_gen f (convert ur) (convert vr)
    end) 0%R l.

Definition invariant (f : R -> R) (p : ptree piece) :=
  all (fun r => match r with Piece uf vf i => valid f uf vf i end) (ptree_to_list p) /\
  exists qh, exists qt, permut (ptree_to_list p) (qh :: qt) /\ invariant_aux qh qt IBu.

Definition sum prec (p : ptree piece) :=
  ptree_fold (fun acc v => I.add prec acc match v with Piece _ _ i => i end) p I.zero.

Theorem sum_invariant :
  forall prec p f,
  invariant f p ->
  valid f IBu IBv (sum prec p).
Proof.
intros prec p f.
unfold sum, invariant, valid.
rewrite ptree_fold_correct.
generalize (ptree_to_list p).
clear p. intros p.
assert (H: (I.convert I.zero <> Inan ->
    all (fun r =>
      match r with
      | Piece ur vr _ => ex_RInt_gen f (convert ur) (convert vr)
      end) nil) /\
    contains (I.convert I.zero) (Xreal (exact_sum f nil))).
  simpl.
  apply (conj (fun _ => I)).
  rewrite I.zero_correct.
  split ; apply Rle_refl.
change p with (nil ++ p) at 1 2.
intros [Hp [qh [qt [Hq Iq]]]].
revert Hq Hp H.
generalize (@nil piece) I.zero.
induction p as [|h t IH] ; simpl ; intros l s Hq Hl [H1 H2].
- clear Hl.
  rewrite app_nil_r in Hq.
  unfold exact_sum in H2.
  rewrite fold_right_permut with (2 := Hq) in H2 by (intros ; ring).
  case_eq (I.convert s) ; [intros Hs | intros sl su Hs].
  easy.
  cut (ex_RInt_gen f uf vf /\ RInt_gen f uf vf = exact_sum f (qh :: qt)).
    intros [H3 H4].
    split.
    intros _.
    apply H3.
    rewrite H4.
    now rewrite <- Hs.
  assert (H1': all (fun r =>
      match r with
      | Piece ur vr _ => ex_RInt_gen f (convert ur) (convert vr)
      end) (qh :: qt)).
    apply all_permut with (2 := Hq).
    apply H1.
    now rewrite Hs.
  clear -Iq H1' Fuf Fvf.
  revert qh Iq H1'.
  change uf with (convert IBu).
  generalize IBu.
  induction qt as [|qh qt IH] ; simpl.
    intros x [u v _] [-> ->] [H _].
    apply (conj H).
    apply eq_sym, Rplus_0_l.
  intros x [u v _] [-> H6] [H1 H2].
  destruct v as [| |x] ; try easy.
  destruct (IH _ _ H6 H2) as [H7 H8].
  assert (H9 := ex_RInt_gen_Chasles _ _ H1 H7).
  assert (H5 := RInt_gen_Chasles _ _ H1 H7).
  clear IH H1 H2 H6 H7.
  apply (conj H9).
  simpl in H8.
  rewrite <- H5, <- H8.
  apply Rplus_comm.
- eapply permut_trans in Hq.
  2: apply permut_insert.
  destruct h as [ur' vr' i].
  eapply all_permut in Hl.
  2: apply permut_sym, permut_insert.
  apply (IH (_ :: l) (I.add prec s i) Hq Hl).
  destruct Hl as [H3 _].
  clear -H1 H2 H3.
  split.
    intros H'.
    split.
    apply H3.
    contradict H'.
    now apply I.add_propagate_r.
    apply H1.
    contradict H'.
    now apply I.add_propagate_l.
  simpl.
  apply J.add_correct.
  apply H2.
  apply H3.
Qed.

Definition le_piece prec (p q : piece) :=
  match p, q with
  | Piece _ _ pi, Piece _ _ qi => I.wider prec pi qi
  end.

Definition split_piece prec midp fi sp :=
  let le_piece := le_piece prec in
  match sp with
  | (s, p) =>
    match ptree_pop le_piece p with
    | (Piece u v i, h) =>
      let m := IBp (midp u v) in
      let i1 := fi u m in
      let i2 := fi m v in
      let p1 := Piece u m i1 in
      let p2 := Piece m v i2 in
      let s := I.add prec (I.cancel_add prec s i) (I.add prec i1 i2) in
      let p := ptree_insert le_piece (pheap_insert le_piece h p1) p2 in
      (s, p)
    end
  end.

Theorem split_piece_correct :
  forall prec midp f fi p,
  (forall u v, valid f u v (fi u v)) ->
  invariant f (snd p) ->
  invariant f (snd (split_piece prec midp fi p)).
Proof.
intros prec midp f fi [sp p] Hfi [H1 [qh [qt [H2 H3]]]].
unfold split_piece.
set (le_piece := le_piece prec).
generalize (ptree_pop_correct le_piece p).
destruct ptree_pop as [[u' v' i] p1].
intros H4.
set (m := IBp (midp u' v')).
generalize (pheap_insert_correct le_piece p1 (Piece u' m (fi u' m))).
generalize (pheap_insert le_piece p1 (Piece u' m (fi u' m))).
intros p2 H5.
generalize (ptree_insert_correct le_piece p2 (Piece m v' (fi m v'))).
generalize (ptree_insert le_piece p2 (Piece m v' (fi m v'))).
intros p3 H6.
unfold invariant.
split.
- apply permut_sym in H6.
  apply all_permut with (2 := H6).
  split.
  apply Hfi.
  apply permut_sym in H5.
  apply all_permut with (2 := H5).
  split.
  apply Hfi.
  clear -H1 H4.
  apply permut_sym in H4.
  eapply all_permut in H4.
  2: apply H1.
  apply H4.
- assert (H7 := permut_trans _ _ _ H4 H2).
  destruct (permut_remove _ _ _ H7) as [s [t [H8 H9]]].
  assert (exists sh st, sh :: st = s ++ Piece u' m (fi u' m) :: nil) as [sh [st Ha]].
    clear.
    destruct s as [|sh st].
    now exists (Piece u' m (fi u' m)), nil.
    now exists sh, (st ++ Piece u' m (fi u' m) :: nil).
  exists sh, (st ++ Piece m v' (fi m v') :: t).
  split.
    change (sh :: st ++ _) with ((sh :: st) ++ Piece m v' (fi m v') :: t).
    rewrite Ha.
    apply permut_trans with (1 := H6).
    eapply permut_trans.
    2: apply permut_insert.
    apply permut_cons.
    rewrite <- app_assoc.
    simpl.
    apply permut_trans with (1 := H5).
    eapply permut_trans.
    2: apply permut_insert.
    now apply permut_cons.
  revert H3 H8 Ha.
  clear.
  generalize IBu.
  revert qh qt sh st.
  induction s as [|[u v i'] s IH] ; simpl ; intros qh qt sh st x H1 [= -> ->] [= -> ->].
    simpl.
    destruct t as [|th tt].
    now destruct H1.
    now destruct H1.
  destruct s as [|sh st].
    destruct H1 as [H1 H2].
    simpl.
    apply (conj H1).
    destruct v as [| |x'] ; try easy.
    destruct t as [|th tt].
    now destruct H2.
    now destruct H2.
  destruct H1 as [H1 H2].
  simpl.
  apply (conj H1).
  destruct v as [| |x'] ; try easy.
  now apply IH with (1 := H2).
Qed.

(*
Definition bisect prec n midp fi (check : I.type -> bool) :=
  let i := fi IBu IBv in
  if check i then (i, i, 0%Z, 0%Z)
  else
    let '(s, p, n1, n2) := iter_until n
      (fun '(p, n1, n2) => (split_piece prec midp fi p, Z.succ n1, n2))
      (fun '(_, p, n1, n2) => (sum prec p, p, n1, Z.succ n2))
      (fun '(p, _, _, _) => check p)
      (i, PTsome (Piece IBu IBv i) nil, 0%Z, 0%Z) in
    (s, sum prec p, n1, n2).
*)

Definition bisect prec n midp fi (check : I.type -> bool) :=
  let i := fi IBu IBv in
  if check i then i
  else
    let p := iter_until n
      (split_piece prec midp fi)
      (fun '(_, p) => (sum prec p, p))
      (fun '(p, _) => check p)
      (i, PTsome (Piece IBu IBv i) nil) in
    sum prec (snd p).

Theorem bisect_correct :
  forall prec n midp f fi check,
  (forall u v, valid f u v (fi u v)) ->
  valid f IBu IBv (bisect prec n midp fi check).
Proof.
intros prec n midp f fi check Hfi.
unfold bisect.
destruct check.
apply Hfi.
apply sum_invariant.
apply iter_until_correct.
intros [v p].
now apply split_piece_correct.
now intros [v p].
split ; simpl.
now split.
exists (Piece IBu IBv (fi IBu IBv)), nil.
split.
apply permut_refl.
easy.
Qed.

End Bounds.

Theorem contains_RInt_valid :
  forall f u v i,
  valid (at_point u) (at_point v) f IBu IBv i ->
  contains (I.convert i) (Xreal (RInt f u v)).
Proof.
intros f u v i [H1 H2].
destruct (I.convert i) as [|il iu].
easy.
rewrite <- RInt_gen_at_point.
exact H2.
apply ex_RInt_gen_at_point.
now apply H1.
Qed.

Theorem valid_at_point :
  forall f u v fi ui vi,
  contains (I.convert ui) (Xreal u) ->
  contains (I.convert vi) (Xreal v) ->
  (forall ui' vi' u' v',
    contains (I.convert ui') (Xreal u') ->
    contains (I.convert vi') (Xreal v') ->
    (I.convert (fi ui' vi') <> Inan -> ex_RInt f u' v') /\
    contains (I.convert (fi ui' vi')) (Xreal (RInt f u' v'))) ->
  forall u' v',
  let cb := fun x =>
    match x with IBu => ui | IBv => vi | IBp x => I.bnd x x end in
  valid (at_point u) (at_point v) f u' v' (fi (cb u') (cb v')).
Proof.
intros f u v fi ui vi Hu Hv Hf u' v' cb.
unfold valid.
set (cb' p := match p with IBu => u | IBv => v | IBp x => proj_val (I.convert_bound x) end).
assert (H1: forall p, at_point (cb' p) = convert (at_point u) (at_point v) p).
  now intros [| |p].
assert (H2: forall p, contains (I.convert (cb p)) (Xreal (cb' p))).
  intros [| |p].
  exact Hu.
  exact Hv.
  simpl.
  rewrite I.bnd_correct; [|admit..].
  destruct (I.convert_bound p) as [|pr].
  easy.
  split ; apply Rle_refl.
rewrite <- 2!H1.
destruct (Hf (cb u') (cb v') (cb' u') (cb' v') (H2 u') (H2 v')) as [H3 H4].
destruct (I.convert (fi (cb u') (cb v'))) as [|il iu] eqn:E.
easy.
split.
intros _.
apply <- (ex_RInt_gen_at_point f).
now apply H3.
rewrite RInt_gen_at_point.
exact H4.
now apply H3.
Admitted.

Theorem valid_at_mixed :
  forall f u v (Fv: ProperFilter v) fi1 fi2 ui,
  contains (I.convert ui) (Xreal u) ->
  (forall ui' vi' u' v',
    contains (I.convert ui') (Xreal u') ->
    contains (I.convert vi') (Xreal v') ->
    (I.convert (fi1 ui' vi') <> Inan -> ex_RInt f u' v') /\
    contains (I.convert (fi1 ui' vi')) (Xreal (RInt f u' v'))) ->
  (forall ui' u',
    contains (I.convert ui') (Xreal u') ->
    (I.convert (fi2 ui') <> Inan -> ex_RInt_gen f (at_point u') v) /\
    contains (I.convert (fi2 ui')) (Xreal (RInt_gen f (at_point u') v))) ->
  forall u' v',
  valid (at_point u) v f u' v'
    (match u', v' with
    | IBu, IBp xu => fi1 ui (I.bnd xu xu)
    | IBp xl, IBp xu => fi1 (I.bnd xl xl) (I.bnd xu xu)
    | IBu, IBv => fi2 ui
    | IBp xl, IBv => fi2 (I.bnd xl xl)
    | _, _ => I.nai
    end).
Proof.
intros f u v Fv fi1 fi2 ui Hu Hf1 Hf2 u' v'.
unfold valid.
assert (H1: forall p, contains (I.convert (I.bnd p p)) (Xreal (proj_val (I.convert_bound p)))).
  intros p.
  rewrite I.bnd_correct; [|admit..].
  destruct (I.convert_bound p) as [|pr].
  easy.
  split ; apply Rle_refl.
destruct u' as [| |ur] ;
  destruct v' as [| |vr] ;
    try (rewrite I.nai_correct ; apply valid_Inan).
- now apply Hf2.
- destruct (Hf1 ui (I.bnd vr vr) u (proj_val (I.convert_bound vr)) Hu) as [H2 H3].
  apply H1.
  destruct (I.convert (fi1 ui (I.bnd vr vr))) as [|il iu] eqn:E.
  easy.
  split.
  intros _.
  apply <- (ex_RInt_gen_at_point f).
  now apply H2.
  simpl convert.
  rewrite RInt_gen_at_point.
  apply H3.
  now apply H2.
- destruct (Hf2 (I.bnd ur ur) (proj_val (I.convert_bound ur))) as [H2 H3].
  apply H1.
  destruct (I.convert (fi2 (I.bnd ur ur))) as [|il iu] eqn:E.
  easy.
  split.
  intros _.
  now apply H2.
  apply H3.
- destruct (Hf1 (I.bnd ur ur) (I.bnd vr vr) (proj_val (I.convert_bound ur)) (proj_val (I.convert_bound vr))) as [H2 H3].
  apply H1.
  apply H1.
  destruct (I.convert (fi1 (I.bnd ur ur) (I.bnd vr vr))) as [|il iu] eqn:E.
  easy.
  split.
  intros _.
  apply <- (ex_RInt_gen_at_point f).
  now apply H2.
  simpl convert.
  rewrite RInt_gen_at_point.
  apply H3.
  now apply H2.
Admitted.

Theorem valid_at_mixed' :
  forall f u v (Fu: ProperFilter u) fi1 fi2 vi,
  contains (I.convert vi) (Xreal v) ->
  (forall ui' vi' u' v',
    contains (I.convert ui') (Xreal u') ->
    contains (I.convert vi') (Xreal v') ->
    (I.convert (fi1 ui' vi') <> Inan -> ex_RInt f u' v') /\
    contains (I.convert (fi1 ui' vi')) (Xreal (RInt f u' v'))) ->
  (forall vi' v',
    contains (I.convert vi') (Xreal v') ->
    (I.convert (fi2 vi') <> Inan -> ex_RInt_gen f u (at_point v')) /\
    contains (I.convert (fi2 vi')) (Xreal (RInt_gen f u (at_point v')))) ->
  forall u' v',
  valid u (at_point v) f u' v'
    (match u', v' with
    | IBu, IBp xu => fi2 (I.bnd xu xu)
    | IBp xl, IBp xu => fi1 (I.bnd xl xl) (I.bnd xu xu)
    | IBu, IBv => fi2 vi
    | IBp xl, IBv => fi1 (I.bnd xl xl) vi
    | _, _ => I.nai
    end).
Proof.
intros f u v Fu fi1 fi2 vi Hv Hf1 Hf2 u' v'.
unfold valid.
assert (H1: forall p, contains (I.convert (I.bnd p p)) (Xreal (proj_val (I.convert_bound p)))).
  intros p.
  rewrite I.bnd_correct; [|admit..].
  destruct (I.convert_bound p) as [|pr].
  easy.
  split ; apply Rle_refl.
destruct u' as [| |ur] ;
  destruct v' as [| |vr] ;
    try (rewrite I.nai_correct ; apply valid_Inan).
- now apply Hf2.
- destruct (Hf2 (I.bnd vr vr) (proj_val (I.convert_bound vr))) as [H2 H3].
  apply H1.
  destruct (I.convert (fi2 (I.bnd vr vr))) as [|il iu] eqn:E.
  easy.
  split.
  intros _.
  now apply H2.
  apply H3.
- destruct (Hf1 (I.bnd ur ur) vi (proj_val (I.convert_bound ur)) v) as [H2 H3].
  apply H1.
  apply Hv.
  destruct (I.convert (fi1 (I.bnd ur ur) vi)) as [|il iu] eqn:E.
  easy.
  split.
  intros _.
  apply <- (ex_RInt_gen_at_point f).
  now apply H2.
  simpl convert.
  rewrite RInt_gen_at_point.
  apply H3.
  now apply H2.
- destruct (Hf1 (I.bnd ur ur) (I.bnd vr vr) (proj_val (I.convert_bound ur)) (proj_val (I.convert_bound vr))) as [H2 H3].
  apply H1.
  apply H1.
  destruct (I.convert (fi1 (I.bnd ur ur) (I.bnd vr vr))) as [|il iu] eqn:E.
  easy.
  split.
  intros _.
  apply <- (ex_RInt_gen_at_point f).
  now apply H2.
  simpl convert.
  rewrite RInt_gen_at_point.
  apply H3.
  now apply H2.
Admitted.

End IntegralRefiner.

Lemma RInt_helper :
  forall f u v i,
  (i <> Inan -> exists I : R, is_RInt f u v I /\ contains i (Xreal I)) ->
  (i <> Inan -> ex_RInt f u v) /\ contains i (Xreal (RInt f u v)).
Proof.
intros f u v [|il iu].
easy.
intros [I [H1 H2]].
easy.
split.
intros _.
now exists I.
apply eq_ind with (1 := H2).
apply f_equal, eq_sym.
now apply is_RInt_unique.
Qed.

Lemma RInt_gen_helper :
  forall f u v {Fu : ProperFilter' u} {Fv : ProperFilter' v} i,
  (i <> Inan -> exists I : R, is_RInt_gen f u v I /\ contains i (Xreal I)) ->
  (i <> Inan -> ex_RInt_gen f u v) /\ contains i (Xreal (RInt_gen f u v)).
Proof.
intros f u v Fu Fv [|il iu].
easy.
intros [I [H1 H2]].
easy.
split.
intros _.
now exists I.
apply eq_ind with (1 := H2).
apply f_equal, eq_sym.
now apply is_RInt_gen_unique.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

Require Import BinPos.
Require Export BinNat.
Require Import NAxioms NProperties.

Local Open Scope N_scope.

(** * [BinNat.N] already implements [NAxiomSig] *)

Module N <: NAxiomsSig := N.

(*
Require Import NDefOps.
Module Import NBinaryDefOpsMod := NdefOpsPropFunct NBinaryAxiomsMod.

(* Some fun comparing the efficiency of the generic log defined
by strong (course-of-value) recursion and the log defined by recursion
on notation *)

Time Eval vm_compute in (log 500000). (* 11 sec *)

Fixpoint binposlog (p : positive) : N :=
match p with
| xH => 0
| xO p' => N.succ (binposlog p')
| xI p' => N.succ (binposlog p')
end.

Definition binlog (n : N) : N :=
match n with
| 0 => 0
| Npos p => binposlog p
end.

Time Eval vm_compute in (binlog 500000). (* 0 sec *)
Time Eval vm_compute in (binlog 1000000000000000000000000000000). (* 0 sec *)

*)


Set Implicit Arguments.

Require Import FCF.
Require Import CompFold.

Section DistSingle.

  Variable A B : Set.
  Hypothesis B_EqDec : EqDec B.
  Variable c1 c2 : A -> Comp B.
  Variable A_State : Set.
  Variable A1 : Comp (A * A_State).
  Variable A2 : A_State -> B -> Comp bool.

  Definition DistSingle_G(c : A -> Comp B) :=
    [a, s_A] <-$2 A1;
    b <-$ c a;
    A2 s_A b.

  Definition DistSingle_Adv :=
    | Pr[DistSingle_G c1] - Pr[DistSingle_G c2] |.

End DistSingle.

Section ListHybrid.

  Variable A B State : Set.
  Variable defA : A.
  Variable c1 c2 : A -> Comp B.
  Hypothesis c1_wf : forall a, well_formed_comp (c1 a).
  Hypothesis c2_wf : forall a, well_formed_comp (c2 a).
  Hypothesis A_EqDec : EqDec A.
  Hypothesis B_EqDec : EqDec B.
  Hypothesis State_EqDec : EqDec State.
  Variable A1 : Comp ((list A) * State).
  Variable A2 : State -> list B -> Comp bool.

  Variable maxA : nat.
  Hypothesis maxA_correct :
    forall ls s_A,
      In (ls, s_A) (getSupport A1) ->
      (length ls <= maxA)%nat.

  Definition ListHybrid_G (c : A -> Comp B) :=
    [lsA, s_A] <-$2 A1;
    lsB <-$ compMap _ c lsA;
    A2 s_A lsB.

  Definition ListHybrid_Advantage :=
    | Pr[ListHybrid_G c1] - Pr[ListHybrid_G c2] |.

  Definition G_hybrid i :=
    [lsA, s_A] <-$2 A1;
    lsA1 <- firstn i lsA;
    lsA2 <- skipn i lsA;
    lsB1 <-$ compMap _ c1 lsA1;
    lsB2 <-$ compMap _ c2 lsA2;
    A2 s_A (lsB1 ++ lsB2).

  Theorem G_2_hybrid_eq :
    Pr[ListHybrid_G c2] == Pr[G_hybrid 0].

    unfold ListHybrid_G, G_hybrid.
    comp_skip.
    comp_simp.
    eapply comp_spec_eq_impl_eq.
    simpl.
    comp_simp.
    simpl.
    eapply comp_spec_eq_refl.

  Qed.

  Theorem G_1_hybrid_eq :
    Pr[ListHybrid_G c1] == Pr[G_hybrid maxA].

    unfold ListHybrid_G, G_hybrid.
    comp_skip.
    comp_simp.
    rewrite firstn_ge_all.
    comp_skip.

    Theorem skipn_ge_nil :
      forall (A : Type)(ls : list A)(n : nat),
        n >= length ls ->
        skipn n ls = nil.

      induction ls; destruct n; intuition; simpl in *.
      omega.
      eapply IHls.
      omega.

    Qed.

    rewrite skipn_ge_nil.
    eapply comp_spec_eq_impl_eq.
    simpl.
    comp_simp.
    rewrite app_nil_r.
    eapply comp_spec_eq_refl.
    eauto.
    eauto.

  Qed.

  Definition B1 i :=
    [lsA, s_A] <-$2 A1;
    lsA1 <- firstn i lsA;
    a <- nth i lsA defA;
    lsA2 <- skipn (S i) lsA;
    incla <- if (lt_dec i (length lsA)) then true else false;
    ret (a, (incla, lsA1, lsA2, s_A)).

  Definition B2 (e : bool * _ * _ * _) b :=
      let '(incla, lsA1, lsA2, s_A) := e in
      lsB1 <-$ compMap _ c1 lsA1;
        lsB2 <-$ compMap _ c2 lsA2;
        lsB <- if incla then (lsB1 ++ (b :: lsB2)) else lsB1;
      A2 s_A lsB.

  Local Open Scope list_scope.
  Theorem compMap_unroll :
    forall (A B : Set)(eqdb : EqDec B)(c : A -> Comp B)(ls : list A)(def : A),
      ls <> nil ->
      comp_spec eq (compMap _ c ls) (x <-$ c (hd def ls); y <-$ compMap _ c (tl ls); ret (x :: y)).

    induction ls; intuition; simpl in *.
    comp_skip.

  Qed.

  Theorem G_hybrid_DistSingle_eq :
    forall i,
      Pr[G_hybrid i] == Pr[DistSingle_G (B1 i) B2 c2].

    intuition.
    unfold G_hybrid, DistSingle_G, B1, B2.
    inline_first.
    comp_skip.
    comp_simp.
    comp_swap_r.
    comp_skip.

    eapply comp_spec_eq_impl_eq.
    destruct (lt_dec i (length l)).
    eapply comp_spec_eq_trans.
    eapply comp_spec_seq_eq; eauto with inhabited.
    eapply compMap_unroll.
    intuition.

    Theorem skipn_lt_nil_false :
      forall (A : Type)(ls : list A)(n : nat),
        n < length ls ->
        skipn n ls = nil ->
        False.

      induction ls; intuition; simpl in *.
      omega.
      destruct n; simpl in *; intuition.
      discriminate.
      eapply IHls; eauto.
      omega.

    Qed.

    eapply skipn_lt_nil_false;
      eauto.

    intuition.
    eapply comp_spec_eq_refl.
    inline_first.
    comp_skip.

    Theorem hd_skip_eq_nth :
      forall (A : Type)(def : A)(ls : list A)(n : nat),
        hd def (skipn n ls) = nth n ls def.

      induction ls; destruct n; intuition; simpl in *.
      eauto.

    Qed.

    rewrite hd_skip_eq_nth.
    eapply comp_spec_eq_refl.
    subst.
    inline_first.

    Theorem tl_skipn_eq :
      forall (A : Type)(ls : list A)(n : nat),
        tl (skipn n ls) = skipn (S n) ls.

      induction ls; intuition; simpl in *.
      rewrite skipn_nil.
      trivial.

      destruct n; simpl in *.
      trivial.
      eauto.

    Qed.

    rewrite tl_skipn_eq.
    comp_skip.

    Theorem skipn_gt_nil :
      forall (A : Type)(ls : list A)(n : nat),
        n >= length ls ->
        skipn n ls = nil.

      induction ls; destruct n; intuition; simpl in *.
      omega.
      eapply IHls; eauto.
      omega.

    Qed.

    rewrite skipn_gt_nil; intuition.
    simpl.
    comp_simp.
    rewrite app_nil_r.
    comp_irr_r.
    comp_irr_r.
    eapply compMap_wf.
    intuition.
  Qed.

  Theorem compMap_unroll_tl :
    forall (A B : Set)(def : A)(eqdb : EqDec B)(c : A -> Comp B)(ls : list A) n,
      length ls = S n ->
      comp_spec eq (compMap _ c ls) (y <-$ compMap _ c (firstn n ls); x <-$ c (nth n ls def); ret (y ++ x :: nil)).

    induction ls; intuition; simpl in *.
    omega.

    destruct n.
    destruct ls.
    simpl in *.
    comp_simp.
    comp_skip.
    simpl.
    eapply comp_spec_eq_refl.
    simpl in*.
    omega.

    simpl.
    inline_first.
    comp_skip.
    eapply comp_spec_eq_trans.
    eapply comp_spec_seq_eq; eauto with inhabited.
    intros.
    eapply comp_spec_eq_refl.
    inline_first.
    comp_skip.
    inline_first.
    comp_simp.
    comp_skip.
    rewrite <- app_comm_cons.
    eapply comp_spec_eq_refl.

  Qed.

  Theorem G_hybrid_DistSingle_S_eq :
    forall i,
      Pr[G_hybrid (S i)] == Pr[DistSingle_G (B1 i) B2 c1].

    intuition.
    unfold G_hybrid, DistSingle_G, B1, B2.
    inline_first.
    comp_skip.
    comp_simp.
    eapply comp_spec_eq_impl_eq.
    destruct (lt_dec i (length l)).

    eapply comp_spec_eq_trans.
    eapply comp_spec_seq_eq; eauto with inhabited.
    eapply compMap_unroll_tl.
    rewrite firstn_length.
    eapply min_l.
    omega.
    intuition.
    eapply comp_spec_eq_refl.
    inline_first.

    Theorem firstn_firstn :
      forall (A : Type)(ls : list A)(n1 n2 : nat),
        (n1 <= n2)%nat ->
        firstn n1 (firstn n2 ls) = firstn n1 ls.

      induction ls; destruct n1; destruct n2; intuition; simpl in *.
      omega.

      f_equal.
      eapply IHls.
      omega.

    Qed.

    rewrite firstn_firstn.
    comp_swap_r.
    comp_skip.
    inline_first.

    Theorem nth_firstn :
      forall (A : Set)(def : A)(ls : list A)(n1 n2 : nat),
        (n1 < n2)%nat ->
        nth n1 (firstn n2 ls) def = nth n1 ls def.

      induction ls; destruct n1; destruct n2; intuition; simpl in *.
      omega.
      omega.
      eapply IHls.
      omega.
    Qed.

    rewrite nth_firstn.
    comp_skip.
    comp_skip.
    rewrite <- app_assoc.
    rewrite <- app_comm_cons.
    simpl.
    eapply comp_spec_eq_refl.
    omega.
    omega.

    comp_irr_r.

    repeat rewrite firstn_ge_all.
    comp_skip.
    comp_skip.
    rewrite skipn_gt_nil in H3.
    simpl in *.
    intuition.
    subst.
    rewrite app_nil_r.
    eapply comp_spec_eq_refl.
    omega.
    omega.
    omega.

  Qed.

  Theorem hybrid_incr_close :
    forall i,
  | Pr[G_hybrid i] - Pr[G_hybrid (S i)] | == DistSingle_Adv c1 c2 (B1 i) B2.

    intuition.
    unfold DistSingle_Adv.

    rewrite G_hybrid_DistSingle_eq.
    rewrite G_hybrid_DistSingle_S_eq.
    eapply ratDistance_comm.
  Qed.

  Theorem ratDistance_sequence_sum :
    forall (f : nat -> Rat)(n : nat),
  | f O - f n | <= sumList (forNats n) (fun i => | f i - f (S i) |).

    induction n; intuition; simpl in *.
    unfold sumList.
    simpl.
    eapply eqRat_impl_leRat.
    rewrite <- ratIdentityIndiscernables.
    intuition.

    eapply leRat_trans.
    Focus 2.
    eapply eqRat_impl_leRat.
    symmetry.
    eapply sumList_cons.
    simpl.
    eapply leRat_trans.
    eapply ratDistance_le_trans.
    eapply IHn.
    eapply leRat_refl.
    rewrite ratAdd_comm.
    intuition.

  Qed.

  Theorem Single_impl_ListHybrid_sum :
    ListHybrid_Advantage
    <=
    sumList (forNats maxA) (fun i => DistSingle_Adv c1 c2 (B1 i) B2).

    unfold ListHybrid_Advantage.
    rewrite G_1_hybrid_eq.
    rewrite G_2_hybrid_eq.
    rewrite ratDistance_comm.
    rewrite (@ratDistance_sequence_sum (fun i => Pr[G_hybrid i])); intuition.
    eapply sumList_le.
    intuition.
    eapply eqRat_impl_leRat.
    eapply hybrid_incr_close.

  Qed.

  Variable maxDistance : Rat.
  Hypothesis maxDistance_correct :
    forall i, DistSingle_Adv c1 c2 (B1 i) B2 <= maxDistance.

  Theorem Single_impl_ListHybrid :
    ListHybrid_Advantage <= maxA / 1 * maxDistance.

    rewrite Single_impl_ListHybrid_sum.
    eapply leRat_trans.
    eapply sumList_le.
    intros.
    eapply maxDistance_correct.
    rewrite sumList_body_const.
    rewrite forNats_length.
    rewrite ratMult_comm.
    intuition.

  Qed.

End ListHybrid.


Require Import Program.

Set Implicit Arguments.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Section variables.
  Variable tvar : Type.

  Inductive type :=
  | TVar (x : tvar)
  | Arrow (t1 t2 : type).

  Section var.
    Variable var : type -> Type.

    Inductive term : type -> Type :=
    | Var : forall t,
      var t -> term t
    | Abs : forall dom ran,
      (var dom -> term ran) -> term (Arrow dom ran)
    | App : forall dom ran,
      term (Arrow dom ran) -> term dom -> term ran.
  End var.

  Definition Term t := forall var, term var t.

  Section tvars.
    Variable tvarD : tvar -> Type.

    Fixpoint typeD (t : type) : Type :=
      match t with
        | Arrow t1 t2 => typeD t1 -> typeD t2
        | TVar a => tvarD a
      end.

    Fixpoint termD t (e : term typeD t) : typeD t :=
      match e with
        | Var _ x => x
        | Abs _ _ e1 => fun x => termD (e1 x)
        | App _ _ e1 e2 => (termD e1) (termD e2)
      end.

    Definition TermD t (E : Term t) : typeD t :=
      termD (E _).
  End tvars.
End variables.

Section finVariables.
  Inductive finType : Type -> Type :=
  | fTVar : finType unit
  | fArrow : forall n m : Type,
               finType n -> finType m -> finType (n + m).

  Fixpoint type_of_finType n tvar (t : finType n)
  : (n -> tvar) -> type tvar
    := match t in finType n return (n -> _) -> _ with
         | fTVar => fun tvars => TVar (tvars tt)
         | fArrow tn tm t1 t2 =>
           fun tvars =>
             Arrow
               (@type_of_finType _ _ t1 (fun x => tvars (inl x)))
               (@type_of_finType _ _ t2 (fun x => tvars (inr x)))
       end.

  Section var.
    Variable tvar : Type.
    Variable var : finType tvar -> Type.

    Inductive finTerm : finType tvar -> Type :=
    | fVar : forall t,
      var t -> term t
    | Abs : forall dom ran,
      (var dom -> term ran) -> term (Arrow dom ran)
    | App : forall dom ran,
      term (Arrow dom ran) -> term dom -> term ran.
  End var.

  Definition Term t := forall var, term var t.

  Section tvars.
    Variable tvarD : tvar -> Type.

    Fixpoint typeD (t : type) : Type :=
      match t with
        | Arrow t1 t2 => typeD t1 -> typeD t2
        | TVar a => tvarD a
      end.

    Fixpoint termD t (e : term typeD t) : typeD t :=
      match e with
        | Var _ x => x
        | Abs _ _ e1 => fun x => termD (e1 x)
        | App _ _ e1 e2 => (termD e1) (termD e2)
      end.

    Definition TermD t (E : Term t) : typeD t :=
      termD (E _).
  End tvars.
End variables.

(*
Section finVariables.
  Variable tvar : Type.
  Variable count_occ : type tvar -> nat.

  Check @term tvar (fun t => Fin (count_occ t)).
  Section var.
    Inductive finTerm n : finType n -> Type :=
    | fVar : forall f : Fin n, finTerm (TVar f)
    | fAbs : forall dom ran,
               (var dom -> term ran) -> term (Arrow dom ran)
    | App : forall dom ran,
      term (Arrow dom ran) -> term dom -> term ran.
  End var.

  Definition Term t := forall var, term var t.

  Section tvars.
    Variable tvarD : tvar -> Type.

    Fixpoint typeD (t : type) : Type :=
      match t with
        | Arrow t1 t2 => typeD t1 -> typeD t2
        | TVar a => tvarD a
      end.

    Fixpoint termD t (e : term typeD t) : typeD t :=
      match e with
        | Var _ x => x
        | Abs _ _ e1 => fun x => termD (e1 x)
        | App _ _ e1 e2 => (termD e1) (termD e2)
      end.

    Definition TermD t (E : Term t) : typeD t :=
      termD (E _).
  End tvars.
End variables.
*)
Record category := {
  Object :> Type;
  Morphism : Object -> Object -> Type;

  Identity : forall o, Morphism o o
}.

Definition op : category -> category :=
  fun C => {| Object := Object C;
              Morphism x y := Morphism C y x;
              Identity x := Identity C x |}.

Record indexedFunctor idx (Cs : idx -> category) (D : category) := {
  ObjectOf :> (forall i, Cs i) -> D;
  MorphismOf : forall (Xs Ys : forall i, Cs i),
                 (forall i, Morphism (Cs i) (Xs i) (Ys i))
                 -> Morphism D (ObjectOf Xs) (ObjectOf Ys)
}.

Definition cat : category :=
  {| Object := category;
     Morphism C D := indexedFunctor (fun _ : unit => C) D;
     Identity C := {| ObjectOf f := f tt;
                      MorphismOf x y m := m tt |}
  |}.

Definition naturalTransformation idx Cs D (F G : @indexedFunctor idx Cs D) :=
  forall (Xs : forall i, Cs i), Morphism D (F Xs) (G Xs).

Definition indexedFunctorCategory idx (Cs : idx -> category) (D : category) :=
  {|
    Object := indexedFunctor Cs D;
    Morphism := @naturalTransformation idx Cs D;
    Identity := fun f x => Identity D (f x)
  |}.

Definition compose_functors_1 idx Cs D D'
        (F : @indexedFunctor unit (fun _ => D) D')
        (G : @indexedFunctor idx Cs D)
: @indexedFunctor idx Cs D'
  := {| ObjectOf x := ObjectOf F (fun _ => ObjectOf G x);
        MorphismOf x y m := MorphismOf F _ _ (fun _ => MorphismOf G _ _ m) |}.

Definition compose_functors idx idx'
           (Cs : idx -> category) (Ds : idx' -> category) D'
           (F : @indexedFunctor idx' Ds D')
           (G : forall i, @indexedFunctor idx Cs (Ds i))
: @indexedFunctor idx Cs D'
  := {| ObjectOf x := ObjectOf F (fun i => ObjectOf (G i) x);
        MorphismOf x y m := MorphismOf F _ _ (fun i => MorphismOf (G i) _ _ m) |}.

Definition indexedFunctorCategory_last_helper C D
           idx (Cs : idx -> category)
           (m : indexedFunctor (fun _ : unit => D) C)
: indexedFunctor (fun _ : unit => indexedFunctorCategory Cs D)
                 (indexedFunctorCategory Cs C).
Proof.
  let Cs := match goal with |- indexedFunctor ?Cs ?D => constr:(Cs) end in
  let D := match goal with |- indexedFunctor ?Cs ?D => constr:(D) end in
  refine (Build_indexedFunctor
            Cs
            D
            (compose_functors m)
            (fun Xs Ys T => fun Xs0 => MorphismOf m _ _ (fun i => T i Xs0))).
Defined.

Definition indexedFunctor_rest_helper
           idx (Cs C's : idx -> category)
           (D : category)
           (F : forall i, indexedFunctor (fun _ : unit => C's i) (Cs i))
           (G : indexedFunctor Cs D)
:  indexedFunctor C's D
  := Build_indexedFunctor
       C's D
       (fun X' =>
          G (fun i => (F i) (fun _ => X' i)))
       (fun Xs Ys Ms =>
          MorphismOf G _ _ (fun i =>
                              MorphismOf (F i) _ _ (fun _ => Ms i))).

Definition indexedFunctorCategory_rest_helper
           idx (Cs C's : idx -> category)
           (D : category)
           (F : forall i, indexedFunctor (fun _ : unit => C's i)
                                         (Cs i))
  := Build_indexedFunctor
       (fun _ : unit =>
          indexedFunctorCategory Cs D)
       (indexedFunctorCategory C's D)
       (fun X => indexedFunctor_rest_helper _ F (X tt))
       (fun Xs Ys Ms _ => Ms tt _).

Definition indexedFunctorCategoryFunctor idx
: indexedFunctor (fun i : option idx => match i with None => cat | Some _ => op cat end) cat
  := Build_indexedFunctor (fun i : option idx => match i with
                                                   | None => cat
                                                   | Some _ => op cat
                                                 end)
                          cat
                          (fun f => @indexedFunctorCategory idx (fun i => f (Some i)) (f None))
                          (fun Xs Ys Ms =>
                             compose_functors
                               (indexedFunctorCategory_last_helper _ (Ms None))
                               (fun ttt =>
                                  indexedFunctorCategory_rest_helper
                                    (fun i => Xs (Some i))
                                    (fun i => Ys (Some i))
                                    (Xs None)
                                    (fun i => Ms (Some i)))).

Section typeCat.
  Variable tvar : Type.
  Variable tvars : tvar -> category.

  Fixpoint typeCat (t : type tvar) : category
    := match t with
         | TVar a => tvars a
         | Arrow t1 t2 => indexedFunctorCategory
                            (fun _ : unit => typeCat t1)
                            (typeCat t2)
       end.

  Definition selection_functor (a : tvar) : indexedFunctor tvars cat
    := Build_indexedFunctor tvars cat
                            (fun x => tvars a)
                            (fun xs ys ms => Identity _ _).

  Program Fixpoint termCat t (e : term typeCat t)
  : indexedFunctor tvars (typeCat t) :=
    match e in term _ t return indexedFunctor tvars (typeCat t) with
      | App _ _ e1 e2 => (termCat e1) (termCat e2)
      | Var _ x => selection_functor _
      | Abs _ _ e1 => e1
    end.

  Next Obligation.
    simpl; fold typeCat; intros.
    Check (fun P H0 H1 H2 x => term_rect P H0 H1 H2 (e1 x)).

  Fixpoint typeCat (t : type tvar) : indexedFunctor tvars cat.
  refine match t with
           | TVar a => selection_functor a
           | Arrow t1 t2 => _
         end.
  assert ((forall i, tvars i) -> cat).
  Set Printing Coercions.
indexedFunctorCategoryFunctor _
(fun _ : unit => typeCat t1) (typeCat t2)

  Axiom cheat : forall T, T.

  Program Fixpoint termCat t (e : term typeCat t) : typeCat t :=
    match e in term _ t return typeCat t with
      | App _ _ e1 e2 => (termCat e1) (termCat e2)
      | Var _ x => x
      | Abs _ _ e1 => {| ObjectOf := fun x => termCat (e1 x);
        MorphismOf := _ |}
    end.

  Next Obligation.
    simpl; fold typeCat; intros.
    Check (fun P H0 H1 H2 x => term_rect P H0 H1 H2 (e1 x)).

Theorem identity_something :.


Require Export Andcomr.
Section ml.
Variables A B:Prop.
Theorem Andcom: and A B <-> and B A.
Proof.
    split; apply Andcomr.
Qed.
End ml.

Check Andcom.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

<<<<<<< HEAD:FPBench/rigid_body.v
Definition rigidbody1_bmap_list := [Build_varinfo Tdouble 1%positive (-15) (15);Build_varinfo Tdouble 2%positive (-15) (15);Build_varinfo Tdouble 3%positive (-15) (15)].

Definition rigidbody1_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list rigidbody1_bmap_list) in exact z).

Definition rigidbody1 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) :=
  cast Tdouble (((((-(x1 * x2)%F64) - (((2)%F64 * x2)%F64 * x3)%F64)%F64 - x1)%F64 - x3)%F64).

Definition rigidbody1_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) rigidbody1 in exact e').

Derive rigidbody1_b
SuchThat (forall vmap, prove_roundoff_bound rigidbody1_bmap vmap rigidbody1_expr rigidbody1_b)
As rigidbody1_bound.
Proof.
idtac "Starting rigidbody1".
time "rigidbody1" (
try (subst rigidbody1_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2; prune_terms (cutoff 30); do_interval)).
Qed.

Lemma check_rigidbody1_bound: ltac:(CheckBound rigidbody1_b 3.1e-13%F64).
Proof. reflexivity. Qed.

=======
>>>>>>> b35234fce9cbf03ede4c0bfc4b61d33d055eb550:FPBench/rigid_body2.v
Definition rigidbody2_bmap_list := [Build_varinfo Tdouble 1%positive (-15) (15);Build_varinfo Tdouble 2%positive (-15) (15);Build_varinfo Tdouble 3%positive (-15) (15)].

Definition rigidbody2_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list rigidbody2_bmap_list) in exact z).

Definition rigidbody2 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) :=
  cast Tdouble (((((((((2)%F64 * x1)%F64 * x2)%F64 * x3)%F64 + (((3)%F64 * x3)%F64 * x3)%F64)%F64 - (((x2 * x1)%F64 * x2)%F64 * x3)%F64)%F64 + (((3)%F64 * x3)%F64 * x3)%F64)%F64 - x2)%F64).

Definition rigidbody2_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive]) rigidbody2 in exact e').

Derive rigidbody2_b
SuchThat (forall vmap, prove_roundoff_bound rigidbody2_bmap vmap rigidbody2_expr rigidbody2_b)
As rigidbody2_bound.
Proof.
idtac "Starting rigidbody2".
time "rigidbody2" (
try (subst rigidbody2_b; intro; prove_roundoff_bound);
try (prove_rndval; interval);
try (prove_roundoff_bound2; prune_terms (cutoff 30); do_interval)).
Qed.

Lemma check_rigidbody2_bound: ltac:(CheckBound rigidbody2_b 3.9e-11%F64).
Proof. reflexivity. Qed.

End WITHNANS.
Close Scope R_scope.


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Inductive multInd (A I : Set) (B:Set) (f: A-> I) (g: forall i, B)
  : forall (i:I) (b:B), Set  :=
mlind : forall a, multInd A I B f g (f a) (g (f a)).

Require Import SquiggleEq.UsefulTypes.

Run TemplateProgram (genParamInd [] true true "Top.multIndices2NonDep.multInd").
Run TemplateProgram (genParamIndTotAll [] true  "Top.multIndices2NonDep.multInd").

Require Import ReflParam.Trecord.

(*
Definition multIndices2Tot : forall (A A₂ : Set)
                                           (A_R : BestRel A A₂)
                                           (I I₂ : Set)
                                           (I_R : BestRel I I₂)
                                           (B B₂ : Set)
                                           (B_R : BestRel B B₂)
                                           (f : A -> I)
                                           (f₂ : A₂ -> I₂)
                                           (f_R :
                                            BestR
                                              (PiTSummary A A₂ A_R
                                                 (fun _ : A => I)
                                                 (fun _ : A₂ => I₂)
                                                 (fun
                                                 (H : A)
                                                 (H0 : A₂)
                                                 (_ : BestR A_R H H0) => I_R))
                                              f f₂)
                                           (g : I -> B)
                                           (g₂ : I₂ -> B₂)
                                           (g_R :
                                            BestR
                                              (PiTSummary I I₂ I_R
                                                 (fun _ : I => B)
                                                 (fun _ : I₂ => B₂)
                                                 (fun
                                                 (i : I)
                                                 (i₂ : I₂)
                                                 (_ : BestR I_R i i₂) => B_R))
                                              g g₂)
                                           (i : I)
                                           (i₂ : I₂)
                                           (i_R : BestR I_R i i₂)
                                           (b : B)
                                           (b₂ : B₂)
                                           (b_R : BestR B_R b b₂)
                                           (H : multInd A I B f g i b),
   multInd A₂ I₂ B₂ f₂ g₂ i₂ b₂.
refine
(fix
 Top_multIndices2NonDep_multInd_pmtcty_RR0 (A A₂ : Set)
                                           (A_R : BestRel A A₂)
                                           (I I₂ : Set)
                                           (I_R : BestRel I I₂)
                                           (B B₂ : Set)
                                           (B_R : BestRel B B₂)
                                           (f : A -> I)
                                           (f₂ : A₂ -> I₂)
                                           (f_R :
                                            BestR
                                              (PiTSummary A A₂ A_R
                                                 (fun _ : A => I)
                                                 (fun _ : A₂ => I₂)
                                                 (fun
                                                 (H : A)
                                                 (H0 : A₂)
                                                 (_ : BestR A_R H H0) => I_R))
                                              f f₂)
                                           (g : I -> B)
                                           (g₂ : I₂ -> B₂)
                                           (g_R :
                                            BestR
                                              (PiTSummary I I₂ I_R
                                                 (fun _ : I => B)
                                                 (fun _ : I₂ => B₂)
                                                 (fun
                                                 (i : I)
                                                 (i₂ : I₂)
                                                 (_ : BestR I_R i i₂) => B_R))
                                              g g₂)
                                           (i : I)
                                           (i₂ : I₂)
                                           (i_R : BestR I_R i i₂)
                                           (b : B)
                                           (b₂ : B₂)
                                           (b_R : BestR B_R b b₂)
                                           (H : multInd A I B f g i b)
                                           {struct H} :
   multInd A₂ I₂ B₂ f₂ g₂ i₂ b₂ :=
   match
     H in (multInd _ _ _ _ _ i0 b0)
     return
       (forall (i₂0 : I₂) (b₂0 : B₂),
        BestR I_R i0 i₂0 ->
        BestR B_R b0 b₂0 -> multInd A₂ I₂ B₂ f₂ g₂ i₂0 b₂0)
   with
   | mlind _ _ _ _ _ a =>
       fun (i₂0 : I₂) (b₂0 : B₂) (i_R0 : BestR I_R (f a) i₂0)
         (br : BestR B_R (g (f a)) b₂0) =>
       let a₂ := BestTot12 A_R a in
       let a_R := BestTot12R A_R a in
       let c2 := mlind A₂ I₂ B₂ f₂ g₂ a₂ in _
   end i₂ b₂ i_R b_R).
   set (peq := @BestOne12 I I₂ I_R (f a) i₂0
(* so far this exactly matches the type of br above *)
   (f₂ a₂) i_R0 (f_R a a₂ a_R)).
   set (c22 := @transport _ _ _
      (fun i2:I₂ => multInd A₂ I₂ B₂ f₂ g₂ i2
           (g₂ i2(*we had to convert this from (f₂ a₂) in c2 *)))
          peq c2).
   simpl in c22.
  set (peq2 :=
@BestOne12 B B₂ B_R (g (f a)) b₂0
(* so far this exactly matches the type of br above *)
           (g₂ i₂0) br (g_R (f a) i₂0 (*we had to convert this from (f₂ a₂) in c2 *)
           i_R0 (* [f a] was replaced with i_R0. it seems that this will
           be needed even if the second index was not dependent.  *) )).

  exact (@transport B₂ (g₂ i₂0) b₂0 (multInd A₂ I₂ B₂ f₂ g₂ i₂0) peq2 c22).
Defined.

*)