From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor.
From Categories Require Import Cat.Cat.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.

(* empty and singleton categories *)

(** The empty category – initial object of Cat. *)
Definition EmptyCat : Category :=
  {|
    Obj := (Empty : Type);
    Hom := fun _ _ => (unit : Type);
    compose := fun _ _ _ _ _ => tt;
    assoc := fun _ _ _ _ _ _ _ => eq_refl;
    assoc_sym := fun _ _ _ _ _ _ _ => eq_refl;
    id := fun _ => tt;
    id_unit_left :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => eq_refl
        end;
    id_unit_right :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => eq_refl
        end
  |}.

(** The singleton category – terminal object of Cat. *)
Definition SingletonCat : Category :=
  {|
    Obj := (unit : Type);
    Hom := fun _ _ => (unit : Type);
    compose := fun _ _ _ _ _ => tt;
    assoc := fun _ _ _ _ _ _ _ => eq_refl;
    assoc_sym := fun _ _ _ _ _ _ _ => eq_refl;
    id := fun _ => tt;
    id_unit_left :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => eq_refl
        end;
    id_unit_right :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => eq_refl
        end
  |}.

Notation "0" := (EmptyCat) : category_scope.
Notation "1" := (SingletonCat) : category_scope.

(* discrete categories in general *)
Section Discr.
  Context (obj : Type).

  (** Discrete category – one in which has no arrow but identitities.
Note that this definition is not necessarily a discrete cat in Coq as UIP is not
generally provable. We simply assume so by implicitly assuming object type to
have UIP. In HoTT terms, we assume obj to be a hSet. *)
  Program Definition Discr_Cat : Category :=
    {|
      Obj := obj;
      Hom := fun a b => a = b;
      compose := @eq_trans _;
      id := fun a => eq_refl
    |}.

End Discr.

Definition Type_n (n : nat) : Type := {x : nat| x < n}.

Notation "'Discr_n' n" :=
  (Discr_Cat (Type_n n)) (at level 200, n bigint) : category_scope.

(** Any discrete category is ismorphic to its dual. *)
Section Discr_Cat_Dual_Iso.
  Context (obj : Type).

  Local Hint Extern 1 => progress cbn : core.

  Program Definition Discr_Cat_Dual_Iso :
    (Discr_Cat obj ≃≃ (Discr_Cat obj)^op ::> Cat)%isomorphism%category
    :=
      {|
        iso_morphism := {|FO := fun x => x; FA := fun _ _ h => eq_sym h|};
        inverse_morphism := {|FO := fun x => x; FA := fun _ _ h => eq_sym h|}
      |}.

End Discr_Cat_Dual_Iso.

