(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the dynamic semantics of heap objects, pg. 60.

*)

Require Export LanguageModuleDef.
Import LanguageModule.T.

Inductive get : E -> Path -> E -> Prop :=
 | get_pdot: forall (v : E),
               Value v ->
               get v [] v
 | get_l:    forall (v v0 v1 : E) (p : Path),
               Value v  ->
               Value v0 ->
               Value v1 ->
               get v0 p v ->
               get (cpair v0 v1) ((i_pe zero_pe) :: p) v
 | get_r:    forall (v v0 v1 : E) (p : Path),
               Value v  ->
               Value v0 ->
               Value v1 ->
               get v1 p v ->
               get (cpair v0 v1) ((i_pe one_pe) :: p) v
 | get_pack: forall (v v1 : E) (p : Path) (tau tau' : Tau) (alpha : TV.T)
                    (k : Kappa),
               Value v  ->
               Value v1 ->
               get v1 p v ->
               get (pack tau' v1 (etype aliases alpha k tau)) (u_pe :: p) v.

Inductive set : E -> Path -> E -> E -> Prop :=
  | set_ip: forall (v v' : E),
                Value v  ->
                Value v' ->
                set v' [] v v

  | set_l:    forall (v v' v0 v1 : E) (p : Path),
                Value v  ->
                Value v' ->
                Value v0 ->
                set v0 p v v' ->
                set (cpair v0 v1)  ((i_pe zero_pe) :: p) v (cpair v' v1)

  | set_r:    forall (v v' v0 v1 : E) (p : Path),
                Value v  ->
                Value v' ->
                Value v0 ->
                set v1 p v v' ->
                set (cpair v0 v1)  ((i_pe one_pe) :: p) v (cpair v0 v')

  | set_pack: forall (v v' v1 : E) (p : Path) (tau tau' : Tau)
                     (q : Phi) (alpha : TV.T) (k : Kappa),
                Value v  ->
                Value v' ->
                Value v1 ->
                set (pack tau' v1 (etype q alpha k tau))
                    (u_pe :: p) v (pack tau' v' (etype q alpha k tau)).


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import Robust2relTraceProperty.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section Robust2relCrit.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  (*CA: we don't need a particular structure of traces to define preservation
        e.g. traces = values or our defn of traces both make sense
   *)
  Variable trace__S trace__T : Set.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rsat__S := rsat2 Source_Semantics.
  Local Definition rsat__T := rsat2 Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition σ : (trace__T * trace__T -> Prop) -> (trace__S * trace__S -> Prop) :=
                       γ (@induced_connection_prod (trace__T) (trace__S) rel).

  Local Definition τ : (trace__S * trace__S -> Prop) -> (trace__T * trace__T -> Prop) :=
                       α (@induced_connection_prod (trace__T) (trace__S) rel).

  Local Definition σR2rTP := σR2rTP compilation_chain
                                    Source_Semantics Target_Semantics
                                    σ.

  Local Definition τR2rTP := τR2rTP compilation_chain
                                    Source_Semantics Target_Semantics
                                    τ.

  Local Definition induced_adj : Adjunction_law τ σ :=
    adjunction_law (induced_connection_prod rel).

  Definition rel_R2rTC : Prop :=
    forall C__T P1 P2 t1 t2, sem__T (plug__T (P1 ↓) C__T) t1 ->
                       sem__T (plug__T (P2 ↓) C__T) t2 ->
                       exists C__S s1 s2, rel s1 t1 /\
                                    rel s2 t2 /\
                                    sem__S (plug__S P1 C__S) s1 /\
                                    sem__S (plug__S P2 C__S) s2.

  Theorem rel_R2rTC_τR2rTP : rel_R2rTC <-> τR2rTP.
  Proof.
    setoid_rewrite contra_τR2rTP. split.
    + move => Hrel P1 P2 S [C__T [t1 [t2 [Hsem1 [Hsem2 τS_t1_t2]]]]].
      destruct (Hrel C__T P1 P2 t1 t2 Hsem1 Hsem2) as
          [C__S [s1 [s2 [rel1 [rel2 [Hsem1' Hsem2' ]]]]]].
      exists C__S, s1, s2. repeat (split; auto).
      move => HS_s1_s2.
      apply: τS_t1_t2. exists (s1, s2). repeat (split; auto).
    + move => Hτ C__T P1 P2 t1 t2 Hsem1 Hsem2.
      specialize (Hτ P1 P2 (fun s => ~ rel (fst s) t1 \/ ~ rel (snd s) t2)).
      destruct Hτ as [C__S [s1 [s2 [Hsem1' [Hsem2' notS_s1_s2]]]]].
      ++ exists C__T, t1, t2. repeat (split; auto).
         move => [[s1 s2] [Hs1_s2 [H1 H2]]].
         destruct Hs1_s2; contradiction.
      move/de_morgan1: notS_s1_s2. rewrite -dne. move => [rel1 rel2].
      exists C__S, s1, s2. repeat (split; auto).
  Qed.

  Theorem rel_R2rTC_σR2rTP : rel_R2rTC <-> σR2rTP.
  Proof.
    setoid_rewrite (Adj_σR2rTP_iff_τR2rTP _ _ _ induced_adj).
    by rewrite rel_R2rTC_τR2rTP.
  Qed.

End Robust2relCrit.


Require Import Coq.Classes.EquivDec.
Require Import Coq.PArith.PArith.
Require Import Coq.Lists.List.
Require Import FormalMath.Algebra.Word.
Require Import FormalMath.Algebra.CosetEnum.
Require Import FormalMath.lib.List_ext.
Import ListNotations.

Local Open Scope positive_scope.

Section TWO_GEN_COSET_ENUM.

  Inductive TwoGenT := X | Y.

  Instance TwoGenTEqDec: EqDec TwoGenT eq.
  Proof.
    intros x y. unfold complement, Equivalence.equiv.
    change (x = y -> False) with (~ x = y). decide equality.
  Defined.

  Instance FG_TwoGenT: FiniteGenerators TwoGenT.
  Proof.
    apply (Build_FiniteGenerators TwoGenT TwoGenTEqDec [X ; Y] 2); intros.
    - repeat constructor; intuition; simpl in H; intuition. discriminate.
    - destruct x; intuition.
    - simpl. reflexivity.
  Defined.

  (* Mathieu group M11 *)
  Definition M11_gens :=
    [repeat (Pe X) 2; repeat (Pe Y) 4; flatten (repeat [Pe X; Pe Y] 11);
       flatten (repeat [Pe X; Pe Y; Pe Y] 6);
       [Pe X; Pe Y; Pe X; Pe Y; Pe X; Ne Y; Pe X; Pe Y; Pe X; Pe Y; Pe Y; Pe X; Ne Y;
          Pe X; Pe Y; Pe X; Ne Y; Pe X; Ne Y]].

  Definition M11_gens_rep :=
    Eval native_compute in (map (map alphabet_to_positive) M11_gens).

  (* 385465 cosets will be generated *)
  Definition M11_group := compress (coset_enumration_r M11_gens_rep nil 385500).

  Lemma M11_group_size: num_coset M11_group = 7920.
  Proof. idtac "Computing M11 group...". Time native_compute. reflexivity. Qed.
  (* Finished transaction in 3368.17 secs (3354.588u,11.231s) (successful) *)

End TWO_GEN_COSET_ENUM.

Section THREE_GEN_COSET_ENUM.

  Inductive ThreeGenT := A | C | D.

  Instance ThreeGenTEqDec: EqDec ThreeGenT eq.
  Proof.
    intros x y. unfold complement, Equivalence.equiv.
    change (x = y -> False) with (~ x = y). decide equality.
  Defined.

  Instance FG_ThreeGenT: FiniteGenerators ThreeGenT.
  Proof.
    apply (Build_FiniteGenerators ThreeGenT ThreeGenTEqDec [A; C; D] 3); intros.
    - repeat constructor; intuition; simpl in H; intuition; discriminate.
    - destruct x; intuition.
    - simpl. reflexivity.
  Defined.

  (* Mathieu Group M12 *)
  Definition M12_gens :=
    [repeat (Pe A) 11; repeat (Pe C) 2; repeat (Pe D) 2;
       flatten (repeat [Pe A; Pe C] 3); flatten (repeat [Pe A; Pe D] 3);
         flatten (repeat [Pe C; Pe D] 10);
         [Pe A; Pe A; Pe C; Pe D; Pe C; Pe D; Pe A; Ne D; Ne C; Ne D; Ne C]].

  Definition M12_gens_rep :=
    Eval native_compute in (map (map alphabet_to_positive) M12_gens).

  (* 573191 cosets will be generated *)
  Definition M12_group := compress (coset_enumration_r M12_gens_rep nil 573200).

  Lemma M12_group_size: num_coset M12_group = 95040.
  Proof. idtac "Computing M12 group...". Time native_compute. reflexivity. Qed.
  (* Finished transaction in 17412.734 secs (17326.555u,50.783s) (successful) *)

End THREE_GEN_COSET_ENUM.


(* We check that various definitions or lemmas have the correct
   argument scopes, especially the ones created via functor application. *)

Close Scope nat_scope.

Require Import PArith.
Check (Pos.add 1 2).
Check (Pos.add_comm 1 2).
Check (Pos.min_comm 1 2).
Definition f_pos (x:positive) := x.
Definition f_pos' (x:Pos.t) := x.
Check (f_pos 1).
Check (f_pos' 1).

Require Import ZArith.
Check (Z.add 1 2).
Check (Z.add_comm 1 2).
Check (Z.min_comm 1 2).
Definition f_Z (x:Z) := x.
Definition f_Z' (x:Z.t) := x.
Check (f_Z 1).
Check (f_Z' 1).

Require Import NArith.
Check (N.add 1 2).
Check (N.add_comm 1 2).
Check (N.min_comm 1 2).
Definition f_N (x:N) := x.
Definition f_N' (x:N.t) := x.
Check (f_N 1).
Check (f_N' 1).

Require Import Arith.
Check (Nat.add 1 2).
Check (Nat.add_comm 1 2).
Check (Nat.min_comm 1 2).
Definition f_nat (x:nat) := x.
Definition f_nat' (x:Nat.t) := x.
Check (f_nat 1).
Check (f_nat' 1).


(*
 * Section 1 Example, using DEVOID
 *)

Require Import Vector.
Require Import List.
Require Import Ornamental.Ornaments.

(* syntax to match paper *)
Notation vector := Vector.t.

(*
 * map_length from the list standard library
 *)
Check map_length.

(*
 * Coq's vector map.
 *)
Check Vector.map.

(* --- Bonus material --- *)

(*
 * We can get Vector.map from List.map.
 *)

Preprocess List.map as list_map'.
Find ornament list vector as ltv.
Lift list vector in list_map' as map_p.
Unpack map_p as map_u.

(* User-friendly version *)
Program Definition map {T1} {T2} (f : T1 -> T2) {n : nat} (v : vector T1 n) : vector T2 n :=
  map_u T1 T2 f n v.
Next Obligation.
  induction v.
  - auto.
  - simpl. f_equal. auto.
Defined.

(* We can show it's the same as Coq's map *)
Lemma map_correct :
  forall {T1} {T2} (f : T1 -> T2) {n : nat} (v : vector T1 n),
    map f v = Vector.map f v.
Proof.
  intros. induction v.
  - auto.
  - simpl. rewrite <- IHv. unfold map. simpl.
    destruct (map_obligation_1 T1 T2 f n v). auto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo_def.
Open Local Scope R_scope.

Definition A1 (x:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N.

Definition B1 (x:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    N.

Definition C1 (x y:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N.

Definition Reste1 (x y:R) (N:nat) : R :=
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l))) (pred (N - k))) (pred N).

Definition Reste2 (x y:R) (N:nat) : R :=
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1)) (pred (N - k))) (
    pred N).

Definition Reste (x y:R) (N:nat) : R := Reste2 x y N - Reste1 x y (S N).

(* Here is the main result that will be used to prove that (cos (x+y))=(cos x)(cos y)-(sin x)(sin y) *)
Theorem cos_plus_form :
 forall (x y:R) (n:nat),
   (0 < n)%nat ->
   A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n).
intros.
unfold A1, B1 in |- *.
rewrite
 (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k))
    (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) (
    S n)).
rewrite
 (cauchy_finite
    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H)
 .
unfold Reste in |- *.
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-1) ^ (S n - l) / INR (fact (2 * (S n - l))) *
             y ^ (2 * (S n - l)))) (pred (S n - k))) (
    pred (S n))) with (Reste1 x y (S n)).
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (n - l) / INR (fact (2 * (n - l) + 1)) *
             y ^ (2 * (n - l) + 1))) (pred (n - k))) (
    pred n)) with (Reste2 x y n).
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p)) * x ^ (2 * p) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p))) * y ^ (2 * (k - p))))
         k) (S n)) with
 (sum_f_R0
    (fun k:nat =>
       (-1) ^ k / INR (fact (2 * k)) *
       sum_f_R0
         (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k)
    (S n)).
pose
 (sin_nnn :=
  fun n:nat =>
    match n with
    | O => 0
    | S p =>
        (-1) ^ S p / INR (fact (2 * S p)) *
        sum_f_R0
          (fun l:nat =>
             C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p
    end).
ring_simplify.
unfold Rminus.
replace
(* (-   old ring compat *)
 (-
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n) with (sum_f_R0 sin_nnn (S n)).
rewrite <- sum_plus.
unfold C1 in |- *.
apply sum_eq; intros.
induction  i as [| i Hreci].
simpl in |- *.
unfold C in |- *; simpl in |- *.
field; discrR.
unfold sin_nnn in |- *.
rewrite <- Rmult_plus_distr_l.
apply Rmult_eq_compat_l.
rewrite binomial.
pose (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)).
replace
 (sum_f_R0
    (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l)))
    (S i)) with (sum_f_R0 (fun l:nat => Wn (2 * l)%nat) (S i)).
