(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics HoTT.Types.
Require Import Extensions HFiber Truncations NullHomotopy Limits.Pullback.
Require Import Descent Lex Separated.

(** We construct "canonical" binary meets of reflective subuniverses (that is, whose underlying subuniverse is an intersection), without assuming accessibility.  In particular, we will show:

1. Given two reflective subuniverses L and O, if [L O X] is [O]-modal, then it is a reflection into the canonical meet.  In particular, this is always the case if [L] preserves [O]-modal types; this is Theorem 3.30 of RSS.

1. If L and O are lex modalities satisfying an additional "composability" condition, then the composite functor [L o O] converges to a reflection into the canonical meet after n+2 applications when applied to an n-type for some finite n.

The latter gives in particular a synthetic approach to higher sheafification (stack completion).  As described at https://ncatlab.org/nlab/show/plus+construction+on+presheaves, for any site C the topos of presheaves on its Grothendieck topology is cohesive and even totally connected, so that its shape and sharp modalities are both lex.  Their canonical meet is the topos of sheaves for the given topology, and the composite functor [shape o sharp] is the usual "plus construction" on (higher) presheaves.  Thus, we recover synthetically the result that an n-truncated type can be stackified by (n+2) applications of the plus construction.  We also refer to [L o O] as a "plus construction" in the general case of reflective subuniverses.  *)

Section RSUMeet.
  Context (L O : ReflectiveSubuniverse).

  (** The canonical meet of two subuniverses is their intersection. *)

  Definition Meet : Subuniverse.
  Proof.
    unshelve econstructor.
    - intros X; exact (In L X * In O X).
    - intros ? X; exact _.
    - intros T U [? ?] f feq; split; apply (inO_equiv_inO _ f).
  Defined.

  Global Instance inO_inmeet_l (X : Type) `{im : In Meet X} : In L X := fst im.
  Global Instance inO_inmeet_r (X : Type) `{im : In Meet X} : In O X := snd im.

  (** The basic tool in studying its reflectivity is the "plus construction" that applies the two reflectors in sequence. *)

  Definition Plus (X : Type) := L (O X).

  Global Instance inO_plus_l (X : Type) : In L (Plus X) := _.

  (** This is not necessarily a reflector, but it is a well-pointed endofunctor. *)

  Definition to_plus (X : Type) : X -> Plus X
    := to L (O X) o to O X.

  Definition plus_functor {X Y : Type} (f : X -> Y) : Plus X -> Plus Y
    := O_functor L (O_functor O f).

  Definition to_plus_natural {X Y : Type} (f : X -> Y)
    : plus_functor f o to_plus X == to_plus Y o f.
  Proof.
    intros x.
    unfold plus_functor, to_plus.
    refine (to_O_natural L (O_functor O f) (to O X x) @ _).
    apply ap.
    apply to_O_natural.
  Defined.

  Definition wellpointed_plus (X : Type)
    : to_plus (Plus X) == plus_functor (to_plus X).
  Proof.
    rapply (@O_indpaths L).
    intros ox.
    unfold to_plus, plus_functor; cbn.
    refine (_ @ (to_O_natural L _ ox)^).
    apply ap.
    revert ox; apply O_indpaths; intros x.
    exact ((to_O_natural O _ x)^).
  Defined.

  (** Moreover, it has the desired factorization property of a reflector (though it may not belong to the meet subuniverse itself). *)

  Definition ooextendable_plus {X Y : Type} `{In Meet Y}
    : ooExtendableAlong (to_plus X) (fun _  => Y).
  Proof.
    apply (ooextendable_compose _ (to O X) (to L (O X)));
      rapply extendable_to_O.
  Defined.

  Definition plus_rec {P Q : Type} `{In Meet Q} (f : P -> Q)
    : Plus P -> Q
    := (fst (ooextendable_plus 1%nat) f).1.

  Definition plus_rec_beta {P Q : Type} `{In Meet Q} (f : P -> Q) (x : P)
    : plus_rec f (to_plus P x) = f x
    := (fst (ooextendable_plus 1%nat) f).2 x.

  Definition plus_indpaths {P Q : Type} `{In Meet Q} (g h : Plus P -> Q)
             (p : g o to_plus P == h o to_plus P)
    : g == h
    := (fst (snd (ooextendable_plus 2%nat) g h) p).1.

  Definition plus_indpaths_beta {P Q : Type} `{In Meet Q} (g h : Plus P -> Q)
             (p : g o (to_plus P) == h o (to_plus P)) (x : P)
    : plus_indpaths g h p (to_plus P x) = p x
    := (fst (snd (ooextendable_plus 2%nat) g h) p).2 x.

  (** Moreover, its fixed points, as a pointed endofunctor, are the types in the meet. *)

  Definition isequiv_plus_inmeet (X : Type) `{In Meet X} : IsEquiv (to_plus X).
  Proof.
    apply (@isequiv_compose _ _ (to O X) _ _ (to L (O X))).
    apply isequiv_to_O_inO.
    apply (inO_equiv_inO X (to O X)).
  Defined.

  Definition inmeet_isequiv_plus (X : Type) `{IsEquiv _ _ (to_plus X)} : In Meet X.
  Proof.
    split.
    - apply (inO_equiv_inO (Plus X) (to_plus X)^-1).
    - srapply inO_to_O_retract.
      + exact ((to_plus X)^-1 o (to L (O X))).
      + intros x; apply (eissect (to_plus X)).
  Defined.

  (** It follows that if [Plus X] ever *does* lie in the meet, then it is a reflection. *)

  Global Instance prereflects_plus_inO (X : Type) `{In O (Plus X)}
    : PreReflects Meet X.
  Proof.
    unshelve econstructor.
    - exact (Plus X).
    - split; exact _.
    - apply to_plus.
  Defined.

  Global Instance reflects_plus_inO (X : Type) `{In O (Plus X)}
    : Reflects Meet X.
  Proof.
    constructor; intros; apply ooextendable_plus.
  Defined.

  (** Recalling that a type is connected for a reflective subuniverse if and only if its reflector is nullhomotopic, we define a type to be "plus-connected" if its map to plus is nullhomotopic.  If the meet is reflective, this coincides with connectedness for that reflective subuniverse. *)

  Definition PlusConnected (X : Type) := NullHomotopy (to_plus X).

  Definition plusconnected_equiv {X Y : Type} (f : X <~> Y)
    : PlusConnected X -> PlusConnected Y.
  Proof.
    intros [px e].
    exists (plus_functor f px); intros y.
    refine (_ @ ap (plus_functor f) (e (f^-1 y))).
    rewrite to_plus_natural.
    symmetry; apply ap, eisretr.
  Defined.

  (** Similarly, we say a map is plus-connected if all of its fibers are. *)

  Definition PlusConnMap {X Y : Type} (f : X -> Y) := forall y, PlusConnected (hfiber f y).

End RSUMeet.

(** Let's now assume we are trying to intersect two lex modalities. *)

Section LexMeet.
  Context (L O : Modality) `{Lex L} `{Lex O}.

  (** The plus construction, being a composite of two lex functors, is also lex.  Thus, it preserves path-types. *)
  Definition plus_path {X : Type} (x y : X)
    : Plus L O (x = y) <~> (to_plus L O X x = to_plus L O X y).
  Proof.
    refine (equiv_path_O L (to O X x) (to O X y) oE _).
    apply equiv_O_functor.
    rapply equiv_path_O.
  Defined.

  Definition plus_path_to_plus {X : Type} (x y : X)
    : plus_path x y o to_plus L O (x = y) == @ap _ _ (to_plus L O X) x y.
  Proof.
    intros p; unfold plus_path, to_plus, equiv_path_O, equiv_path_OO, path_OO.
    cbn.
    rewrite to_O_natural.
    rewrite O_rec_beta.
    rewrite (ap_compose (to O X) (to L (O X))).
    apply ap.
    apply O_rec_beta.
  Defined.

  (** This implies that plus-connected types are closed under path-spaces. *)
  Definition plusconnected_path {X : Type} (x y : X)
             (pc : PlusConnected L O X) : PlusConnected L O (x = y).
  Proof.
    unfold PlusConnected in *.
    apply (cancelL_nullhomotopy_equiv _ (plus_path x y)).
    apply (nullhomotopy_homotopic (fun u => (plus_path_to_plus x y u)^)).
    apply nullhomotopy_ap; assumption.
  Defined.

  (** And hence plus-connected maps are closed under diagonals. *)
  Definition plusconnmap_diagonal {X Y : Type} (f : X -> Y)
    : PlusConnMap L O f -> PlusConnMap L O (diagonal f).
  Proof.
    intros pc p.
    refine (plusconnected_equiv L O (hfiber_diagonal f p)^-1 _).
    apply plusconnected_path, pc.
  Defined.

  (** The plus-construction also preserves fibers. *)
  Definition plus_hfiber {X Y : Type} (f : X -> Y) (y : Y)
    : Plus L O (hfiber f y) <~> hfiber (plus_functor L O f) (to_plus L O Y y).
  Proof.
    refine (equiv_O_functor_hfiber L (O_functor O f) (to O Y y) oE _).
    apply equiv_O_functor.
    rapply equiv_O_functor_hfiber.
  Defined.

  Definition plus_hfiber_to_plus {X Y : Type} (f : X -> Y) (y : Y)
    : plus_hfiber f y o to_plus L O (hfiber f y)
      == functor_hfiber (fun u => (to_plus_natural L O f u)^) y.
  Proof.
    intros [x q]; unfold plus_hfiber, to_plus.
    cbn.
    rewrite to_O_natural.
    rewrite O_functor_hfiber_natural.
    unfold O_functor_hfiber, functor_hfiber, functor_sigma; cbn.
    rewrite O_rec_beta; cbn.
    apply ap.
    unfold to_plus_natural.
    rewrite !inv_V, ap_pp, concat_p_pp.
    apply whiskerL.
    rewrite <- ap_compose.
    reflexivity.
  Defined.

  (** And pullbacks. *)
  Definition equiv_plus_pullback {A B C : Type} (f : B -> A) (g : C -> A)
    : Plus L O (Pullback f g) <~> Pullback (plus_functor L O f) (plus_functor L O g).
  Proof.
    refine (equiv_O_pullback L (O_functor O f) (O_functor O g) oE _).
    apply equiv_O_functor.
    rapply equiv_O_pullback.
  Defined.

  (** And diagonals. *)
  Definition diagonal_plus_functor {A B : Type} (f : A -> B)
    : diagonal (plus_functor L O f) == equiv_plus_pullback f f o plus_functor L O (diagonal f).
  Proof.
    intros x.
    refine (diagonal_O_functor L (O_functor O f) x @ _).
    apply (ap (equiv_O_pullback L (O_functor O f) (O_functor O f))).
    refine (O_functor_homotopy L _ _ (diagonal_O_functor O f) x @ _).
    unfold plus_functor.
    exact (O_functor_compose L _ _ x).
  Defined.

  (** Recall that a modality is characterized by connectedness of the units.  Analogously, we can now prove that the plus-units are all plus-connected.  This is equivalently a sort of coherence axiom for the homotopy [wellpointed_plus], that when precomposed with [to_plus] it becomes [to_plus_natural]. *)
  Definition plusconnmap_to_plus (X : Type) : PlusConnMap L O (to_plus L O X).
  Proof.
    intros y; unfold PlusConnected.
    apply (cancelL_nullhomotopy_equiv _ (plus_hfiber (to_plus L O X) y)).
    apply (nullhomotopy_homotopic (fun u => (plus_hfiber_to_plus (to_plus L O X) y u)^)).
    unfold NullHomotopy, hfiber.
    unshelve refine ((y ; _) ; _).
    { symmetry; apply wellpointed_plus. }
    intros [x p]; destruct p.
    unfold functor_hfiber, functor_sigma; cbn.
    apply ap.
    rewrite inv_V, concat_p1.
    unfold wellpointed_plus.
    rewrite !O_indpaths_beta.
    rewrite inv_pp, ap_V, !inv_V.
    reflexivity.
  Defined.

  (** Recall also (from [nsep_iff_trunc_to_O]) that a type is n-separated for a lex modality [O] if and only if its [O]-unit is an n-truncated map.  We can now prove the analogous fact for the plus-construction.  We state this using [MapIn (Tr n)] instead of [IsTrunc n] because we have more useful lemmas for [MapIn]. *)
  Definition nsep_iff_trunc_plus (n : trunc_index) (X : Type)
    : In (nSep n (Meet L O)) X <-> MapIn (Tr n) (to_plus L O X).
  Proof.
    revert X; induction n as [|n IHn]; intros X; split; intros H.
    - apply contr_map_isequiv.
      rapply isequiv_plus_inmeet.
    - apply inmeet_isequiv_plus.
      rapply isequiv_contr_map.
    - apply istruncmap_from_ap; intros x y.
      apply istruncmap_mapinO_tr.
      pose (i := fst (IHn _) (H x y)).
      apply (mapinO_homotopic _ _ (plus_path_to_plus x y)).
    - intros x y.
      apply (snd (IHn (x = y))).
      pose (i := istruncmap_ap n (to_plus L O X) x y).
      apply mapinO_tr_istruncmap in i.
      apply (mapinO_homotopic _ ((plus_path x y)^-1 o (@ap _ _ (to_plus L O X) x y))).
      { intros p; apply moveR_equiv_V; symmetry; apply plus_path_to_plus. }
      rapply mapinO_compose.
  Defined.

  (** We now make one more assumption, that the plus-construction inverts plus-connected embeddings.  In the case of the plus-construction for stacks, this corresponds roughly to the "local character" condition on a Grothendieck topology. *)
  Context (composing : forall (X Y : Type) (f : X -> Y)
                              (fe : IsEmbedding f) (fc : PlusConnMap L O f),
              IsEquiv (plus_functor L O f)).

  (** This implies, by induction, that the plus-construction decreases the truncation-level of any finitely truncated plus-connected map. *)
  Definition istruncmap_plus_functor {n : trunc_index} {X Y : Type} (f : X -> Y)
             `{MapIn (Tr n.+1) _ _ f} (pc : PlusConnMap L O f)
    : MapIn (Tr n) (plus_functor L O f).
  Proof.
    generalize dependent f; revert X Y; induction n as [|n IHn]; intros X Y f ? pc.
    { apply mapinO_tr_istruncmap, contr_map_isequiv, composing; assumption. }
    pose (O_eq_Tr n).
    apply (mapinO_O_leq (Sep (Tr n)) _), mapinO_from_diagonal.
    nrapply (mapinO_homotopic (Tr n) _ (fun u => (diagonal_plus_functor f u)^)).
    apply mapinO_compose.
    2:rapply mapinO_isequiv.
    apply IHn.
    - rapply mapinO_diagonal.
      pose (O_eq_Tr n.+1).
      rapply (mapinO_O_leq _ (Sep (Tr n.+1))).
    - apply plusconnmap_diagonal; assumption.
  Defined.

  (** It follows, by applying this to the plus-unit and using well-pointedness, that the plus-construction on *types* decreases their plus-separatedness. *)
  Definition nsep_plus (n : trunc_index) (X : Type) `{In (nSep n.+1 (Meet L O)) X}
    : In (nSep n (Meet L O)) (Plus L O X).
  Proof.
    apply nsep_iff_trunc_plus.
    nrefine (mapinO_homotopic _ _ (fun u => (wellpointed_plus L O X u)^)).
    apply mapinO_tr_istruncmap, istruncmap_plus_functor.
    - apply istruncmap_mapinO_tr, nsep_iff_trunc_plus; assumption.
    - apply plusconnmap_to_plus.
  Defined.

  (** Therefore, if a type starts out as n-plus-separated, then n+2 applications of the plus-construction suffice to make it (-2)-plus-separated, i.e. in the meet subuniverse.  Hence it has a reflection. *)
  Global Instance prereflects_plus_nsep (n : trunc_index) (X : Type) `{In (nSep n (Meet L O)) X}
    : PreReflects (Meet L O) X.
  Proof.
    generalize dependent X; induction n as [|n IHn]; intros X ?.
    { rapply prereflects_in. }
    specialize (IHn (Plus L O X) (nsep_plus n X)).
    unshelve econstructor.
    - exact (O_reflector (Meet L O) (Plus L O X)).
    - exact _.
    - exact (to (Meet L O) (Plus L O X) o to_plus L O X).
  Defined.

  Global Instance reflects_plus_nsep (n : trunc_index) (X : Type) `{In (nSep n (Meet L O)) X}
    : Reflects (Meet L O) X.
  Proof.
    generalize dependent X; induction n as [|n IHn]; intros X ?.
    { rapply reflects_in. }
    specialize (IHn (Plus L O X) (nsep_plus n X)).
    constructor; intros.
    apply (ooextendable_compose _ (to_plus L O X) (to (Meet L O) (Plus L O X))).
    - apply (@extendable_to_O (Meet L O) (Plus L O X)); assumption.
    - rapply ooextendable_plus.
  Defined.

End LexMeet.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj13eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv1) lv2) (plus (mult (Succ lv0) lv1) lv2)).
Admitted.
QuickChick conj13eqsynthconj3.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

Fixpoint len (l : lst) : nat :=
match l with
  | Nil => 0
  | Cons a l1 => 1 + (len l1)
end.

Fixpoint rev (l1 l2: lst): lst :=
  match l1 with
  | Nil => l2
  | Cons x l1' => rev l1' (Cons x l2)
  end.

Lemma list_rev2_len_lem: forall l1 l2,
len (rev l1 l2) = (len l1) + (len l2).
Proof.
  induction l1.
  - simpl. reflexivity.
  - simpl. intros. rewrite IHl1. simpl. rewrite <- plus_n_Sm.
    reflexivity.
Qed.

Theorem list_rev2_len: forall l: lst, len (rev l Nil) = len l.
Proof.
  induction l.
  - simpl. reflexivity.
  - lfind. Admitted.


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

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

Print Assumptions add.


Require Import HoTT.
Require Import UnivalenceAxiom.

Require Import HoTTEx.
Require Import Denotation.
Require Import UnivalentSemantics.

Open Scope type.

Module Index (T : Types) (S : Schemas T) (R : Relations T S)  (A : Aggregators T S).

  Import T S R A.
  Module SQL_TSRA := SQL T S R A.
  Import SQL_TSRA.

  Definition Index {s t0 t1} (R: SQL empty s) (k: Column t0 s) (ic: Column t1 s) :=
    SELECT2 (variable (right⋅k)), (variable (right⋅ic)) FROM1 R.

  Definition isUnique {s τ} (k: Column τ s) (R: SQL empty s) :=
    forall t, denoteSQL R tt t ->
         denoteSQL (SELECT1 right⋅k FROM1 R) tt (⟦k⟧ t) = Unit.

  Definition isKey {s t} (k: Column t s) (R: SQL empty s) :=
    forall t1 t2, denoteSQL R tt t1 -> denoteSQL R tt t2 -> ⟦k⟧ t1 = ⟦k⟧ t2 -> t1 = t2.

  Definition isKey2 {s t} (k: Column t s) (R: SQL empty s) :=
    ⟦ empty ⊢ R : _ ⟧ =
    ⟦ empty ⊢ ((project (right⋅left)) (FROM R, R
                WHERE equal (variable (right⋅left⋅k))
                (variable (right⋅right⋅k)))): _ ⟧.

  Lemma sum_pair_split' {A B C}:
    {ab: A * B & C ab} <~> {a:A & {b:B & C (a, b)}}.
  Proof.
    simple refine (BuildEquiv _ _ _ _). {
      intros [[a b] c].
      exists a.
      exists b.
      exact c. }
    simple refine (BuildIsEquiv _ _ _ _ _ _ _). {
      intros [a [b c]].
      exists (a, b).
      exact c. }
    + unfold Sect.
      intros.
      reflexivity.
    + unfold Sect.
      intros.
      reflexivity.
    + reflexivity.
  Qed.

  Lemma sum_commute {A B C}:
    {a:A & {b: B & C (a, b)}} <~> {b:B & {a:A & C (a, b)}}.
  Proof.
    simple refine (BuildEquiv _ _ _ _). {
      intros [a [b c]].
      exists b.
      exists a.
      exact c. }
    simple refine (BuildIsEquiv _ _ _ _ _ _ _). {
      intros [b [a c]].
      exists a.
      exists b.
      exact c. }
    + unfold Sect.
      reflexivity.
    + unfold Sect.
      reflexivity.
    + reflexivity.
  Qed.

  Lemma equiv_prod_sigma_nested {A B C D}:
    {a: A & {b:B & C a b * D a}} <~> {a:A & {b:B & C a b} * D a}.
  Admitted.

  Lemma equiv_prod_sigma_assoc {A B C D}:
    {a: A & B a * C a * D a} <~> {a: A & B a * (C a * D a)}.
  Admitted.

  Lemma equiv_prod_unit {A B}:
    (A -> (B = Unit)) ->  (A * B <~> A).
  Proof.
    intros h.
    simple refine (BuildEquiv _ _ _ _). {
      intros [a b].
      exact a. }
    simple refine (BuildIsEquiv _ _ _ _ _ _ _). {
      intro a.
      (*try equiv_hprop_allpath *)
      rewrite (h a).
      exact (a, tt). }
    - unfold Sect.
      intros.
      unfold Overture.internal_paths_rew_r.
  Abort.

  Lemma isKeyProof: forall s t (k:Column t s) (R: SQL empty s),
      isUnique k R -> isKey2 k R.
  Proof.
    intros s t k R h.
    unfold isKey2.
    simpl.
    by_extensionality g.
    by_extensionality t'.
    unfold isKey in h.
    match goal with
    |  |- _ = ∑ a, @?C a  => rewrite (path_universe_uncurried (@sum_pair_split' (Tuple s) (Tuple s) C))
    end.
    cbn.
    rewrite (path_universe_uncurried (equiv_prod_sigma_nested)).
    rewrite <- (path_universe_uncurried eqSum).
    rewrite (path_universe_uncurried (equiv_sigma_prod_symm _ _ _)).
    rewrite (path_universe_uncurried equiv_prod_sigma_assoc).
    rewrite <- (path_universe_uncurried (equiv_prod_sigma _ _ _)).
    unfold isUnique in h.
    cbn in h.
    specialize (h t').
    match goal with
    | |- _ = ?A * ?B => assert (A -> B) as h1 end.
    { rewrite (unit_eq g).
      intro h2.
      specialize (h h2).
      exists t'.
      refine (h2, _).
      reflexivity. }
    { symmetry.
      apply path_universe_uncurried.
      rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
      match goal with
      | |- ?A * ?B <~> _ => assert (IsHProp A) as h3 end.
      admit.
      apply hprop_prod_l'.
      exact h1.
  Abort.

  Definition IntroProj: Type.
    refine (forall r (R: SQL empty r) t0 (l: constant t0)
              (a: Column t0 r) t1 (k: Column t1 r) (ik: isKey k R)
              (ik2: isKey2 k R), _ ).
    pose (Index R k a) as I.
    pose (empty ++ (singleton t1 ++ singleton t0 ++ empty) ++ r) as qs.
    pose (@variable _ qs (right⋅left⋅right⋅left⋅star)) as ia.
    pose (@variable _ qs (right⋅left⋅left⋅star)) as ik'.
    pose (@variable _ qs (right⋅right⋅k)) as rk.
    refine ( ⟦ empty ⊢ (project (right⋅right)
                         (FROM I, R
                          WHERE and (equal ia (constantExpr l))
                                    (equal ik' rk))) :_ ⟧ =
             ⟦ empty ⊢ (project (right⋅right)
                         (FROM R, R
                          WHERE and (equal (variable (right⋅left⋅a)) (constantExpr l))
                                    (equal (variable (right⋅left⋅k)) (variable (right⋅right⋅k))))) :_ ⟧).
  Defined.

  Arguments IntroProj /.

  Definition IntroProjProof: IntroProj.
    start.
    rewrite (path_universe_uncurried (equiv_sigma_prod_symm _ _ _)).
    match goal with
   | |- ∑ a, @?A a * (@?B a * @?C a * (@?D a * @?E a)) = _ =>
     assert (∑ a, A a * (B a * C a * (D a * E a)) = ∑ a, (A a * B a * C a * E a) * D a) as h
    end.
    {  f_ap.
       by_extensionality a0.
       repeat rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
       rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
       repeat rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
       rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
       symmetry.
       rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
       f_ap.
       rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
       repeat rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
       reflexivity. }
    rewrite h.
    clear h.
    rewrite (path_universe_uncurried agg_sum).
    rewrite (path_universe_uncurried sum_assoc).
    f_ap.
    by_extensionality t2.
    destruct t2 as [ta tb].
    rewrite (path_universe_uncurried (equiv_sigma_prod_symm _ _ _)).
    cbn.
    rewrite (path_universe_uncurried (sum_prod_assoc)).
    rewrite (path_universe_uncurried (equiv_prod_sigma_r _ _ _ )).
    repeat rewrite (path_universe_uncurried (sum_prod_assoc)).
    rewrite (path_universe_uncurried (equiv_sigma_prod_symm _ _ _)).
    repeat rewrite (path_universe_uncurried (sum_prod_assoc)).
    rewrite (path_universe_uncurried (equiv_sigma_prod_symm _ _ _)).
    repeat rewrite (path_universe_uncurried (sum_prod_assoc)).
    rewrite (path_universe_uncurried (equiv_prod_sigma_r _ _ _ )).
    repeat rewrite (path_universe_uncurried (sum_prod_assoc)).
    rewrite (path_universe_uncurried (equiv_sigma_prod_symm _ _ _)).
    repeat rewrite (path_universe_uncurried (sum_prod_assoc)).
    rewrite (path_universe_uncurried (equiv_prod_sigma_r _ _ _)).
    unfold isKey2 in ik2.
    match goal with
    | |- ?A * _ * _ * _ = _ =>  assert (IsHProp A) as h1 end. {
      apply ishprop_sigma_disjoint.
      intros x y h1 h2.
      destruct x as [x1 [x2 x3]].
      destruct y as [y1 [y2 y3]].
      destruct h1 as [h1 [h3 h4]].
      destruct h2 as [h2 [h5 h6]].
      rewrite h3.
      rewrite h5.
      rewrite h4.
      rewrite h6.
      rewrite (unit_eq x3).
      rewrite (unit_eq y3).
      reflexivity. }
    symmetry.
    rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
    repeat rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
    rewrite <- (path_universe_uncurried (equiv_prod_assoc _ _ _)).
    rewrite <- (path_universe_uncurried (equiv_prod_assoc _ _ _)).
    match goal with
      | |- _ * _ * ?C  = _ => assert ((ta = tb) * C = C) as h2 end. {
      apply path_universe_uncurried.
      apply hprop_prod_l'.
      intros [eq [ra rb]].
      unfold isKey in ik.
      rewrite (unit_eq g) in *.
      exact (ik ta tb ra rb eq). }
    rewrite <- h2.
    clear h2.
    rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
    rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
    match goal with
    | |- _ = ?A * ?B * ?C * _ => assert (A * B * C = A * C * B) as h2 end. {
      rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
      rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
      match goal with
        | |- ?A * ?B * _  = _ => assert (A * B = B * A) as h3 end.
      + rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
        reflexivity.
      + rewrite h3.
        reflexivity. }
    rewrite h2.
    clear h2.
    symmetry.
    rewrite <- (path_universe_uncurried (equiv_prod_assoc _ _ _)).
    assert ( denoteSQL R g tb * denoteSQL R g ta =  denoteSQL R g ta * denoteSQL R g tb ) as h2. {
      rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
      reflexivity. }
    rewrite h2.
    clear h2.
    match goal with
    | |- ?A = _ => assert ((ta = tb) * A = A) as h2 end. {
      apply path_universe_uncurried.
      apply hprop_prod_l'.
      intros [[[[i1 [i2 i3]] [e2 [e3 e4]]] e1] [ra rb]].
      apply pair_f_eq in e2.
      destruct e2 as [e2 e5].
      apply pair_f_eq in e5.
      destruct e5 as [e5 e6].
      unfold isKey in ik.
      rewrite (unit_eq g) in *.
      rewrite e4 in e2.
      symmetry in e2.
      exact (ik ta tb ra rb e2). }
    rewrite <- h2.
    clear h2.
    rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
    f_ap.
    apply path_universe_uncurried.
    apply equiv_iff_hprop_uncurried.
    constructor.
    + intros [eq [[[i1 [i2 i3]] [p1 [p2 p3]]] h]].
      apply pair_f_eq in p1.
      destruct p1 as [p1 p4].
      apply pair_f_eq in p4.
      destruct p4 as [p4 p5].
      destruct h.
      destruct eq.
      destruct p4.
      destruct p2.
      refine (_, _, _, _); reflexivity.
    + intros [[[e1 e2] e3] e4].
      destruct e3.
      refine (_,( _, _)); try reflexivity.
    - simple refine (_; _). {
        refine (denoteProj k ta, (⟦l⟧, tt)).
      }
      cbn.
      destruct e2.
      refine (_, (_, _)); reflexivity.
    - exact e1.
  Defined.

  Definition IndexTransProj: Type.
    refine (forall r (R: SQL empty r) t0 (l: constant t0)
              (a: Column t0 r) t1 (k: Column t1 r) (ik: isKey k R)
              (ik2: isKey2 k R), _ ).
    refine ( ⟦ empty ⊢ (project (right⋅right)
                         (FROM R, R
                          WHERE and (equal (variable (right⋅left⋅a)) (constantExpr l))
                                    (equal (variable (right⋅left⋅k)) (variable (right⋅right⋅k))))) :_ ⟧ =
             ⟦ empty ⊢ (project (right⋅left)
                         (FROM R, R
                          WHERE and (equal (variable (right⋅left⋅a)) (constantExpr l))
                          (equal (variable (right⋅left⋅k)) (variable (right⋅right⋅k))))) :_ ⟧).
  Defined.

  Arguments IndexTransProj /.

  Definition IndexTransProjProof: IndexTransProj.
    unfold IndexTransProj.
    start.
    f_ap.
    by_extensionality t2.
    destruct t2 as [ta tb].
    cbn.
    unfold isKey in *.
    cbn in *.
    apply prod_eq_assoc.
    intros h.
    unfold isKey in ik.
    destruct h as [[h1 h2] [h3 h4]].
    apply ik.
    + rewrite <- (unit_eq g).
      refine h4.
    + rewrite <- (unit_eq g).
      refine h3.
    + cbn.
      symmetry in h2.
      refine h2.
  Defined.

  (*
     If k is R's primary key, I is R's index on column a.
     Then we want to prove:
     SELECT * FROM R WHERE R.a = l
     can be rewritten to
     SELECT * FROM I, R WHERE I.a = l and I.k = R.k
   *)
  Definition IndexExample0: Type.
    refine (forall r (R: SQL empty r) t0 (l: constant t0)
              (a: Column t0 r) t1 (k: Column t1 r) (ik: isKey k R)
              (ik2: isKey2 k R), _).
    pose (Index R k a) as I.
    pose (empty ++ (singleton t1 ++ singleton t0 ++ empty) ++ r) as qs.
    pose (@variable _ qs (right⋅left⋅right⋅left⋅star)) as ia.
    pose (@variable _ qs (right⋅left⋅left⋅star)) as ik'.
    pose (@variable _ qs (right⋅right⋅k)) as rk.
    refine (⟦ empty ⊢ (SELECT * FROM1 R
                       WHERE equal (variable (right⋅a)) (constantExpr l)): _ ⟧ =
            ⟦ empty ⊢ (project (right⋅right) (FROM I, R
                       WHERE and (equal ia (constantExpr l))
                                 (equal ik' rk) )) : _ ⟧).
  Defined.

  Arguments IndexExample0 /.

   Definition f_ap_eq {A B C} {f g: A -> B -> C}:
    forall x y, f = g -> f x y = g x y.
    intros.
    rewrite X.
    reflexivity.
  Defined.

  Definition IndexExampleProof0: IndexExample0.
    unfold IndexExample0.
    unfold Index.
    intros.
    rewrite (IntroProjProof r R t0 l a t1 k ik ik2).
    rewrite (IndexTransProjProof r R t0 l a t1 k ik ik2).
    by_extensionality g.
    by_extensionality t.
    unfold isKey2 in ik2.
    cbn in ik2.
    apply (f_ap_eq g t) in ik2.
    cbn in ik2.
    rewrite ik2.
    rewrite (path_universe_uncurried (equiv_prod_sigma _ _ _)).
    f_ap.
    by_extensionality t2.
    repeat rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
    match goal with
      | |- ?a1 * _ * _ * _ * _   = ?a2 * _ * _ * _ * ?b => assert (b * a1 = b * a2) end.
    +  apply path_universe_uncurried.
       apply equiv_iff_hprop_uncurried.
       constructor.
       { intro h.
         destruct h as [h1 h2].
         refine (h1, _).
         rewrite <- h1 in h2.
         exact h2. }
       { intro h.
         destruct h as [h1 h2].
         refine (h1, _).
         rewrite <- h1.
         exact h2. }
    +  rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
       repeat rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
       symmetry.
       rewrite (path_universe_uncurried (equiv_prod_symm _ _)).
       repeat rewrite (path_universe_uncurried (equiv_prod_assoc _ _ _)).
       rewrite X.
       reflexivity.
  Defined.

End Index.


Theorem parametricity_identity (a : Type) (f : a -> a) (x : a) : (f x = x).
Proof.
  admit.
Qed.


Require Import Common.Definitions.
Require Import Common.Util.

Require Import Lib.Extra.
From mathcomp Require Import ssreflect ssrnat eqtype.

Set Bullet Behavior "Strict Subproofs".

Module Block.
  Definition id := nat.
  Definition offset := Z.
  Definition local : id := 0.
End Block.

Definition addr_t : Type := (Component.id * Block.id).

Definition addr_eqb (a1 a2 : addr_t) : bool :=
  (fst a1 =? fst a2) && (snd a1 =? snd a2).

Lemma addr_eqP : Equality.axiom addr_eqb.
Proof.
  intros [C1 b1] [C2 b2].
  unfold addr_eqb.
  destruct (C1 =? C2) eqn:Hcase1; rewrite Hcase1;
    destruct (b1 =? b2) eqn:Hcase2; rewrite Hcase2;
    constructor;
    (* False cases *)
    try (injection as ? ?; subst;
         try rewrite Nat.eqb_refl in Hcase1;
         try rewrite Nat.eqb_refl in Hcase2;
         discriminate).
  (* True case *)
  move: Hcase1 => /eqP ->.
  move: Hcase2 => /eqP ->.
  reflexivity.
Qed.

Definition addr_eqMixin: Equality.mixin_of addr_t := EqMixin addr_eqP.
Canonical addr_eqType := Eval hnf in EqType addr_t addr_eqMixin.

Module Permission.
  Variant id :=
  | code
  | data.

  Definition eqb (p1 p2 : id) : bool :=
    match p1, p2 with
    | code, code
    | data, data
      => true
    | _, _
      => false
    end.

  Lemma eqP : Equality.axiom eqb.
  Proof.
    intros [] []; now constructor.
  Qed.

  Definition eqMixin: Equality.mixin_of id := EqMixin eqP.
  Canonical eqType := Eval hnf in EqType id eqMixin.
End Permission.

Module Pointer.
  Definition t : Type := Permission.id * Component.id * Block.id * Block.offset.

  Definition permission (p : t) : Permission.id :=
    let '(P, _, _, _) := p in P.

  Definition component (p : t) : Component.id :=
    let '(_, C, _, _) := p in C.

  Definition block (p : t) : Block.id :=
    let '(_, _, b, _) := p in b.

  Definition offset (p : t) : Block.offset :=
    let '(_, _, _, o) := p in o.

  (* TODO: Restore use of =? notation, broken by inductive permissions. *)
  Definition eq (p1 p2 : t) : bool :=
    let '(P1, C1, b1, o1) := p1 in
    let '(P2, C2, b2, o2) := p2 in
    (Permission.eqb P1 P2) && (Nat.eqb C1 C2) && (Nat.eqb b1 b2) && (Z.eqb o1 o2).

  Lemma eqP : Equality.axiom eq.
  Proof.
    intros [[[perm1 C1] b1] o1] [[[perm2 C2] b2] o2].
    simpl.
    destruct (Permission.eqP perm1 perm2);
      destruct (C1 =? C2) eqn:Hcase2;
      move: Hcase2 => /eqP => Hcase2;
      destruct (b1 =? b2) eqn:Hcase3;
      move: Hcase3 => /eqP => Hcase3;
      destruct (o1 =? o2)%Z eqn:Hcase4;
      move: Hcase4 => /Z.eqb_spec => Hcase4;
      constructor;
      try injection; (* All cases (false) except all-true case. *)
      congruence.
  Qed.

  Definition eqMixin: Equality.mixin_of t := EqMixin eqP.
  Canonical eqType := Eval hnf in EqType t eqMixin.

  Definition leq (p1 p2 : t) : option bool :=
    let '(P1, C1, b1, o1) := p1 in
    let '(P2, C2, b2, o2) := p2 in
    if (Permission.eqb P1 P2) && (Nat.eqb C1 C2) && (Nat.eqb b1 b2) then
      Some ((o1 <=? o2) % Z)
    else
      None.

  Definition add (ptr : t) (offset : Z) : t :=
    let '(P, C, b, o) := ptr in (P, C, b, (o+offset)%Z).

  Definition sub (ptr : t) (offset : Z) : t :=
    let '(P, C, b, o) := ptr in (P, C, b, (o-offset)%Z).

  Definition inc (ptr : t) : t := add ptr 1.

  Ltac preserves_proof_add := intros ?p ?n; destruct p as [[[P C] b] o]; reflexivity.
  Ltac preserves_proof_inc := intros ?p; destruct p as [[[P C] b] o]; reflexivity.

  Lemma add_preserves_permission:
    forall p n, permission (add p n) = permission p.
  Proof. preserves_proof_add. Qed.

  Lemma add_preserves_component:
    forall p n, component (add p n) = component p.
  Proof. preserves_proof_add. Qed.

  Lemma add_preserves_block:
    forall p n, block (add p n) = block p.
  Proof. preserves_proof_add. Qed.

  Lemma sub_preserves_permission:
    forall p n, permission (sub p n) = permission p.
  Proof. preserves_proof_add. Qed.

  Lemma sub_preserves_component:
    forall p n, component (sub p n) = component p.
  Proof. preserves_proof_add. Qed.

  Lemma sub_preserves_block:
    forall p n, block (sub p n) = block p.
  Proof. preserves_proof_add. Qed.

  Lemma inc_preserves_permission:
    forall p, permission (inc p) = permission p.
  Proof. preserves_proof_inc. Qed.

  Lemma inc_preserves_component:
    forall p, component (inc p) = component p.
  Proof. preserves_proof_inc. Qed.

  Lemma inc_preserves_block:
    forall p, block (inc p) = block p.
  Proof. preserves_proof_inc. Qed.

  Lemma compose :
    forall ptr,
      (permission ptr, component ptr, block ptr, offset ptr) = ptr.
  Proof.
    now intros [[[P C] b] o].
  Qed.
End Pointer.

(* Values. *)
Inductive value : Type :=
| Int : Z -> value
| Ptr : Pointer.t -> value
| Undef : value.

Definition is_ptr (v : value) : bool :=
  match v with
  | Ptr _ => true
  | _ => false
  end.

Definition eqvalue v1 v2 :=
  match v1, v2 with
  | Int z1, Int z2 => z1 == z2
  | Ptr p1, Ptr p2 => Pointer.eq p1 p2
  (* RB: TODO: From FG, however should Undef be equal to itself? *)
  | Undef, Undef => true
  | _, _ => false
  end.

Lemma eqvalueP : Equality.axiom eqvalue.
Proof.
  move; elim => [z1 | p1 |] [z2 | p2 |]//= ;
                 apply: (iffP idP); move => H; inversion H ; try constructor.
  by move: H => /Z.eqb_spec => H; rewrite H.
  done.
  by move: H => /Pointer.eqP => H; rewrite H.
  destruct p2 as [[[p C] b] o]. simpl.
  Locate "=?".
  rewrite Z.eqb_refl !Nat.eqb_refl !andbT.
    by apply /Permission.eqP.
Qed.

Definition value_eqMixin: Equality.mixin_of value := EqMixin eqvalueP.
Canonical value_eqType := Eval hnf in EqType value value_eqMixin.

(* Binary operations. *)
Inductive binop := Add | Minus | Mul | Eq | Leq.

Definition binop_eqb (op1 op2 : binop) : bool :=
  match op1, op2 with
  | Add, Add
  | Minus, Minus
  | Mul, Mul
  | Eq, Eq
  | Leq, Leq => true
  | _, _ => false
  end.

Lemma binopP : Equality.axiom binop_eqb.
Proof.
  intros [] []; by constructor.
Qed.

Definition binop_eqMixin: Equality.mixin_of binop := EqMixin binopP.
Canonical binop_eqType := Eval hnf in EqType binop binop_eqMixin.

Definition eval_binop (op : binop) (v1 v2 : value) : value :=
  match op, v1, v2 with
  (* natural numbers *)
  | Add,   Int n1, Int n2 => Int (n1 + n2)
  | Minus, Int n1, Int n2 => Int (n1 - n2)
  | Mul,   Int n1, Int n2 => Int (n1 * n2)
  | Eq,    Int n1, Int n2 => Int (Util.Z.of_bool (n1  =? n2)%Z)
  | Leq,   Int n1, Int n2 => Int (Util.Z.of_bool (n1 <=? n2)%Z)
  (* data-pointer arithmetic *)
  | Add,   Ptr p,  Int n  => Ptr (Pointer.add p n)
  | Add,   Int n,  Ptr p  => Ptr (Pointer.add p n)
  | Minus, Ptr p1, Ptr p2 => let '(P1, C1, b1, o1) := p1 in
                             let '(P2, C2, b2, o2) := p2 in
                             if (Permission.eqb P1 P2) && (Nat.eqb C1 C2) && (Nat.eqb b1 b2) then
                               Int (o1 - o2)
                             else
                               Undef
  | Minus, Ptr p,  Int n  => Ptr (Pointer.sub p n)
  | Eq,    Ptr p1, Ptr p2 => Int (Util.Z.of_bool (Pointer.eq p1 p2))
  | Leq,   Ptr p1, Ptr p2 => match Pointer.leq p1 p2 with
                             | Some res => Int (Util.Z.of_bool res)
                             | None     => Undef
                             end
  (* undefined operations *)
  | _,     _,       _       => Undef
  end.

Lemma eval_binop_ptr :
  forall op v1 v2 p,
    eval_binop op v1 v2 = Ptr p ->
    (exists p1 i1, ((v1 = Ptr p1 /\ v2 = Int i1) \/ (v2 = Ptr p1 /\ v1 = Int i1))
                /\
                Pointer.permission p = Pointer.permission p1 /\
                Pointer.component p = Pointer.component p1 /\
                Pointer.block p = Pointer.block p1
    ).
  intros op v1 v2 p Heval.
  unfold eval_binop in Heval.
  destruct op eqn:eop; destruct v1 eqn:e1; destruct v2 eqn:e2;
    try discriminate.
  - exists t. exists z. split.
    + right. intuition.
    + inversion Heval.
      split; last split.
      apply Pointer.add_preserves_permission.
      apply Pointer.add_preserves_component.
      apply Pointer.add_preserves_block.
  - exists t. exists z. split.
    + left. intuition.
    + inversion Heval.
      split; last split.
      apply Pointer.add_preserves_permission.
      apply Pointer.add_preserves_component.
      apply Pointer.add_preserves_block.
  - exists t. exists z. split.
    + left. intuition.
    + inversion Heval.
      split; last split.
      apply Pointer.sub_preserves_permission.
      apply Pointer.sub_preserves_component.
      apply Pointer.sub_preserves_block.
  - destruct t as [[[tp tc] tb] to].
    destruct t0 as [[[t0p t0c] t0b] t0o].
    destruct ((Permission.eqb tp t0p) && (tc =? t0c) && (tb =? t0b)); discriminate.
  - destruct (Pointer.leq t t0); discriminate.
Qed.

Lemma eval_binop_int :
  forall op v1 v2 i,
    eval_binop op v1 v2 = Int i ->
    (
      (exists i1 i2, v1 = Int i1 /\ v2 = Int i2)
      \/
      (exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2 /\ op = Eq)
      \/
      (exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2 /\
                     (
                       (op = Minus \/ op = Leq)
                       /\
                       (
                         Pointer.permission p1 = Pointer.permission p2 /\
                         Pointer.component p1 = Pointer.component p2 /\
                         Pointer.block p1 = Pointer.block p2
                       )
                     )
      )
    ).
Proof.
  intros op v1 v2 p Heval.
  unfold eval_binop in Heval.
  destruct op eqn:eop;
    destruct v1 as [i1 | [[[perm1 cid1] bid1] off1] |] eqn:e1;
    destruct v2 as [i2 | [[[perm2 cid2] bid2] off2] |] eqn:e2;
    try discriminate.
  - left; do 2 eexists; intuition.
  - left; do 2 eexists; intuition.
  - destruct ((Permission.eqb perm1 perm2) && (cid1 =? cid2) && (bid1 =? bid2)) eqn:Heq;
      try discriminate.
    assert (perm1 = perm2 /\ cid1 = cid2 /\ bid1 = bid2) as [H1 [H2 H3]]; subst.
    {
      pose proof andb_prop _ _ Heq as [Heq' H3].
      pose proof andb_prop _ _ Heq' as [H1 H2].
      intuition;
        try by apply beq_nat_true.
        by move: H1 => /Permission.eqP.
    }
    right; right; do 2 eexists; eauto; intuition.
  - left; do 2 eexists; intuition.
  - left; do 2 eexists; intuition.
  - unfold Pointer.eq in *.
    right; left; do 2 eexists; eauto; intuition; discriminate.
  - left; do 2 eexists; intuition.
  - unfold Pointer.leq in *.
    destruct ((Permission.eqb perm1 perm2) && (cid1 =? cid2) && (bid1 =? bid2)) eqn:Heq;
      try discriminate.
    assert (perm1 = perm2 /\ cid1 = cid2 /\ bid1 = bid2) as [H1 [H2 H3]]; subst.
    {
      pose proof andb_prop _ _ Heq as [Heq' H3].
      pose proof andb_prop _ _ Heq' as [H1 H2].
      intuition;
        try by apply beq_nat_true.
        by move: H1 => /Permission.eqP.
    }
    right; right; do 2 eexists; eauto; intuition.
Qed.

Lemma eval_binop_undef :
  forall op v1 v2,
    eval_binop op v1 v2 = Undef ->
    (
      v1 = Undef
      \/
      v2 = Undef
      \/
      (op = Mul /\ exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2)
      \/
      (op = Add /\ exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2)
      \/
      (op <> Add /\ exists i p, v1 = Int i /\ v2 = Ptr p)
      \/
      (op <> Add /\ op <> Minus /\ exists i p, v1 = Ptr p /\ v2 = Int i)
      \/
      (op = Leq /\ exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2 /\
                                 Permission.eqb (Pointer.permission p1) (Pointer.permission p2) = false)
      \/
      (op = Minus /\ exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2 /\
                                 Permission.eqb (Pointer.permission p1) (Pointer.permission p2) = false)
      \/
      (op = Leq /\ exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2 /\
                                 Pointer.component p1 =? Pointer.component p2 = false)
      \/
      (op = Minus /\ exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2 /\
                                 Pointer.component p1 =? Pointer.component p2 = false)
      \/
      (op = Leq /\ exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2 /\
                                 Pointer.block p1 =? Pointer.block p2 = false)
      \/
      (op = Minus /\ exists p1 p2, v1 = Ptr p1 /\ v2 = Ptr p2 /\
                                 Pointer.block p1 =? Pointer.block p2 = false)
    ).
Proof.
  intros op v1 v2 Heval.
  unfold eval_binop in Heval.
  destruct op eqn:eop;
    destruct v1 as [i1 | [[[perm1 cid1] bid1] off1] |] eqn:e1;
    destruct v2 as [i2 | [[[perm2 cid2] bid2] off2] |] eqn:e2;
    try discriminate; intuition.
  (* 11 subgoals remain. *)
  - do 3 right. left. intuition. by do 2 eexists.
  - do 4 right. left. intuition; try discriminate. by do 2 eexists.
  - destruct ((Permission.eqb perm1 perm2) && (cid1 =? cid2) && (bid1 =? bid2)) eqn:Hvalid;
      try discriminate.
    apply andb_false_iff in Hvalid as [H1 | H2].
    + apply andb_false_iff in H1 as [H1 | H2].
      * do 7 right; left; intuition; by do 2 eexists.
      * do 9 right; left; intuition; by do 2 eexists.
    + do 11 right; intuition; by do 2 eexists.
  - do 4 right. left. intuition; try discriminate. by do 2 eexists.
  - do 5 right. left. intuition; try discriminate. by do 2 eexists.
  - do 2 right. left. intuition. by do 2 eexists.
  - do 4 right. left. intuition; try discriminate. by do 2 eexists.
  - do 5 right. left. intuition; try discriminate. by do 2 eexists.
  - do 4 right. left. intuition; try discriminate. by do 2 eexists.
  - do 5 right. left. intuition; try discriminate. by do 2 eexists.
  - unfold Pointer.leq in Heval.
    destruct ((Permission.eqb perm1 perm2) && (cid1 =? cid2) && (bid1 =? bid2)) eqn:Hvalid;
      try discriminate.
    apply andb_false_iff in Hvalid as [H1 | H2].
    + apply andb_false_iff in H1 as [H1 | H2].
      * do 6 right; left; intuition; by do 2 eexists.
      * do 8 right; left; intuition; by do 2 eexists.
    + do 10 right; left; intuition; by do 2 eexists.
Qed.

Lemma eval_binop_op1_Undef:
  forall op v, eval_binop op Undef v = Undef.
Proof. by destruct op; auto.
Qed.

Lemma eval_binop_op2_Undef:
  forall op v, eval_binop op v Undef = Undef.
Proof. by destruct op; destruct v; auto.
Qed.

(* RB: TODO: Where should this go? Probably not values
   NOTE: It may be good to give the buffer type an explicit definition. *)
Module Buffer.
  Definition t : Type := nat + list value.

  Definition nth_error (buf : (nat + list value)) (i : Z) : option value :=
    let read (i : nat) : option value :=
        match buf with
        | inl n => if i <? n then Some Undef else None
        | inr vs => List.nth_error vs i
        end
    in
    match i with
    | Zpos n => read (Pos.to_nat n)
    | Z0 => read 0
    | Zneg _ => None
    end.

  Definition well_formed_buffer (buf : (nat + list value)) : bool :=
    match buf with
    | inl n => 0 <? n
    | inr vs => (0 <? seq.size vs) && seq.all (fun v => ~~is_ptr v) vs
    end.

  Definition well_formed_buffer_opt (buf : option (nat + list value)) : bool :=
    match buf with
    | Some buf => well_formed_buffer buf
    | _ => true
    end.
End Buffer.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Logic.Classical_Pred_Type.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.Semantics.Trivial.
Require Import Logic.MinimunLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Trivial.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Trivial.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section TruthLemma.

Context {L: Language}
        {minL: MinimunLanguage L}
        {pL: PropositionalLanguage L}
        {Gamma: ProofTheory L}
        {bSC: BasicSequentCalculus L Gamma}
        {minSC: MinimunSequentCalculus L Gamma}
        {ipSC: IntuitionisticPropositionalSequentCalculus L Gamma}
        {cpSC: ClassicalPropositionalSequentCalculus L Gamma}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {SM: Semantics L MD}
        {tminSM: TrivialMinimunSemantics L MD SM}
        {tpSM: TrivialPropositionalSemantics L MD SM}.

Context (cP: context -> Prop)
        (rel: bijection (Kworlds M) (sig cP)).

Context (AL_MC: at_least (maximal consistent) cP).

Lemma truth_lemma_falsep:
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= falsep <-> proj1_sig Phi falsep).
Proof.
  intros.
  rewrite sat_falsep.
  pose proof proj2_sig Phi.
  pose proof proj1 (AL_MC _ H0).
  rewrite consistent_spec in H1.
  split; [intros [] |].
  intro; apply H1.
  apply derivable_assum; auto.
Qed.

Lemma truth_lemma_andp
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x && y <-> proj1_sig Phi (x && y)).
Proof.
  intros.
  rewrite sat_andp.
  rewrite MCS_andp_iff by (apply AL_MC, (proj2_sig Phi)).
  apply Morphisms_Prop.and_iff_morphism; auto.
Qed.

Lemma truth_lemma_orp
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x || y <-> proj1_sig Phi (x || y)).
Proof.
  intros.
  rewrite sat_orp.
  rewrite MCS_orp_iff by (apply AL_MC, (proj2_sig Phi)).
  apply Morphisms_Prop.or_iff_morphism; auto.
Qed.

Lemma truth_lemma_impp
      (x y: expr)
      (IHx: forall m Phi, rel m Phi -> (KRIPKE: M, m |= x <-> proj1_sig Phi x))
      (IHy: forall m Phi, rel m Phi -> (KRIPKE: M, m |= y <-> proj1_sig Phi y)):
  forall m Phi, rel m Phi -> (KRIPKE: M, m |= x --> y <-> proj1_sig Phi (x --> y)).
Proof.
  intros.
  rewrite sat_impp.
  rewrite MCS_impp_iff by (apply AL_MC, (proj2_sig Phi)).
  apply Morphisms_Prop.iff_iff_iff_impl_morphism; auto.
Qed.

End TruthLemma.


Add LoadPath "../from_compcert".

Require Import AST.
Require Import Memory.
(*Require Import Values.*)
Require Import Maps.
Require Import NArith.
Require Import ZArith.
Require Import List.
Require Import Program.
Require Import Coqlibext.
Require Import ArithClasses.
Require Import Integers.
Require Import ClassesAndNotations.
Require Import Do_notation.
Require Import Psatz.
Require Import CeildFloord.
Open Scope numerical_scope.

Set Implicit Arguments.

(* some stuff used in several modules *)
Module Tools (N:NUMERICAL).
  Import N.
  Existing Instance Numerical_Num.
  Open Scope numerical_scope.
  Notation "'NVector'" := (Vector Num).
  Notation "'NMatrix'" := (Matrix Num).
  Section NBRPARAMS.
    (* number of global parameters of a program *)
  Variable nbr_global_parameters: nat.
  Definition Global_Parameters := NVector nbr_global_parameters.
  Variable global_params: Global_Parameters.
  (* the outer iterators (say k ::: j ::: i) *)
  Definition Iterators depth := NVector depth.
  (* an extended context (say 1 ::: k ::: j ::: i ::: params) *)
  Definition Context global_depth :=
    NVector global_depth.
  Definition Context_ext global_depth :=
    NVector (S global_depth).
  Definition extend_context {global_depth} (ctxt: Context global_depth)
    : Context_ext global_depth := 1 ::: ctxt.
(*  Definition make_context_ext {depth} (iters:Iterators depth):
    Context_ext depth := 1 ::: (iters +++ global_params).*)
  (* the arguments of an instruction, obtain from the extended
     environment multiplied by the matrix *)
  Definition Arguments n := NVector n.
  Definition Arguments_ext n := NVector (S n).
  Definition extend_arguments {n} (args: Arguments n):
    Arguments_ext n := 1 ::: args.
  (* translate_locs takes an extended arguments and a list of read locs and build
     a cell_id *)
  Definition translate_locs {csi} (ectxt: Arguments_ext csi)
    (p: Array_Id * list (NVector (S csi))): Cell_Id Num:=
    {| array := fst p;
       cell := List.map (fun v =>〈v, ectxt〉) (snd p)|}.
  End NBRPARAMS.
  Definition bound global_depth :=
    not_empty_list (Num * (NVector (S (global_depth)))).

  Definition bound_to_not_emptyNum global_depth (b: bound global_depth):
    not_empty_list (Num * NVector (S global_depth)):=
    b.

  Global Coercion bound_to_not_emptyNum: bound >-> not_empty_list.

  (* those two definitions are part of the TCB (they define the
     semantics of Loop), but they are far from being trivially
     correct. They are, nevertheless, proved for Num = Z below *)

  Definition eval_lower_bound {global_depth}
    (ctxt : Context global_depth)
    (lower_bound: bound global_depth) :=
    let ectx := extend_context ctxt in
    do l <- not_empty_mmap (fun p: (Num * (NVector (S global_depth))) =>
        let (k, v) := p in Aceild 〈ectx, v〉 k) lower_bound;
    Some (Amax_list l).

  Definition eval_upper_bound {global_depth}
    (ctxt : Context global_depth)
    (upper_bound: bound global_depth) :=
    let ectx := extend_context ctxt in
    do l <- not_empty_mmap (fun p: (Num * (NVector (S global_depth))) =>
        let (k, v) := p in Afloord 〈ectx, v〉 k) upper_bound;
    Some (Amin_list l).
End Tools.

Module ZTools := Tools(ZNum).
Import ZTools.

(*Definition bound_to_not_emptyZNum global_depth (b: bound global_depth):
  not_empty_list (ZNum.Num * NVector (S global_depth)):=
  b.

Coercion bound_to_not_emptyZNum: bound >-> not_empty_list.

Definition bound_to_not_emptyZ global_depth (b: bound global_depth):
  not_empty_list (Z * NVector (S global_depth)):=
  b.

Coercion bound_to_not_emptyZ: bound >-> not_empty_list.*)

Section GLOBALDEPTH.
  Open Scope Z_scope.
  Context {nbr_params: nat}.

  Local Notation "'bound'" := (bound nbr_params).
  Implicit Types b lb ub: bound.

  Definition bound_constr_correct (bc: ZNum.Num * NVector (S nbr_params))
    := 0 < fst bc.
  Hint Unfold bound_constr_correct: autounfold.

  Program Definition check_bound_constr
    (bc: ZNum.Num * NVector (S nbr_params)) :
    { bound_constr_correct bc }+
    { ~bound_constr_correct bc } :=
    match fst bc with
      | Zpos _ => left _
      | Z0 => right _
      | Zneg _ => right _
    end.
    Next Obligation.
      unfold*; simpl in *; subst; compute; reflexivity.
    Qed.
    Next Obligation.
      unfold *; simpl in *; subst; compute; intro; congruence.
    Qed.
    Next Obligation.
      unfold *; simpl in *; subst; compute; intro; congruence.
    Qed.

  Definition bound_correct (bnd: bound) :=
    list_forall bound_constr_correct bnd.
  Hint Unfold bound_correct: autounfold.

  Definition check_bound (bnd: bound)
    : {bound_correct bnd} +
      {~ bound_correct bnd} :=
    list_forall_dec check_bound_constr bnd.

  (* under a certain environment, z is greater or equal than the constraint,

     (used when talking about lower_bound )
     *)
  Definition ge_bound_constraint (ectxt: Context_ext nbr_params)
    (z:Z) (constr: Z * NVector (S nbr_params)) :=
    let (x, v) := constr in
    〈ectxt, v〉<= x * z.

  Lemma gt0_ge0: forall z, 0 < z -> 0 <= z.
  Proof. intros. lia. Qed.
  Hint Resolve gt0_ge0.

  Lemma ge_bound_constraint_trans (ectxt: Context_ext nbr_params)
    (constr: Z * NVector (S nbr_params)) (z1 z2:Z):
    bound_constr_correct constr ->
    z1 <= z2 ->
    ge_bound_constraint ectxt z1 constr -> ge_bound_constraint ectxt z2 constr.
  Proof.
    unfold*.
    unfold ge_bound_constraint. destruct constr. simpl.
    intros.
    assert (z * z1 <= z * z2).
    apply Zmult_le_compat_l; auto. simpl in *; omega.
  Qed.

  (* under a certain environment, z is lower or equal than the constraint

     for upper bounds *)
  Definition le_bound_constraint (ectxt: Context_ext nbr_params)
    (z:Z) (constr: Z * NVector (S nbr_params)) :=
    let (x, v) := constr in
    x * z <= 〈ectxt, v〉.

  Lemma le_bound_constraint_trans (ectxt: Context_ext nbr_params)
    (constr: Z * NVector (S nbr_params)) (z1 z2:Z):
    bound_constr_correct constr ->
    z2 <= z1 ->
    le_bound_constraint ectxt z1 constr -> le_bound_constraint ectxt z2 constr.
  Proof.
    unfold le_bound_constraint. destruct constr. simpl.
    intros.
    assert (z * z2 <= z * z1)%Z.
    apply Zmult_le_compat_l; auto. omega.
  Qed.

  Definition ge_bound (ctxt: Context nbr_params)
    (lower_bound: bound) z : Prop :=
    let ectxt := extend_context ctxt in
    list_forall (ge_bound_constraint ectxt z) lower_bound.

  Lemma ge_bound_trans (ctxt: Context nbr_params)
    (lower_bound: bound) z1 z2:
    bound_correct lower_bound ->
    z1 <= z2 ->
    ge_bound ctxt lower_bound z1 -> ge_bound ctxt lower_bound z2.
  Proof.
    unfold ge_bound. unfold *.
    destruct lower_bound as (hd, tl). simpl.
    remember (hd:: tl) as l. clear Heql hd tl.
    induction l; intros; auto.
    inv H1. inv H.
    constructor; eauto using @ge_bound_constraint_trans.
  Qed.

  Definition le_bound (ctxt: Context nbr_params)
    (upper_bound: bound) z : Prop :=
    let ectxt := extend_context ctxt in
    list_forall (le_bound_constraint ectxt z) upper_bound.

  Lemma le_bound_trans (ctxt: Context nbr_params)
    (upper_bound: bound) z1 z2:
    bound_correct upper_bound ->
    z2 <= z1 ->
    le_bound ctxt upper_bound z1 -> le_bound ctxt upper_bound z2.
  Proof.
    unfold le_bound. unfold *.
    destruct upper_bound as (hd, tl). simpl.
    remember (hd:: tl) as l. clear Heql hd tl.
    induction l; intros; auto.
    inv H1. inv H.
    constructor; eauto using @le_bound_constraint_trans.
  Qed.

  (* to lib *)
  Lemma not_empty_mmap_option {C D} (f: C -> option D)
    (nl1: not_empty_list C) (nl2: not_empty_list D):
    not_empty_mmap f nl1 = Some nl2 ->
    list_forall2 (fun d od => Some d = od) nl2 (map f nl1).
  Proof.
    unfold not_empty_mmap. intros.
    destruct nl1 as (hd1, tl1). prog_dos.
    simpl. constructor; auto using @mmap_option.
  Qed.

  (* the result of eval_lower_bound in in the set of value satisfying
     ge_bound *)

  Lemma eval_lower_bound_is_ge (ctxt: Context nbr_params)
    (lower_bound: bound) z:
    eval_lower_bound ctxt lower_bound = Some z ->
    ge_bound ctxt lower_bound z.
  Proof.
    intro EVAL_LOWER.
    unfold eval_lower_bound in EVAL_LOWER.
    prog_do; clean. apply not_empty_mmap_option in Heq_do.

    unfold ge_bound.
    simpl in *.
    destruct lower_bound as (hd_lb, tl_lb).
    simpl in *.
    inv Heq_do. destruct l as (hd_l, tl_l); simpl in *. clean. inv H.
    pose proof (Amax_list_ge_forall (hd_l, tl_l)).

    remember (Amax_list (hd_l, tl_l)) as amax. clear Heqamax.
    inv H.
    constructor.
    Case "head".
      unfold ge_bound_constraint. destruct hd_lb. simpl.
      eapply ceildZ_bound2; eauto.
    Case "tail".
      clear dependent hd_l.
      revert dependent tl_l.
      revert dependent tl_lb.
      induction' tl_lb as [|hd tl]; simpl; intros; clean; auto.
      SCase "cons hd tl".
        inv H3. inv H5. clean.
        constructor.
        SSCase "head".
          unfold ge_bound_constraint. destruct hd. simpl.
          eapply ceildZ_bound2; eauto.
        SSCase "tl".
          eapply IHtl; eauto.
  Qed.

  Lemma eval_lower_bound_bound_correct (ctxt: Context nbr_params)
    (lower_bound: bound) z:
    eval_lower_bound ctxt lower_bound = Some z ->
    bound_correct lower_bound.
  Proof.
    unfold *.
    intro H.
    unfold eval_lower_bound in H.
    prog_do; clean.
    apply not_empty_mmap_option in Heq_do.
    destruct lower_bound. destruct l. simpl in *.
    inv Heq_do.
    constructor.
    Case "head".
      destruct p; simpl in *. clean.
      unfold ceildZ in H2; destruct n0; clean.
    Case "tail".
      revert dependent l. clear H2.
      induction' l0; intros; eauto.
      simpl in *. inv H4.
      constructor; eauto.
      destruct a; simpl in *; clean; unfold ceildZ in *. destruct n0; clean.
  Qed.

  Lemma bound_correct_eval_lower_bound_is_some (ctxt: Context nbr_params)
    (lower_bound: bound):
    bound_correct lower_bound ->
    is_some (eval_lower_bound ctxt lower_bound).
  Proof.
    unfold *.
    intro H.
    unfold eval_lower_bound.
    match goal with
      | |- context[not_empty_mmap ?f ?l] =>
        assert (is_some (not_empty_mmap f l))
    end.
      apply not_empty_mmap_is_some.
      eapply list_forall_imply; [|eauto].
      intros. simpl.
      destruct a as ([|?|?],?); simpl in *; auto; compute in H0; inv H0.
    inv H0. simpl.
    rewrite <- H2. simpl_do; auto.
  Qed.

  (* the result of eval_lower_bound is the smallest of the set of
     value satisfying ge_bound *)

  Lemma ge_bound_ge_lower_bound (ctxt: Context nbr_params)
    (lower_bound: bound) z:
    eval_lower_bound ctxt lower_bound = Some z ->
    forall x, ge_bound ctxt lower_bound x -> z <= x.
  Proof.
    intro EVAL_LOWER.
    unfold eval_lower_bound in EVAL_LOWER.
    prog_do; clean. apply not_empty_mmap_option in Heq_do.

    unfold ge_bound.
    simpl in *.
    destruct lower_bound as (hd_lb, tl_lb).
    simpl in *.
    inv Heq_do. destruct l as (hd_l, tl_l); simpl in *. clean. inv H.

    intros x LFL.
    pose proof (@ge_forall_ge_Amax_list _ _ (hd_l, tl_l)) as GAGAL. simpl in GAGAL. apply GAGAL.
    clear GAGAL.
    inv LFL.

    constructor.
    Case "head".
      unfold ge_bound_constraint in H1.
      destruct hd_lb. simpl in *.
      eapply ceildZ_bound1 in H1; eauto.
    Case "tail".
      simpl.
      clear dependent hd_l. clear dependent hd_lb.
      revert dependent tl_l.
      revert dependent tl_lb.
      induction' tl_lb as [|hd tl]; simpl in *; intros; clean; auto.
      SCase "nil".
        inv H3. constructor.
      SCase "cons hd tl".
        inv H3. inv H4. clean.
        constructor.
        SSCase "head".
          unfold ge_bound_constraint in H1.
          destruct hd. simpl in *.
          eapply ceildZ_bound1 in H1; eauto.
        SSCase "tail".
          eapply IHtl; eauto.
  Qed.

  (* this is the important proof that eval_lower_bound is not absurd *)
  Theorem ge_bound_equiv_eval_lower_bound (ctxt: Context nbr_params)
    (lower_bound: bound) z:
    eval_lower_bound ctxt lower_bound = Some z ->
    forall x, ge_bound ctxt lower_bound x <-> z <= x.
  Proof.
    intros.
    split.
    apply ge_bound_ge_lower_bound; auto.
    intros.
    assert (ge_bound ctxt lower_bound z) by
      (eapply eval_lower_bound_is_ge; eauto).
    eapply ge_bound_trans; eauto.
    eapply list_forall_imply;[|eapply eval_lower_bound_bound_correct; eauto].
    unfold *.
    simpl; intros; lia.
  Qed.

  Lemma eval_upper_bound_is_ge (ctxt: Context nbr_params)
    (upper_bound: bound) z:
    eval_upper_bound ctxt upper_bound = Some z ->
    le_bound ctxt upper_bound z.
  Proof.
    intro EVAL_UPPER.
    unfold eval_upper_bound in EVAL_UPPER.
    prog_do; clean. apply not_empty_mmap_option in Heq_do.

    unfold le_bound.
    simpl in *.
    destruct upper_bound as (hd_ub, tl_ub).
    simpl in *.
    inv Heq_do. destruct l as (hd_l, tl_l); simpl in *. clean. inv H.
    pose proof (Amin_list_le_forall (hd_l, tl_l)).

    remember (Amin_list (hd_l, tl_l)) as amin. clear Heqamin.
    inv H.
    constructor.
    Case "head".
      unfold le_bound_constraint. destruct hd_ub. simpl.
      eapply floordZ_bound2; eauto.
    Case "tail".
      clear dependent hd_l.
      revert dependent tl_l.
      revert dependent tl_ub.
      induction' tl_ub as [|hd tl]; simpl; intros; clean; auto.
      SCase "cons hd tl".
        inv H3. inv H5. clean.
        constructor.
        SSCase "head".
          unfold le_bound_constraint. destruct hd. simpl.
          eapply floordZ_bound2; eauto.
        SSCase "tl".
          eapply IHtl; eauto.
  Qed.

  Lemma le_bound_le_upper_bound (ctxt: Context nbr_params)
    (upper_bound: bound) z:
    eval_upper_bound ctxt upper_bound = Some z ->
    forall x, le_bound ctxt upper_bound x -> x <= z.
  Proof.
    intro EVAL_UPPER.
    unfold eval_upper_bound in EVAL_UPPER.
    prog_do; clean. apply not_empty_mmap_option in Heq_do.

    unfold le_bound.
    simpl in *.
    destruct upper_bound as (hd_ub, tl_ub).
    simpl in *.
    inv Heq_do. destruct l as (hd_l, tl_l); simpl in *. clean. inv H.

    intros x LFL.
    pose proof (@le_forall_le_Amin_list _ _ (hd_l, tl_l)) as LALAL. simpl in LALAL. apply LALAL.
    clear LALAL.
    inv LFL.

    constructor.
    Case "head".
      unfold le_bound_constraint in H1.
      destruct hd_ub. simpl in *.
      eapply floordZ_bound1 in H1; eauto.
    Case "tail".
      simpl.
      clear dependent hd_l. clear dependent hd_ub.
      revert dependent tl_l.
      revert dependent tl_ub.
      induction' tl_ub as [|hd tl]; simpl in *; intros; clean; auto.
      SCase "nil".
        inv H3. constructor.
      SCase "cons hd tl".
        inv H3. inv H4. clean.
        constructor.
        SSCase "head".
          unfold le_bound_constraint in H1.
          destruct hd. simpl in *.
          eapply floordZ_bound1 in H1; eauto.
        SSCase "tail".
          eapply IHtl; eauto.
  Qed.

  Lemma eval_upper_bound_bound_correct (ctxt: Context nbr_params)
    (upper_bound: bound) z:
    eval_upper_bound ctxt upper_bound = Some z ->
    bound_correct upper_bound.
  Proof.
    unfold *.
    intro H.
    unfold eval_upper_bound in H.
    prog_do; clean.
    apply not_empty_mmap_option in Heq_do.
    destruct upper_bound. destruct l. simpl in *.
    inv Heq_do.
    constructor.
    Case "head".
      destruct p; simpl in *. clean.
      unfold floordZ in H2; destruct n0; clean.
    Case "tail".
      revert dependent l. clear H2.
      induction' l0; intros; eauto.
      simpl in *. inv H4.
      constructor; eauto.
      destruct a; simpl in *; clean; unfold floordZ in *. destruct n0; clean.
  Qed.

  Lemma bound_correct_eval_upper_bound_is_some (ctxt: Context nbr_params)
    (upper_bound: bound):
    bound_correct upper_bound ->
    is_some (eval_upper_bound ctxt upper_bound).
  Proof.
    unfold *.
    intro H.
    unfold eval_upper_bound.
    match goal with
      | |- context[not_empty_mmap ?f ?l] =>
        assert (is_some (not_empty_mmap f l))
    end.
      apply not_empty_mmap_is_some.
      eapply list_forall_imply; [|eauto].
      intros. simpl.
      destruct a as ([|?|?],?); simpl in *; auto; compute in H0; inv H0.
    inv H0. simpl.
    rewrite <- H2. simpl_do; auto.
  Qed.

  Lemma le_bound_equiv_eval_upper_bound (ctxt: Context nbr_params)
    (upper_bound: bound) z:
    eval_upper_bound ctxt upper_bound = Some z ->
    forall x, le_bound ctxt upper_bound x <-> x <= z.
  Proof.
    intros.
    split.
    apply le_bound_le_upper_bound; auto.
    intros.
    assert (le_bound ctxt upper_bound z) by
      (eapply eval_upper_bound_is_ge; eauto).
    eapply le_bound_trans; eauto.
    eapply list_forall_imply;[|eapply eval_upper_bound_bound_correct; eauto].
    unfold*.
    simpl; intros; lia.
  Qed.

End GLOBALDEPTH.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier FunctionalExtensionality Psatz.
Require Import Coq.omega.Omega.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.
Global Set Bullet Behavior "Strict Subproofs".

Section rec_convert_unary.
Variable X: eqType.
Variable size: X → R.
Variable A A' B : X → finType.
Variable ΩT: ∀ x, distrib (A x).
Variable ΩT': ∀ x, distrib (A' x).
Variable Ωh: ∀ x, distrib (B x).
Variable T: ∀ x: X, rrvar (ΩT x).
Variable T': ∀ x: X, rrvar (ΩT' x).
Variable h: ∀ x: X, rvar (Ωh x) X.
Variable P: X → Prop.
Variable hP: ∀ x n, P x → P  ((h x) n).
Variable G: R → R.
Variable a: R → R.

Lemma eq_dist_unary_rec_gt:
  (∀ z, P z → eq_dist (T' z) (T z)) →
  (∀ z r, P z → pr_gt (T z) r <= \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_gt (rvar_comp (T (sval x')) G) (r - a (size z))))
                        →
  ∀ z r,
  P z →
  pr_gt (T' z) r <= \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_gt (rvar_comp (T' (sval x')) G) (r - a (size z))).
Proof.
  intros Heq_dist Hrec z r HP. rewrite (proj1 (eq_dist_pr_gt _ _) (Heq_dist _ HP)).
  etransitivity; first apply Hrec; auto.
  right.
  apply eq_bigr => i ?. f_equal.
  apply (proj1 (eq_dist_pr_gt (rvar_comp (T (sval i)) G)
                                 (rvar_comp (T' (sval i)) G))).
  apply: eq_dist_comp.
  intros r'.
  rewrite ?Heq_dist //.
  destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
  destruct Hin as (x&<-). by apply hP.
Qed.

Variable Trec:
  ∀ x r, P x → pr_eq (T x) r = \big[Rplus/0]_(x' : imgT (h x))
                        (pr_eq (h x) (sval x') * pr_eq (rvar_comp (T (sval x')) G)
                                                       (r - a (size x))).

Lemma img_Trec_unary b z x:
  P z →
  pr_eq (rvar_comp (T x) G) b ≠ 0 →
  x \in img (h z) →
  pr_eq (h z) x ≠ 0 →
  b + a (size z) \in img (T z).
Proof.
  intros HP Hneq0 Hin Hneq0'. apply pr_img.
  specialize (Rmult_neq_0_compat _ _ Hneq0 Hneq0'). intros.
  enough (Hneq: pr_eq (T z) (b + a (size z)) ≠ 0).
  { move:Hneq. rewrite /pr_eq.
    intros. edestruct (ge_pr_0 (rvar_dist (T z))) as [|Heq0]; first eauto.
    rewrite Heq0 in Hneq. congruence. }
  rewrite Trec; last done.
  intros Hfalse.
  symmetry in Hfalse.
  enough (Hfalse': ∀ x', x' \in img (h z) → pr_eq (h z) x' *
                  (pr_eq (rvar_comp (T x') G)
                     (b + a (size z) - a (size z))) = 0).
  { specialize (Hfalse' x). move:Hfalse'.
    rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r.
    rewrite Rmult_comm. auto.
  }
  intros x' Hin'. edestruct (Req_dec) as [Heq|Hneq]; first apply Heq.
  exfalso. eapply Rlt_not_eq; last apply Hfalse.
  apply Rlt_0_bigr.
  - intros. replace 0 with (0 * 0) by nra. apply Rmult_le_compat; try nra.
    * apply Rge_le, ge_pr_0.
    * apply Rge_le, ge_pr_0.
  - exists (exist _ x' Hin'); repeat split; auto.
    rewrite //=.
    specialize (pr_eq_ge_0 (h z) x').
    specialize (pr_eq_ge_0 (rvar_comp (T x') G)
                           (b + a (size z) - a (size z))).
    clear -Hneq. rewrite //=. intros ??.  rewrite //= in Hneq. nra.
Qed.

Lemma eq_dist_unary_rec:
  (∀ z, P z → eq_dist (T' z) (T z)) →
  ∀ z r,
  P z →
  pr_eq (T' z) r = \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_eq (rvar_comp (T' (sval x')) G) (r - a (size z))).
Proof.
  intros Heq_dist z r HP. rewrite Heq_dist // Trec //.
  apply eq_bigr => i ?. f_equal.
  apply: eq_dist_comp.
  intros r'.
  rewrite ?Heq_dist //.
  destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
  destruct Hin as (x&<-). by apply hP.
Qed.

Lemma rec_pr_rec_gt_unary z r:
  P z →
  pr_gt (T z) r ≤ \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') *
                         pr_gt (rvar_comp (T (sval x')) G) (r - a (size z))).
Proof.
  rewrite /pr_gt pr_gt_alt3.
  etransitivity.
  { right. eapply eq_bigr => ? _. by apply Trec. }
  rewrite //=.
  rewrite exchange_big //=.
  apply Rle_bigr => x'.
  rewrite -big_distrr //=.
  set (Trec' := rvar_comp (T (sval x')) G);
    rewrite -/Trec'.
  transitivity (pr_eq (h z) (sval x') *
                \big[Rplus/0]_(i : imgT (A:=A z) (T z)
                              | (Rgt_dec (sval i) r) && (pr_eq Trec' ((sval i) - a (size z)) != 0))
                 pr_eq Trec' ((sval i) - a (size z))).
  {
    right. symmetry.
    eapply Rmult_eq_0_inv_r => Hneq //=. rewrite /index_enum.
    apply (@sum_reidx_map  [finType of imgT (T z)] _ _ _ _ _ (λ x, x)); auto.
    - rewrite /id //=. intros ??. move/andP=>[? ?].
      split; auto. rewrite mem_filter. apply /andP.
      split; auto.
    - intros b Hin' HQ Hfalse.
      case (Req_dec (pr_eq Trec' (sval b - a (size z))) 0); auto.
      intros Hneq0. exfalso. eapply Hfalse.
      exists b. rewrite mem_filter in Hin'. move /andP in Hin'. destruct Hin' as [-> ->].
      split; auto. rewrite //=. split; auto.
      move: Hneq0. move /eqP => -> //.
    - rewrite -enumT. apply enum_uniq.
    - rewrite -enumT. apply filter_uniq => //=. apply: enum_uniq.
  }
  transitivity (pr_eq (h z) (sval x') * pr_gt Trec' (r - a (size z))).
  {
    right.
    eapply Rmult_eq_0_inv_r => Hneq.
    rewrite /pr_gt. rewrite pr_gt_alt3.
    rewrite -(big_map sval (λ x, (Rgt_dec x r) && (pr_eq _ (x - _) != 0))
                           (λ i, pr_eq Trec' (i - a (size z)))).
    rewrite -(big_map sval (λ x, true) (λ i, pr_eq Trec' i)).
    eapply (@sum_reidx_map _ _ _ _ _ _ (λ x, x - a (size z))); auto.
    - intros a0 ?. move/andP => [Hgt HPr]. split; last done.
      move:Hgt. intros Hlt'.
      rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
      rewrite mem_filter. apply /andP. split.
      ** rewrite //=. do 2 destruct (Rgt_dec) => //=; nra.
      ** apply /mapP.
           assert (Hpf: a0 - a (size z) \in img Trec').
           { apply pr_img. edestruct (ge_pr_0 (rvar_dist Trec')) as [Hgt|Heq]; first apply Hgt.
             move /eqP in HPr. rewrite /pr_eq in HPr. rewrite //= in Heq. }
           exists (exist _ (a0 - a (size z)) Hpf); last by done.
           rewrite [Finite.enum]unlock //=. apply img_fin_mem.
  - intros b.
    rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
    rewrite mem_filter.  move /andP =>[Hgt Hin'] _ Hfalse.
    case (Req_dec (pr_eq Trec' b) 0); auto.
    intros Hneq'.
    exfalso; apply Hfalse.
    exists (b + a (size z)).
    repeat split.
    * assert (b + a (size z) \in img (T z)) as Hin.
      { eapply img_Trec_unary; eauto. destruct x'; auto. }
      rewrite -mem_undup. rewrite img_alt'.
      exists (exist _ (b + a (size z)) Hin).
      rewrite //=.
    * apply /andP; split.
      ** do 2 destruct (Rgt_dec) => //=. nra.
      ** rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply /eqP. done.
    * rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply /eqP. done.
  - rewrite /index_enum//=. rewrite [Finite.enum]unlock //= img_fin_enum_sval_comp.
    apply undup_uniq.
  - rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
    apply filter_uniq. rewrite /index_enum//=.
    rewrite [Finite.enum]unlock //= img_fin_enum_sval_comp.
    apply undup_uniq.
  - intros ??. intros. nra.
  }
  apply Rmult_le_compat_l; first by apply Rge_le, ge_pr_0.
  rewrite /Trec'//=. reflexivity.
Qed.

End rec_convert_unary.

Section rec_convert.
Variable X: eqType.
Variable size: X → R.
Variable A A' B : X → finType.
Variable ΩT: ∀ x, distrib (A x).
Variable ΩT': ∀ x, distrib (A' x).
Variable Ωh: ∀ x, distrib (B x).
Variable T: ∀ x: X, rrvar (ΩT x).
Variable T': ∀ x: X, rrvar (ΩT' x).
Variable h: ∀ x: X, rvar (Ωh x) [eqType of X * X]%type.
Variable P: X → Prop.
Variable hP: ∀ x n, P x → P (fst ((h x) n)) ∧ P (snd ((h x) n)).
Variable G: R * R → R.
Variable a: R → R.

Lemma eq_dist_rec_gt:
  (∀ z, P z → eq_dist (T' z) (T z)) →
  (∀ z r, P z → pr_gt (T z) r <= \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_gt (rvar_comp (rvar_pair (T (fst (sval x')))
                                                                          (T (snd (sval x'))))
                                       G) (r - a (size z)))) →
  ∀ z r,
  P z →
  pr_gt (T' z) r <= \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_gt (rvar_comp (rvar_pair (T' (fst (sval x')))
                                                                          (T' (snd (sval x'))))
                                       G) (r - a (size z))).
Proof.
  intros Heq_dist Hrec z r HP. rewrite (proj1 (eq_dist_pr_gt _ _) (Heq_dist _ HP)).
  etransitivity; first apply Hrec; auto.
  right.
  apply eq_bigr => i ?. f_equal.
  apply (proj1 (eq_dist_pr_gt (rvar_comp (rvar_pair (T (sval i).1) (T (sval i).2)) G)
                              (rvar_comp (rvar_pair (T' (sval i).1) (T' (sval i).2)) G))).
  apply: eq_dist_comp.
  intros (r1&r2).
  rewrite ?pr_eq_rvar_pair ?Heq_dist //.
  - destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
    destruct Hin as (x&<-). by apply hP.
  - destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
    destruct Hin as (x&<-). by apply hP.
Qed.

Variable Trec:
  ∀ x r, P x → pr_eq (T x) r = \big[Rplus/0]_(x' : imgT (h x))
                        (pr_eq (h x) (sval x') * pr_eq (rvar_comp (rvar_pair (T (fst (sval x')))
                                                                          (T (snd (sval x'))))
                                       G) (r - a (size x))).

Lemma img_Trec_work b z x:
  P z →
  pr_eq (rvar_comp (rvar_pair (T x.1) (T x.2)) G) b ≠ 0 →
  x \in img (h z) →
  pr_eq (h z) x ≠ 0 →
  b + a (size z) \in img (T z).
Proof.
  intros HP Hneq0 Hin Hneq0'. apply pr_img.
  specialize (Rmult_neq_0_compat _ _ Hneq0 Hneq0'). intros.
  enough (Hneq: pr_eq (T z) (b + a (size z)) ≠ 0).
  { move:Hneq. rewrite /pr_eq.
    intros. edestruct (ge_pr_0 (rvar_dist (T z))) as [|Heq0]; first eauto.
    rewrite Heq0 in Hneq. congruence. }
  rewrite Trec; last done.
  intros Hfalse.
  symmetry in Hfalse.
  enough (Hfalse': ∀ x', x' \in img (h z) → pr_eq (h z) x' *
                  (pr_eq (rvar_comp (rvar_pair (T x'.1) (T x'.2)) G)
                     (b + a (size z) - a (size z))) = 0).
  { specialize (Hfalse' x). move:Hfalse'.
    rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r.
    rewrite Rmult_comm. auto.
  }
  intros x' Hin'. edestruct (Req_dec) as [Heq|Hneq]; first apply Heq.
  exfalso. eapply Rlt_not_eq; last apply Hfalse.
  apply Rlt_0_bigr.
  - intros. replace 0 with (0 * 0) by nra. apply Rmult_le_compat; try nra.
    * apply Rge_le, ge_pr_0.
    * apply Rge_le, ge_pr_0.
  - exists (exist _ x' Hin'); repeat split; auto.
    rewrite //=.
    specialize (pr_eq_ge_0 (h z) x').
    specialize (pr_eq_ge_0 (rvar_comp (rvar_pair (T (fst x')) (T (snd x'))) G)
                           (b + a (size z) - a (size z))).
    clear -Hneq. rewrite //=. intros ??.  rewrite //= in Hneq. nra.
Qed.

Lemma eq_dist_rec:
  (∀ z, P z → eq_dist (T' z) (T z)) →
  ∀ z r,
  P z →
  pr_eq (T' z) r = \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') * pr_eq (rvar_comp (rvar_pair (T' (fst (sval x')))
                                                                          (T' (snd (sval x'))))
                                       G) (r - a (size z))).
Proof.
  intros Heq_dist z r HP. rewrite Heq_dist // Trec //.
  apply eq_bigr => i ?. f_equal.
  apply: eq_dist_comp.
  intros (r1&r2).
  rewrite ?pr_eq_rvar_pair ?Heq_dist //.
  - destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
    destruct Hin as (x&<-). by apply hP.
  - destruct i as (i&Hin). clear -HP Hin hP. rewrite /sval. apply img_alt in Hin.
    destruct Hin as (x&<-). by apply hP.
Qed.

Lemma rec_pr_rec_gt z r:
  P z →
  pr_gt (T z) r ≤ \big[Rplus/0]_(x' : imgT (h z))
                        (pr_eq (h z) (sval x') *
                         pr_gt (rvar_comp (rvar_pair (T (fst (sval x'))) (T (snd (sval x'))))
                                                     G) (r - a (size z))).
Proof.
  rewrite /pr_gt pr_gt_alt3.
  etransitivity.
  { right. eapply eq_bigr => ? _. by apply Trec. }
  rewrite //=.
  rewrite exchange_big //=.
  apply Rle_bigr => x'.
  rewrite -big_distrr //=.
  set (Trecpair := rvar_comp (rvar_pair (T (sval x').1) (T (sval x').2)) G);
    rewrite -/Trecpair.
  transitivity (pr_eq (h z) (sval x') *
                \big[Rplus/0]_(i : imgT (A:=A z) (T z)
                              | (Rgt_dec (sval i) r) && (pr_eq Trecpair ((sval i) - a (size z)) != 0))
                 pr_eq Trecpair ((sval i) - a (size z))).
  {
    right. symmetry.
    eapply Rmult_eq_0_inv_r => Hneq //=. rewrite /index_enum.
    apply (@sum_reidx_map  [finType of imgT (T z)] _ _ _ _ _ (λ x, x)); auto.
    - rewrite /id //=. intros ??. move/andP=>[? ?].
      split; auto. rewrite mem_filter. apply /andP.
      split; auto.
    - intros b Hin' HQ Hfalse.
      case (Req_dec (pr_eq Trecpair (sval b - a (size z))) 0); auto.
      intros Hneq0. exfalso. eapply Hfalse.
      exists b. rewrite mem_filter in Hin'. move /andP in Hin'. destruct Hin' as [-> ->].
      split; auto. rewrite //=. split; auto.
      move: Hneq0. move /eqP => -> //.
    - rewrite -enumT. apply enum_uniq.
    - rewrite -enumT. apply filter_uniq => //=. apply: enum_uniq.
  }
  transitivity (pr_eq (h z) (sval x') * pr_gt Trecpair (r - a (size z))).
  {
    right.
    eapply Rmult_eq_0_inv_r => Hneq.
    rewrite /pr_gt. rewrite pr_gt_alt3.
    rewrite -(big_map sval (λ x, (Rgt_dec x r) && (pr_eq _ (x - _) != 0))
                           (λ i, pr_eq Trecpair (i - a (size z)))).
    rewrite -(big_map sval (λ x, true) (λ i, pr_eq Trecpair i)).
    eapply (@sum_reidx_map _ _ _ _ _ _ (λ x, x - a (size z))); auto.
    - intros a0 ?. move/andP => [Hgt HPr]. split; last done.
      move:Hgt. intros Hlt'.
      rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
      rewrite mem_filter. apply /andP. split.
      ** rewrite //=. do 2 destruct (Rgt_dec) => //=; nra.
      ** apply /mapP.
           assert (Hpf: a0 - a (size z) \in img Trecpair).
           { apply pr_img. edestruct (ge_pr_0 (rvar_dist Trecpair)) as [Hgt|Heq]; first apply Hgt.
             move /eqP in HPr. rewrite /pr_eq in HPr. rewrite //= in Heq. }
           exists (exist _ (a0 - a (size z)) Hpf); last by done.
           rewrite [Finite.enum]unlock //=. apply img_fin_mem.
  - intros b.
    rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
    rewrite mem_filter.  move /andP =>[Hgt Hin'] _ Hfalse.
    case (Req_dec (pr_eq Trecpair b) 0); auto.
    intros Hneq'.
    exfalso; apply Hfalse.
    exists (b + a (size z)).
    repeat split.
    * assert (b + a (size z) \in img (T z)) as Hin.
      { eapply img_Trec_work; eauto. destruct x'; auto. }
      rewrite -mem_undup. rewrite img_alt'.
      exists (exist _ (b + a (size z)) Hin).
      rewrite //=.
    * apply /andP; split.
      ** do 2 destruct (Rgt_dec) => //=. nra.
      ** rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply /eqP. done.
    * rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply /eqP. done.
  - rewrite /index_enum//=. rewrite [Finite.enum]unlock //= img_fin_enum_sval_comp.
    apply undup_uniq.
  - rewrite -(filter_map sval (λ x, (Rgt_dec x (r - a (size z))) : bool)).
    apply filter_uniq. rewrite /index_enum//=.
    rewrite [Finite.enum]unlock //= img_fin_enum_sval_comp.
    apply undup_uniq.
  - intros ??. intros. nra.
  }
  apply Rmult_le_compat_l; first by apply Rge_le, ge_pr_0.
  rewrite /Trecpair//=. reflexivity.
Qed.

End rec_convert.


Require Import Coq.Program.Equality.
Require Export DeclarationEvaluation.
Set Implicit Arguments.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tall {Γ t T} (v: Value t) (wt: Typing Γ t (tall T)) :
  ∃ t1, t = tabs t1.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with try (subst; eauto using red).
  depind wt; simpl; auto.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - inversion wt1; eauto using subst_evar_Typing with subst.
  - inversion wt; eauto using subst_etvar_Typing with subst.
Qed.


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

Section Lambda_Arith.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.
  Context {Sub_AType_D : AType :<: D}.
  Context {Sub_LType_D : LType :<: D}.
  Context {Distinct_AType_LType : Distinct_Sub_Functor Fun_D Sub_AType_D Sub_LType_D}.
  Context {WF_Sub_AType_D : WF_Functor _ _ (Sub_AType_D) _ _}.
   Context {WF_Sub_LType_F : WF_Functor _ _ (Sub_LType_D) _ _}.

  Variable F : Set -> Set -> Set.
  Context {Fun_F : forall A, Functor (F A)}.
  Context {Sub_Arith_F : forall A, Arith :<: F A}.
  Context {Sub_Lambda_F : forall A : Set, Lambda D A :<: F A}.

  (* Constructor + Universal Property. *)
   Context {WF_Sub_ExceptE_F : forall A, WF_Functor _ _ (Sub_Lambda_F A) _ _}.
   Context {WF_Sub_Arith_F : forall A, WF_Functor _ _ (Sub_Arith_F A) _ _}.

   Variable V : Set -> Set.
   Context {Fun_V : Functor V}.
   Context {Sub_StuckValue_V : StuckValue :<: V}.
   Context {Sub_NatValue_V : NatValue :<: V}.
   Context {Sub_ClosValue_V : ClosValue F :<: V}.

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

   Variable MT : Set -> Set.
   Context {Fun_MT : Functor MT}.
   Context {Mon_MT : Monad MT}.
   Context {Fail_MT : FailMonad MT}.

   Variable ME : Set -> Set.
   Context `{Enviroment_ME : Environment ME (Env (Value V))}.
   Context {Fail_ME : FailMonad ME}.
   Context {FailEnvME : FailEnvironmentMonad _ ME}.

  Context {Reasonable_ME : Reasonable_Monad ME}.

  Context {evalM_F : FAlgebra EvalName (Exp F nat) (evalMR V ME) (F nat)}.
  Context {WF_eval_Lambda_F :
    @WF_FAlgebra EvalName _ _ (Lambda D nat) (F nat)
    (Sub_Lambda_F nat) (MAlgebra_evalM_Lambda D F V ME) evalM_F}.
  Context {WF_eval_Arith_F : @WF_FAlgebra EvalName _ _ Arith (F nat)
    (Sub_Arith_F _) (MAlgebra_evalM_Arith V ME _) evalM_F}.

  Context {Typeof_F : forall T, FAlgebra TypeofName T (typeofR D MT) (F (DType D))}.
  Context {WF_ExceptE_Typeof_F : forall T, @WF_FAlgebra TypeofName _ _ (Lambda D _) (F _)
    (Sub_Lambda_F _) (MAlgebra_typeof_Lambda D MT _) (Typeof_F T)}.
  Context {WF_Arith_Typeof_F : forall T, @WF_FAlgebra TypeofName _ _ Arith (F _)
    (Sub_Arith_F _) (MAlgebra_typeof_Arith _ MT _) (Typeof_F T)}.

  Variable TypContext : Set.
  Context {TypContextCE : ConsExtensionC TypContext}.
  Context {GammaTypContext : GammaTypContextC D TypContext}.
  Context {TypContext_GCE : GammaConsExtensionC _ TypContext _ _}.

  Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
  Context {funWFV : iFunctor WFV}.
  Context {Sub_WFV_VI_WFV : Sub_iFunctor (WFValue_VI V D _) WFV}.

  Variable WFVM : (WFValueM_i D V MT ME TypContext -> Prop) -> WFValueM_i D V MT ME TypContext -> Prop.
  Context {funWFVM : iFunctor WFVM}.
  Context {Sub_WFVM_Base_WFVM : Sub_iFunctor (WFValueM_base D V MT ME _ WFV) WFVM}.
  Context {Sub_WFVM_Environment_WFVM : Sub_iFunctor (WFValueM_Environment D MT V ME _ WFV) WFVM}.
  Context {Sub_WFVM_Bot_WFVM : Sub_iFunctor (WFValueM_Bot D V MT ME _) WFVM}.

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

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

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

  Definition ind_alg_Arith_eqv
    (A B : Set)
    (P : eqv_i F A B -> Prop)
    (Hlit : forall gamma gamma' n e e'
      e_eq e'_eq,
      P (mk_eqv_i _ _ _ gamma gamma' e e'))
    (Hadd : forall gamma gamma' a b a' b' e e'
      (IHa : P (mk_eqv_i _ _ _ gamma gamma' a a'))
      (IHb : P (mk_eqv_i _ _ _ gamma gamma' b b'))
      e_eq e'_eq,
      P (mk_eqv_i _ _ _ gamma gamma' e e'))
    i (e : Arith_eqv A B P i) : P i :=
    match e in Arith_eqv _ _ _ i return P i with
      | Lit_eqv gamma gamma' n e e' e_eq e'_eq =>
        Hlit gamma gamma' n e e' e_eq e'_eq
      | Add_eqv gamma gamma' a b a' b' e e'
        eqv_a_a' eqv_b_b' e_eq e'_eq =>
        Hadd gamma gamma' a b a' b' e e'
        eqv_a_a' eqv_b_b' e_eq e'_eq
    end.

  Definition Arith_eqv_ifmap (A B : Set)
    (A' B' : eqv_i F A B -> Prop) i (f : forall i, A' i -> B' i)
    (eqv_a : Arith_eqv A B A' i) : Arith_eqv A B B' i :=
    match eqv_a in Arith_eqv _ _ _ i return Arith_eqv _ _ _ i with
      | Lit_eqv gamma gamma' n e e' e_eq e'_eq =>
        Lit_eqv _ _ _ gamma gamma' n e e' e_eq e'_eq
      | Add_eqv gamma gamma' a b a' b' e e'
        eqv_a_a' eqv_b_b' e_eq e'_eq =>
        Add_eqv _ _ _ gamma gamma' a b a' b' e e'
        (f _ eqv_a_a') (f _ eqv_b_b') e_eq e'_eq
    end.

  Global Instance iFun_Arith_eqv A B : iFunctor (Arith_eqv A B).
    constructor 1 with (ifmap := Arith_eqv_ifmap A B).
    destruct a; simpl; intros; reflexivity.
    destruct a; simpl; intros; unfold id; eauto.
  Defined.

  Context {Sub_Arith_eqv_EQV_E : forall A B,
    Sub_iFunctor (Arith_eqv A B) (EQV_E A B)}.
  Context {Sub_Lambda_eqv_EQV_E : forall A B,
    Sub_iFunctor (Lambda_eqv _ _ A B) (EQV_E A B)}.

  Global Instance EQV_proj1_Arith_eqv :
    forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (Arith_eqv _ _).
    econstructor; intros.
    unfold iAlgebra; intros; apply ind_alg_Arith_eqv;
      unfold EQV_proj1_P; simpl; intros; subst.
    apply (inject_i (subGF := Sub_Arith_eqv_EQV_E A B)); econstructor; simpl; eauto.
    apply (inject_i (subGF := Sub_Arith_eqv_EQV_E A B)); econstructor 2; simpl; eauto.
    destruct a; destruct a'; eapply IHa; eauto.
    destruct b; destruct b'; eapply IHb; eauto.
    apply H.
  Qed.

  Context {WF_invertVI_WFV :
    iPAlgebra WF_invertVI_Name (WF_invertVI_P _ _ _ WFV) WFV}.
  Context {WFVM_bind_WFVM :
    iPAlgebra wfvm_bind_Name (wfvm_bind_P _ _ _ _ _ WFV WFVM) WFVM}.
  Context {EQV_proj1_EQV_E :
    forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P F EQV_E A B) (EQV_E _ _)}.

  Global Instance eqv_soundness_X'_Arith_eqv eval_rec :
    iPAlgebra soundness_X'_Name
    (soundness_X'_P D V F MT ME _ EQV_E WFVM (fun e => typeof _ _ MT (proj1_sig e)) eval_rec
      (f_algebra (FAlgebra := Typeof_F _))
      (f_algebra (FAlgebra := evalM_F))) (Arith_eqv _ _).
  Proof.
      econstructor; unfold iAlgebra; intros.
      eapply ind_alg_Arith_eqv; try eassumption;
        unfold soundness_X'_P, eval_soundness'_P; unfold bevalM; simpl; intros.
      (* lit case *)
      split; intros.
      apply (inject_i (subGF := Sub_Arith_eqv_EQV_E _ _));
        econstructor; eauto.
      rewrite e_eq, e'_eq.
      unfold lit, lit'; simpl; repeat rewrite out_in_fmap.
      repeat rewrite wf_functor.
      rewrite (wf_algebra (WF_FAlgebra := WF_eval_Arith_F));
        rewrite (wf_algebra (WF_FAlgebra := WF_Arith_Typeof_F _));
          simpl fmap; simpl f_algebra; unfold Arith_fmap;
            unfold Arith_typeof, Arith_evalM.
      apply (inject_i (subGF := Sub_WFVM_Base_WFVM)); econstructor.
      apply inject_i; econstructor; unfold vi; simpl; reflexivity.
      apply return_orn; eauto.
      (* add case *)
      intros; destruct a as [mE mT]; destruct b as [nE nT];
        destruct (IHa IH) as [eqv_m_m' IHm];
          destruct (IHb IH) as [eqv_n_n' IHn]; simpl in *|-*.
      split; intros.
      apply (inject_i (subGF := Sub_Arith_eqv_EQV_E _ _));
        econstructor 2.
      eapply eqv_m_m'.
      eapply eqv_n_n'.
      rewrite e_eq; reflexivity.
      rewrite e'_eq; reflexivity.
      rewrite e_eq, e'_eq; unfold add, add'; simpl; repeat rewrite out_in_fmap.
      repeat rewrite wf_functor.
      rewrite (wf_algebra (WF_FAlgebra := WF_eval_Arith_F));
        rewrite (wf_algebra (WF_FAlgebra := WF_Arith_Typeof_F _));
          simpl fmap; simpl f_algebra; unfold Arith_fmap.
      intros; apply Arith_eval_soundness'_H0 with (WFV := WFV) (TypContextCE := TypContextCE);
        eauto with typeclass_instances.
      eapply IH with (pb := (gamma, gamma')).
      split; destruct WF_Gamma; eauto.
      apply (EQV_proj1 _ EQV_E _ _ _ eqv_m_m'); simpl; eauto.
      generalize in_out_UP'_inverse; simpl; intros in_out';
        eapply (in_out' _ _ _ (proj2_sig a')).
      destruct WF_Gamma; eauto.
      apply (EQV_proj1 _ EQV_E _ _ _ eqv_m_m'); simpl; eauto.
      generalize in_out_UP'_inverse; simpl; intros in_out';
        eapply (in_out' _ _ _ (proj2_sig a')).
      intros; eapply IH with (pb := (gamma, gamma')).
      split; destruct WF_Gamma; eauto.
      apply (EQV_proj1 _ EQV_E _ _ _ eqv_n_n'); simpl; eauto.
      generalize in_out_UP'_inverse; simpl; intros in_out';
        eapply (in_out' _ _ _ (proj2_sig b')).
      eapply WF_eqv_environment_P_Sub; eauto.
      apply (EQV_proj1 _ EQV_E _ _ _ eqv_n_n'); simpl; eauto.
      generalize in_out_UP'_inverse; simpl; intros in_out';
        eapply (in_out' _ _ _ (proj2_sig b')).
  Qed.

  Lemma functional_extensionality2 : forall (A B C : Set) (f g : A -> B -> C),
    (forall a b, f a b = g a b) -> f = g.
  Proof.
    repeat (intros; apply functional_extensionality_dep); auto.
  Qed.

  Lemma rewrite_do2 : forall (M : Set -> Set)
    {Fun_M : Functor M}
    {Monad_M : Monad M},
    forall (A B C : Set) (n : M A) (o : M B) (m m' : A -> B -> M C),
      m = m' -> (do n' <- n; do o' <- o; m n' o') = (do n' <- n; do o' <- o; m' n' o').
    intros; rewrite H; reflexivity.
  Qed.

  Global Instance WF_invertClos_WFV_VI :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P D F MT V EQV_E _ WFV) (WFValue_VI V D _).
  Proof.
    constructor.
    unfold iAlgebra; intros; apply ind_alg_WFV_VI with (Sub_NatValue_V := Sub_NatValue_V)
      (Sub_AType_D := Sub_AType_D); unfold WF_invertClos_P; simpl; intros; auto; split.
    apply inject_i; econstructor; eauto.
    rewrite Teq; intros.
    unfold tnat in H0; simpl in H0; apply in_t_UP'_inject in H0.
    repeat rewrite wf_functor in H0; simpl in H0.
    elimtype False; eapply (inj_discriminate _ _ _ H0).
  Qed.

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

  Global Instance WFV_VI_Weaken' :
    iPAlgebra WFValue_Weaken'_Name (WFValue_Weaken'_P D V TypContext WFV)
    (WFValue_VI V D TypContext).
  Proof.
    constructor.
    unfold iAlgebra; intros; apply ind_alg_WFV_VI with (Sub_NatValue_V := Sub_NatValue_V)
      (Sub_AType_D := Sub_AType_D); unfold WFValue_Weaken'_P; simpl; intros; auto.
    apply inject_i; econstructor; eauto.
  Qed.

End Lambda_Arith.

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