(** Any two isomorphic types form isomorphic discrete categories. *)
Section Discr_Cat_Iso.
  Context {obj obj' : Type} (I : (obj ≃≃ obj' ::> Type_Cat)%isomorphism).

  Program Definition Discr_Cat_Iso :
    ((Discr_Cat obj) ≃≃ (Discr_Cat obj') ::> Cat)%isomorphism
    :=
      {|
        iso_morphism :=
          {|
            FO := iso_morphism I;
            FA :=
              fun c d h =>
                match h in _ = y return
                      (iso_morphism I c) = (iso_morphism I y)
                with
                  eq_refl => eq_refl
                end
          |};
        inverse_morphism :=
          {|
            FO := inverse_morphism I;
            FA :=
              fun c d h =>
                match h in _ = y return
                      (inverse_morphism I c) = (inverse_morphism I y)
                with
                  eq_refl => eq_refl
                end
          |}
      |}.

  Next Obligation.
  Proof.
    Func_eq_simpl.
    {
      FunExt; cbn in *.
      match goal with
        [|- ?A = ?B] => destruct A
      end.
      apply JMeq_eq; auto.
    }
    {
      FunExt; cbn.
      cbn_rewrite (equal_f (left_inverse I)); trivial.
    }
  Qed.

  Next Obligation.
  Proof.
    Func_eq_simpl.
    {
      FunExt; cbn in *.
      match goal with
        [|- ?A = ?B] => destruct A
      end.
      apply JMeq_eq; auto.
    }
    {
      FunExt; cbn.
      cbn_rewrite (equal_f (right_inverse I)); trivial.
    }
  Qed.

End Discr_Cat_Iso.

(* Discrete Functor *)
Section Discr_Func.
  Context {C : Category} {A : Type} (Omap : A → C).

  (** The discrete functor – a functor from a discrete category of type A
 to a category C based on a function from A to objects of C. *)
  Program Definition Discr_Func : ((Discr_Cat A) --> C)%functor :=
    {|
      FO := Omap;

      FA := fun (a b : A) (h : a = b) =>
              match h in _ = y return ((Omap a) --> (Omap y))%morphism with
              | eq_refl => id
              end
    |}.

  (** The discrete-opposite functor – a functor from the opposite of a
      discrete category of type A to a category C based on a function
      from A to objects of C. *)
  Program Definition Discr_Func_op : ((Discr_Cat A)^op --> C)%functor :=
    {|
      FO := Omap;
      FA := fun (a b : A) (h : b = a) =>
              match h in _ = y return ((Omap y) --> (Omap b))%morphism with
              | eq_refl => id
              end
    |}.

End Discr_Func.

Arguments Discr_Func {_ _} _, _ {_} _.
Arguments Discr_Func_op {_ _} _, _ {_} _.


Require Import Coq.Lists.List
        Coq.Strings.String
        Fiat.Common
        Coq.Arith.Arith
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.StringBound.
Require Export
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.QueryStructure.Specification.Representation.Schema
        Fiat.QueryStructure.Specification.Representation.Relation.

Import Vectors.VectorDef.VectorNotations.

(* A Query Structure schema is a set of named relation
   schemas and a set of cross-relation constraints
   (i.e. foreign key constraints). *)

Record NamedSchema  :=
  { relName : string;
    relSchema : Schema
  }.

Definition GetNRelSchema
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (idx : Fin.t n) :=
  Vector.nth namedSchemas idx.

Definition GetNRelSchemaHeading
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (idx : Fin.t n)
  := rawSchemaHeading (GetNRelSchema namedSchemas idx).

Definition crossRelationR
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (idx idx' : Fin.t n)
  := @RawTuple (GetNRelSchemaHeading namedSchemas idx)
     -> Ensemble (@IndexedRawTuple (GetNRelSchemaHeading namedSchemas idx'))
     -> Prop.

Definition crossRelationProdR
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (idxs : _ * _)
  := crossRelationR namedSchemas (fst idxs) (snd idxs).

Record RawQueryStructureSchema :=
  { numRawQSschemaSchemas : nat;
    qschemaSchemas : Vector.t RawSchema numRawQSschemaSchemas;
    qschemaConstraints:
      list (sigT (crossRelationProdR qschemaSchemas))
  }.

Record QueryStructureSchema :=
  { numQSschemaSchemas : nat;
    QSschemaSchemas : Vector.t Schema numQSschemaSchemas;
    QSschemaConstraints:
      list (sigT (crossRelationProdR (Vector.map schemaRaw QSschemaSchemas)));
    QSschemaNames : Vector.t string numQSschemaSchemas  }.

Definition QueryStructureSchemaRaw
           (QSSchema : QueryStructureSchema)
  : RawQueryStructureSchema :=
  {| numRawQSschemaSchemas := numQSschemaSchemas QSSchema;
     qschemaConstraints := QSschemaConstraints QSSchema |}.

Coercion QueryStructureSchemaRaw : QueryStructureSchema >-> RawQueryStructureSchema.

Definition QSGetNRelSchema
           (QSSchema : QueryStructureSchema)
           (idx : BoundedString (QSschemaNames QSSchema)) :=
  Vector.nth (QSschemaSchemas QSSchema) (ibound (indexb idx)).

Definition QSGetNRelSchemaHeading
           (QSSchema : QueryStructureSchema)
           (idx : BoundedString (QSschemaNames QSSchema)) :=
  schemaHeading (QSGetNRelSchema QSSchema idx).

Notation GetHeading QSSchema index :=
  (@QSGetNRelSchemaHeading QSSchema (@Build_BoundedIndex _ _ _ index _)).

(* Notations for Query Structures. *)

Notation "'relation' name 'has' sch " :=
  {| relName := name%string;
     relSchema := sch%Schema
  |} : NamedSchema_scope.

Notation "[ rel1 ; .. ; reln ]" :=
  (@Vector.cons _ rel1 _ (.. (@Vector.cons _ reln _ (Vector.nil _)) .. )) : NamedSchema_scope.
Notation "[ rel1 ; rel2 ; .. ; reln ]" :=
  (@Vector.cons _ rel1 _ (@Vector.cons _ rel2 _ (.. (@Vector.cons _ reln _ (Vector.nil _)) .. ))) : NamedSchema_scope.

Bind Scope NamedSchema_scope with NamedSchema.

(* A notation for foreign key constraints. This gives us
  a pair of relation schema names and a predicate on
  tuples in those tables. We use the namedSchemaHint
  typeclass to get the typechecking to work. *)

Definition ForeignKey_P heading relSchema attr1 attr2 tupmap
           (tup : @RawTuple heading)
           (R : Ensemble (@IndexedRawTuple relSchema)) :=
  exists tup2,
    R tup2 /\
    GetAttributeRaw tup attr1 =
    tupmap (GetAttributeRaw (indexedRawTuple tup2) attr2).

Definition BuildForeignKeyConstraints
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (rel1 rel2 : _)
           attr1
           attr2
           {tupmap} :=
  (existT (crossRelationProdR namedSchemas)
          (rel1, rel2)
          (ForeignKey_P attr1 attr2 tupmap)).

Class namedSchemaHint :=
  { numnSchemaHint : nat;
    nSchemaHint :> Vector.t Schema numnSchemaHint;
    nSchemaNamesHint :> Vector.t string numnSchemaHint}.

Notation "'attribute' attr 'for' rel1 'references' rel2 " :=
  (let hint : namedSchemaHint := _ in
   let rel1' := ibound (indexb (@Build_BoundedIndex _ _ (@nSchemaNamesHint hint) rel1%string _)) in
   let rel2' := ibound (indexb (@Build_BoundedIndex _ _ (@nSchemaNamesHint hint) rel2%string _)) in
   @BuildForeignKeyConstraints
     _ (Vector.map schemaRaw (@nSchemaHint hint)) rel1' rel2'
     (ibound (indexb (@Build_BoundedIndex _ _ (schemaHeadingNames (Vector.nth (@nSchemaHint hint) rel1')) attr%string _)))
     (ibound (indexb (@Build_BoundedIndex _ _ (schemaHeadingNames (Vector.nth (@nSchemaHint hint) rel2')) attr%string _)))
     id) : QSSchemaConstraints_scope.

Notation "'Query' 'Structure' 'Schema' relList 'enforcing' constraints" :=
  (let relNames := Vector.map relName relList%NamedSchema in
   let relSchemas := Vector.map relSchema relList%NamedSchema in
   @Build_QueryStructureSchema
     _ relSchemas
     (let relListHint := Build_namedSchemaHint relSchemas relNames in
          (constraints%QSSchemaConstraints)%list)
     relNames) : QSSchema_scope.

Arguments BuildForeignKeyConstraints _ _ [_ _] _ _ _ (*/*) .

Arguments eq_rect_r _ _ _ _ _ _ / .
(*Arguments ForeignKey_P _ _ _ _ _ / _ _ . *)

Notation "'Query' 'Structure' 'Schema' relList " :=
    (let relNames := Vector.map relName relList%NamedSchema in
   let relSchemas := Vector.map relSchema relList%NamedSchema in
   @Build_QueryStructureSchema _ relSchemas nil relNames) : QSSchema_scope.

Bind Scope QSSchema_scope with QueryStructureSchema.
Require Export Fiat.Common.DecideableEnsembles.

Instance Astring_eq : Query_eq string := {| A_eq_dec := string_dec |}.

Instance Anat_eq : Query_eq nat := {| A_eq_dec := eq_nat_dec |}.

Instance Query_eq_list {A : Type}
         {a_eq_dec : Query_eq A}
: Query_eq (list A) :=
  {| A_eq_dec := list_eq_dec (@A_eq_dec A a_eq_dec) |}.

Require Import Coq.NArith.NArith Coq.ZArith.ZArith.
Instance AN_eq : Query_eq N := {| A_eq_dec := N.eq_dec |}.
Instance AZ_eq : Query_eq Z := {| A_eq_dec := Z.eq_dec |}.

(*Notation GetAttributeKey Rel index :=
  ((fun x : Attributes (GetNRelSchemaHeading (qschemaSchemas _) Rel) => x)  {| bindex := index |}).

Notation GetRelationKey QSSchema index :=
  (@Build_BoundedIndex _ (map relName (qschemaSchemas QSSchema))
                      index _).

Notation RawTupleDef QSSchema index :=
  (@RawTuple (QSGetNRelSchemaHeading QSSchema {| bindex := index%string |})). *)


(* Chapter 3.1.1 folgende *)

Require Import EqNat Lists.List.
Import ListNotations.

Definition Ref := nat.

Inductive Ty : Type :=
  | Int    : Ty
  | Float  : Ty
  | Double : Ty
  | Bool   : Ty.

Inductive Val : Type :=
  | VInt    : nat  -> Val
  | VFloat  : nat  -> Val
  | VDouble : nat  -> Val
  | VBool   : bool -> Val
  | Undefined : Val.

Definition newVarVal (T : Ty) : Val :=
  match T with
  | Int    => VInt 0
  | Float  => VFloat 0
  | Double => VDouble 0
  | Bool   => VBool false
  end.

Definition Name := nat.

Inductive EnvEntry : Type :=
  | VarType   : Ref -> Ty  -> EnvEntry
  | ConstType : Ty  -> Val -> EnvEntry.

Definition Env := list (Name * EnvEntry).

Definition Memory := list (Ref * Val).

Fixpoint envLookup (E : Env) (n : Name) : option EnvEntry :=
  match E with
  | []           => None
  | (k, v) :: es => if (beq_nat n k) then Some v else envLookup es n
  end.

Definition envAdd (E : Env) (n : Name) (v : (EnvEntry)) : Env :=
  (n, v) :: E.

Fixpoint memLookup (M : Memory) (r : Ref) : Val :=
  match M with
  | [] => Undefined
  | (k, v) :: ms => if (beq_nat r k) then v else memLookup ms r
  end.

Fixpoint memUpdate (M : Memory) (e : (Ref * Val)) : Memory :=
  match M, e with
  | [],          _     => []
  | (s,u) :: ms, (r,v) => if beq_nat r s then (r,v) :: ms
                                         else (s,u) :: memUpdate ms e
  end.

Definition memAdd (M : Memory) (e : (Ref * Val)) : Memory :=
  match (find (beq_nat (fst e)) (map fst M)) with
  | None   => e :: M
  | Some _ => memUpdate M e
  end.

Fixpoint isFree (M : Memory) (r : Ref) : bool :=
  match M with
  | []          => true
  | (s,_) :: ms => if (beq_nat r s) then false else (isFree ms r)
  end.

Definition free (M : Memory) : Ref :=
  match M with
  | [] => 0
  | (r,_) :: _ => r + 1
  end.

Inductive Ops : Type :=
  | plus : Ops
  | mult : Ops
  | neq  : Ops.

Inductive Exp : Type :=
  | Num    : Val  -> Exp
  | Var    : Name -> Exp
  | Const  : Name -> Exp
  | Op     : Exp  -> Ops  -> Exp -> Exp.

Reserved Notation "EM '|-R' x ':::' v" (at level 40).
Inductive evalR : (Env * Memory) -> Exp -> Val -> Prop :=
  | EvVarR  : forall E M x l T v,
               envLookup E x = Some (VarType l T) ->
               memLookup M l = v ->
               (E,M) |-R (Var x) ::: v

  | EvNumR  : forall E M n, (E,M) |-R (Num n) ::: n

  | EvPlusR : forall E M e1 e2 v1 v2 v,
               (E,M) |-R e1 ::: (VInt v1) ->
               (E,M) |-R e2 ::: (VInt v2) ->
               v = VInt (v1 + v2) ->
               (E,M) |-R (Op e1 plus e2) ::: v

  | EvMultR : forall E M e1 e2 v1 v2 v,
               (E,M) |-R e1 ::: (VInt v1) ->
               (E,M) |-R e2 ::: (VInt v2) ->
               v = VInt (v1 * v2) ->
               (E,M) |-R (Op e1 mult e2) ::: v

  | EvNeqTR : forall E M e1 e2 v1 v2,
               (E,M) |-R e1 ::: (VInt v1) ->
               (E,M) |-R e2 ::: (VInt v2) ->
               v1 <> v2 ->
               (E,M) |-R (Op e1 neq e2) ::: (VBool true)

  | EvNeqFR : forall E M e1 e2 v1 v2,
               (E,M) |-R e1 ::: (VInt v1) ->
               (E,M) |-R e2 ::: (VInt v2) ->
               v1 = v2 ->
               (E,M) |-R (Op e1 neq e2) ::: (VBool false)

  | EvConstR: forall E M x T v,
                envLookup E x = Some (ConstType T v)  ->
                (E,M) |-R (Const x) ::: v

  where "EM '|-R' x ':::' v" := (evalR EM x v).

Reserved Notation "EM '|-L' x ':::' v" (at level 40).
Inductive evalL : (Env * Memory) -> Exp -> Ref -> Prop :=
  | EvVarL : forall E M x l T,
              envLookup E x = Some (VarType l T) ->
              (E,M) |-L (Var x) ::: l

  where "EM '|-L' x ':::' v" := (evalL EM x v).

(* Command *)

Inductive Cmnd : Type :=
  | Ass    : Exp  -> Exp  -> Cmnd
  | Decl   : Ty   -> Name -> Cmnd
  | DeclC  : Ty   -> Name -> Val  -> Cmnd
  | Seq    : Cmnd -> Cmnd -> Cmnd
  | If     : Exp  -> Cmnd -> Cmnd -> Cmnd
  | While  : Exp  -> Cmnd -> Cmnd.

Notation "T 'var'   N"       := (Decl T N) (at level 60).
Notation "T 'const' N :=: V" := (DeclC T N V) (at level 60).
Notation "E1 ::= E2"         := (Ass E1 E2) (at level 60).
Notation "C1 ;; C2"          := (Seq C1 C2) (at level 80, right associativity).
Notation "'If' ( B ) C1 'Else' C2" := (If B C1 C2) (at level 80, right associativity).
Notation "'While' ( B ) C1"  := (While B C1) (at level 80, right associativity).

Reserved Notation "EM '{{' a '}}' Em'" (at level  40).
Inductive eval : (Env * Memory) -> Cmnd -> (Env * Memory) -> Prop :=
  | EvDecl  : forall E M T x,
                let l  := free M in
                let E' := envAdd E x (VarType l T) in
                let M' := memAdd M (l, (newVarVal T))
                 in (E,M) {{Decl T x}} (E', M')
  | EvDeclC : forall E M T x n,
                let E' := envAdd E x (ConstType T n)
                 in (E,M) {{DeclC T x n}} (E', M)

  | EvAss   : forall E M e1 e2 l v,
                (E,M) |-L e1 ::: l ->
                (E,M) |-R e2 ::: v ->
                let M' := memAdd M (l, v)
                 in (E,M) {{Ass e1 e2}} (E, M')

  | EvSeq   : forall E M E' M' E'' M'' S1 S2,
                (E,M)   {{S1}} (E',M')   ->
                (E',M') {{S2}} (E'',M'') ->
                (E,M)   {{S1;;S2}} (E'',M'')

  | EvIfT   : forall E M E' M' B S1 S2,
                (E,M) |-R B ::: VBool true ->
                (E,M) {{S1}} (E',M') ->
                (E,M) {{If (B) S1 Else S2}} (E',M')

  | EvIfF   : forall E M E' M' B S1 S2,
                (E,M) |-R B ::: VBool false ->
                (E,M) {{S2}} (E',M') ->
                (E,M) {{If (B) S1 Else S2}} (E',M')

  | EvWhileF : forall E M B S,
                 (E,M) |-R B ::: VBool false ->
                 (E,M) {{While (B) S}} (E,M)

  | EvWhileT : forall E M E' M' B S,
                 (E,M) |-R B ::: VBool true ->
                 (E,M) {{S;; While (B) S}} (E',M') ->
                 (E,M) {{While (B) S}} (E,M')

  where "EM '{{' a '}}' EM'" := (eval EM a EM').


(*
Copyright © 2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)
Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import CoRN.model.totalorder.QposMinMax.
Require Export CoRN.metric2.Compact.
Require Export CoRN.metric2.LocatedSubset.
Require Export CoRN.reals.fast.CRArith.
Require Import CoRN.reals.fast.CRabs.
Require Export CoRN.model.metric2.Qmetric.
Require Import Coq.QArith.Qround.
Require Import Coq.QArith.Qabs.
Require Import CoRN.model.totalorder.QMinMax.
Require Import CoRN.logic.Classic.

Local Open Scope Q_scope.

Opaque Qabs.

Set Implicit Arguments.

Section Interval.
(**
* Intervals as a Compact Set.
We want to make an efficent implementation of intervals as compact sets.
We want to minimize the number of sample points in the approximations of

a compact interval.
*)
Variable (l r:Q).
Hypothesis Hlr : l <= r.

Let f (n:positive) (i:Z) := l + ((r-l)*(2*i+1#1))/(2*Zpos n#1).

Fixpoint iterateN_succ (z:Z) (n:positive) : list Z :=
  match n with
  | xI p => z :: app (iterateN_succ (Z.succ z) p)
                   (iterateN_succ (Z.succ z + Zpos p) p)
  | xO p => app (iterateN_succ z p) (iterateN_succ (z + Zpos p) p)
  | xH => z :: nil
  end.

Lemma iterateN_succ_example : iterateN_succ 4 3 = (4 :: 5 :: 6 :: nil)%Z.
Proof. reflexivity. Qed.

Lemma iterateN_succ_length
  : forall n z,
    length (iterateN_succ z n) = Pos.to_nat n.
Proof.
  induction n.
  - intro z. simpl.
    rewrite Pos2Nat.inj_xI. apply f_equal.
    rewrite app_length, IHn, IHn.
    simpl.
    rewrite Nat.add_0_r. reflexivity.
  - intro z. simpl.
    rewrite app_length, IHn, IHn.
    rewrite Pos2Nat.inj_xO. simpl.
    rewrite Nat.add_0_r. reflexivity.
  - reflexivity.
Qed.

Lemma iterateN_succ_nth
  : forall n (j:nat) s z,
    (j < Pos.to_nat n)%nat -> nth j (iterateN_succ s n) z = (s + Z.of_nat j)%Z.
Proof.
  induction n.
  - intros. simpl.
    destruct j. simpl. rewrite Z.add_0_r. reflexivity.
    destruct (le_lt_dec (Pos.to_nat n) j) as [l0|l0].
    + rewrite <- (iterateN_succ_length n (Z.succ s)) in l0.
      rewrite (app_nth2 _ _ z l0).
      pose proof (Nat.le_exists_sub _ _ l0) as [k [H0 _]].
      subst j.
      rewrite Nat.add_sub.
      rewrite IHn.
      rewrite iterateN_succ_length.
      rewrite Nat2Z.inj_succ, Nat2Z.inj_add, <- positive_nat_Z.
      ring.
      rewrite (iterateN_succ_length n (Z.succ s)), Pos2Nat.inj_xI in H.
      simpl in H. rewrite Nat.add_0_r in H.
      apply le_S_n in H.
      apply (Nat.add_le_mono_r _ _ (Pos.to_nat n)).
      exact H.
    + rewrite <- (iterateN_succ_length n (Z.succ s)) in l0.
      rewrite (app_nth1 _ _ z l0).
      rewrite IHn.
      rewrite Nat2Z.inj_succ. ring.
      rewrite <- (iterateN_succ_length n (Z.succ s)).
      exact l0.
  - intros. simpl.
    destruct (le_lt_dec (Pos.to_nat n) j) as [l0|l0].
    + rewrite <- (iterateN_succ_length n s) in l0.
      rewrite (app_nth2 (iterateN_succ s n)
                        (iterateN_succ (s + Z.pos n) n) z l0).
      pose proof (Nat.le_exists_sub _ _ l0) as [k [H0 _]].
      subst j.
      rewrite Nat.add_sub.
      rewrite IHn.
      rewrite (iterateN_succ_length n s).
      rewrite Nat2Z.inj_add, <- positive_nat_Z.
      ring.
      rewrite (iterateN_succ_length n s), Pos2Nat.inj_xO in H.
      simpl in H. rewrite Nat.add_0_r in H.
      apply (Nat.add_le_mono_r _ _ (Pos.to_nat n)).
      exact H.
    + rewrite <- (iterateN_succ_length n s) in l0.
      rewrite (app_nth1 (iterateN_succ s n)
                        (iterateN_succ (s + Z.pos n) n) z l0).
      apply IHn.
      rewrite <- (iterateN_succ_length n s).
      exact l0.
  - intros. simpl.
    destruct j. simpl. rewrite Z.add_0_r. reflexivity.
    exfalso. inversion H. inversion H1.
Qed.

(** [UniformPartition] produces a set of n points uniformly distributed
    inside the interval [[l, r]]. We use binary positive instead of
    unary nat for faster computations. *)
Definition UniformPartition (n:positive) : list Q :=
  map (f n) (iterateN_succ 0%Z n).

Lemma UniformPartitionZ : forall n a z,
    In z (iterateN_succ a n) <-> (a <= z < a + Zpos n)%Z.
Proof.
  split.
  - intro H. apply (In_nth _ _ 0%Z) in H.
    destruct H as [p [H H0]].
    subst z. rewrite iterateN_succ_length in H.
    rewrite iterateN_succ_nth.
    2: exact H. split.
    rewrite <- (Z.add_0_r a) at 1.
    apply Z.add_le_mono_l. apply Nat2Z.is_nonneg.
    apply Z.add_lt_mono_l.
    destruct p. reflexivity.
    rewrite <- (Nat2Pos.id (S p)) in H.
    2: discriminate.
    apply Pos2Nat.inj_lt in H.
    simpl.
    rewrite Pos.of_nat_succ. exact H.
  - revert n z a.
    induction n; intros.
    + simpl. destruct (Z.le_gt_cases z a).
      left. apply Z.le_antisymm. apply H. exact H0.
      right. destruct (Z.le_gt_cases (Z.succ a + Z.pos n) z).
      apply in_app_iff. right. apply IHn.
      split. apply H1.
      rewrite <- Z.add_assoc, Z.add_diag.
      apply (Z.lt_le_trans _ _ _ (proj2 H)).
      rewrite <- Z.add_1_l, (Z.add_comm 1).
      rewrite <- Z.add_assoc.
      apply Z.le_refl.
      apply in_app_iff. left. apply IHn.
      split. apply Zlt_le_succ, H0. exact H1.
    + simpl. destruct (Z.le_gt_cases (a + Z.pos n) z).
      apply in_app_iff. right. apply IHn.
      split. apply H0.
      rewrite <- Z.add_assoc, Z.add_diag. apply H.
      apply in_app_iff. left. apply IHn.
      split. apply H. exact H0.
    + left. destruct H. apply Z.le_antisymm. exact H.
      rewrite Z.add_comm, Z.add_1_l in H0.
      apply Zlt_succ_le, H0.
Qed.

Lemma UniformPartition_inside : forall n x, In x (UniformPartition n) -> l <= x <= r.
Proof.
 intros n x.
 unfold UniformPartition.
 assert (forall z, In z (iterateN_succ 0%Z n) -> (0 <= z < Zpos n)%Z) as H.
 { intros. apply UniformPartitionZ in H. exact H. }
 revert H.
  generalize (iterateN_succ 0%Z n).
  intros s Hs H.
  induction s.
   contradiction.
  destruct H as [H | H];auto with *.
  rewrite <- H.
  destruct (Hs a) as [Hz0 Hz1]; auto with *.
  clear - Hz0 Hz1 Hlr.
  split.
   unfold f, Qdiv.
   rewrite <- (Qplus_0_r l) at 1.
   apply Qplus_le_r.
   apply Qle_shift_div_l. reflexivity.
   rewrite Qmult_0_l.
   apply Qmult_le_0_compat.
  unfold Qminus. rewrite <- Qle_minus_iff. exact Hlr.
   unfold Qle, Qnum, Qden.
   rewrite Z.mul_1_r, Z.mul_1_r.
   apply (Z.le_trans _ (1*a+0)%Z).
   rewrite Z.add_0_r, Z.mul_1_l. exact Hz0.
   apply Z.add_le_mono. apply Z.mul_le_mono_nonneg_r.
   exact Hz0.
   discriminate. discriminate.
  unfold f.
  apply (Qplus_le_r _ _ (-l)).
  rewrite Qplus_assoc.
  rewrite (Qplus_comm (-l)), Qplus_opp_r, Qplus_0_l.
  apply Qle_shift_div_r. reflexivity.
  rewrite (Qplus_comm (-l)), Qmult_comm, (Qmult_comm (r+-l)).
  apply Qmult_le_compat_r.
  unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r.
  rewrite Z.add_comm, Z.add_1_l.
  apply Zlt_le_succ.
  apply Z.mul_lt_mono_pos_l.
  reflexivity. exact Hz1.
  rewrite <- Qle_minus_iff. exact Hlr.
Qed.

(** Given a point [x] in the interval [[l, r]], one can find a
nearby point in our [UniformPartition]. n is the number of points in
the partition, ie the step is (r-l)/n. This function computes the
maximum index k such that l+k(r-l)/n <= x. *)
Definition rasterize1 (n:positive) (x:Q) : Z
  := Qfloor (inject_Z (Zpos n)*(x-l)/(r-l)).

Lemma rasterize1_close : l < r -> forall (n:positive) (x:Q),
      Qabs (x - f n (rasterize1 n x))
      <= ((r-l)/((2#1) * inject_Z (Zpos n))).
Proof.
 clear Hlr.
 intros Hlr' n x.
 rewrite -> Qlt_minus_iff in Hlr'.
 assert (A:~ r - l == 0 /\ ~ inject_Z (Zpos n) == 0)
   by (split;auto with *;discriminate).
 setoid_replace ((r - l) / ((2#1) * inject_Z (Zpos n)))
   with ((1#2)/(inject_Z (Zpos n)/(r - l)))
   by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; auto).
 apply Qle_shift_div_l.
  apply Qlt_shift_div_l; auto with *.
 rewrite <- (Qabs_pos (inject_Z (Zpos n)/(r-l))); [|apply Qle_shift_div_l; auto with *].
 rewrite <- Qabs_Qmult.
 unfold f.
 change (2*Zpos n # 1) with ((2#1)*inject_Z (Zpos n)).
 setoid_replace ((x - (l + (r - l) * (2 * rasterize1 n x + 1 # 1) / ((2#1) * inject_Z (Zpos n)))) * (inject_Z (Zpos n) / (r - l)))
   with (inject_Z (Zpos n)*(x-l)/(r-l) - (2*rasterize1 n x + 1 # 1)/(2#1))
   by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; auto).
 rewrite -> Qmake_Qdiv.
 rewrite Q.Zplus_Qplus.
 unfold Qdiv.
 change (inject_Z 1) with 1%Q.
 rewrite Qmult_1_r.
 rewrite Q.Zmult_Qmult.
 change (inject_Z 2) with (2#1).
 setoid_replace (((2#1) * inject_Z (rasterize1 n x) + 1) / (2#1))
   with (inject_Z (rasterize1 n x) + (1#2))
   by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; auto).
 unfold rasterize1.
 unfold Qdiv.
 generalize (inject_Z (Zpos n) * (x - l) * / (r - l)).
 intros q.
 clear - q.
 apply Qabs_case; intros H; rewrite -> Qle_minus_iff.
 setoid_replace ((1 # 2) + - (q - (inject_Z (Qfloor q) + (1 # 2))))
   with (inject_Z (Qfloor q) + 1 + - q)
   by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
  rewrite <- Qle_minus_iff.
  apply Qlt_le_weak.
  change 1 with (inject_Z 1).
  rewrite <- (Q.Zplus_Qplus (Qfloor q) 1).
  apply Qlt_floor.
  setoid_replace ((1 # 2) + - - (q - (inject_Z (Qfloor q) + (1 # 2))))
    with (q + -inject_Z (Qfloor q))
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
 rewrite <- Qle_minus_iff.
 apply Qfloor_le.
Qed.

Definition rasterize1_boundL : forall n (x:Q), l <= x -> (0 <= rasterize1 n x)%Z.
Proof.
 intros n x Hx.
 change 0%Z with (Qfloor 0).
 apply Qfloor_resp_le.
 destruct (Qle_lt_or_eq _ _ Hlr) as [Hlr' | Hlr'].
  rewrite -> Qlt_minus_iff in Hlr'.
  rewrite -> Qle_minus_iff in Hx.
  apply Qle_shift_div_l; auto with *.
  rewrite Qmult_0_l.
  apply Qmult_le_0_compat; simpl; auto with *.
 rewrite -> Hlr'.
 unfold Qminus.
 rewrite Qplus_opp_r.
 unfold Qdiv.
 change (/0) with 0.
 ring_simplify.
 auto with *.
Qed.

Definition rasterize1_boundR : forall n (x:Q), x < r -> (rasterize1 n x < Zpos n)%Z.
Proof.
 intros n x Hx.
 rewrite Zlt_Qlt.
 unfold rasterize1.
 apply (Qle_lt_trans _ _ _ (Qfloor_le _)).
 destruct (Qle_lt_or_eq _ _ Hlr) as [Hlr' | Hlr'].
  rewrite -> Qlt_minus_iff in Hlr'.
  apply Qlt_shift_div_r.
   auto with *.
  apply Qmult_lt_l;simpl; auto with *.
  rewrite -> Qlt_minus_iff.
  setoid_replace (r - l + - (x - l))
    with (r + - x)
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
  rewrite <- Qlt_minus_iff; auto.
 rewrite -> Hlr'.
 unfold Qminus.
 rewrite Qplus_opp_r.
 unfold Qdiv.
 change (/0) with 0.
 rewrite Qmult_0_r.
 auto with *.
Qed.

(* Index of x = r in the partition. *)
Lemma UniformPartition_fine_aux
  : forall (n : positive) (x : Q) (Hx : l <= x <= r) (q : r <= x),
  In (f n (Zpos n - 1)) (UniformPartition n) /\
  Qabs (x - f n (Zpos n - 1)) <= (r - l) / ((2#1) * inject_Z (Zpos n)).
Proof.
  intros.
  split.
  - apply in_map; rewrite -> UniformPartitionZ.
    split. apply Z.le_0_sub, Pos.le_1_l.
    rewrite Z.add_comm.
   apply Z.add_lt_mono_l. reflexivity.
  - destruct Hx as [_ Hx].
    setoid_replace x with r by (apply Qle_antisym; assumption).
    unfold f.
    replace (2 * (Z.pos n - 1) + 1)%Z with (2 * Z.pos n - 1)%Z by ring.
    change (2*Zpos n #1) with ((2#1)*inject_Z (Zpos n)).
    change (2*Zpos n - 1#1) with (inject_Z (2*Zpos n + - 1)).
    rewrite Q.Zplus_Qplus.
    rewrite Q.Zmult_Qmult.
    change (inject_Z 2) with (2#1).
    change (inject_Z (-1)) with (-1#1).
    setoid_replace (r - (l + (r - l) * ((2#1) * inject_Z (Zpos n) + (-1#1))
                                         / ((2#1) * (inject_Z (Zpos n)))))
      with (((r-l) / ((2#1) * (inject_Z (Zpos n)))))
      by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; auto).
    rewrite -> Qabs_pos.
    apply Qle_refl.
    apply Qle_shift_div_l. reflexivity.
    rewrite Qmult_0_l; rewrite -> Qle_minus_iff in Hlr; auto.
Qed.

(* For any point x in [[l,r]], there is a point y in the uniform partition
   that is close to x within half the partition's step. *)
Lemma UniformPartition_fine : forall (n:positive) (x:Q),
    l <= x <= r
    -> {y | In y (UniformPartition n)
           /\ Qabs (x - y) <= ((r-l)/((2#1)*inject_Z (Zpos n)))}.
Proof.
 intros n x Hx.
 destruct (Qlt_le_dec_fast x r).
 - (* x < r *)
   exists (f n (rasterize1 n x)).
 abstract ( destruct Hx as [Hlx Hxr]; split;
            [apply in_map; rewrite -> UniformPartitionZ; split;
             [apply rasterize1_boundL; auto |apply rasterize1_boundR; auto]
            |apply rasterize1_close; apply Qle_lt_trans with x; auto]).
 - (* x = r *)
   exists (f n (Zpos n - 1)).
   apply UniformPartition_fine_aux; assumption.
Defined.

(** Construct the compact set. *)
Lemma CompactIntervalQ_nat : forall (e:Qpos),
    (0 <= Qceiling ((r-l)/(inject_Z 2*proj1_sig e)))%Z.
Proof.
 intros e.
 change (0%Z) with (Qceiling 0).
 apply Qceiling_resp_le.
 apply Qle_shift_div_l.
  auto with *.
  rewrite Qmult_0_l.
  unfold Qminus.
  rewrite <- Qle_minus_iff.
  exact Hlr.
Qed.

(* The finite approximation of real interval [l,r] by rational numbers,
   at precision e. *)
Definition CompactIntervalQ_raw (e:QposInf) : list Q :=
match e with
| QposInfinity => nil
| Qpos2QposInf e' =>
  UniformPartition (Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e'))))
end.

Lemma CompactIntervalQ_prf
  : is_RegularFunction (@ball (FinEnum Q_as_MetricSpace)) CompactIntervalQ_raw.
Proof.
 cut (forall (e1 e2:Qpos), hemiMetric Q_as_MetricSpace (proj1_sig e1 + proj1_sig e2) (fun a : Q_as_MetricSpace =>
   InFinEnumC a (CompactIntervalQ_raw e1)) (fun a : Q_as_MetricSpace =>
     InFinEnumC a (CompactIntervalQ_raw e2))).
  { intros Z e1 e2.
  split. apply (Qpos_nonneg (e1+e2)). split.
   apply Z.
  eapply hemiMetric_wd1;[|apply Z].
  unfold QposEq; simpl; ring. }
 intros e1 e2 a Ha.
 assert (l <= a <= r).
 { unfold CompactIntervalQ_raw in Ha.
  set (e1':=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e1)))) in *.
  assert (L:=UniformPartition_inside e1').
  induction (UniformPartition e1').
  exfalso; exact (FinSubset_ball_nil Ha).
  destruct (Qeq_dec a a0) as [A|A].
   rewrite -> A.
   auto with *.
  apply IHl0; auto with *.
  apply FinSubset_ball_orC in Ha.
  destruct Ha as [G | Ha | Ha] using orC_ind.
  intro abs. contradict G; intro G. contradiction.
   elim A.
   apply Qball_0 in Ha. exact Ha.
  assumption. }
 unfold CompactIntervalQ_raw.
 set (e2':=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e2)))).
 pose proof (UniformPartition_fine e2' H) as [y [Hy0 Hy1]].
 apply existsWeaken.
 exists y.
 split.
 - apply InFinEnumC_weaken, Hy0.
 - simpl.
   rewrite -> Qball_Qabs.
   eapply Qle_trans;[apply Hy1|].
   apply Qle_trans with (proj1_sig e2).
   apply Qle_shift_div_r.
   destruct e2'; auto with *.
   rewrite Qmult_comm, (Qmult_comm (2#1)), <- Qmult_assoc.
   rewrite <- (Qinv_involutive (inject_Z 2*proj1_sig e2)).
   apply Qle_shift_div_l.
   + apply Qinv_lt_0_compat.
     exact (Qpos_ispos ((2#1)*e2)).
   + unfold e2'.
     generalize (CompactIntervalQ_nat e2).
     unfold Qdiv.
     generalize ((r - l) * / (inject_Z 2 * proj1_sig e2)).
     intros q He.
     apply Qle_trans with (inject_Z (Qceiling q)).
     apply Qle_ceiling.
     destruct (Qceiling q). discriminate.
     rewrite Z2Pos.id.
     apply Z.le_refl.
     reflexivity. discriminate.
   + rewrite <- Qplus_0_l at 1.
     apply Qplus_le_l.
     apply Qpos_nonneg.
Qed.

Definition CompactIntervalQ : Compact Q_as_MetricSpace :=
Build_RegularFunction CompactIntervalQ_prf.

Local Open Scope CR_scope.

Opaque max.

(** The compact set indeed represents the interval [[l, r]]. *)
Lemma CompactIntervalQ_correct1 : forall (x:CR),
 inCompact x CompactIntervalQ -> ('l <= x /\ x <= 'r).
Proof.
 intros x Hx.
 split.
  unfold CRle.
  assert (x - 'l == '(-l)%Q + x)%CR. ring. rewrite -> H. clear H.
  rewrite -> CRplus_translate.
  intros e.
  simpl.
  rewrite -> Qle_minus_iff.
  setoid_replace (- l + approximate x e + - - proj1_sig e)%Q
    with (proj1_sig e + - (l - approximate x e))%Q
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
  rewrite <- Qle_minus_iff.
  apply Qle_closed.
  intros e2.
  assert (L:=Hx e e2).
  simpl in L.
  set (a:=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e2)))) in *.
  assert (L0:=UniformPartition_inside a).
  induction (UniformPartition a).
  exfalso; exact (FinSubset_ball_nil L).
  apply FinSubset_ball_orC in L.
  destruct L as [ G | L | L] using orC_ind.
    auto with *.
   rewrite -> Qball_Qabs in L.
   eapply Qle_trans;[|apply L].
   rewrite <- Qabs_opp.
   eapply Qle_trans;[|apply Qle_Qabs].
   rewrite -> Qle_minus_iff.
   setoid_replace (- (approximate x e - a0) + - (l - approximate x e))%Q
     with (a0 + - l)%Q
     by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
   rewrite <- Qle_minus_iff.
   destruct (L0 a0); auto with *.
  apply IHl0; auto with *.
 unfold CRle.
 rewrite -> CRplus_translate.
 intros e.
 simpl.
 rewrite -> Qle_minus_iff.
 setoid_replace (r + - approximate x e + - - proj1_sig e)%Q
   with (proj1_sig e + - (approximate x e - r))%Q
   by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
 rewrite <- Qle_minus_iff.
 apply Qle_closed.
 intros e2.
 assert (L:=Hx e e2).
 simpl in L.
 set (a:=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e2)))) in *.
 assert (L0:=UniformPartition_inside a).
 induction (UniformPartition a).
  exfalso; exact (FinSubset_ball_nil L).
  apply FinSubset_ball_orC in L.
 destruct L as [ G | L | L] using orC_ind.
   auto with *.
  rewrite -> Qball_Qabs in L.
  eapply Qle_trans;[|apply L].
  eapply Qle_trans;[|apply Qle_Qabs].
  rewrite -> Qle_minus_iff.
  setoid_replace (approximate x e - a0 + - (approximate x e - r))%Q
    with (r + - a0)%Q
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
  rewrite <- Qle_minus_iff.
  destruct (L0 a0); auto with *.
 apply IHl0; auto with *.
Qed.

Lemma CompactIntervalQ_correct2 : forall (x:CR),
 ('l <= x /\ x <= 'r) -> inCompact x CompactIntervalQ.
Proof.
 intros x [Hlx Hxr] e1 e2.
 simpl.
 set (y:= (Qmax (Qmin (approximate x e1) r) l)).
 apply (@FinSubset_ball_triangle_l _ (proj1_sig e1) (proj1_sig e2) (approximate x e1) y).
 - unfold y.
  apply Qmin_case.
   apply Qmax_case.
    auto with *.
   intros H _.
   split; simpl.
    unfold CRle in Hlx.
    assert (x - 'l == '(-l)%Q + x). ring. rewrite -> H0 in Hlx. clear H0.
    rewrite -> CRplus_translate in Hlx.
    assert (H0:=Hlx e1).
    simpl in H0.
    clear - H0.
    unfold Qminus. rewrite Qplus_comm.
    exact H0.
   apply Qle_trans with 0%Q; auto with *.
   clear - H.
   rewrite Qle_minus_iff in *.
   setoid_replace (0 + - (approximate x e1 - l))%Q
     with (l + - approximate x e1)%Q
     by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
   exact H.
  intros H.
  rewrite -> Qle_max_l in Hlr.
  simpl.
  rewrite -> Hlr.
  split; simpl.
   clear - H.
   apply Qle_trans with 0%Q.
   apply (Qopp_le_compat 0), Qpos_nonneg.
   rewrite -> Qle_minus_iff in *.
   rewrite Qplus_0_r.
   auto.
  unfold CRle in Hxr.
  rewrite -> CRplus_translate in Hxr.
  assert (H0:=Hxr e1).
  simpl in H0.
  clear - H0.
  rewrite -> Qle_minus_iff in *.
  setoid_replace (proj1_sig e1 + - (approximate x e1 - r))%Q
    with ( r + - approximate x e1 + - - proj1_sig e1)%Q
    by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring).
  exact H0.
 - assert (L: l <= y <= r).
   { unfold y. auto with *. }
 set (n:=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e2)))).
 destruct (UniformPartition_fine n L) as [z Hz].
  clear - Hz.
  destruct Hz as [Hz0 Hz1].
  induction (UniformPartition n).
   contradiction.
  destruct Hz0 as [Hz0 | Hz0].
   + intro abs; contradict abs. exists a.
     split. left. reflexivity.
   rewrite Hz0.
   simpl.
   rewrite -> Qball_Qabs.
   eapply Qle_trans;[apply Hz1|].
   clear Hz1.
   apply Qle_shift_div_r.
   reflexivity.
   unfold Qdiv in n.
   unfold n. clear n.
   rewrite (Qmult_comm (r-l)).
   apply (Qmult_le_l _ _ (/(inject_Z 2 * proj1_sig e2))).
   apply Qinv_lt_0_compat. apply (Qpos_ispos ((2#1)*e2)).
   generalize (/ (inject_Z 2 * proj1_sig e2) * (r-l))%Q.
   intro q.
   rewrite Qmult_assoc, Qmult_assoc.
   setoid_replace (/ (inject_Z 2 * proj1_sig e2) * proj1_sig e2 * (2#1))%Q with 1%Q
     by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field).
   rewrite Qmult_1_l.
   apply (Qle_trans _ (inject_Z (Qceiling q)) _ (Qle_ceiling _)).
   rewrite <- Zle_Qle.
   destruct (Qceiling q).
   discriminate.
   apply Z.le_refl.
   discriminate. apply Qpos_nonzero.
   + apply FinSubset_ball_cons.
     apply IHl0, Hz0.
Qed.

Lemma CompactIntervalQ_bonus_correct : forall e x,
 In x (approximate CompactIntervalQ e) -> (l <= x <= r).
Proof.
 intros [e|] x H.
  simpl in H.
  eapply UniformPartition_inside.
  apply H.
 elim H.
Qed.

End Interval.

(* Located subsets are more general than compact subsets. *)
Lemma InfiniteIntervalLocated
  : forall a : CR, LocatedSubset CR (fun x => a <= x)%CR.
Proof.
  intros a d e x ltde.
  (* The distance between x and [a,+\infty[ is CRmax 0 (a-x). *)
  destruct (CRlt_linear _ (CRmax 0%CR (a-x)%CR) _ (CRlt_Qlt d e ltde))
    as [far|close].
  - left. intros y H abs.
    clear ltde e.
    destruct (Qlt_le_dec d 0).
    apply (msp_nonneg (msp CR)) in abs.
    exact (Qlt_not_le _ _ q abs).
    assert (~(('d < a - x)%CR -> False)).
    { intros H0. apply CRle_not_lt in H0.
      revert far. apply CRle_not_lt, CRmax_lub.
      apply CRle_Qle, q. exact H0. }
    clear far.
    contradict H0. apply CRle_not_lt.
    apply CRabs_ball, CRabs_AbsSmall in abs.
    destruct abs as [abs _].
    rewrite (CRplus_le_r _ _ (y+('d)))%CR in abs.
    ring_simplify in abs.
    apply (CRle_trans H) in abs.
    clear H y.
    rewrite (CRplus_le_r _ _ x).
    ring_simplify.
    rewrite CRplus_comm. exact abs.
  - destruct (Qlt_le_dec d 0).
    left. intros y H abs.
    apply (msp_nonneg (msp CR)) in abs.
    exact (Qlt_not_le _ _ q abs).
    right. exists (CRmax a x).
    split. apply CRmax_ub_l.
    apply CRabs_ball, CRabs_AbsSmall.
    split.
    + rewrite (CRplus_le_r _ _ (CRmax a x + 'e))%CR.
      ring_simplify.
      apply CRmax_lub.
      rewrite (CRplus_le_r _ _ (-x))%CR.
      rewrite <- CRplus_assoc.
      rewrite CRplus_opp, CRplus_0_r.
      apply CRle_not_lt. intro abs.
      apply (CRlt_trans _ _ _ close) in abs.
      clear close. revert abs.
      apply CRle_not_lt.
      apply CRmax_ub_r.
      apply (@CRle_trans _ (0+x)%CR).
      rewrite CRplus_0_l. apply CRle_refl.
      apply CRplus_le_r.
      apply CRle_Qle, (Qle_trans _ _ _ q).
      apply Qlt_le_weak, ltde.
    + rewrite (CRplus_le_r _ _ (CRmax a x)).
      ring_simplify.
      apply (@CRle_trans _ (CRmax a x + 0)%CR).
      rewrite CRplus_0_r. apply CRmax_ub_r.
      apply CRplus_le_l, CRle_Qle.
      apply (Qle_trans _ _ _ q).
      apply Qlt_le_weak, ltde.
Qed.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                           General.v                                *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega ArithRing.

(* some general-purpose tactics *)

Ltac eapply2 H := eapply H; eauto.

Ltac split_all := simpl; intros; auto.

Ltac noway := intros; assert False by omega; contradiction.

Ltac exist x := exists x; split_all.

Ltac gen_case H W :=
  generalize H; clear H; case W; split_all.

Ltac gen2_case H0 H1 W :=
  generalize H0 H1; clear H0 H1; case W; split_all.

Ltac gen3_case H0 H1 H2 W :=
  generalize H0 H1 H2; clear H0 H1 H2; case W; split_all.

Ltac gen4_case H0 H1 H2 H3 W :=
  generalize H0 H1 H2 H3; clear H0 H1 H2 H3; case W; split_all.

Ltac gen_inv H W :=
  generalize H; clear H; inversion W; split_all.

Ltac gen2_inv H0 H1 W :=
  generalize H0 H1; clear H0 H1; inversion W; split_all.

Ltac gen3_inv H0 H1 H2 W :=
  generalize H0 H1 H2; clear H0 H1 H2; inversion W; split_all.

Ltac gen4_inv H0 H1 H2 H3 W :=
  generalize H0 H1 H2 H3; clear H0 H1 H2 H3; inversion W; split_all.

Ltac gen_case_inv H M := gen_case H M; inversion H; auto.

Ltac invsub := match goal with | H : _ = _ |- _ => inversion H; subst; clear H; invsub | _ => split_all end.

(* some arithmetic *)

Lemma max_is_max : forall m n, max m n >= m /\ max m n >= n.
Proof.
double induction m n; split; auto; try omega.
elim (H0 n); intros; auto; simpl; omega.
elim (H0 n); intros; auto; simpl; omega.
Qed.

Lemma max_succ: forall m n, S (max m n) = max (S m) (S n).
Proof. double induction m n; split_all.  Qed.

Lemma max_pred: forall m n, pred (max m n) = max (pred m) (pred n).
Proof. double induction m n; intros; auto. case n; intros; auto. Qed.

Lemma max_max : forall m n p, m >= max n p -> m>= n /\ m>= p.
Proof.
induction m; intros n p.
case n; case p; simpl; intros; split; auto; subst; try noway; try omega.
intros.
assert(m >= pred (max n p)) by omega.
rewrite max_pred in H0.
elim (IHm (pred n) (pred p)); split_all; omega.
Qed.

Lemma max_max2 : forall m n k, k>= m -> k>= n -> k>= max m n.
Proof.
double induction m n; simpl; intros; auto.
assert(pred k >= max n1 n) .  eapply2 H0; omega.  omega.
Qed.

Lemma max_zero : forall m, max m 0 = m.
Proof. induction m; split_all. Qed.

Lemma max_plus: forall m n k, max m n +k = max (m+k) (n+k).
Proof.
double induction m n; simpl; intros; auto.
induction k; simpl; auto.
assert(max k (S (n0+k)) >= S(n0+k)) by eapply2 max_is_max.
assert(S(n0+k) >= max k (S(n0+k))) . eapply2 max_max2.
omega.
omega.
case k; simpl; intros; auto.
assert(max (n+S n1) n1 >= n+ S n1) by  eapply2 max_is_max.
assert(n+ S n1 >= max (n+S n1) n1) . eapply2 max_max2.
omega.
omega.
Qed.

Lemma max_minus: forall m n k, max m n -k = max (m-k) (n-k).
Proof.
double induction m n; split_all.
case k; split_all.
rewrite max_zero. omega.
case k; split_all.
Qed.

Lemma max_monotonic : forall m1 m2 n1 n2, m1 >= n1 -> m2 >= n2 -> max m1 m2 >= max n1 n2.
Proof.
double induction m1 m2; split_all.
assert (n1 = 0) by omega; subst.
assert (n2 = 0) by omega; subst.
split_all.
assert (n1 = 0) by omega; subst. split_all.
assert (n2 = 0) by omega; subst.
assert(max n1 0 = n1) . case n1; split_all.
rewrite H2; auto.
assert(n0 >= pred n1) by omega.
cut(max n0 n >= pred (max n1 n2)).
intro.
omega.
rewrite max_pred.
eapply2 H0.
omega.
Qed.

Lemma max_succ_zero : forall k n, max k (S n) = 0 -> False .
Proof. split_all. assert(max k (S n) >= S n) by eapply2 max_is_max. noway. Qed.
Ltac max_out :=
match goal with
| H : max _ (S _) = 0  |- _ => assert False by (eapply2 max_succ_zero); noway
| H : max ?m ?n = 0 |- _ =>
assert (m = 0) by (assert (max m n >= m) by eapply2 max_is_max; omega);
assert (n = 0) by (assert (max m n >= n) by eapply2 max_is_max; omega);
clear H; try omega; try noway
| H : max ?m ?n <= 0 |- _ =>
assert (m = 0) by (assert (max m n >= m) by eapply2 max_is_max; omega);
assert (n = 0) by (assert (max m n >= n) by eapply2 max_is_max; omega);
clear H; try omega; try noway
end.

Lemma max_choice: forall m n, max m n = m \/ max m n = n.
Proof.
induction m; split_all.   case n; split_all.
assert(max m n0 = m \/ max m n0 = n0) by eapply2 IHm.
inversion H; rewrite H0; auto.
Qed.


From mathcomp Require Import all_ssreflect all_algebra all_field all_fingroup.
From codegen Require Import codegen.
Require Import mt cycle BinNat BinPos.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Lemma break_if (T : 'F_2) :
  (if T == 1%R then 1%R else 0%R) = T.
Proof.
  case: ifP => [/eqP/esym //|].
  case: T => [][|[]]// *.
  by apply/val_inj.
Qed.

Lemma if_xorb (T1 T2 : bool)  :
  (if xorb T1 T2 then 1%R else 0%R : 'F_2) =
  ((if T1 then 1%R : 'F_2 else 0%R) + (if T2 then 1%R else 0%R))%R.
Proof.
  case: T1 T2 => [][]//=.
   by rewrite GRing.addrr_char2.
  by rewrite GRing.addr0.
Qed.

Local Open Scope N_scope.

Definition w := 32.
Definition r := mt.r.
Definition n := mt.len.
Definition m := mt.m.

Definition N_of_word (t : w.-tuple 'F_2) :=
  foldr (fun x y => 2*y + x) 0
        (map_tuple (fun x => if (x == 1 :> 'F_2)%R then 1%N else 0) t).

Fixpoint word_of_N_iter (fuel : nat) (p : positive) : seq 'F_2 :=
  match fuel, p with
  | f.+1, xI p0 => 1%R :: word_of_N_iter f p0
  | f.+1, xO p0 => 0%R :: word_of_N_iter f p0
  | f.+1, xH => 1%R :: map (fun _ => 0%R) (iota 0 f)
  | 0%nat, _ => [::]
  end.

Definition zero_size : size (map (fun _ => (0%R : 'F_2)) (iota 0 w)) == w.
Proof. by rewrite size_map size_iota. Qed.
Definition zero := Tuple zero_size.

Lemma word_of_N_iter0 p : size (word_of_N_iter 0 p) == 0.
Proof. by []. Qed.

Lemma size_word_of_N_iter p : size (word_of_N_iter w p) == w.
Proof.
  elim: (nat_of_bin w) p => // w IH p.
  case: p => [p|p|].
    by rewrite /= (eqP (IH _)).
   by rewrite /= (eqP (IH _)).
  by rewrite /= size_map size_iota.
Defined.

Definition word_of_N (n' : N) :=
  match n' with
  | N0 => zero
  | N.pos p => Tuple (size_word_of_N_iter p)
  end.

Lemma word_of_N0 d (i : 'I_w) : nth d (word_of_N 0) i = 0%R.
Proof.
  case: i => //= i.
  do 32!(case: i => // i).
Qed.

Lemma bin_of_add_nat n1 n2 :
  bin_of_nat n1 + bin_of_nat n2 = bin_of_nat (n1 + n2)%nat.
Proof.
  apply: (can_inj nat_of_binK).
  by rewrite bin_of_natK nat_of_add_bin !bin_of_natK.
Qed.

Lemma succ_nat i : bin_of_nat i.+1 = N.succ (bin_of_nat i).
Proof.
  elim: i => // i IH.
  by rewrite -addn1 -bin_of_add_nat IH N.add_1_r.
Qed.

Lemma Num_succ i : [Num of i] + 1 = [Num of i.+1].
Proof. by rewrite N.add_1_r succ_nat. Qed.

Lemma pos_Num i : 0 <= [Num of i].
Proof. by case: i. Qed.

Lemma nat_of_pos_pred i : (nat_of_pos i).-1 = nat_of_bin (Pos.pred_N i).
Proof.
  elim: i => // i IH; rewrite /= natTrecE.
  case: i IH => //= p; rewrite /= ?natTrecE // => <-.
  rewrite -!subn1 doubleB subn2 subn1 prednK //.
  have: (nat_of_pos p > 0)%nat.
   elim: p => //= p IH.
   rewrite natTrecE.
   by case: (nat_of_pos p) IH.
  by case: (nat_of_pos p).
Qed.

Lemma pos_of_nat_pred_succ i : Pos.pred_N (pos_of_nat i i) = bin_of_nat i.
Proof.
  apply: (can_inj nat_of_binK).
  rewrite bin_of_natK -nat_of_pos_pred.
  have->: nat_of_pos (pos_of_nat i i) = nat_of_bin (bin_of_nat i.+1) by [].
  by rewrite bin_of_natK.
Qed.

Lemma nth_word_of_N x d (i : 'I_w) :
  nth d (word_of_N x) i =
  if N.testbit x [Num of (val i)]
  then 1%R : 'F_2 else 0%R.
Proof.
case: x; first by rewrite word_of_N0.
rewrite /word_of_N => p.
rewrite -tnth_nth (tnth_nth 0%R).
have->: tval (Tuple (size_word_of_N_iter p)) = word_of_N_iter w p by [].
elim: (nat_of_bin w) i p => [[][]//|] w IH i p.
case: p => [p|p|].
+ case: i => [][]//= i; rewrite ltnS => i0.
  by move: (IH (Ordinal i0) p) ->; rewrite pos_of_nat_pred_succ.
+ case: i => [][]//= i; rewrite ltnS => i0.
  by move: (IH (Ordinal i0) p) ->; rewrite pos_of_nat_pred_succ.
+ case: i => [][]//= i _.
  elim: (iota 0 w) i => [*|? l IHl []//]; by rewrite nth_default.
Qed.

Hint Resolve pos_Num : core.

Lemma N_of_wordK : cancel N_of_word word_of_N.
Proof.
  move=> x; apply/eq_from_tnth => j.
  rewrite (tnth_nth 0%R) nth_word_of_N /N_of_word.
  set T := (fun x0 y : N => 2 * y + x0).
  case: x j => x xH [] i iH.
  rewrite (tnth_nth 0%R) /= => {xH iH}.
  elim: x i => [?|x0 x IH i].
   by rewrite nth_default.
  case: i => [|i].
   case: x0 => [][|[]]//= i.
    rewrite /T /= N.add_0_r N.testbit_even_0.
    by apply/val_inj.
   rewrite /T /= N.testbit_odd_0.
   by apply/val_inj.
  rewrite succ_nat /= N.testbit_succ_r_div2.
  have->: (N.div2 (T (if x0 == 1%R then 1 else 0)
                  (foldr T 0 [seq (if x1 == 1%R then 1 else 0) | x1 <- x])))
        = (foldr T 0 [seq (if x1 == 1%R then 1 else 0) | x1 <- x]).
   rewrite /T.
   case: (x0 == 1%R).
    by rewrite -N.succ_double_spec N.div2_succ_double.
   by rewrite N.add_0_r -N.double_spec N.div2_double.
  rewrite IH //.
  by elim: i.
Qed.

Lemma N_of_word_last v : N.testbit (N_of_word v) [Num of w] = false.
Proof.
  case: v => v i; rewrite /N_of_word; set T := [Num of w].
  have-> /=: T = [Num of (size v)] by rewrite (eqP i).
  have: (size v > 0)%nat by rewrite (eqP i).
  elim: v {i T} => // ? l IHl _.
  case l0: (size l).
   rewrite /= l0.
   move/size0nil:l0 => -> /=.
   by case: ifP.
  rewrite succ_nat /=.
  case: ifP.
   rewrite N.testbit_odd_succ ?IHl -/size ?l0 //.
  by rewrite N.add_0_r N.testbit_even_succ ?IHl -/size ?l0 //.
Qed.

Definition N_of_vector (x : 'rV['F_2]_w) := N_of_word (mktuple (x ord0)).
Definition vector_of_N n := (\row_i (tnth (word_of_N n) i))%R.

Lemma N_of_vectorK : cancel N_of_vector vector_of_N.
Proof.
  move=> x.
  rewrite /N_of_vector /vector_of_N N_of_wordK.
  apply/rowP => i.
  by rewrite mxE tnth_mktuple.
Qed.

Local Notation ai := (@array_incomplete w n (n - m) r erefl erefl erefl erefl erefl).
Local Notation ia := (@incomplete_array w n (n - m) r erefl erefl erefl erefl).

Definition array_of_state (y : random_state) :=
  ia (\matrix_(i, j) nth 0%R (nth (word_of_N 0)
      [seq (@rev_tuple _ _ \o word_of_N) i | i <- rev (rot (index y) (state_vector y))] i) j)%R.

Definition state_of_array (y : 'rV['F_2]_(n * w - r)) :=
  {| index:=0;
     state_vector:=rev (map (N_of_word \o (@rev_tuple _ _))
      (mktuple (fun j => mktuple (fun x => ai y j x))));|}.

Lemma state_of_arrayK : cancel state_of_array array_of_state.
Proof.
  move=> x.
  rewrite /array_of_state /state_of_array rot0.
  set T := (\matrix_(_, _) _)%R; have->: T = (ai x)%R.
   apply/matrixP => i j; subst T.
   rewrite !mxE !revK (nth_map 0) /=; last by rewrite 2!size_map size_enum_ord.
   rewrite (nth_map (word_of_N 0)) /=; last by rewrite size_tuple card_ord.
   by rewrite N_of_wordK ?revK ?nth_mktuple ?(castmxE, mxE).
  by rewrite array_incompleteK.
Qed.

Lemma pm : prime (2 ^ (n * w - r) - 1).
Admitted.

Local Notation B := (@B w n (n - m) r (rev_tuple (word_of_N a)) erefl erefl erefl erefl).

(* Local Notation B := (@B w n (n - m) r (Tuple a32) erefl erefl erefl erefl). *)

Definition computeB :=
  array_of_state \o snd \o next_random_state \o state_of_array.

Lemma size_next_random_state v :
size (state_vector (next_random_state (state_of_array v)).2) = n.
Proof.
by rewrite /next_random_state size_set_nth size_tuple.
Qed.

Lemma index_next_random_state v :
index (next_random_state (state_of_array v)).2 = 1.
Proof. by []. Qed.

Lemma nth_next_random_state v i :
  nth 0 (state_vector (next_random_state (state_of_array v)).2) i.+1%N
= nth 0 (state_vector (state_of_array v)) i.+1.
Proof. by rewrite nth_set_nth. Qed.

Lemma nth_state_vector v (i : 'I_n) :
  nth 0 (state_vector (state_of_array v)) i =
  N_of_word (rev_tuple (mktuple (ai v (rev_ord i)))).
Proof.
rewrite nth_rev; last by rewrite 2!size_map size_enum_ord.
rewrite (nth_map (word_of_N 0)) size_map size_tuple ; last by rewrite rev_ord_proof.
rewrite (nth_map ord0) ?size_tuple ?rev_ord_proof //.
congr N_of_word.
apply/eq_from_tnth => j.
rewrite !(tnth_nth ord0) !nth_rev ?size_tuple //
        !(nth_map ord0) ?size_tuple ?rev_ord_proof
        ?(esym (enumT _), size_enum_ord, rev_ord_proof) //.
by congr (ai _ _); apply/ord_inj; rewrite /= nth_enum_ord ?rev_ord_proof.
Qed.

Lemma testbit_N_of_word v a :
  N.testbit (N_of_word v) [Num of val a] = (tnth v a == 1%R).
Proof.
rewrite (tnth_nth 0%R) -[in RHS](N_of_wordK v) nth_word_of_N.
by case: ifP.
Qed.

Local Lemma tns v b a (Ha : (a < w)%nat) (Hb : (b < n)%nat) :
  N.testbit (nth 0 (state_vector (state_of_array v)) b) [Num of a]
= (ai v (rev_ord (Ordinal Hb)) (rev_ord (Ordinal Ha)) == 1%R).
Proof.
  have H: b = val (Ordinal Hb) by [].
  rewrite [in LHS]H nth_state_vector.
  have {H} H : a = val (Ordinal Ha) by [].
  rewrite [in LHS]H testbit_N_of_word (tnth_nth ord0) nth_rev ?size_tuple //
          (nth_map ord0) ?size_tuple ?rev_ord_proof //.
  congr (_ == _); congr (ai _ _); apply/ord_inj.
  by rewrite nth_enum_ord ?rev_ord_proof.
Qed.

Local Lemma tnsw v b (Hb : (b < n)%nat) :
  N.testbit (nth 0 (state_vector (state_of_array v)) b) [Num of w] = false.
Proof.
  by rewrite /state_of_array /= nth_rev ?(size_enum_ord, size_map) //
          (nth_map (word_of_N 0%N)) ?(size_enum_ord, size_map)
          ?(rev_ord_proof (Ordinal Hb)) // N_of_word_last.
Qed.

Lemma lower_maskT i : (i < r)%nat -> N.testbit lower_mask [Num of i] = true.
Proof. by do 31!(case: i => // i). Qed.
Lemma upper_maskF i : (i < r)%nat -> N.testbit upper_mask [Num of i] = false.
Proof. by do 31!(case: i => // i). Qed.

Lemma testbita i :
  (i < r)%nat ->
  (if N.testbit a [Num of i] then 1%R else 0%R) = nth 0%R (word_of_N a) i.
Proof. by do 32!(case: i => // i). Qed.

Lemma computeBE v : computeB v = (v *m B)%R.
Proof.
  rewrite /computeB mulBE /cycle.computeB.
  apply/rowP => i.
  rewrite !mxE ?castmxE ?mxE (nth_map 0)
          ?nth_rev ?size_tuple ?size_rot ?ltn_pmod //
          ?size_rev ?size_rot ?size_next_random_state //.
  set R := row_ind _ _ _.
  have<-: (rev_ord R = w - R.+1 :> nat)%nat by [].
  set I := (cast_ord _ i); subst R.
  rewrite nth_word_of_N /cycle.B index_next_random_state
          ?size_rot ?size_next_random_state ?nth_drop //
          nth_cat size_drop ?size_next_random_state.
  set I' := col_ind _ _ _ _ _.
  case: (splitP I) => j Ij; rewrite /= in Ij; last first.
   have I'0: (I' > 0)%nat.
    by rewrite /= Ij divnDl.
   have->: (n - I'.+1 < n - 1%N)%nat.
    rewrite /leq subn1 subnS.
    case H: (n - I' > 0)%nat.
     by rewrite prednK // subnAC -subn1 subnBA.
    rewrite lt0n in H.
    by move/negP/negP/eqP: H => ->.
   rewrite nth_drop add1n nth_next_random_state tns => *.
     rewrite /leq -!subSn //;last by apply/leqW.
     by rewrite subnAC subSn //.
    by rewrite (rev_ord_proof (Ordinal (@ltn_pmod i w erefl))).
   rewrite break_if !mxE !castmxE.
   congr (v _ _); apply/ord_inj => //.
   rewrite /arr_ind /=.
   set T := cast_ord _ _.
   case: (splitP T) => k /=.
    rewrite Ij 3!subnS -!subn1 -!subnDA !addn1 subnDA subKn.
     rewrite subn2 /= !divnDl // divnn add1n modnDl // -subSn
             ?ltn_mod // subSS subKn; last by rewrite ltnW // ltn_mod.
     by rewrite -divn_eq => ->.
    rewrite divnDl // add1n /leq !subSS subn_eq0.
    case: j {Ij} => j H.
    apply/leq_trans.
     apply leq_div2r.
     by apply H.
    by [].
   rewrite Ij 3!subnS -!subn1 -!subnDA !addn1 subnDA subKn.
    rewrite subn2 /= !divnDl // divnn add1n modnDl // -subSn
            ?ltn_mod // subSS subKn; last by rewrite ltnW // ltn_mod.
    rewrite -divn_eq => jnwr.
    case: j {Ij} jnwr => j H jnwr.
    suff: (n.-1 * w - r < n.-1 * w - r)%nat by rewrite ltnn.
     apply/leq_trans.
      apply: (_ : _ < n * w - r)%nat; first by rewrite ltn_sub2r.
     apply/leq_trans.
      apply: (_ : _ <= n * w - r + k)%nat; first by rewrite leq_addr.
     apply/ltnW.
     by rewrite -jnwr.
    rewrite divnDl // add1n /leq !subSS subn_eq0.
    case: j {Ij} => j H.
    apply/leq_trans.
     apply leq_div2r.
     by apply H.
    by [].

   have->: val I' = 0 by rewrite /= Ij divn_small.
   rewrite subn1 ltnn ?(mxE, castmxE) subnn nth_take // nth_set_nth.
   rewrite !N.lxor_spec // N.shiftr_spec // N.lor_spec !N.land_spec.
   rewrite !if_xorb tns ?(rev_ord_proof (Ordinal (@ltn_pmod i w erefl))) // => Hp.
   rewrite !break_if.
   rewrite mxE -!GRing.addrA.
   congr (_ + _)%R; first congr (v _ _); apply/ord_inj => //.
   rewrite /= /arr_ind; set P := cast_ord _ _.
   case: (splitP P) => l Pl.
    by rewrite /= modn_small ?Ij // 2!subSS subKn // -ltnS in Pl.
   move/eqP: Pl; rewrite /= modn_small ?Ij //.
   have H: (n = n - m.+1 + m.+1)%nat by rewrite subnK.
   rewrite [X in _ == (X * _ - _ + _)%nat]H mulnDl eqn_add2l => /eqP je.
   suff: (w < w)%nat by rewrite ltnn.
   apply/leq_trans/(_ : j < w)%nat => //.
   rewrite 2!subSS // subKn // in je; last by rewrite -ltnS.
   by rewrite ltnS je.

   set R := cast_ord _ _.
   case: (splitP (R : 'I_(1 + w.-1))) => r Rr.
    rewrite /= in Rr.
    case: r Rr => [][]// ? Rr.
    rewrite Num_succ.
    set T := (val (rev_ord _)).+1.
    have->: T = w by rewrite /T /= Ij Rr mod0n subn1.
    rewrite ?tnsw // ?mxE !GRing.add0r.
    set S := cast_ord _ _; case: (splitP S) => s Ss; first by case: s Ss => [][].
    rewrite ?(mxE, castmxE).
    rewrite ?N.lor_spec ?N.land_spec.
    have->: 0 = [Num of 0] by [].
    rewrite ?tns // !mxE /= andbF andbT.
    set L := v _ _; set R0 := v _ _; have<-: L = R0.
     congr (v _ _); apply/ord_inj => //.
     rewrite /arr_ind.
     set T' := cast_ord _ _.
     case: (splitP T') => t //= T't.
     rewrite /= in T't, Ss.
     have-> //: val s = 30.
     rewrite subSn // subnn add1n in Ss.
     by case: Ss.
    rewrite /= Ij Rr mod0n subn1 /=.
    case L1: (L == 1%R).
     rewrite mxE.
     case: (splitP (R : 'I_(1 + w.-1))) => r' Rr'.
      case: r' Rr' => [][]// *.
      by rewrite mxE -GRing.mulr_natr.
     by rewrite /= Rr in Rr'.
    by rewrite mxE.
   (**)
   rewrite !Num_succ !tns.
    rewrite /= in Rr.
    by rewrite /= Ij Rr add1n modn_small ?subSS ?ltnS ?leq_subr // -ltnS //.
    rewrite /= in Rr.
    by rewrite /= Ij Rr add1n modn_small ?subSS ?ltnS ?leq_subr // -ltnS //.
   move=> ? ?.
   rewrite ?N.lor_spec ?N.land_spec.
   have->: 0 = [Num of 0] by [].
   rewrite ?tns // !mxE andbF andbT ?(castmxE, mxE).
   set P := cast_ord _ _; set Q' := cast_ord (esym _) _; set Q := cast_ord (esym _) _.
   case: (splitP Q) => q Qq.
    by case: q Qq => [][]//.
   rewrite /= in Qq.
   case: (splitP P) => p Pp.
    case: p Pp => [][]// p Pp.
    rewrite /= in Pp, Rr.
    set TT := val (rev_ord _).
    have TT30: TT = 30.
     subst TT.
     by rewrite /= Ij Rr Pp addn0 modn_small //.
    have->: N.testbit lower_mask [Num of TT.+1] = false by rewrite TT30.
    have->: N.testbit upper_mask [Num of TT.+1] = true by rewrite TT30.
    rewrite ?(mxE, castmxE) andbT andbF orbF.
    set X := v _ _; set Y := v _ _; set Z := v _ _; set W := v _ _.
    have->: X = Z.
     congr (v _ _); apply/ord_inj => //.
     rewrite /arr_ind /=.
     set Tmp := cast_ord _ _.
     case: (splitP Tmp) => t Tmpt.
      by rewrite -Tmpt /= TT30.
     by rewrite /= TT30 in Tmpt.
    have q30: val q = 30.
     rewrite /= subSn // subnn add1n in Qq.
     by case: Qq.
    have->: Y = W.
     congr (v _ _); apply/ord_inj => //.
     rewrite /arr_ind /=.
     set Tmp := cast_ord _ _.
     case: (splitP Tmp) => t Tmpt //.
     by rewrite -Tmpt /= q30.
    case: (W == 1)%R.
     rewrite mxE.
     case: (splitP (R : 'I_(1 + w.-1))) => r' Rr';
      rewrite /= in Rr'.
      case: r' Rr' => [][]//= ? Rr'.
      by rewrite Rr' in Rr.
     rewrite Rr' !add1n in Rr.
     case: Rr => Rr.
     rewrite TT30 /= mxE /= Rr Pp /=.
     case ZE: (Z == 1)%R.
      by move/eqP: ZE => ->.
     by case: Z ZE => [][]//[]//.
    rewrite mxE TT30 /=.
    by case: Z => [][]//[]//.
   rewrite /= in Pp, Rr.
   have q30: val q = 30.
    rewrite /= subSn // subnn add1n in Qq.
    by case: Qq.
   rewrite ?(mxE, castmxE).
   set A := v _ _.
   set X := v _ _; set Y := v _ _; set Z := v _ _; set W := v _ _.
   have->: X = Z.
    congr (v _ _); apply/ord_inj => //.
    rewrite /= /arr_ind.
    set Tmp := cast_ord _ _.
    case: (splitP Tmp) => t Tmpt.
     rewrite -Tmpt /= Ij Rr Pp.
     rewrite modn_small; last by rewrite -Pp add1n ltnS.
     by rewrite 3!subSS !subnDA subn1 -subnDA subKn subSn // -Pp -ltnS.
    rewrite /= Ij Rr Pp modn_small in Tmpt; last by rewrite -Pp add1n ltnS.
    rewrite 3!subSS !subnDA subn1 -subnDA subKn subSn // -Pp in Tmpt;
     last by rewrite -ltnS.
    suff: (n.-2 * w + r < n.-2 * w + r)%nat by rewrite ltnn.
    rewrite [X in (_ < X)%nat]Tmpt.
    apply/leq_trans.
     apply: (_ : _ < n.-2 * w + w.-1)%nat; first by rewrite ltn_add2l.
    by [].
   have->: W = Y.
    congr (v _ _); apply/ord_inj => //.
    rewrite /= /arr_ind.
    set Tmp := cast_ord _ _.
    case: (splitP Tmp) => t Tmpt //.
    by rewrite -Tmpt /= q30.
   set TT := val (rev_ord _).
   have TTwp2: (TT = gluing.r - p.+2)%nat.
    subst TT.
    by rewrite /= Ij modn_small // Rr Pp subSS.
   have->: N.testbit lower_mask [Num of TT.+1] = true.
    rewrite add1n in Pp.
    rewrite lower_maskT // TTwp2 -subSn.
     by rewrite subSS ?rev_ord_proof.
    by rewrite -Pp.
   have->: N.testbit upper_mask [Num of TT.+1] = false.
    rewrite add1n in Pp.
    rewrite upper_maskF // TTwp2 -subSn.
     by rewrite subSS ?rev_ord_proof.
    by rewrite -Pp.
   rewrite andbF andbT /= break_if.
   case YE: (Y == 1%R).
    rewrite TTwp2 mxE.
    case: (splitP (R : 'I_(1 + w.-1))) => r' Rr';
     rewrite /= in Rr'.
     case: r' Rr' => [][]// ? Rr'.
     by rewrite Rr' in Rr.
    rewrite Rr' !add1n in Rr.
    case: Rr => Rr.
    have->: r' = r by apply/ord_inj.
    have->: p.+1 = r by rewrite Pp.
    rewrite mxE nth_rev ?size_tuple // ?subSS; last by rewrite ltnS.
    rewrite testbita //.
    apply/leq_ltn_trans.
     apply leq_subr.
    by [].
   by rewrite mxE /=.
Qed.


(** * Prelude -- definitions of basic of data types*)

(** Definitions of basic of data types required for the crowdfunding contract along with notations for developing contract using the deep embedding *)

Require Import String ZArith Basics.
From ConCert.Embedding Require Import Ast CustomTactics Notations
     PCUICTranslate PCUICtoTemplate Utils.
Require Import List.

From MetaCoq.Template Require Import All.

Import MonadNotation.

Import ListNotations.
Import BaseTypes.
Open Scope list.

Definition expr_to_tc Σ := compose trans (expr_to_term Σ).
Definition type_to_tc := compose trans type_to_term.
Definition global_to_tc := compose trans_minductive_entry trans_global_dec.

(** ** Wrappers for some primitive types *)

Run TemplateProgram
      (mkNames ["address"; "time"; "ContractAddr"; "UserAddr"; "Time" ; "Money" ] "_coq").

Definition address_ty :=
  [\ data address =
      ContractAddr [Nat,_]
    | UserAddr [Nat, _] \].

Make Inductive (global_to_tc address_ty).

Definition time_ty :=
  [\ data time = Time [Nat,_] \].

Make Inductive (global_to_tc time_ty).

Definition money := "Coq.Numbers.BinNums.Z".

(** Comparison for addresses and time *)

Definition ltb_time (t1 t2 : time_coq) :=
  let '(Time_coq n1) := t1 in
    let '(Time_coq n2) := t2 in
    n1 <? n2.

Definition leb_time (t1 t2 : time_coq) :=
  let '(Time_coq n1) := t1 in
  let '(Time_coq n2) := t2 in
  n1 <=? n2.

Definition eqb_addr (a1 a2 : address_coq) :=
  match a1,a2 with
  | ContractAddr_coq n1, ContractAddr_coq n2 => Nat.eqb n1 n2
  | UserAddr_coq n1, UserAddr_coq n2 => Nat.eqb n1 n2
  | _, _ => false
  end.

(** Our approximation for finite maps. Eventually, will be replaced with the Oak's standard library implementation. We assume that the standard library is available for a contract developer. *)
Section Maps.
  Open Scope nat.

  Definition addr_map_acorn :=
    [\ data "addr_map" =
          "mnil" [_]
        | "mcons" [address, money, "addr_map",_] \].

  Make Inductive (global_to_tc addr_map_acorn).

  Fixpoint lookup_map (m : addr_map) (key : address_coq) : option Z :=
    match m with
    | mnil => None
    | mcons k v m' =>
      if (eqb_addr key k) then Some v else lookup_map m' key
    end.

  (* Ported from FMapWeaklist of StdLib *)
  Fixpoint add_map (k : address_coq) (x : Z) (s : addr_map) : addr_map :=
  match s with
   | mnil => mcons k x mnil
   | mcons k' y l => if eqb_addr k k' then mcons k x l else mcons k' y (add_map k x l)
  end.

  Definition inmap_map k m := match lookup_map m k with
                              | Some _ => true
                              | None => false
                              end.

  Lemma lookup_map_add k v m : lookup_map (add_map k v m) k = Some v.
  Proof.
    induction m.
    + simpl. destruct k;simpl; now rewrite PeanoNat.Nat.eqb_refl.
    + simpl. destruct (eqb_addr k a) eqn:Heq.
      * destruct k;simpl;now rewrite PeanoNat.Nat.eqb_refl.
      * simpl. now rewrite Heq.
  Qed.

  Fixpoint to_list (m : addr_map) : list (address_coq * Z)%type:=
    match m with
    | mnil => nil
    | mcons k v tl => cons (k,v) (to_list tl)
    end.

  Fixpoint of_list (l : list (address_coq * Z)) : addr_map :=
    match l with
    | nil => mnil
    | cons (k,v) tl => mcons k v (of_list tl)
    end.

  Lemma of_list_to_list m: of_list (to_list m) = m.
  Proof. induction m;simpl;congruence. Qed.

  Lemma to_list_of_list l: to_list (of_list l) = l.
  Proof. induction l as [ | x l'];simpl;auto.
         destruct x. simpl;congruence. Qed.

  Fixpoint map_forallb (p : Z -> bool)(m : addr_map) : bool:=
    match m with
    | mnil => true
    | mcons k v m' => p v && map_forallb p m'
    end.

  Lemma map_forallb_lookup_map p m k v :
    map_forallb p m = true ->
    lookup_map m k = Some v ->
    p v = true.
  Proof.
    revert k v p.
    induction m;intros;tryfalse;simpl in *.
    inv_andb H. destruct (eqb_addr _ _);auto.
    * now inversion H0;subst.
    * easy.
  Qed.

End Maps.

Notation "a ∈ m" := (inmap_map a m = true) (at level 50).
Notation "a ∉ m" := (inmap_map a m = false) (at level 50).

(** Notations for functions on finite maps *)

Definition Map := "addr_map".

Notation "'MNil'" := [| {eConstr "addr_map" "mnil"} |]
                       (in custom expr at level 0).

Notation "'mfind' a b" :=  [| {eConst "lookup_map"} {a} {b} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1).

Notation "'madd' a b c" :=  [| {eConst "add_map"} {a} {b} {c} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1,
            c custom expr at level 1).

Notation "'mem' a b" :=  [| {eConst "inmap_map"} {a} {b} |]
        (in custom expr at level 0,
            a custom expr at level 1,
            b custom expr at level 1).

  Definition Σ : list global_dec :=
  [gdInd Unit 0 [("tt", [])] false;
     gdInd Bool 0 [("true", []); ("false", [])] false;
     gdInd Nat 0 [("Z", []); ("Suc", [(None,tyInd Nat)])] false;
     gdInd "list" 1 [("nil", []); ("cons", [(None,tyRel 0);
                                              (None,tyApp (tyInd "list") (tyRel 0))])] false;
     gdInd "prod" 2 [("pair", [(None,tyRel 1);(None,tyRel 0)])] false].

Notation "a + b" := [| {eConst "Coq.ZArith.BinInt.Z.add"} {a} {b} |]
                      (in custom expr at level 0).
Notation "a * b" := [| {eConst "Coq.ZArith.BinInt.Z.mul"} {a} {b} |]
                      (in custom expr at level 0).
Notation "a - b" := [| {eConst "Coq.ZArith.BinInt.Z.sub"} {a} {b} |]
                      (in custom expr at level 0).
Notation "a == b" := [| {eConst "Coq.ZArith.BinInt.Z.eqb"} {a} {b} |]
                        (in custom expr at level 0).
Notation "a < b" := [| {eConst "Coq.ZArith.BinInt.Z.ltb"} {a} {b} |]
                      (in custom expr at level 0).
Notation "a <= b" := [| {eConst "Coq.ZArith.BinInt.Z.leb"} {a} {b} |]
                       (in custom expr at level 0).
Notation "a <n b" := [| {eConst "PeanoNat.Nat.ltb"} {a} {b} |]
                      (in custom expr at level 0).
Notation "a <=n b" := [| {eConst "PeanoNat.Nat.leb"} {a} {b} |]
                       (in custom expr at level 0).
Notation "a <t b" := [| {eConst "ltb_time"} {a} {b} |]
                      (in custom expr at level 0).
Notation "a <=t b" := [| {eConst "leb_time"} {a} {b} |]
                      (in custom expr at level 0).

Notation "'Zero'" := (eConstr Nat "Z") ( in custom expr at level 0).
Notation "'Suc'" := (eConstr Nat "Suc") ( in custom expr at level 0).
Notation "0" := [| Zero |] ( in custom expr at level 0).
Notation "1" := [| Suc Zero |] ( in custom expr at level 0).

Notation "'Zero'" := (pConstr "Z" [])
                (in custom pat at level 0).

Notation "'Suc' x" := (pConstr "Suc" [x])
                  (in custom pat at level 0,
                      x constr at level 4).

Notation "a && b" := [| {eConst "andb"} {a} {b} |]
                       (in custom expr at level 0).
Notation "~ a" := [| {eConst "negb"} {a} |]
                      (in custom expr at level 0).

Definition true_name := "true".
Definition false_name := "false".

Notation "'True'" := (eConstr Bool true_name) (in custom expr at level 0).
Notation "'False'" := (eConstr Bool false_name) ( in custom expr at level 0).

Notation "'star'" :=
  (eConstr Unit "tt")
    (in custom expr at level 0).

Notation "A × B" := (tyApp (tyApp (tyInd "prod") A) B)
                        (in custom type at level 6,
                            A custom type,
                            B custom type at level 8).

Notation "'Pair' b o" :=
    (pConstr "pair" [b;o]) (in custom pat at level 0,
                                b constr at level 4,
                                o constr at level 4).

Notation "'Pair' A B b o" :=
    [| {eConstr "prod" "pair"} {eTy A} {eTy B} {b} {o} |]
      (in custom expr at level 0,
          A custom type at level 1,
          B custom type at level 1,
          b custom expr at level 1,
          o custom expr at level 1).

Notation "'first' A B p" := [| {eConst "fst"} {eTy A} {eTy B} {p} |]
                              (in custom expr at level 0,
                                  A custom type at level 1,
                                  B custom type at level 1,
                                  p custom expr at level 1).

Notation "'second' A B p" := [| {eConst "snd"} {eTy A} {eTy B} {p} |]
                              (in custom expr at level 0,
                                  A custom type at level 1,
                                  B custom type at level 1,
                                  p custom expr at level 1).

(** A simplified representation of a call context.
    Contains: current time, sender, transaction amount, contract's balance *)
Notation "'CallCtx'" := [! time × (address × (money × money)) !] (in custom type at level 0).

Notation "'current_time' st" :=
  [| first time (address × (money × money)) {st} |]
    (in custom expr at level 0).

Notation "'sender_addr' st" :=
  [| first address (money × money) (second time (address × (money × money)) {st}) |]
    (in custom expr at level 0).

Notation "'sent_amount' st" :=
  [| first money money (second address (money × money) (second time (address × (money × money)) {st})) |]
    (in custom expr at level 0).

Notation "'acc_balance' st" :=
  [| second money money (second address (money × money) (second time (address × (money × money)) {st})) |]
    (in custom expr at level 0).

Notation "'mkCallCtx' now sender sent_am bal " :=
  [| Pair time (address × (money × money)) {now}
          (Pair address (money × money) {sender}
                (Pair money money {sent_am} {bal} )) |]
    (in custom expr at level 0).

(** We use this abbreviation to state lemmas *)
Definition SimpleCallCtx : Set:= time_coq × (address_coq × (Z × Z)).

(** These projections correspont to the notations above *)
Definition sc_current_time (ctx : SimpleCallCtx) : time_coq := ctx.1.
Definition sc_sender_addr (ctx : SimpleCallCtx) : address_coq := ctx.2.1.
Definition sc_sent_amount (ctx : SimpleCallCtx) : Z := ctx.2.2.1.
Definition sc_acc_balance (ctx : SimpleCallCtx) : Z := ctx.2.2.2.

Definition Just := "Some".
Definition Nothing := "None".

Definition AcornList : global_dec :=
  gdInd "list" 1 [("nil", []);("cons", [(None, tyRel 0);(None, (tyApp (tyInd "list") (tyRel 0)))])] false.

Notation List := "list".

Notation "'Nil' A" :=
  [| {eConstr List "nil"} {eTy A}|]
    (in custom expr at level 0,
        A custom type at level 1).

Notation "'Cons' A x xs" :=
  [| {eConstr List "cons"} {eTy A} {x} {xs}|]
    (in custom expr at level 0,
        A custom type at level 1,
        x custom expr at level 1,
        xs custom expr at level 1).

Definition Maybe := "option".

Definition AcornMaybe : global_dec :=
  gdInd "option" 1 [("Some", [(None, tyRel 0)]);("None", [])] false.

Definition AcornProd : global_dec :=
  gdInd "prod" 2 [("pair", [(None, tyRel 1); (None, tyRel 0)])] false.

(** A shortcut for [if .. then .. else ..]  *)
Notation "'if' cond 'then' b1 'else' b2 : ty" :=
  (eCase (Bool,[]) ty cond
         [(pConstr true_name [],b1);(pConstr false_name [],b2)])
    (in custom expr at level 4,
        cond custom expr at level 4,
        ty custom type at level 4,
        b1 custom expr at level 4,
        b2 custom expr at level 4).