replace
 (sum_f_R0
    (fun l:nat =>
       C (2 * S i) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (i - l))) i) with
 (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i).
apply sum_decomposition.
apply sum_eq; intros.
unfold Wn in |- *.
apply Rmult_eq_compat_l.
replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))).
reflexivity.
omega.
apply sum_eq; intros.
unfold Wn in |- *.
apply Rmult_eq_compat_l.
replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat.
reflexivity.
omega.
replace
 (-
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n) with
 (-1 *
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n);[idtac|ring].
rewrite scal_sum.
rewrite decomp_sum.
replace (sin_nnn 0%nat) with 0.
rewrite Rplus_0_l.
change (pred (S n)) with n.
   (* replace (pred (S n)) with n; [ idtac | reflexivity ]. *)
apply sum_eq; intros.
rewrite Rmult_comm.
unfold sin_nnn in |- *.
rewrite scal_sum.
rewrite scal_sum.
apply sum_eq; intros.
unfold Rdiv in |- *.
(*repeat rewrite Rmult_assoc.*)
(* rewrite (Rmult_comm (/ INR (fact (2 * S i)))). *)
repeat rewrite <- Rmult_assoc.
rewrite <- (Rmult_comm (/ INR (fact (2 * S i)))).
repeat rewrite <- Rmult_assoc.
replace (/ INR (fact (2 * S i)) * C (2 * S i) (S (2 * i0))) with
 (/ INR (fact (2 * i0 + 1)) * / INR (fact (2 * (i - i0) + 1))).
replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ].
replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ].
replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)).
ring.
simpl in |- *.
pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
rewrite pow_add.
ring.
symmetry  in |- *; apply le_plus_minus; assumption.
unfold C in |- *.
unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_l.
rewrite Rinv_mult_distr.
replace (S (2 * i0)) with (2 * i0 + 1)%nat;
 [ apply Rmult_eq_compat_l | ring ].
replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat.
reflexivity.
omega.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
reflexivity.
apply lt_O_Sn.
(* ring. *)
apply sum_eq; intros.
rewrite scal_sum.
apply sum_eq; intros.
unfold Rdiv in |- *.
repeat rewrite <- Rmult_assoc.
rewrite <- (Rmult_comm (/ INR (fact (2 * i)))).
repeat rewrite <- Rmult_assoc.
replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with
 (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))).
replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)).
ring.
pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
rewrite pow_add.
ring.
symmetry  in |- *; apply le_plus_minus; assumption.
unfold C in |- *.
unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_l.
rewrite Rinv_mult_distr.
replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat.
reflexivity.
omega.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
unfold Reste2 in |- *; apply sum_eq; intros.
apply sum_eq; intros.
unfold Rdiv in |- *; ring.
unfold Reste1 in |- *; apply sum_eq; intros.
apply sum_eq; intros.
unfold Rdiv in |- *; ring.
apply lt_O_Sn.
Qed.

Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i.
intros.
assert (H := pow_Rsqr x i).
unfold Rsqr in H; exact H.
Qed.

Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x).
intro.
assert (H := exist_cos (x * x)).
elim H; intros.
assert (p_i := p).
unfold cos_in in p.
unfold cos_n, infinite_sum in p.
unfold R_dist in p.
cut (cos x = x0).
intro.
rewrite H0.
unfold Un_cv in |- *; unfold R_dist in |- *; intros.
elim (p eps H1); intros.
exists x1; intros.
unfold A1 in |- *.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with
 (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n).
apply H2; assumption.
apply sum_eq.
intros.
replace ((x * x) ^ i) with (x ^ (2 * i)).
reflexivity.
apply pow_sqr.
unfold cos in |- *.
case (exist_cos (Rsqr x)).
unfold Rsqr in |- *; intros.
unfold cos_in in p_i.
unfold cos_in in c.
apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption.
Qed.

Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)).
intros.
assert (H := exist_cos ((x + y) * (x + y))).
elim H; intros.
assert (p_i := p).
unfold cos_in in p.
unfold cos_n, infinite_sum in p.
unfold R_dist in p.
cut (cos (x + y) = x0).
intro.
rewrite H0.
unfold Un_cv in |- *; unfold R_dist in |- *; intros.
elim (p eps H1); intros.
exists x1; intros.
unfold C1 in |- *.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n)
 with
 (sum_f_R0
    (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n).
apply H2; assumption.
apply sum_eq.
intros.
replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)).
reflexivity.
apply pow_sqr.
unfold cos in |- *.
case (exist_cos (Rsqr (x + y))).
unfold Rsqr in |- *; intros.
unfold cos_in in p_i.
unfold cos_in in c.
apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i);
 assumption.
Qed.

Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x).
intro.
case (Req_dec x 0); intro.
rewrite H.
rewrite sin_0.
unfold B1 in |- *.
unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1))
    n) with 0.
unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
induction  n as [| n Hrecn].
simpl in |- *; ring.
rewrite tech5; rewrite <- Hrecn.
simpl in |- *; ring.
unfold ge in |- *; apply le_O_n.
assert (H0 := exist_sin (x * x)).
elim H0; intros.
assert (p_i := p).
unfold sin_in in p.
unfold sin_n, infinite_sum in p.
unfold R_dist in p.
cut (sin x = x * x0).
intro.
rewrite H1.
unfold Un_cv in |- *; unfold R_dist in |- *; intros.
cut (0 < eps / Rabs x);
 [ intro
 | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ].
elim (p (eps / Rabs x) H3); intros.
exists x1; intros.
unfold B1 in |- *.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    n) with
 (x *
  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n).
replace
 (x *
  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
  x * x0) with
 (x *
  (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
   x0)); [ idtac | ring ].
rewrite Rabs_mult.
apply Rmult_lt_reg_l with (/ Rabs x).
apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4;
 assumption.
apply Rabs_no_R0; assumption.
rewrite scal_sum.
apply sum_eq.
intros.
rewrite pow_add.
rewrite pow_sqr.
simpl in |- *.
ring.
unfold sin in |- *.
case (exist_sin (Rsqr x)).
unfold Rsqr in |- *; intros.
unfold sin_in in p_i.
unfold sin_in in s.
assert
 (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s).
rewrite H1; reflexivity.
Qed.


Check (fun x : nat => 0).

From Coq Require Import ssreflect ssrfun ssrbool.
(* ssreflext completely hides a spurious argument *)
Check (fun x : nat => 0).

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Parameter map : (nat -> nat) -> list nat -> list nat.
Parameter sumlist : list nat -> nat.
Axiom eq_map :
  forall F1 F2 : nat -> nat,
  (forall n : nat, F1 n = F2 n) ->
  forall l : list nat, map F1 l = map F2 l.

Require Import Arith.

Lemma example_map l : sumlist (map (fun m => m - m) l) = 0.
Proof.
  under eq_map => m.
  rewrite Nat.sub_diag. over.


Require Import Gc.Language Gc.Gc.

Require Import List ListSet Equality CpdtTactics.

Ltac destructo :=
  repeat match goal with
         | [H : _ /\ _ |- _] => destruct H
         | [H : exists _, _|- _] => destruct H
         | [H : _ <-> _ |- _] => destruct H
         end.

Definition struct_equiv (s1: list val) (s2: list val) : Prop :=
  length s1 = length s2
  /\
  forall n i,
    nth_error s1 n = Some (Int i) <-> nth_error s2 n = Some (Int i).

Lemma struct_equiv_refl : forall s1, struct_equiv s1 s1.
Proof.
  Hint Unfold struct_equiv.
  induction s1 ; crush.
Qed.
Hint Resolve struct_equiv_refl.

Lemma struct_equiv_symm : forall s1 s2, struct_equiv s1 s2 -> struct_equiv s2 s1.
Proof.
  Hint Unfold struct_equiv.
  intros.
  unfold struct_equiv in *.
  destructo.
  split. auto.
  intros.
  specialize (H0 n i).
  destructo.
  split ; auto.
Qed.
Hint Resolve struct_equiv_symm.

Lemma struct_equiv_trans : forall s1 s2 s3,
    struct_equiv s1 s2 ->
    struct_equiv s2 s3 ->
    struct_equiv s1 s3.
Proof.
  Hint Unfold struct_equiv.
  intros.
  unfold struct_equiv in *.
  destructo.
  split. crush.
  intros.
  specialize (H1 n i).
  specialize (H2 n i).
  destructo.
  split ; auto.
Qed.
Hint Resolve struct_equiv_trans.

(* All integers reachable from the same variable, address, and index. *)
Definition equiv' (s1 s2: state) : Prop :=
  forall v p1 address p1' struct1,
      roots_maps (roots s1) v p1 ->
      addresses (heap s1) p1 address p1' ->
      heap_maps_struct (heap s1) p1' struct1 ->
      exists p2 p2' struct2,
        roots_maps (roots s2) v p2 /\
        addresses (heap s2) p2 address p2' /\
        heap_maps_struct (heap s2) p2' struct2 /\
        struct_equiv struct1 struct2.

Definition equiv (s1 s2: state) : Prop :=
  (output s1 = output s2) /\ equiv' s1 s2 /\ equiv' s2 s1.

Lemma equiv_refl : forall s1, equiv s1 s1.
  intros.
  unfold equiv.
  split. reflexivity.
  split ;
    unfold equiv' ;
    intros ;
    exists p1, p1', struct1 ;
    auto.
Qed.

Lemma equiv_symm : forall s1 s2, equiv s1 s2 -> equiv s2 s1.
  intros.
  unfold equiv in *.
  crush.
Qed.

Lemma equiv_trans : forall s1 s2 s3, equiv s1 s2 -> equiv s2 s3 -> equiv s1 s3.
Proof.
  intros.
  unfold equiv in *.
  destructo.
  split. crush.
  clear H H0.
  split ; unfold equiv' ; intros.
  * specialize (H3 v p1 address p1' struct1).
    intuition.
    destructo.
    specialize (H1 v x address x0 x1).
    intuition.
    destructo.
    exists x2, x3, x4.
    eauto.
  * specialize (H2 v p1 address p1' struct1).
    intuition.
    destructo.
    specialize (H4 v x address x0 x1).
    intuition.
    destructo.
    exists x2, x3, x4.
    eauto.
Qed.

Theorem gc_forward_safety :
  forall st, equiv' st (gc st)
.
Proof.
  unfold equiv'.
  intros.
  exists p1.
  exists p1'.
  exists struct1.
  intuition.
  * subst; eapply pointer_equivalence; eauto.
  * unfold heap_maps_struct in H1.
    specialize address_maps_to_value with (heap (gc st)) p1 p1' address; intros.
    assert (addresses (heap (gc st)) p1 address p1').
    - subst; eapply pointer_equivalence; eauto.
    - intuition.
      destructo.
      assert (heap_maps_struct (heap st) p1' struct1). auto.
      assert (struct1 = x).
      + eapply (value_equivalence (roots st) (heap st) (heap (gc st)) p1' struct1 x); crush.
      + subst.
        auto.
Qed.

Lemma sweep_maps_forward :
  forall r h p v,
    heap_maps_struct (mark_sweep r h) p v ->
    heap_maps_struct h p v.
Proof.
  intros.
  unfold mark_sweep in *.
  remember (mark r h) as marked. clear Heqmarked.

  induction h. crush.

  unfold heap_maps_struct in * ; fold heap_maps_struct in *.
  unfold sweep in * ; fold sweep in *.
  destruct a.
  edestruct set_mem eqn:? ; destruct (ptr_eq_dec p p0) eqn:? ;
    unfold heap_get_struct in * ; fold heap_get_struct in *.
  * subst.
    edestruct ptr_eq_dec ; eauto.
  * edestruct ptr_eq_dec ; eauto.
  * intuition.
    edestruct ptr_eq_dec ; eauto.
    subst.
    contradict H.
    - unfold not. intros.
      clear - Heqb H.
      induction h. crush.
      unfold sweep in * ; fold sweep in *.
      destruct a.
      destruct (ptr_eq_dec p p0).
      + subst.
        rewrite Heqb in H.
        intuition.
      + destruct (set_mem ptr_eq_dec p marked) ;
         unfold heap_get_struct in * ; fold heap_get_struct in *.
        ** destruct (ptr_eq_dec p p0) ; crush.
        ** intuition.
    - subst.
      discriminate.
  * intuition.
    destruct (ptr_eq_dec p0 p) eqn:?.
    crush.
    crush.
Qed.

Theorem gc_backward_safety :
  forall st, equiv' (gc st) st
.
Proof.
  unfold equiv'.
  intros.
  exists p1, p1', struct1.
  crush.
  * clear H.
    dependent induction address generalizing p1.
    - inversion H0. clear H0. destructo. subst.
      constructor.
      exists x.
      eapply sweep_maps_forward ; eauto.
    - inversion H0. clear H0. destructo. subst.
      specialize (IHaddress p' p1' struct1).
      intuition.
      eapply FollowAddresses.
      + unfold heap_maps in *.
        unfold heap_get in *.
        destruct (heap_get_struct p1 (mark_sweep (roots st) (heap st))) eqn:?.
        Focus 2. discriminate.
        specialize (sweep_maps_forward _ _ _ _ Heqo).
        intros.
        rewrite H.
        crush.
      + apply H0.
  * eapply sweep_maps_forward ; eauto.
Qed.

Theorem gc_safety :
  forall st, equiv st (gc st)
.
Proof.
  Hint Resolve gc_forward_safety gc_backward_safety.
  Hint Unfold equiv.
  crush.
Qed.


Notation " [ a ] " := (inhabited a).

Definition join : forall (A : Type), [[A]] -> [A]
  := fun A m => match m with inhabits m => m end.

Definition map : forall (A B : Type), (A -> B) -> [A] -> [B]
  := fun A B f m => match m with inhabits x => inhabits (f x) end.

Definition lift : forall (A : Type), A -> [A]
  := inhabits.

Definition choice := forall A (B : A -> Type),
  (forall x, [ B x ]) -> [ forall x, B x ].

Lemma map_composition : forall A B C (f : B -> C) (g : A -> B) (m : [A]),
  map A C (fun y => f (g y)) m = map B C f (map A B g m).
Proof.
intros A B C f g m.
refine (match m with inhabits x => _ end).
reflexivity.
Qed.

Lemma map_id : forall A (m : [A]),
  map A A (fun y => y) m = m.
Proof.
intros A m.
refine (match m with inhabits x => _ end).
reflexivity.
Qed.

Lemma map_lift : forall A B (f : A -> B) (x : A),
  map A B f (lift A x) = lift B (f x).
Proof.
auto.
Qed.

Lemma join_map_join : forall A (m : [[[A]]]),
  join A (map [[A]] [A] (join A) m) = join A (join [A] m).
Proof.
intros A m.
refine (match m with inhabits x => _ end).
reflexivity.
Qed.

Lemma join_map_lift : forall A (m : [A]),
  join A (map A [A] (lift A) m) = m.
Proof.
intros A m.
refine (match m with inhabits x => _ end).
reflexivity.
Qed.

Lemma join_lift : forall A (m : [A]),
  join A (lift [A] m) = m.
Proof.
auto.
Qed.

Lemma join_map_map : forall A B (f : A -> B) (m : [[A]]),
  join B (map [A] [B] (map A B f) m) = map A B f (join A m).
Proof.
intros A B f mm.
refine (match mm with inhabits x => _ end).
reflexivity.
Qed.


Require Export SeparationLogicProofSystem.Util.

Record signature: Type := mksignature
{ Func: Set
; arity: Func -> nat
; Pred: Set
; adic: Pred -> nat }.
Arguments arity {_} _.
Arguments adic {_} _.

Record csignature: Type := mkcsignature
{ sig :> signature
; Func_countable: countable (Func sig)
; Pred_countable: countable (Pred sig) }.

(* First-order individual variables *)
Definition V := nat.
Definition x: V := 0.
Definition y: V := 1.

Inductive term (Sigma: signature): Set :=
| id: V -> term Sigma
| app (f: Func Sigma): Vector.t (term Sigma) (arity f) -> term Sigma.

Arguments id {_} _.
Arguments app {_} _ _.

Fixpoint tsub {Sigma: signature} (t: term Sigma) (z: V) (s: term Sigma): term Sigma :=
match s with
| id zz => if Nat.eq_dec z zz then t else id zz
| app f arg => app f (Vector.map (tsub t z) arg)
end.

Fixpoint freevartl {Sigma: signature} (t: term Sigma): list V :=
match t with
| id z => List.cons z List.nil
| app _ arg => Vector.fold_right (@List.app V)
    (Vector.map (@freevartl Sigma) arg) List.nil
end.

Definition freevart {Sigma: signature} (t: term Sigma): V -> Prop :=
fun z => List.In z (freevartl t).

Inductive formula (Sigma: signature): Set :=
| eq: term Sigma -> term Sigma -> formula Sigma
| prim (P: Pred Sigma): Vector.t (term Sigma) (adic P) -> formula Sigma
| lnot: formula Sigma -> formula Sigma
| land: formula Sigma -> formula Sigma -> formula Sigma
| lforall: V -> formula Sigma -> formula Sigma.

Arguments eq {_} _ _.
Arguments prim {_} _ _.
Arguments lnot {_} _.
Arguments land {_} _ _.
Arguments lforall {_} _ _.

Definition lor {Sigma: signature} (phi psi: formula Sigma): formula Sigma :=
  lnot (land (lnot phi) (lnot psi)).
Definition limp {Sigma: signature} (phi psi: formula Sigma): formula Sigma :=
  lor (lnot phi) psi.
Definition lbimp {Sigma: signature} (phi psi: formula Sigma): formula Sigma :=
  land (limp phi psi) (limp psi phi).
Definition lexists {Sigma: signature} (z: V) (phi: formula Sigma): formula Sigma :=
  lnot (lforall z (lnot phi)).

Fixpoint fsub {Sigma: signature} (t: term Sigma) (z: V) (phi: formula Sigma): formula Sigma :=
match phi with
| eq t1 t2 => eq (tsub t z t1) (tsub t z t2)
| prim p arg => prim p (Vector.map (tsub t z) arg)
| lnot phi => lnot (fsub t z phi)
| land phi psi => land (fsub t z phi) (fsub t z psi)
| lforall zz phi => if Nat.eq_dec z zz then lforall zz phi else lforall zz (fsub t z phi)
end.

Fixpoint freevarfl {Sigma: signature} (phi: formula Sigma): list V :=
match phi with
| eq t1 t2 => List.app (freevartl t1) (freevartl t2)
| prim _ arg => Vector.fold_right (@List.app V)
    (Vector.map (@freevartl Sigma) arg) List.nil
| lnot phi => freevarfl phi
| land phi psi => List.app (freevarfl phi) (freevarfl psi)
| lforall z phi => List.remove (Nat.eq_dec) z (freevarfl phi)
end.

Definition freevarf {Sigma: signature} (phi: formula Sigma): V -> Prop :=
fun z => List.In z (freevarfl phi).

Proposition freevarf_eq {Sigma: signature} (t1 t2: term Sigma):
  freevarf (eq t1 t2) = Union (freevart t1) (freevart t2).
apply functional_extensionality; intro z.
unfold freevarf; simpl.
unfold Union.
apply propositional_extensionality.
apply List.in_app_iff.
Qed.

Proposition freevarf_fsub {Sigma: signature} (t: term Sigma) (z: V) (phi: formula Sigma):
freevarf (fsub t z phi) = Union (Subtract (freevarf phi) z) (freevart t).
Admitted.

Record binformula (Sigma: signature) := mkbinformula
{ binformula_form: formula Sigma
; binformula_prop: forall z, freevarf binformula_form z ->
    z = x \/ z = y
}.
Coercion binformula_form: binformula >-> formula.

Record model (Sigma: signature): Type := mkstructure
{ domain: Set
; element: domain
; func (f: Func Sigma): Vector.t domain (arity f) -> domain
; pred (P: Pred Sigma): Vector.t domain (adic P) -> Prop
}.
Coercion domain: model >-> Sortclass.
Arguments domain {_} _.
Arguments element {_} _.
Arguments func {_} {_} _ _.
Arguments pred {_} {_} _ _.

Definition valuation {Sigma: signature} (M: model Sigma) := V -> M.

Definition nulval {Sigma: signature} (M: model Sigma): valuation M :=
fun x => element M.

Definition update {Sigma: signature} {M: model Sigma}
  (s: valuation M) (x: V) (d: M): valuation M :=
fun y => if Nat.eq_dec x y then d else s y.

Fixpoint interp {Sigma: signature} {M: model Sigma}
  (s: valuation M) (t: term Sigma): M :=
match t with
| id x => s x
| app f arg => func f (Vector.map (interp s) arg)
end.

Fixpoint satisfy {Sigma: signature} {M: model Sigma}
  (s: valuation M) (phi: formula Sigma): Prop :=
match phi with
| eq t1 t2 => interp s t1 = interp s t2
| prim p arg => pred p (Vector.map (interp s) arg)
| lnot phi => ~satisfy s phi
| land phi psi => satisfy s phi /\ satisfy s psi
| lforall x phi => forall (d: domain M), satisfy (update s x d) phi
end.

Proposition satisfy_lnot {Sigma: signature} {M: model Sigma} (s: valuation M) (phi: formula Sigma):
  satisfy s (lnot phi) <-> ~satisfy s phi.
split; intro; simpl; auto.
Qed.

Proposition satisfy_land {Sigma: signature} {M: model Sigma} (s: valuation M) (phi psi: formula Sigma):
  satisfy s (land phi psi) <-> satisfy s phi /\ satisfy s psi.
split; intro; simpl; auto.
Qed.

Proposition satisfy_lor {Sigma: signature} {M: model Sigma} (s: valuation M) (phi psi: formula Sigma):
  satisfy s (lor phi psi) <-> satisfy s phi \/ satisfy s psi.
split; intro; unfold lor in *.
- rewrite satisfy_lnot in H.
  rewrite satisfy_land in H.
  rewrite satisfy_lnot in H.
  rewrite satisfy_lnot in H.
  apply not_and_or in H.
  destruct H.
  left. apply NNPP; auto.
  right. apply NNPP; auto.
- rewrite satisfy_lnot.
  rewrite satisfy_land.
  rewrite satisfy_lnot.
  rewrite satisfy_lnot.
  apply or_not_and.
  destruct H.
  left; intro; auto.
  right; intro; auto.
Qed.

Proposition satisfy_limp {Sigma: signature} {M: model Sigma} (s: valuation M) (phi psi: formula Sigma):
  satisfy s (limp phi psi) <-> (satisfy s phi -> satisfy s psi).
split; intro; unfold limp in *.
- intro.
  rewrite satisfy_lor in H.
  rewrite satisfy_lnot in H.
  destruct H.
  exfalso; auto. assumption.
- rewrite satisfy_lor.
  rewrite satisfy_lnot.
  apply imply_to_or in H.
  assumption.
Qed.

Proposition satisfy_lbimp {Sigma: signature} {M: model Sigma} (s: valuation M) (phi psi: formula Sigma):
  satisfy s (lbimp phi psi) <-> (satisfy s phi <-> satisfy s psi).
split; intro; unfold lbimp in *.
- rewrite satisfy_land in H.
  rewrite satisfy_limp in H.
  rewrite satisfy_limp in H.
  destruct H.
  split; auto.
- rewrite satisfy_land.
  destruct H.
  split; rewrite satisfy_limp; auto.
Qed.

Proposition satisfy_lforall {Sigma: signature} {M: model Sigma} (s: valuation M) (x: V) (phi: formula Sigma):
  satisfy s (lforall x phi) <-> forall d, satisfy (update s x d) phi.
split; intro; simpl; auto.
Qed.

Proposition satisfy_lexists {Sigma: signature} {M: model Sigma} (s: valuation M) (x: V) (phi: formula Sigma):
  satisfy s (lexists x phi) <-> exists d, satisfy (update s x d) phi.
split; intro; unfold lexists in *.
- rewrite satisfy_lnot in H.
  rewrite satisfy_lforall in H.
  apply not_all_ex_not in H; destruct H.
  rewrite satisfy_lnot in H.
  apply NNPP in H.
  exists x0; auto.
- destruct H.
  rewrite satisfy_lnot.
  rewrite satisfy_lforall.
  apply ex_not_not_all.
  exists x0.
  rewrite satisfy_lnot.
  intro. apply H0; auto.
Qed.

Definition relation {Sigma: signature} (M: model Sigma) (phi: binformula Sigma): M * M -> Prop :=
fun '(d, d') => satisfy (update (update (nulval M) x d) y d') phi.

Proposition union_prop {Sigma: signature} (phi psi: binformula Sigma):
  forall z : V, freevarf (lor phi psi) z -> z = x \/ z = y.
intros.
unfold freevarf in H.
simpl in H.
apply List.in_app_or in H.
destruct H; eapply binformula_prop; unfold freevarf; apply H.
Qed.

Definition union {Sigma: signature} (phi: binformula Sigma) (psi: binformula Sigma): binformula Sigma :=
mkbinformula _ (lor phi psi) (union_prop phi psi).

Proposition Union_union {Sigma: signature} (M: model Sigma) (phi: binformula Sigma) (psi: binformula Sigma):
  Union (relation M phi) (relation M psi) = relation M (union phi psi).
unfold Union.
apply functional_extensionality; intro; destruct x0 as (x, y).
unfold relation.
simpl.
apply propositional_extensionality; split; intro.
destruct H.
intro. destruct H0.
apply H0; auto.
intro. destruct H0.
apply H1; auto.
apply not_and_or in H.
destruct H; apply NNPP in H; auto.
Qed.


(* HCOL metaoperators *)

Require Import Util.Misc.
Require Import Helix.Util.VecSetoid.
Require Import Helix.HCOL.CarrierType.

Require Import Coq.Arith.Arith.
Require Import Coq.Program.Program. (* compose *)
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relations.

Require Import Helix.Tactics.HelixTactics.
Require Import Coq.Logic.FunctionalExtensionality.

(* CoRN MathClasses *)
Require Import MathClasses.interfaces.abstract_algebra.
Require Import MathClasses.orders.minmax MathClasses.interfaces.orders.

Import VectorNotations.
Open Scope vector_scope.

Section WithCarrierA.
  Context `{CAPROPS: @CarrierProperties CADEFS}.

  (* --------- *)

  Section THCOL_implementations.

    (* Apply 2 functions to the same input returning tuple of results *)
    Definition Stack {D R F: Type} (fg:(D->R)*(D->F)) (x:D) : (R*F) :=
      match fg with
      | (f,g) => pair (f x) (g x)
      end.

    (* Apply 2 functions to 2 inputs returning tuple of results *)
    Definition Cross {D R E F: Type} (fg:(D->R)*(E->F)) (x:D*E) : (R*F) :=
      match fg with
      | (f,g) => match x with
                | (x0,x1) => pair (f x0) (g x1)
                end
      end.

    (* --- Pointwise Comparison --- *)

    (* Zero/One version *)
    Definition ZVLess {n}
               (ab: (avector n)*(avector n)) : avector n :=
      match ab with
      | (a,b) => Vmap2 (Zless) a b
      end.

    Instance ZVLess_proper {n:nat}:
      Proper ((=) ==> (=))  (@ZVLess n).
    Proof.
      (* solve_proper. *)
      intros x y E.
      unfold ZVLess.
      repeat break_let.
      inversion E. simpl in *.
      unfold equiv, vec_Equiv.
      rewrite H0, H.
      reflexivity.
    Qed.

  End THCOL_implementations.

  Section THCOL_implementation_proper.

    Global Instance Cross_arg_proper
           `{Equiv D,Equiv R,Equiv E,Equiv F}
           `{pF: !Proper ((=) ==> (=)) (f: D -> R)}
           `{pG: !Proper ((=) ==> (=)) (g: E -> F)}:
      Proper ((=) ==> (=))  (Cross (f,g)).
    Proof.
      intros fg fg' fgE.
      destruct fg, fg'.
      destruct fgE as [M2 M1]. simpl in *.
      split; simpl.
      apply pF; assumption.
      apply pG; assumption.
    Qed.

    Global Instance Stack_arg_proper
           `{Equiv D,Equiv R,Equiv F}
           `{pF: !Proper ((=) ==> (=)) (f: D -> R)}
           `{pG: !Proper ((=) ==> (=)) (g: D -> F)}:
      Proper ((=) ==> (=))  (Stack (f,g)).
    Proof.
      intros fg fg' fgE.
      split; simpl.
      apply pF; assumption.
      apply pG; assumption.
    Qed.

  End THCOL_implementation_proper.

End WithCarrierA.


(*
 * This file explains the assumptions from Section 3 in more detail,
 * and demonstrates some failing examples.
 *
 * These assumptions are not core to the type theory or to the
 * original definition of algebraic ornaments. Accordingly, this
 * file can be viewed as a suite of test cases we'd eventually
 * like to pass.
 *
 * See issue #37 for the status of lifting restrictions that Search makes.
 *)

Add LoadPath "coq/examples".
Require Import Ornamental.Ornaments.
Require Import List ZArith Nat.
Require Import Search.

Set DEVOID search prove coherence.
Set DEVOID search prove equivalence.

(*
 * Our arguments to cons are swapped from Coq's in the paper
 *)
Definition vect_rect {T : Type} p f_nil f_cons (n : nat) (v : vector T n) :=
  Vector.t_rect T p
    f_nil
    (fun (t : T) (n : nat) (v : vector T n) (IH : p n v) =>
      f_cons n t v IH)
    n
    v.

(* --- Same number of constructors --- *)

(*
 * We require that B has the same number of constructors as A.
 * We cannot, for example, find this ornament:
 *)

Inductive vector3 (T : Type) : nat -> Type :=
| nilV3 : vector3 T 0
| consV30 : T -> vector3 T 1
| consV3S : forall (n : nat), T -> vector3 T (S n) -> vector3 T (S (S n)).

Fail Find ornament list vector3 as ltv3.

(*
 * This is not fundamental to the original definition of ornaments.
 * The definition of "same inductive structure" can in fact capture types
 * with different numbers of constructors.
 *
 * This example isn't minimal; there are other reasons we can't support it yet.
 * But the reason we don't support different numbers of constructors is that
 * it requires search to understand that both consV30 and consV3S corespond to
 * the cons case of a list. That is, that we can combine them to get consV.
 *
 * This is absolutely possible, it is just not done yet.
 *)

(* --- Same order of constructors --- *)

(*
 * We require that B has constructors in the same order as A.
 * We cannot, for example, find this ornament:
 *)

Inductive vector_flip (T : Type) : nat -> Type :=
| consVflip : forall (n : nat), T -> vector_flip T n -> vector_flip T (S n)
| nilVflip : vector_flip T 0.

Fail Find ornament list vector_flip as ltv_flip.

(*
 * This is not fundamental to the original definition of ornaments.
 * vector and vector_flip are very obviously equivalent.
 *
 * The reason we don't support a different order of constructors is that
 * it requires search to understand that nil maps to nilVflip and
 * cons maps to consVflip. We simplify search a lot by just assuming
 * the 0th constructor maps to the 0th constructor, and so on. But here
 * we need to construct a map between constructors first. This is
 * not straightforward.
 *)

(* --- No recursive references under products --- *)

(*
 * We don't allow for recursive references under products:
 *)

Inductive T1 (T : Type) : Type :=
| t1 : (T -> T1 T) -> T1 T.

Inductive T2 (T : Type) : nat -> Type :=
| t2 : (T -> T2 T 0) -> T2 T 0.

Fail Find ornament T1 T2 as T1_to_T2.

(*
 * I am not sure what supporting these would mean, or whether these should be
 * supported. What is the relationship between T1 and T2, exactly? Is this
 * an algebraic ornament? Does the original model the other papers constructed
 * allow for this kind of inductive type? I don't know the answer to these questions.
 * If you do, please chime in on issue #37.
 *)

(* --- One new hypothesis per recursive reference: Non-algebraic versions --- *)

(*
 * The error messages are bad for these; sorry about that.
 *
 * We require that for every recursive reference to A in A, there's exactly
 * one new hypothesis in B. Most ornaments you can define this way aren't
 * algebraic. For example, this one is not algebraic:
 *)

Inductive bintree (A : Type) : Type :=
| leaf :
    bintree A
| node :
    bintree A -> A -> bintree A -> bintree A.

Inductive bal_bintree (A : Type) : nat -> Type :=
| bal_leaf :
    bal_bintree A 0
| bal_node :
    forall (n : nat),
      bal_bintree A n -> A -> bal_bintree A n -> bal_bintree A (n + n).

Fail Find ornament bintree bal_bintree as orn_bintree_balbintree.

(*
 * It has a hidden premise! You can only go from a bintree to a bal_bintree
 * if the bintree is balanced.
 *
 * If we add an extra hypothesis, then we may have something not algebraic, too:
 *)

Inductive vector2 (A : Type) : nat -> Type :=
| nilV2 : vector2 A 0
| consV2 : forall (n m : nat), A -> vector2 A n -> vector2 A (n + m).

Fail Find ornament list vector2 as list_to_vector2.

(*
 * This is not algebraic because we need to inhabit m.
 *
 * Everyone loves the fin example:
 *)

Inductive fin : nat -> Type :=
| F1 : forall (n : nat), fin (S n)
| FS : forall (n : nat), fin n -> fin (S n).

Fail Find ornament nat fin as orn_nat_fin.

(*
 * But I don't think this is algebraic. It's an ornament, but there are infinitely
 * many fins for every nat.
 *)

(* --- One new hypothesis per recursive reference: Algebraic version --- *)

(*
 * If we are being deliberately silly:
 *)

Inductive vector4 (A : Type) : nat -> Type :=
| nilV4 : vector4 A 0
| consV4 : forall (n : nat), unit -> A -> vector4 A n -> vector4 A (S n).

Fail Find ornament list vector4 as orn_list_vector4.

(*
 * Then we can actually define an algebraic ornament that we can't find because it
 * has an extra hypothesis. This ornament is algebraic because vector4 is obviously
 * equivalent to vector, since we can inhabit unit with tt and only with tt.
 *
 * This is an interesting problem for search! But I think it should also be
 * undecidable, because it necessarily must determine whether the new hypothesis type
 * (here unit) is inhabitable. So, an idea for supporting this part is to get extra
 * user input on what to do about that extra type. Or, search can attempt to solve
 * this obligation in obvious cases.
 *
 * After figuring out that unit is inhabitable, for this to be an equivalence,
 * we need that unit is uniquely inhabitable. For unit this is easy,
 * but I can imagine having some dependent type here instead that makes even
 * this part not easy.
 *
 * This is also really interesting to me, so feel free to chime into #37 with ideas.
 *)

(* --- No index hypothesis of different types --- *)

(*
 * In addition to having the same number of hypotheses, we require that the
 * indices have type IB. This simplifies search. Consider this example:
 *)

Inductive vector_int (A : Type) : Z -> Type :=
| nilV_int : vector_int A (Z.of_nat 0)
| consV_int :
    forall (n : nat),
       A -> vector_int A (Z.of_nat n) -> vector_int A (Z.of_nat (S n)).

Fail Find ornament list vector_int as orn_list_vectorint.

(*
 * This is equivalent to vector, so this is an algebraic ornament.
 * But a search procedure needs to figure out that Z.of_nat is the patch
 * that gets us from nat to Z first. And for some terms, this function
 * might be less obvious.
 *
 * The way to loosen this restriction a bit is to chain DEVOID with PUMPKIN PATCH.
 * Finding the relationship between vector and vector_int is very, very much
 * a PUMPKIN PATCH problem in the original style of PUMPKIN PATCH. I am very
 * excited to do this as part of my thesis work, and I was very excited when
 * I found this problem to begin with. But it's a hard problem.
 *)

(* --- New hypotheses must be exactly the new index of the recursive references --- *)

(*
 * We actually had some support for some types for which this wans't true in
 * the past. But it led to some difficulties, so it's just in our GitHub history
 * for now. Here is a case that we never figured out:
 *)

Inductive bintree_weird (A : Type) : nat -> Type :=
| leafW :
    bintree_weird A 0
| nodeW :
    forall (n m : nat),
      bintree_weird A n -> A -> bintree_weird A (n + m - n) -> bintree_weird A (n + m).

Fail Find ornament bintree bintree_weird as orn_bintree_bintree_weird.

(*
 * This is exactly the same as our bintreeV type we can support, so it's an
 * algebraic ornament. But search doesn't know how to get (n + m) from n
 * and (n + m - n). And when it's looking for the indexer, it doens't have
 * the hypotheses n and m directly; it must make use of the indices n
 * and (n + m - n). This should be undecidable in general.
 *
 * Some cases should be easy, though:
 *)

Inductive bintree_weird2 (A : Type) : nat -> Type :=
| leafW2 :
    bintree_weird2 A 0
| nodeW2 :
    forall (n m : nat),
      bintree_weird2 A n -> A -> bintree_weird2 A ((0 + 0) + m) -> bintree_weird2 A (n + m).

Fail Find ornament bintree bintree_weird2 as orn_bintree_bintree_weird2.

(*
 * In this case, we should just be able to reduce ((0 + 0) + m) to m. So, at the
 * very least, we can easily loosen "exactly" to "definitionally equal to."
 * But we don't do this yet. If it's useful, we will.
 *)

(* --- Input term is well-typed --- *)

(*
 * Well, you can't define an ill-typed term in Coq, but if you could,
 * we wouldn't provide any guarantees about lifting it.
 *)

(* --- Input term is fully η-expanded --- *)

(*
 * We actually lift this restriction. Consider:
 *)
Lift list vector in @cons as consV.

(*
 * It was just easier to assume it for presenting the algorithm.
 * Basically you should either fully expand your term ahead of time when
 * running through the algorithm, or the algorithm should do it as it goes.
 * We implement lazy η-expansion.
 *)

(* --- Input term does not apply promote or forget --- *)

(*
 * We can lift some of these terms without failing, but we don't recursively
 * preserve the equivalence. So there aren't any real guarantees. Consider:
 *)

Definition promote_again (T : Type) (l : list T) :=
  ltv T l.

Lift list vector in promote_again as id_sigT_vect.
Check id_sigT_vect.

(*
 * This might be fine, honestly, but it's harder to reason about.
 *)

(* --- Input term does not reference the new type --- *)

(*
 * Along the same lines, I'm not sure what it means to lift this,
 * even though it works:
 *)

Definition unsure (T : Type) (l : list T) (v : sigT (vector T)) :=
  l.

Lift list vector in unsure as unsure_v.
Check unsure_v.

(*
 * I think this is actually OK, too. I think it still preserves the
 * equivalence this way. But, I didn't think much about these terms,
 * and I didn't want to make any claims in the paper that weren't true,
 * so I just was honest about not thinking about them.
 *)

(* --- Index is not the original type (no refinement) --- *)

(*
 * We don't yet support refinements:
 *)

Inductive nat_nat : nat -> Set :=
| OO : nat_nat 0
| SS : forall (n : nat), nat_nat n -> nat_nat (S n).

(*
 * Search can actually handle this fine:
 *)

Find ornament nat nat_nat as nat_to_nat_nat.

(*
 * The difficult comes from lifting. Some liftings work:
 *)
Lift nat nat_nat in 0 as OO_p.
Lift nat nat_nat in (fun (n : nat) => n) as id_nat_nat.

(*
 * But some do not (because of some kind of compiler bug, I can't demonstrate this infinite loop
 * since it will actually loop infinitely and not trigger the timeout, thanks to some incorrect compiler
 * optimization):
 *)
(*Fail Timeout 5 Lift nat nat_nat in S as SS_p.*)

(*
 * This is because the lifting algorithm is not yet smart enough to stop
 * recursing in some cases. For example, LIFT-CONSTR recurses after calling
 * the intermediate rule. It will this keep recursively lifting S.
 *
 * Supporting this is tricky, but should be possible. It took more than a few days
 * of trying, though, so we deferred it to later. We're primarily interested
 * in changes in types when the old type is no longer available, or deriving
 * new libraries from old libraries. But refinement types are a really
 * interesting use case for a tool like this. So we'd like to handle this one day.
 * See issue #41 for the status of this.
 *)

(* --- Extra restrictions for forgetful direction --- *)

(*
 * The forgetful direction currently doesn't let you forget terms defined
 * directly over vectors (see #42 for status here). You must pack them instead.
 *
 * There's a bug (see #58) that means you can't actually roundtrip right now
 * without reducing in the general case. I'm going to fix it for simple cases
 * right now, but I want #42 for the more general case.
 *)


From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp.
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 ProofIrrelevance FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.
Global Set Bullet Behavior "Strict Subproofs".

Lemma Rlt_plus_reg a b a' b': a + b < a' + b' → (a < a') ∨ (b < b').
Proof.
  intros.
  destruct (Rlt_dec a a') as [|?%Rnot_lt_ge]; first by auto.
  destruct (Rlt_dec b b') as [|?%Rnot_lt_ge]; first by auto.
  fourier.
Qed.

Section lemma31_simplex.

Variable A: finType.
Variable B: eqType.
Variable Ω: distrib A.
Variable X: rvar Ω [eqType of B * B].
Variable size: B → R.
Variable g: R → R.
Variable f: R → R.
Variable x c: R.

Hypothesis xgt : x > 0.
Hypothesis cgt : c > 0.
Hypothesis Xrange11: ∀ r,  r \in img X → 0 ≤ size (fst r).
Hypothesis Xrange21: ∀ r,  r \in img X → 0 ≤ size (snd r).
Hypothesis Xrange12: ∀ r,  r \in img X → size (fst r) ≤ x.
Hypothesis Xrange22: ∀ r,  r \in img X → size (snd r) ≤ x.
Hypothesis grange1: ∀ r,  r \in img X → 0 ≤ g (size (fst r)).
Hypothesis grange2: ∀ r,  r \in img X → 0 ≤ g (size (snd r)).
Hypothesis grange_sum: ∀ r,  r \in img X → g (size (fst r)) + g (size (snd r)) ≤ g x.

Hypothesis f0: f 0 = 0.
Hypothesis frange1: ∀ x,  0 ≤ f x.
Variable z : R.
Hypothesis zgt1 : z ≥ 1.
Hypothesis frange2: ∀ y, y ≥ c → f y = z.

Hypothesis fnondec: ∀ y y',
    (y ≤ y') ∧
    (0 < y ∧ y ≤ c) ∧
    (0 < y' ∧ y' ≤ c) →
    (f y / y) ≤ (f y' / y').

Lemma min_xc_gt: Rmin x c > 0.
Proof. by apply Rmin_case. Qed.
Lemma min_xc_neq0: Rmin x c ≠ 0.
Proof. eapply Rlt_not_eq'. apply min_xc_gt. Qed.

Lemma fmono_aux y y':
  0 ≤ y → y ≤ y' → y' ≤ c → f y ≤ f y'.
Proof.
  intros Hge0 Hle Hlec.
  inversion Hge0; last first.
  { subst. rewrite f0; eauto. }
  assert (f y / y ≤ f y' / y') as Hdiv.
  { eapply fnondec. repeat split; eauto; try fourier. }
  apply (Rmult_le_reg_r (/ y')).
  { apply Rinv_0_lt_compat; fourier. }
  transitivity (f y / y); last by auto.
  rewrite /Rdiv. apply Rmult_le_compat; auto; try fourier.
  * left. apply Rinv_0_lt_compat; fourier.
  * apply Rinv_le_contravar; fourier.
Qed.

Lemma fmono y y':
  0 ≤ y → y ≤ y' → f y ≤ f y'.
Proof.
  intros Hge0 Hle.
  destruct (Rle_dec y' c) as [?|Hgt%Rnot_le_gt]; first apply fmono_aux; eauto.
  destruct (Rle_dec y c) as [?|Hgt'%Rnot_le_gt].
  - rewrite (frange2 y'); last fourier.
    rewrite -(frange2 c); last fourier.
    apply fmono_aux; auto; fourier.
  - rewrite (frange2 y'); last fourier.
    rewrite (frange2 y); last fourier.
    reflexivity.
Qed.

Lemma lemma31_simplex: Ex (rvar_comp X (λ r, (g (size (fst r))) * f (size (fst r)) +
                                           (g (size (snd r))) * f (size (snd r))))
                                   ≤ (Ex (rvar_comp X (λ r, Rmax (size (fst r)) (size (snd r)))))
                                          * (g x * f (Rmin x c) / (Rmin x c)).
Proof.
  rewrite /Rdiv Rmult_comm.
  rewrite ?Ex_fin_pt.
  rewrite big_distrr//=.
  apply (Rle_bigr) => r Hin.
  - rewrite -?Rmult_assoc.
    apply (Rmult_le_compat_r (rvar_dist X r)); first by (auto using Rge_le, pmf_pos).
     etransitivity.
     { apply Rplus_le_compat; apply Rmult_le_compat_l.
       - apply grange1, img_alt. exists r. auto.
       - apply (fmono _ (Rmax (size (fst (X r))) (size (snd (X r))))).
         * apply Xrange11, img_alt. exists r. auto.
         * apply Rmax_l.
       - apply grange2, img_alt. exists r. auto.
       - apply (fmono _ (Rmax (size (fst (X r))) (size (snd (X r))))).
         * apply Xrange21, img_alt. exists r. auto.
         * apply Rmax_r.
     }
     rewrite -Rmult_plus_distr_r.
     rewrite ?Rmult_assoc.
     apply Rmult_le_compat; eauto.
     {
       - replace 0 with (0 + 0) by field.
         apply Rplus_le_compat.
         * apply grange1, img_alt. exists r. auto.
         * apply grange2, img_alt. exists r. auto.
     }
     { apply grange_sum, img_alt. exists r. auto. }
     set (y := Rmax (size (fst (X r))) (size (snd (X r)))).
     rewrite -?/y.
     assert (y ≤ x).
     {
       rewrite /y. apply Rmax_case.
       * apply Xrange12, img_alt; eauto.
       * apply Xrange22, img_alt; eauto.
     }
     assert (g y ≤ g x).
     {
       assert (0 ≤ (g (size ((fst (X r)))))); first apply grange1, img_alt; eauto.
       assert (0 ≤ (g (size ((snd (X r)))))); first apply grange2, img_alt; eauto.
       rewrite /y; transitivity (g (size (X r).1) + g (size (X r).2)).
       - apply Rmax_case; fourier.
       - apply grange_sum, img_alt; eauto.
     }
     assert (0 ≤ y) as [Hgt|HX0].
     {
       rewrite /y; apply Rmax_case; [ eapply Xrange11 | eapply Xrange21]; apply img_alt;
       exists r; eauto.
     }
     * apply (Rmult_le_reg_r (Rdiv 1 y)).
         apply Rdiv_lt_0_compat; fourier.
         transitivity (f (Rmin x c) / (Rmin x c)); last first.
         *** apply Req_le. field; split.
             **** by apply Rlt_not_eq'.
             **** apply min_xc_neq0.
         *** rewrite -Rmult_assoc.
             rewrite Rmult_1_r.
             destruct (Rlt_or_le y c).
             **** eapply fnondec; repeat split; auto; try fourier.
                  { apply Rmin_case; fourier. }
                  { apply Rmin_case; fourier. }
                  { apply Rmin_r. }
             **** assert (Rmin x c = c) as ->.
                  { apply Rmin_right. fourier. }
                  rewrite frange2; last fourier.
                  rewrite frange2; last fourier.
                  rewrite /Rdiv. apply Rmult_le_compat; try fourier.
                  { apply Rlt_le. apply Rinv_0_lt_compat. fourier. }
                  eapply Rinv_le_contravar; fourier.
     * rewrite -HX0 f0 Rmult_0_r. fourier.
Qed.

End lemma31_simplex.

Section span_bound_sec.

Variable X: eqType.
Variable size: X → R.
Variable g: R → R.
Variable A B : X → finType.
Variable ΩT: ∀ x, distrib (A x).
Variable Ωh: ∀ x, distrib (B 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 a: R → R.
Variable m: R → R.
Variable u u': R → R.
Variable d: R.
Hypothesis umin: R.
Hypothesis umin_non_neg: 0 ≤ umin.
Hypothesis umin_lb: ∀ x, x > d → umin ≤ u x - a x.
Variable u_mono: ∀ x y, x ≤ y → u x ≤ u y.
Variable u_strict_inc: ∀ x y, x ≥ d → x < y → u x < u y.
Variable u'_mono: ∀ x y, x ≤ y → u' x ≤ u' y.
Variable u'_pos: ∀ x,  u' x > 0.
Variable u'u: ∀ x, (* d < x → *) x ≤ u' (u x).
Variable u'_inv_above: ∀ z, d < z → u' (u z) = z.
Variable u_inv_above: ∀ z, umin < z → u (u' z) = z.
Variable ud_umin: u d = umin.
Variable m_bound_Eh: ∀ x, Ex (rvar_comp (h x) (λ x, Rmax (size (fst x)) (size (snd x)))) ≤ m (size x).

Variable u_cont: ∀ x, d < x → continuity_pt u x.
Variable a_cont: ∀ x, d < x → continuity_pt a x.

Hypothesis T_non_neg: ∀ x n, (T x) n ≥ 0.

Hypothesis Trec:
  ∀ x r, P x → size x > d →  pr_gt (T x) r ≤ \big[Rplus/0]_(x' : imgT (h x))
                        (pr_eq (h x) (sval x') *
                         pr_gt (rvar_comp (rvar_pair (T (fst (sval x'))) (T (snd (sval x'))))
                                          (fun xy => Rmax (fst xy) (snd xy))) (r - a (size x))).
(*
Hypothesis Trec:
  ∀ x r,  pr (T x) r = \rsum_(x' <- img (h x))
                        (pr (h x) x') * pr (comp_rv (pair_rv (T (fst x')) (T (snd x')))
                                        (fun xy => Rmax (fst xy) (snd xy))) (r - a (size x)).
*)

Hypothesis urec:
  ∀ x, x > d →  u x ≥ a x + u (m x).

Hypothesis hP: ∀ x n, P x → P (fst ((h x) n)) ∧ P (snd ((h x) n)).
(* Hypothesis hrange_sum: ∀ x n, size (fst ((h x) n)) + size (snd ((h x) n)) ≤ size x. *)
Hypothesis hgrange_sum: ∀ x n, size x > d → g (size (fst ((h x) n))) + g (size (snd ((h x) n))) ≤ g (size x).
(* FIXME: 11, 21 follow from sum And 12 22 *)
Hypothesis hrange11: ∀ x n, size (fst ((h x) n)) ≤ size x.
Hypothesis hrange21: ∀ x n, size (snd ((h x) n)) ≤ size x.
Hypothesis hrange12: ∀ x n, d < size x →  0 ≤ size (fst ((h x) n)).
Hypothesis hrange22: ∀ x n, d < size x →  0 ≤ size (snd ((h x) n)).

Hypothesis alower: ∀ x, x ≤ d → a x = 0.
Hypothesis a_nonneg: ∀ x, a x ≥ 0.
Hypothesis a_mono: Rmono a.
Hypothesis a_pos: ∀ x, d < x → 0 < a x.
Hypothesis mnondec: ∀ y y', 0 < y → y ≤ y' → (m y / y) ≤ (m y' / y').
Hypothesis d_non_neg: 0 ≤ d.
Hypothesis mpos: ∀ x, 0 ≤ x → 0 ≤ m x.

Definition Bn (nx: nat * X) : finType := B (snd nx).
Definition Ωn (nx: nat * X) := Ωh (snd nx).
Definition hpath (φ: nat → bool) (nx: nat * X) : rvar (Ωn nx) [eqType of nat * X].
  destruct nx as (n, x).
  apply mkRvar.
  intros i.
  exact (match (φ n) with
         | true =>  (S n, fst ((h x) i))
         | false => (S n, snd ((h x) i))
         end).
Defined.

(*
Definition Krecfun φ (i: nat) r x : R := Krec _ (λ x, size (snd x)) _ (hpath φ) a umin i r x.
*)

(* This could be weakend; I think what's needed is to say it in the limit
   it's bounded above by 2^-n *)
Hypothesis hinf_0: ∀ a, ∃ n, ∀ φ, pr_gt (rvar_comp (recN_rvar (hpath φ) (O, a) n)
                                                  (λ x, size (snd x))) d = 0.

Hypothesis Tbelow: ∀ x e, size x ≤ d → (T x) e ≤ umin.
Hypothesis gd: ∀ x, x > d → g x ≥ 1.
Hypothesis gpos: ∀ x, 0 ≤ x → 0 ≤ g x.
Hypothesis g_mono: Rmono g.

Definition K r z := pr (rvar_dist (T z)) (λ n, Rgt_dec ((T z) n) r).

Lemma umin_lb_simple: ∀ x, x ≥ d → umin ≤ u x.
Proof.
  rewrite /Rge => x [Hgt|Heq].
  - transitivity (u x - a x); first auto. assert (a x > 0) by (apply a_pos; auto).
    fourier.
  - subst. reflexivity.
Qed.

Lemma K_alt4 r z:
  P z →
  size z > d →
  K r z ≤ \big[Rplus/0]_(i : imgT (h z)) ((pr_eq (h z) (sval i)
                                             * ((K (r - (a (size z))) (fst (sval i))) +
                                                (K (r - (a (size z))) (snd (sval i)))))).
Proof.
  rewrite {1}/K.
  etransitivity.
  { etransitivity; first apply Trec; last reflexivity; auto. }
  apply Rle_bigr.  intros (x'&Hin) _.
  set (Trecpair := rvar_comp (rvar_pair (T x'.1) (T x'.2)) (λ xy, Rmax (fst xy) (snd xy)));
    rewrite -/Trecpair.
  apply Rmult_le_compat_l; first by (rewrite /pr_eq; apply Rge_le, ge_pr_0).
  set (pred_combined := (fun x: (A (fst x')) * A (snd x') =>
                           Rgt_dec (Rmax ((T x'.1) x.1) (T x'.2 x.2))
                                   (r - a (size z))) : pred (A (fst x') * A (snd x'))).
  set (predA := (fun x: (A (fst x')) * A (snd x') =>
                           Rgt_dec (T (fst x') (fst x))
                                   (r - a (size z))) : pred (A (fst x') * A (snd x'))).
  set (predB := (fun x: (A (fst x')) * A (snd x') =>
                           Rgt_dec (T (snd x') (snd x))
                                   (r - a (size z))) : pred (A (fst x') * A (snd x'))).
    assert (Heq: pred_combined =i predU predA predB).
    {
      intros y. rewrite /in_mem//=/pred_combined/predA/predB/predU.
      apply Rmax_case_strong => Hcase;
      destruct (Rgt_dec) as [Hgt|Hnotgt] => //=; try nra;
      destruct (Rgt_dec) as [Hgt'|Hnotgt'] => //=; try nra;
      rewrite //= in Hgt', Hnotgt, Hcase; nra.
    }
   rewrite /pr_gt.
   rewrite (pr_eq_pred _ _ _ Heq).
   etransitivity; first apply pr_union_le.
   rewrite /K/Trecpair//=.
   apply Rplus_le_compat; right.
   - rewrite /predA.
     by rewrite (rvar_pair_marginal1 (T (fst x')) (T (snd x'))
                 ((λ x, Rgt_dec ((T x'.1) x) (r - a (size z))))).
   - rewrite /predB.
     by rewrite (rvar_pair_marginal2 (T (fst x')) (T (snd x'))
                 ((λ x, Rgt_dec ((T x'.2) x) (r - a (size z))))).
Qed.

Definition K0 r (z: X) :=
  if (Rlt_dec r umin) then
    1
  else
    0.

Fixpoint Krec i r x :=
  match i with
    | 0 => K0 r x
    | S i' => Rmin 1 (Ex (rvar_comp (h x) (fun x' => Krec i' (r - a (size x)) (fst x') +
                                           Krec i' (r - a (size x)) (snd x'))))
  end.

Definition round r x := Rceil ((r - u x) / a x).

Definition D r x :=
  if Rle_dec r umin then
    1
  else
    if Rle_dec x d then
        0
    else
      if Rle_dec r (u x) then
         Rmax 1 (g (u' r))
      else
        (m x / x)^(Z.to_nat (round r x)) * (g(x) * x / (u' (r - a(x) * IZR (round r x)))).

Definition Dalt r x :=
  if Rle_dec r umin then
    1
  else
    if Rle_dec x d then
        0
    else
      if Rlt_dec r (u x) then
         Rmax 1 (g (u' r))
      else
        (m x / x)^(Z.to_nat (round r x)) * (g(x) * x / (u' (r - a(x) * IZR (round r x)))).

Lemma D_Dalt_equiv r x:
  D r x = Dalt r x.
Proof.
  rewrite /Dalt /D.
  destruct (Rle_dec) as [?|Hgt] => //=.
  apply Rnot_le_gt in Hgt.
  destruct (Rle_dec) as [?|Hgt'] => //=.
  apply Rnot_le_gt in Hgt'.
  destruct (Rle_dec) as [Hle|?] => //=.
  - inversion Hle as [Hlt|Heq].
    * destruct (Rlt_dec) => //=.
    * subst. destruct (Rlt_dec) => //=.
      assert (round (u x) x = 0%Z) as ->.
      {
        rewrite /round. rewrite -Rceil_0. f_equal.
        rewrite Rminus_diag_eq // /Rdiv Rmult_0_l //.
      }
      rewrite //= Rmult_0_r /Rminus Ropp_0 Rplus_0_r u'_inv_above //=.
      rewrite /Rdiv Rmult_1_l. rewrite Rmax_right; first field.
      ** apply Rgt_not_eq; nra.
      ** apply Rge_le, gd; fourier.
  - destruct (Rlt_dec) => //=.
    intros. exfalso. nra.
Qed.

Lemma K_0 r z: r < 0 → K r z = 1.
Proof.
  intros Hlt. rewrite /K /pr.
  rewrite -(pmf_sum1_Series (rvar_dist (T z))).
  rewrite ?SeriesC_fin_big.
  eapply eq_big; auto.
  intros x Hin.
  destruct (Rgt_dec) as [?|Hngt] => //=.
  exfalso; apply Hngt.
  eapply Rlt_le_trans; eauto.
  apply Rge_le, T_non_neg.
Qed.

Lemma K_unfold r x: P x → size x > d →
                    K r x ≤ Ex (rvar_comp (h x) (fun x' => K (r - a (size x)) (fst x') +
                                                         K (r - a (size x)) (snd x'))).
Proof.
  intros; etransitivity; first apply K_alt4; auto.
  rewrite Ex_fin_comp.
  right; apply eq_bigr => ??. by rewrite Rmult_comm.
Qed.

Lemma Krec_non_decS: ∀ (i: nat) r x, Krec i r x ≤ Krec (S i) r x.
Proof.
  induction i as [|i'] => r x.
  - rewrite /Krec. rewrite Ex_fin_pt //= /K0.
    destruct (Rlt_dec) as [H|H];
    rewrite //= /rvar_comp //=.
    * destruct Rlt_dec as [|Hfalse].
      ** apply Rmin_case_strong; intros; first nra.
         rewrite //=. rewrite -big_distrr //=. rewrite -SeriesC_fin_big pmf_sum1_Series. nra.
      ** exfalso. eapply Hfalse.
         specialize (a_nonneg (size x)). nra.
    * destruct Rlt_dec as [|].
      ** apply Rmin_case_strong; intros; first fourier.
         rewrite //=. rewrite -big_distrr //=. rewrite -SeriesC_fin_big pmf_sum1_Series. nra.
      ** apply Rmin_case_strong; intros; first fourier.
         rewrite //=. rewrite -big_distrr //=. rewrite -SeriesC_fin_big pmf_sum1_Series. nra.
  - rewrite /Krec -/Krec. apply Rle_min_compat_l.
    rewrite ?Ex_fin_pt.
    apply (Rle_bigr) => i hin.
    rewrite //=. etransitivity.
    * apply Rmult_le_compat_r.
      { apply Rge_le, pmf_pos. }
      { apply Rplus_le_compat; eapply IHi'. }
    * rewrite //= ?Ex_fin_pt /rvar_comp //=; reflexivity.
Qed.

Lemma Krec_non_dec (i i': nat) r x: (i ≤ i')%nat → Krec i r x ≤ Krec i' r x.
Proof.
  induction 1; first reflexivity.
  etransitivity; [ apply IHle | apply Krec_non_decS ].
Qed.

Lemma Krec_bound0 r x i: 0 ≤ Krec i r x.
Proof.
  revert r x.
  induction i => r x.
  - rewrite //=. rewrite /K0. destruct Rlt_dec => //=; nra.
  - rewrite /Krec -/Krec Ex_fin_pt /rvar_comp //=.
    apply Rmin_case; first fourier.
    apply Rle_big0 => ??.
    rewrite -[a in a ≤ _](Rmult_0_l 0).
    apply Rmult_le_compat; try fourier.
    * replace 0 with (R0 + R0) by rewrite Rplus_0_l //=. apply Rplus_le_compat; eauto.
    * apply Rge_le, pmf_pos.
Qed.

Lemma Krec0_bound01 r x: 0 ≤ Krec 0 r x ∧ Krec 0 r x ≤ 1.
Proof.
  revert r x.
  rewrite //= /K0. split; destruct Rlt_dec => //=; nra.
Qed.

Lemma Krec_bound01 r x i: 0 ≤ Krec i r x ∧ Krec i r x ≤ 1.
Proof.
  revert r x.
  induction i => r x; (split; first (apply Krec_bound0; rewrite //=)).
  - rewrite //=/K0. destruct Rlt_dec => //=; nra.
  - rewrite /Krec -/Krec Ex_fin_pt /rvar_comp //=.
    apply Rmin_l.
Qed.

Lemma Krec_bound r x: bound (fun v => ∃ i, Krec i r x = v).
Proof.
  rewrite /bound /is_upper_bound. exists 1 => v [i <-].
  edestruct Krec_bound01; eauto.
Qed.

Definition Krec_sup (r: R) x : R :=
  proj1_sig (completeness (fun v => ∃ i, Krec i r x = v)
                          (Krec_bound r x)
                          (ex_intro _ (Krec 0 r x) (ex_intro _ O erefl))).

Lemma Krec_sup_is_lub r x: is_lub (fun v => ∃ i, Krec i r x = v) (Krec_sup r x).
Proof.
  rewrite /Krec_sup //=. by destruct (completeness _).
Qed.

Lemma K_Krec_leq_below i r x: size x ≤ d → K r x ≤ Krec i r x.
Proof.
  revert r x. induction i as [| i'] => r x Hle.
  - rewrite /K /Krec /K0 //=.
    destruct (Rlt_dec).
    + rewrite /is_left. apply pr_le_1.
    + rewrite /pr//=.  right. rewrite SeriesC_fin_big. eapply big1 => b ?.
      rewrite //=. destruct (Rgt_dec) as [?|Hnlt] => //=; try nra.
      specialize (Tbelow _ b Hle).
      exfalso. destruct (T x); simpl in *. nra.
  - etransitivity; first eapply IHi'; eauto.
    apply Krec_non_decS.
Qed.

Lemma K_Krec_bounded_gap i r x: K r x ≤ Krec i r x + 1.
Proof.
  transitivity 1; first apply pr_le_1.
  specialize (Krec_bound0 r x i) =>?. fourier.
Qed.

Definition recN_a {i: nat} φ x (b: @recN_space _ _ _ (hpath φ) x i) : R.
  revert x b. induction i.
  - intros x ?. exact 0.
  - intros x (b&b').
    exact (a (size (snd x)) + IHi ((hpath φ x) b) b').
Defined.

Lemma Rge_not_gt_eq x y: x >= y → (¬ x > y) → x = y.
Proof. nra. Qed.

Lemma Rge_not_eq_gt x y: x >= y → (¬ x = y) → x > y.
Proof. nra. Qed.

Lemma pr_gt_path_shift:
  ∀ k φ b r j x,
  pr_gt (rvar_comp (recN_rvar (hpath φ) (j, x) k) (λ x, size (snd x))) r=
  pr_gt (rvar_comp (recN_rvar (hpath (λ n, match n with
                                         | O => b
                                         | S n' => φ n'
                                         end)) (S j, x) k) (λ x, size (snd x))) r.
Proof.
  induction k; intros.
  - rewrite //=.
  - rewrite ?recN_pr_gt.
    rewrite /index_enum.
    rewrite [@Finite.enum]unlock //=.
    rewrite (img_fin_big' _ (λ i, (pr_eq _ i * pr_gt (rvar_comp (recN_rvar _ i _) _) _)) (λ x, true)).
    rewrite (img_fin_big' _ (λ i, (pr_eq _ i * pr_gt (rvar_comp (recN_rvar _ i _) _) _)) (λ x, true)).
    eapply (sum_reidx_map _ _ _ _ (λ x, (S (fst x), snd x))); auto.
    * intros (?&?) Hin; f_equal.
      ** rewrite /pr_eq/pr ?SeriesC_fin_big.
         apply eq_big => //=.
         intros ? _. destruct (φ j); auto.
      ** rewrite //=.
    * rewrite //=. intros (n&x'). rewrite ?img_alt'. intros (i&Hin) _.
      split; auto. exists i. move: Hin. rewrite //=.
      case: ifP; intros; inversion Hin; subst; f_equal; auto; omega.
    * rewrite //=. intros (n&x') Hin _ Hfalse.
      apply Rmult_eq_0_compat. right.

      rewrite /pr_gt.
      apply Rge_not_gt_eq; first apply ge_pr_0.
      intros Hgt.
      apply Rlt_gt, pr_img_gt in Hgt as (r'&Hgt&Himg).
      apply img_alt in Himg as (i&Himg).
      apply img_alt' in Hin as (i'&Himg').
      rewrite //= in Himg, Himg'.
      contradiction (Hfalse).
      move: Himg'. case: ifP => ? [? ?].
      ** exists (S j, x'). rewrite img_alt'. repeat split; auto.
         *** eexists; f_equal; eauto.
         *** f_equal; rewrite //=; try congruence; try omega.
      ** exists (S j, x'). rewrite img_alt'. repeat split; auto.
         *** eexists; f_equal; eauto.
         *** f_equal; rewrite //=; try congruence; try omega.
    * rewrite /img. apply undup_uniq.
    * rewrite /img. apply undup_uniq.
    * intros (?&?) (?&?). rewrite //= => _. inversion 1. subst; done.
Qed.

Lemma Krec_le_K_non_zero_path r x i:
  P x →
  Krec i r x < K r x →
  ∃ φ, pr_gt (rvar_comp (recN_rvar (hpath φ) (O, x) i) (λ x, size (snd x))) d > 0.
Proof.
  revert r x.
  induction i => r x HP Hlt.
  - destruct (Rle_dec (size x) d) as [Hlt2|Hnlt].
    * exfalso. apply Rlt_not_le in Hlt. apply Hlt.
      by apply K_Krec_leq_below.
    * exists (fun x => true).
      rewrite /pr_gt /pr //=.
      apply Rnot_le_gt in Hnlt.
      destruct (Rgt_dec) => //=.
      rewrite SeriesC_fin_big.
      rewrite /index_enum. rewrite (eq_bigl predT).
      ** rewrite /index_enum {1}[@Finite.enum]unlock big_seq1 //=. fourier.
      ** intros ?. rewrite /in_mem//=.
  - destruct (Rle_dec (size x) d) as [Hlt2|Hnlt%Rnot_le_gt].
    { exfalso. apply Rlt_not_le in Hlt. apply Hlt.
      by apply K_Krec_leq_below. }
    rewrite /Krec -/Krec in Hlt. move: Hlt. apply Rmin_case.
    { intros Hfalse%Rlt_not_le. contradiction Hfalse.
      rewrite /K. apply pr_le_1. }
    intros Hlt.
    eapply Rlt_le_trans in Hlt; last apply K_alt4; auto.
    rewrite Ex_fin_comp in Hlt.
    rewrite /index_enum [@Finite.enum]unlock //= in Hlt.
    rewrite (img_fin_big' _ (λ i, (pr_eq _ i * (Krec _ _ (fst i) + Krec _ _ (snd i)))) (λ x, true))
            in Hlt.
    rewrite (img_fin_big' _ (λ i, (pr_eq _ i * (K _ (fst i) + K _ (snd i)))) (λ x, true))
            in Hlt.
    apply Rlt_big_inv in Hlt as (b&Hin&_&Hlt).
    assert (pr_eq (h x) b > 0) as HPrb.
    { rewrite /pr_eq; apply Rge_not_eq_gt; first apply (ge_pr_0).
      intros Heq.
      rewrite /pr_eq ?Heq in Hlt. nra.
    }
    apply Rmult_lt_reg_l in Hlt; last auto.
    apply Rlt_plus_reg in Hlt as [Hlt1|Hlt2].
    * assert (P (fst b)) as HPb.
      { rewrite img_alt' in Hin *. intros (n&<-). eapply hP. eauto. }
      edestruct (IHi _ _ HPb Hlt1) as (φ&Hpr).
      exists (λ n, match n with
                | O => true
                | S n' => φ n'
                end).
      rewrite recN_pr_gt => //=.
      rewrite /index_enum.
      rewrite [@Finite.enum]unlock //=.
      rewrite (img_fin_big' _ (λ i, (pr_eq _ i * pr_gt (rvar_comp (recN_rvar _ i _) _) _))
                            (λ x, true)).
      eapply (Rle_lt_trans); first (right; symmetry; apply big1; reflexivity).
      eapply Rlt_bigr.
      ** intros; apply Rmult_le_pos; apply Rge_le, ge_pr_0.
      ** rewrite //=.
         exists (S O, fst b); repeat split.
         *** apply img_alt'. apply img_alt' in Hin.
             destruct Hin as (s&Heq). exists s. rewrite Heq. done.
         *** rewrite //=. apply Rmult_lt_0_compat.
             **** eapply Rlt_le_trans; first apply HPrb.
                  rewrite /pr_eq /pr ?SeriesC_fin_big /index_enum /Bn /=.
                  rewrite -?big_mkcondr.
                  apply Rle_bigr'; try nra.
                  ***** intros ?. move /andP => [_ Heq]. move /eqP in Heq; subst.
                        split; try nra. apply /andP; split; auto.
                        rewrite //= in Hpr. rewrite /Ωn//=. nra.
                  ***** intros. apply Rge_le, pmf_pos.
             **** eapply Rlt_le_trans; first apply Hpr.
                  right. apply pr_gt_path_shift.
    * assert (P (snd b)) as HPb.
      { rewrite img_alt' in Hin *. intros (n&<-). eapply hP. eauto. }
      edestruct (IHi _ _ HPb Hlt2) as (φ&Hpr).
      exists (λ n, match n with
                | O => false
                | S n' => φ n'
                end).
      rewrite recN_pr_gt => //=.
      rewrite /index_enum.
      rewrite [@Finite.enum]unlock //=.
      rewrite (img_fin_big' _ (λ i, (pr_eq _ i * pr_gt (rvar_comp (recN_rvar _ i _) _) _))
                            (λ x, true)).
      eapply (Rle_lt_trans); first (right; symmetry; apply big1; reflexivity).
      eapply Rlt_bigr.
      ** intros; apply Rmult_le_pos; apply Rge_le, ge_pr_0.
      ** exists (S O, (snd b)).
         repeat split.
         *** apply img_alt'. apply img_alt' in Hin.
             destruct Hin as (s&Heq). exists s. rewrite Heq. done.
         *** rewrite //=. apply Rmult_lt_0_compat.
             **** eapply Rlt_le_trans; first apply HPrb.
                  rewrite /pr_eq /pr /index_enum /Bn /= ?SeriesC_fin_big.
                  rewrite -?big_mkcondr.
                  apply Rle_bigr'; try nra.
                  ***** intros ?. move /andP => [_ Heq]. move /eqP in Heq; subst.
                        split; try nra. apply /andP; split; auto.
                        rewrite /Ωn //=. reflexivity.
                  ***** intros. apply Rge_le, pmf_pos.
             **** eapply Rlt_le_trans; first apply Hpr.
                  right. apply pr_gt_path_shift.
Qed.

Lemma K_le_supKrec r x: P x → K r x ≤ Krec_sup r x.
Proof.
  intros HP.
  apply Rnot_gt_le.
  intros Hgt.
  destruct (hinf_0 x) as [n Hpath0].
  destruct (Krec_sup_is_lub r x) as [Hub _].
  specialize (Hub (Krec n r x)).
  edestruct (Krec_le_K_non_zero_path r x n) as (φbad&Hbad); auto.
  { eapply (Rle_lt_trans _ (Krec_sup r x)); auto. apply Hub. eauto. }
  specialize (Hpath0 φbad). fourier.
Qed.

Lemma D0_aux r x:
   0 < x → 0 ≤ ((m x) / x) ^ Z.to_nat (round r x)
                                          * (g(x) * x / u' (r - a x * IZR (round r x))).
Proof.
  intros Hlt.
    eapply Rmult_pos.
    * eapply pow_le. rewrite /Rdiv.
      eapply Rle_mult_inv_pos; eauto.
      apply mpos. fourier.
    * rewrite /round //=.
      eapply Rle_mult_inv_pos.
      ** apply Rmult_le_pos; eauto.
         *** eapply gpos; fourier.
         *** fourier.
      ** eapply u'_pos.
Qed.

Lemma D0 r x:
  0 ≤ D r x.
Proof.
  rewrite /D.
  destruct (Rle_dec) => //=; intros; try nra.
  destruct (Rle_dec) => //=; intros; try nra.
  destruct (Rle_dec) => //=; intros; try nra.
  intros.
  { transitivity 1; first fourier. apply Rmax_l. }
  apply D0_aux. nra.
Qed.

Lemma uu'_adjoint x y: (* d < x → *) umin < y → x ≤ u' y ↔ u x ≤ y.
Proof.
  split.
  - intros ?%u_mono. transitivity (u (u' y)); eauto. right. by rewrite u_inv_above.
  - transitivity (u' (u x)); eauto.
Qed.

Lemma uu'_adjointrl x y: umin < y → x ≤ u' y → u x ≤ y.
Proof.
  eapply uu'_adjoint.
Qed.

Lemma uu'_adjointlr x y: (* d < x → *) u x ≤ y → x ≤ u' y.
Proof.
  transitivity (u' (u x)); eauto.
Qed.

Lemma uu': ∀ x, umin < x → u (u' x) ≤ x.
Proof.
  intros. apply uu'_adjointrl; auto; reflexivity.
Qed.

Definition kD := karp.D a m u u' d umin.

Lemma D_karpD r x:
  r > umin →
  (0 ≤ x ∧ x ≤ (u' r)) →
  D r x = g(x) * kD r x.
Proof.
  intros Hr (?&Hrange).
  rewrite D_Dalt_equiv.
  rewrite /kD. erewrite karp.D_Dalt_equiv; eauto.
  rewrite /Dalt /karp.Dalt.
  destruct (Rle_dec); first nra.
  rewrite /is_left.
  destruct (Rle_dec); first nra.
  rewrite /is_left.
  destruct (Rlt_dec).
  { intros. apply uu'_adjointrl in Hrange; last fourier.
  apply Rle_not_gt in Hrange. nra. }
  rewrite /karp.round/round.
  field; apply Rgt_not_eq, u'_pos.
Qed.

Lemma D_karpD' r x:
  r > umin →
  (0 ≤ x) →
  D r x ≤ g x * kD r x.
Proof.
  intros Hr ?.
  rewrite D_Dalt_equiv.
  rewrite /kD. erewrite karp.D_Dalt_equiv; eauto.
  rewrite /Dalt /karp.Dalt.
  destruct (Rle_dec) as [|?]; first nra.
  rewrite /is_left.
  destruct (Rle_dec) as [|Hled]; first nra.
  rewrite /is_left.
  destruct (Rlt_dec) as [Hr'%Rlt_le|?].
  { intros. rewrite Rmult_1_r.
    apply u'_mono in Hr'. rewrite u'_inv_above in Hr'; eauto; try nra.
    apply Rmax_case_strong; intros.
    * apply Rge_le, gd. nra.
    * apply g_mono; eauto.
  }
  rewrite /karp.round/round.
  right. field; apply Rgt_not_eq, u'_pos.
Qed.

Lemma D_karpD'' r x:
  g x > 1 →
  D r x ≤ g x * kD r x.
Proof.
  intros Hgt.
  rewrite D_Dalt_equiv.
  rewrite /kD. erewrite karp.D_Dalt_equiv; eauto.
  rewrite /Dalt /karp.Dalt.
  destruct (Rle_dec) as [|?]; first by nra.
  rewrite /is_left.
  destruct (Rle_dec) as [|Hled]; first nra.
  rewrite /is_left.
  destruct (Rlt_dec) as [Hr'%Rlt_le|?].
  { intros. rewrite Rmult_1_r.
    apply u'_mono in Hr'. rewrite u'_inv_above in Hr'; eauto; try nra.
    apply Rmax_case_strong; intros.
    * apply Rge_le, gd. nra.
    * apply g_mono; eauto.
  }
  rewrite /karp.round/round.
  right. field; apply Rgt_not_eq, u'_pos.
Qed.

Lemma Rmin_le_right x y z: y ≤ z → Rmin x y ≤ z.
Proof.
  intros. apply Rmin_case_strong; intros; fourier.
Qed.

Lemma Rceil_1 x: (0 < x) → (x ≤ 1) → Rceil x = 1%Z.
Proof.
  intros Hgt Hle.
  rewrite /Rceil.
  move: Hgt.
  case: ifP.
  - apply Int_part_mono in Hle.
    replace (Int_part 1) with 1%Z in Hle; last first.
    { replace 1 with (IZR 1) by auto. rewrite Int_part_IZR //=. }
    move /eqP => Heq.
    rewrite {1}(Int_frac_decompose x) Heq.
    destruct (Z_le_dec (Int_part x) 0) as [l|nl].
    * apply IZR_le in l. replace (IZR 0) with 0 in l by auto. intros; fourier.
    * intros. omega.
  - move /eqP => Hnfp0 Hgt.
    assert (Int_part x = 1 ∨ Int_part x = 0)%Z as [?|?].
    {
      apply Rlt_le in Hgt. apply Int_part_mono in Hgt.
      replace (Int_part 0) with 0%Z in Hgt; last first.
      { replace 0 with (IZR 0) by auto. rewrite Int_part_IZR //=. }
      apply Int_part_mono in Hle.
      replace (Int_part 1) with 1%Z in Hle; last first.
      { replace 1 with (IZR 1) by auto. rewrite Int_part_IZR //=. }
      assert (Int_part x = 1 ∨ Int_part x = 0)%Z as [?|?] by omega; omega.
    }
    * exfalso. rewrite {1}(Int_frac_decompose x) in Hle.
      destruct (base_fp x) as [Hge0 ?].
      inversion Hge0; last by nra.
      rewrite H in Hle. replace (IZR 1) with 1 in Hle by auto. fourier.
    * omega.
Qed.

Lemma Krec_le_D: ∀ i r x, Krec i r x ≤ D r (size x).
Proof.
  induction i => r x.
  - rewrite /K /D.
    destruct (Rle_dec) as [|Hgtmin]; first by (edestruct Krec0_bound01; eauto).
    rewrite /is_left.
    destruct (Rle_dec) as [Hge|Hnge].
    { right. rewrite //= /K0 //=. destruct (Rlt_dec) => //=; try nra. }
    rewrite /is_left.
    destruct (Rle_dec) as [Hge|Hnge'].
    { edestruct (Krec_bound01 r x O); eauto.
      transitivity 1; first nra. apply Rmax_l. }
    rewrite //= /K0.
    destruct (Rlt_dec) as [|Hnlt].
    { intros. exfalso; eapply Hgtmin. fourier. }
    eapply D0_aux. nra.
  - rewrite /K /D.
    destruct (Rle_dec) as [|Hgtmin]; first (clear IHi; edestruct Krec_bound01; eauto).
    destruct (Rle_dec) as [Hge|Hnge].
    {
      clear IHi.
      right. revert r x Hgtmin Hge. induction (S i).
      * rewrite //= /K0 //=. intros. destruct Rlt_dec; last reflexivity.
        exfalso; eapply Hgtmin. nra.
      * intros. rewrite /Krec -/Krec Ex_fin_pt /rvar_comp //=.
        rewrite alower; last fourier. rewrite Rminus_0_r.
        etransitivity; last (apply (Rmin_right)); f_equal; try nra.
        eapply big1 => b ?.  rewrite ?IHn //=; auto; try nra.
        ** transitivity (size x) => //.
        ** transitivity (size x) => //.
    }
    rewrite /is_left.
    destruct (Rle_dec) as [Hge|Hnge'].
    { clear IHi; transitivity 1; last apply Rmax_l. edestruct Krec_bound01; eauto. }
    assert (r - a (size x) > umin) as Hgt.
    {
      apply Rgt_ge_trans with (r2 := u (size x) - a (size x)); first by nra.
      apply /Rle_ge/umin_lb. nra.
    }
    destruct (Rge_dec d (u' (r - a (size x)))) as [Hge|Hlt]; [| apply Rnot_ge_lt in Hlt].
    {
      exfalso. apply Rge_le in Hge. apply u_mono in Hge.
      rewrite u_inv_above //= in Hge. fourier.
    }
    rewrite /Krec -/Krec.
    transitivity
      (Ex (rvar_comp (h x) (λ x', (g (size (fst x'))) * kD (r - a (size x)) (size (fst x')) +
                                  (g (size (snd x'))) * kD (r - a (size x)) (size (snd x'))))).
    {
      apply Rmin_le_right.
      rewrite ?Ex_fin_pt //=.
      apply Rle_bigr => z ?.
      * apply Rmult_le_compat_r. apply Rge_le, pmf_pos.
        apply Rplus_le_compat.
        ** etransitivity; last apply D_karpD'; eauto.
           eapply hrange12. nra.
        ** etransitivity; last apply D_karpD'; eauto.
           eapply hrange22. nra.
    }
    etransitivity.
    {
    eapply lemma31_simplex with (g := g) (size := size) (X := h x) (c := u' (r - a (size x)))
                                          (f := (λ z, kD (r - a (size x)) z))
                                          (x := size x)
                                          (z := 1).
        * nra.
        * apply u'_pos.
        * intros p. rewrite img_alt. intros (n&?). subst.
          eapply hrange12. nra.
        * intros p. rewrite img_alt. intros (n&?). subst.
          eapply hrange22. nra.
        * intros p. rewrite img_alt. intros (n&?). subst.
          eauto.
        * intros p. rewrite img_alt. intros (n&?). subst.
          eauto.
        * intros p. rewrite img_alt. intros (n&?). subst.
          eapply gpos, hrange12. nra.
        * intros p. rewrite img_alt. intros (n&?). subst.
          eapply gpos, hrange22. nra.
        * intros p. rewrite img_alt. intros (n&?). subst.
          eauto. eapply hgrange_sum. nra.
        * rewrite /kD/karp.D.
          repeat (destruct (Rle_dec); rewrite /is_left; try nra).
        * rewrite /kD; apply karp.D0; eauto.
        * fourier.
        * intros y Hley.
          rewrite /kD/karp.D.
          repeat (destruct (Rle_dec); rewrite /is_left; try nra).
          apply Rge_le, u_mono in Hley. rewrite u_inv_above // in Hley.
        * intros. eapply karp.Dnondec; eauto.
    }
    rewrite /Rdiv ?Rmult_assoc. etransitivity.
    {
      apply Rmult_le_compat_r; last (apply m_bound_Eh).
      apply Rmult_le_pos.
      - apply gpos. nra.
      - apply Rle_mult_inv_pos; auto.
          * rewrite /kD. apply karp.D0; eauto.
          * apply Rmin_case; nra.
    }
    assert (round r (size x) = 1 + round (r - a (size x)) (size x))%Z as Hplus.
    {  rewrite /round. rewrite Zplus_comm -Rceil_plus_1; f_equal.
       field. apply Rgt_not_eq. apply a_pos. nra.
    }
    assert (Hrgt0: (round r (size x) > 0)%Z).
    {
      rewrite /round. rewrite -Rceil_0. apply Zlt_gt, Rceil_mono_strict. apply frac_part_0.
      apply Rdiv_lt_0_compat.
      - nra.
      - apply a_pos. nra.
    }
    assert (0 <= round (r - a (size x)) (size x))%Z by omega.
    apply Rmin_case_strong.
    * rewrite Hplus.
      intros Hminl. rewrite /kD. erewrite karp.D_Dalt_equiv; eauto. rewrite /karp.Dalt //.
      destruct (Rle_dec); rewrite /is_left; first nra.
      destruct (Rle_dec); rewrite /is_left; first nra.
      destruct (Rlt_dec).
      { move: Hminl. move /uu'_adjointrl/Rle_ge/Rge_not_lt. nra. }
      right.
      rewrite Z2Nat.inj_add; try omega.
      rewrite plus_IZR. replace (IZR 1) with 1 by auto.
      rewrite //=.
      rewrite Rmult_plus_distr_l Rmult_1_r.
      rewrite /Rminus. rewrite Ropp_plus_distr.
      rewrite Rplus_assoc.
      rewrite /round/karp.round.
      rewrite /Rdiv. field.
      split.
      ** apply Rgt_not_eq, u'_pos.
      ** apply Rgt_not_eq. nra.
    * intros Hminr. rewrite /kD. erewrite karp.D_Dalt_equiv; eauto. rewrite /karp.Dalt //.
      destruct (Rle_dec); rewrite /is_left; first nra.
      destruct (Rle_dec); rewrite /is_left; first nra.
      destruct (Rlt_dec) as [Hbad|].
      { move: Hbad. rewrite u_inv_above; nra. }
      right. symmetry.
      assert (round (r - a (size x)) (u' (r - a (size x))) = 0)%Z as Hround0'.
      {
        rewrite /round -Rceil_0. f_equal.
        rewrite u_inv_above /Rdiv; last done.
        apply Rmult_eq_0_compat_r; ring.
      }
      rewrite /karp.round. rewrite /round in Hround0'. rewrite Hround0'.
      rewrite //= Rmult_0_r Rminus_0_r Rmult_1_l /Rdiv Rinv_r;
        last by apply Rgt_not_eq, u'_pos.
      rewrite Rmult_1_l.
      assert (round r (size x) = 1)%Z as ->.
      { rewrite /round. apply Rceil_positive_le1.
        - move: Hrgt0. rewrite /round. done.
        - apply (Rmult_le_reg_r (a (size x))).
          * apply a_pos. nra.
          * rewrite Rmult_1_l /Rdiv Rmult_assoc Rinv_l.
            ** rewrite Rmult_1_r. apply u_mono in Hminr.
               rewrite u_inv_above in Hminr; nra.
            ** apply Rgt_not_eq, a_pos. nra.
      }
      replace (IZR 1) with 1 by auto. rewrite //= ?Rmult_1_r.
      field; split.
      ** apply Rgt_not_eq, u'_pos.
      ** nra.
Qed.

Theorem span_bound r x: P x → K r x ≤ D r (size x).
Proof.
  transitivity (Krec_sup r x).
  - apply K_le_supKrec; auto.
  - apply (proj2 (Krec_sup_is_lub r x)).
    intros ? (i&<-); apply Krec_le_D.
Qed.

Theorem span_bound_simple w x:
  g (size x) > 1 →
  size x > d →
  P x → pr_gt (T x) (u (size x) + INR w * a (size x)) ≤ g (size x) * (m (size x) / size x) ^ w.
Proof.
  set (r := u (size x) + INR w * a (size x)).
  transitivity (D r (size x)).
  - apply span_bound; auto.
  -  rewrite /D/r. destruct (Rle_dec) as [Hle|?].
     { rewrite //=. destruct w; first by (rewrite //=; nra).
         assert (umin <= u (size x)) by (apply umin_lb_simple; nra).
         assert (a (size x) > 0) by (apply a_pos; nra).
         specialize (pos_INR w).
         intros. rewrite S_INR in Hle. exfalso. nra.
     }
     rewrite //=.
     destruct Rle_dec => //=; try nra; [].
     destruct Rle_dec as [Hle|?].
     { intros. rewrite //=.
       destruct w.
       { replace (INR 0) with 0 by auto. rewrite Rmult_0_l Rplus_0_r.
         rewrite u'_inv_above; last nra.
         apply Rmax_case_strong; nra.
       }
       assert (umin <= u (size x)) by (apply umin_lb_simple; nra).
       assert (a (size x) > 0) by (apply a_pos; nra).
       specialize (pos_INR w).
       intros. exfalso.  rewrite S_INR in Hle. exfalso. nra.
     }
     rewrite //=.
     assert (round (u (size x) + INR w * a (size x)) (size x) = Z_of_nat w) as Hround.
     {
       rewrite /round.
       assert ((u (size x) + INR w * a (size x) - u (size x)) / a (size x)=
               INR w) as ->.
       { field. specialize (a_pos (size x)). nra. }
        rewrite INR_IZR_INZ Rceil_IZR. done.
     }
     rewrite Hround //=. rewrite INR_IZR_INZ.
     rewrite (Rmult_comm (IZR _)).
     assert (u (size x) + a (size x) * IZR (Z.of_nat w) - a (size x) * IZR (Z.of_nat w)
             = u (size x)) as -> by field.
     rewrite u'_inv_above; last by nra.
     rewrite /Rdiv. rewrite (Rmult_assoc (g (size x))). rewrite Rinv_r; last by nra. rewrite Rmult_1_r.
      rewrite Nat2Z.id. nra.
Qed.

End span_bound_sec.


Require Import Iron.Language.SystemF2r.SubstTypeType.
Require Import Iron.Language.SystemF2r.TyJudge.

Theorem subst_type_exp_ix
 :  forall ix ke te x1 t1 t2 k2
 ,  get ix ke = Some k2
 -> TYPE ke  te x1 t1
 -> KIND (delete ix ke)  t2 k2
 -> TYPE (delete ix ke)     (substTE ix t2 te)
         (substTX ix t2 x1) (substTT ix t2 t1).
Proof.
 intros. gen ix ke te t1 t2 k2.
 induction x1; intros; simpl; inverts_type; eauto.

 Case "XVar".
  apply TYVar.
  unfold substTE. auto.
  eapply subst_type_type_ix; eauto.

 Case "XLAM".
  simpl. apply TYLAM.
  rewrite delete_rewind.
  rewrite (liftTE_substTE 0 ix).
  eauto using kind_kienv_weaken.

 Case "XAPP".
  rewrite (substTT_substTT 0 ix).
  eauto using subst_type_type_ix.
  apply TYAPP.
   simpl. eapply (IHx1 ix) in H6; eauto.
   simpl. eapply subst_type_type_ix; eauto.

 Case "XLam".
  simpl. apply TYLam.
  eapply subst_type_type_ix; eauto.
  unfold substTE. rewrite map_rewind.
  rrwrite ( map (substTT ix t2) (te :> t)
         = substTE ix t2 (te :> t)).
  burn.

 Case "XApp".
  eapply TYApp.
   eapply IHx1_1 in H6; eauto.
    simpl in H6. burn.
   eapply IHx1_2 in H8; eauto.
Qed.

Theorem subst_type_exp
 :  forall ke te x1 t1 t2 k2
 ,  TYPE (ke :> k2) te x1 t1
 -> KIND ke  t2 k2
 -> TYPE ke (substTE 0 t2 te) (substTX 0 t2 x1) (substTT 0 t2 t1).
Proof.
 intros.
 rrwrite (ke = delete 0 (ke :> k2)).
 eapply subst_type_exp_ix; burn.
Qed.