(** * Encoder/Decoder by Radix *)
Require Import Recdef.
Require Import List.
Require Import Arith.
Require Import NArith.
Require Import ZArith.
Require Import Omega.
Require Import Ring.

Section fold_unfold_N.
(** Variable *)
Variable radix : Z.
Variable Hradix : (radix >= 2)%Z.

Definition Nradix := N_of_Z radix.

(** Preparations *)

Ltac intro_discri :=
 let H' := fresh "H" in
 intro H'; discriminate H'.

Ltac simpl_discri H :=
 simpl in H; discriminate H.

Ltac add_H' P H' := specialize P; intro H'.

Ltac add_H P := specialize P; intro.

(* It solves only trivial ones. *)
Ltac elim_ineq H' :=
match type of H' with
| (_ < _)%Z => unfold Zlt in H'; simpl_discri H'
| (_ > _)%Z => unfold Zgt in H'; simpl_discri H'
| (_ <= _)%Z => unfold Zle in H'; simpl in H'; elim H'; auto
| (_ >= _)%Z => unfold Zge in H'; simpl in H'; elim H'; auto
| (_ < _)%N => unfold Nlt in H'; simpl_discri H'
| (_ > _)%N => unfold Ngt in H'; simpl_discri H'
| (_ <= _)%N => unfold Nle in H'; simpl in H'; elim H'; auto
| (_ >= _)%N => unfold Nge in H'; simpl in H'; elim H'; auto
end.

(* Simple lemmas *)
Lemma radix_pos : (radix > 0)%Z.
Proof with auto.
omega.
Qed.

Lemma Z0_le_radix : (0 <= radix)%Z.
Proof with auto.
omega.
Qed.

Lemma Zabs_radix : (Zabs radix = radix)%Z.
Proof with auto.
destruct radix...
elim Hradix. simpl...
Qed.

Hint Extern 5 ((radix > 0)%Z) => eapply radix_pos : mydb.
Hint Extern 5 ((0 <= radix)%Z) => eapply Z0_le_radix : mydb.
Hint Extern 5 ((Zabs radix = radix)%Z) => eapply Zabs_radix : mydb.

Lemma Z0_le_Zpos : forall p, (0<=Zpos p)%Z.
Proof.
intros; destruct p; unfold Zle;
simpl; intro_discri.
Qed.

Lemma Z0_lt_Zpos : forall p, (0<Zpos p)%Z.
Proof.
intros; destruct p; unfold Zlt; auto.
Qed.

Lemma Zpos_ge_Z0 : forall p, (Zpos p>=0)%Z.
Proof.
intros; destruct p; unfold Zle;
simpl; intro_discri.
Qed.

Lemma Zpos_gt_Z0 : forall p, (Zpos p>0)%Z.
Proof.
intros; add_H (Z0_lt_Zpos p); omega.
Qed.

Hint Extern 5 ((0 < Zpos ?X)%Z) => eapply Z0_lt_Zpos : mydb.
Hint Extern 5 ((0 <= Zpos ?X)%Z) => eapply Z0_le_Zpos : mydb.
Hint Extern 5 ((Zpos ?X > 0)%Z) => eapply Zpos_gt_Z0 : mydb.
Hint Extern 5 ((Zpos ?X >= 0)%Z) => eapply Zpos_ge_Z0 : mydb.

Lemma N0_le_N : forall n:N, (0<=n)%N.
Proof.
intro; destruct n; unfold Nle; intro_discri.
Qed.

Lemma N_ge_N0 : forall n:N, (n>=0)%N.
Proof.
intro; destruct n; unfold Nge; intro_discri.
Qed.

Lemma N0_lt_Npos : forall p, (0<Npos p)%N.
Proof with auto.
intro; unfold Nlt; simpl...
Qed.

Lemma Npos_gt_N0 : forall p, (Npos p>0)%N.
Proof with auto.
intro; unfold Ngt; simpl...
Qed.

Hint Extern 5 ((0 < Npos ?X)%N) => eapply N0_lt_Npos : mydb.
Hint Extern 5 ((Npos ?X > 0)%N) => eapply Npos_gt_N0 : mydb.
Hint Extern 5 ((0 <= ?X)%N) => eapply N0_le_N : mydb.
Hint Extern 5 ((?X >= 0)%N) => eapply N_ge_N0 : mydb.

Lemma Zcompare_Lt : forall a b:Z,
 (a<b)%Z -> (a ?= b)%Z=Lt.
Proof with auto.
intros...
Qed.
Lemma Zcompare_Gt : forall a b:Z,
 (a>b)%Z -> (a ?= b)%Z=Gt.
Proof with auto.
intros...
Qed.
Lemma Zcompare_Le : forall a b:Z,
 (a<=b)%Z -> (a ?= b)%Z<>Gt.
Proof with auto.
intros...
Qed.
Lemma Zcompare_Ge : forall a b:Z,
 (a>=b)%Z -> (a ?= b)%Z<>Lt.
Proof with auto.
intros...
Qed.
Lemma Ncompare_Lt : forall a b:N,
 (a<b)%N -> (a ?= b)%N=Lt.
Proof with auto.
intros...
Qed.
Lemma Ncompare_Gt : forall a b:N,
 (a>b)%N -> (a ?= b)%N=Gt.
Proof with auto.
intros...
Qed.
Lemma Ncompare_Le : forall a b:N,
 (a<=b)%N -> (a ?= b)%N<>Gt.
Proof with auto.
intros...
Qed.
Lemma Ncompare_Ge : forall a b:N,
 (a>=b)%N -> (a ?= b)%N<>Lt.
Proof with auto.
intros...
Qed.

Ltac fold_compare :=
match goal with
| [ |- (?a ?= ?b)%Z = Lt ] => eapply Zcompare_Lt; try omega; try auto
| [ |- (?a ?= ?b)%Z = Gt ] => eapply Zcompare_Gt; try omega; try auto
| [ |- (?a ?= ?b)%Z <> Gt ] => eapply Zcompare_Le; try omega; try auto
| [ |- (?a ?= ?b)%Z <> Lt ] => eapply Zcompare_Ge; try omega; try auto
| [ |- (?a ?= ?b)%N = Lt ] => eapply Ncompare_Lt; try omega; try auto
| [ |- (?a ?= ?b)%N = Gt ] => eapply Ncompare_Gt; try omega; try auto
| [ |- (?a ?= ?b)%N <> Gt ] => eapply Ncompare_Le; try omega; try auto
| [ |- (?a ?= ?b)%N <> Lt ] => eapply Ncompare_Ge; try omega; try auto
end.

Lemma Zcompare_Lt_H : forall a b:Z,
 (a ?= b)%Z=Lt -> (a<b)%Z.
Proof with auto.
intros...
Qed.
Lemma Zcompare_Gt_H : forall a b:Z,
 (a ?= b)%Z=Gt -> (a>b)%Z.
Proof with auto.
intros...
Qed.
Lemma Zcompare_Le_H : forall a b:Z,
 (a ?= b)%Z<>Gt -> (a<=b)%Z.
Proof with auto.
intros...
Qed.
Lemma Zcompare_Ge_H : forall a b:Z,
 (a ?= b)%Z<>Lt -> (a>=b)%Z.
Proof with auto.
intros...
Qed.
Lemma Ncompare_Lt_H : forall a b:N,
 (a ?= b)%N=Lt -> (a<b)%N.
Proof with auto.
intros...
Qed.
Lemma Ncompare_Gt_H : forall a b:N,
 (a ?= b)%N=Gt -> (a>b)%N.
Proof with auto.
intros...
Qed.
Lemma Ncompare_Le_H : forall a b:N,
 (a ?= b)%N<>Gt -> (a<=b)%N.
Proof with auto.
intros...
Qed.
Lemma Ncompare_Ge_H : forall a b:N,
 (a ?= b)%N<>Lt -> (a>=b)%N.
Proof with auto.
intros...
Qed.

Ltac fold_compare_H H' :=
match type of H' with
| ((?a ?= ?b)%Z = Lt) => add_H (Zcompare_Lt_H a b H')
| ((?a ?= ?b)%Z = Gt) => add_H (Zcompare_Gt_H a b H')
| ((?a ?= ?b)%Z <> Gt) => add_H (Zcompare_Le_H a b H')
| ((?a ?= ?b)%Z <> Lt) => add_H (Zcompare_Ge_H a b H')
| ((?a ?= ?b)%N = Lt) => add_H (Ncompare_Lt_H a b H')
| ((?a ?= ?b)%N = Gt) => add_H (Ncompare_Gt_H a b H')
| ((?a ?= ?b)%N <> Gt) => add_H (Ncompare_Le_H a b H')
| ((?a ?= ?b)%N <> Lt) => add_H (Ncompare_Ge_H a b H')
end; clear H'; try omega.

Lemma nat_compare_Lt : forall n m:nat,
 nat_compare n m = Lt -> n < m.
Proof with auto.
induction n.
 intros m H. unfold nat_compare in H.
 induction m.
  discriminate H.
 omega.
induction m.
 intros H. unfold nat_compare in H.
 discriminate H.
intros H. simpl in H. specialize (IHn m H).
omega.
Qed.

Lemma Nplus_eq_N0 : forall n m:N,
 (n+m=0)%N -> (n=0)%N /\ (m=0)%N.
Proof with auto.
destruct n; destruct m...
simpl. intro_discri.
Qed.

Lemma Nmult_eq_N0 : forall n m:N,
 (n*m=0)%N -> (n=0)%N \/ (m=0)%N.
Proof with auto.
destruct n; destruct m...
simpl. intro_discri.
Qed.

Lemma Zneg_le_M1 : forall p, (Zneg p <= -1)%Z.
Proof with auto.
destruct p; unfold Zle; simpl; intro_discri.
Qed.

Hint Extern 5 ((Zneg ?p <= -1)%Z) => eapply Zneg_le_M1 : mydb.

(** Z and N *)

Lemma Z_of_N_of_Z : forall z,
 (0 <= z)%Z ->
 Z_of_N (N_of_Z z) = z.
Proof with auto.
intros z H. destruct z...
elim_ineq H.
Qed.

Lemma N_of_Z_of_N : forall n,
 N_of_Z (Z_of_N n) = n.
Proof with auto.
intros n. destruct n...
Qed.

Lemma N_of_Z_preserve_plus : forall z1 z2,
 (0 <= z1)%Z -> (0 <= z2)%Z ->
 (N_of_Z z1 + N_of_Z z2)%N = N_of_Z (z1 + z2)%Z.
Proof with auto.
destruct z1; destruct z2; intros H1 H2...
 elim_ineq H2.
elim_ineq H1.
Qed.

Lemma N_of_Z_preserve_mult : forall z1 z2,
 (0 <= z1)%Z -> (0 <= z2)%Z ->
 (N_of_Z z1 * N_of_Z z2)%N = N_of_Z (z1 * z2)%Z.
Proof with auto.
destruct z1; destruct z2; intros H1 H2...
elim_ineq H1.
Qed.

Lemma N_of_Z_preserve_compare : forall z1 z2,
 (0 <= z1)%Z -> (0 <= z2)%Z ->
 (N_of_Z z1 ?= N_of_Z z2)%N = (z1 ?= z2)%Z.
Proof with auto.
destruct z1; destruct z2; intros H1 H2...
  elim_ineq H2...
 elim_ineq H1...
elim_ineq H1...
Qed.

Lemma Z_of_N_preserve_plus : forall n1 n2,
 (Z_of_N n1 + Z_of_N n2)%Z = Z_of_N (n1 + n2)%N.
Proof with auto.
destruct n1; destruct n2...
Qed.

Lemma Z_of_N_preserve_mult : forall n1 n2,
 (Z_of_N n1 * Z_of_N n2)%Z = Z_of_N (n1 * n2)%N.
Proof with auto.
destruct n1; destruct n2...
Qed.

Lemma Z_of_N_preserve_compare : forall n1 n2,
 (Z_of_N n1 ?= Z_of_N n2)%Z = (n1 ?= n2)%N.
Proof with auto.
destruct n1; destruct n2...
Qed.

(** Zdiv-related *)

Lemma Zneg_False : forall p p0 r,
 Zpos p = (radix*Zneg p0+r)%Z ->
 (0<=r<radix)%Z -> False.
Proof with auto with mydb.
intros p p0 r H H0.
assert((radix*Zneg p0+r < 0)%Z).
 assert((radix*Zneg p0 <= radix*(-1))%Z).
  assert((Zneg p0 <= -1)%Z)...
  eapply Zmult_le_compat_l...
 omega.
rewrite <- H in H1. elim_ineq H1.
Qed.

Ltac elim_neg Hx :=
match type of Hx with
| Zpos ?p = (radix * Zneg ?p0 + ?r)%Z =>
  elim (Zneg_False p p0 r Hx); auto
| (radix * Zneg ?p0 + ?r)%Z = Zpos ?p =>
  elim (Zneg_False p p0 r Hx); auto
end.

Ltac div_eucl Hx :=
match type of Hx with
| Zdiv_eucl (Zpos ?p) radix = (_, _)
  => let H' := fresh "H" in
     specialize(Z_div_mod (Zpos p) radix radix_pos);
     intro H'; erewrite Hx in H'; destruct H'
| (_, _) = Zdiv_eucl (Zpos ?p) radix
  => let H' := fresh "H" in
     specialize(Z_div_mod (Zpos p) radix radix_pos);
     intro H'; erewrite <- Hx in H'; destruct H'
end.

Ltac tuple_eucl z q r:=
 let p' := fresh "p" in
 remember(Zdiv_eucl z radix) as p'; destruct p' as [q r].

(** * foldr and unfoldr by radix *)

Fixpoint foldr_by_radix(ns:list N):N :=
let nr := N_of_Z radix in
match ns with
| nil => N0
| n::ns' => (n + nr*(foldr_by_radix ns'))%N
end.

Function unfoldr_by_radix(n:N){measure nat_of_N n}:list Z :=
match n with
| N0 => nil
| Npos p => match (Zdiv_eucl (Zpos p) radix) with
  | (Z0,r) => r::nil
  | (q,r) => r::(unfoldr_by_radix (N_of_Z q))
  end
end.
Proof with auto.
 intros n p Hpn q r p0 Hqp0 Heucl.
 eapply nat_compare_lt.
 erewrite <- nat_of_Ncompare. simpl.
 add_H (Z_div_lt (Zpos p) radix Hradix (Zpos_gt_Z0 p)).
 unfold Zdiv in H.
 rewrite Heucl in H...
intros n p Hnp q r p0 Hqp0 Heucl.
div_eucl Heucl. elim_neg H.
Defined.
(* Here we have two supporting lemmas:
unfoldr_by_radix_ind :
  forall P : N -> list Z -> Prop,
  (some conditions) ->
  forall n : N, P n (unfoldr_by_radix n),
  which is its induction principle.
unfoldr_by_radix_equation :
  forall n : N, unfoldr_by_radix n = ...,
  which is its definition.
*)

Inductive Zproper:list Z -> Prop :=
| Nil_Zproper : Zproper nil
| Single_Zproper : forall z,
  (0 < z < radix)%Z -> Zproper (z::nil)
| Cons_Zproper : forall z zs,
  (0 <= z < radix)%Z -> zs<> nil -> Zproper zs ->
  Zproper (z::zs).

Inductive Nproper:list N -> Prop :=
| Nil_Nproper : Nproper nil
| Single_Nproper : forall n:N,
  (0 < n)%N -> (n < Nradix)%N -> Nproper (n::nil)
| Cons_Nproper : forall (n:N)(ns:list N),
  (0 <= n)%N -> (n < Nradix)%N -> ns<> nil -> Nproper ns ->
  Nproper (n::ns).

Hint Constructors Zproper Nproper: mydb.

Lemma Zproper_is_Nproper : forall zs,
 Zproper zs -> Nproper (map N_of_Z zs).
Proof with auto with mydb.
induction zs.
 intro H. simpl. eapply Nil_Nproper.
intro H. induction zs.
 inversion H. simpl. eapply Single_Nproper.
   replace 0%N with (N_of_Z 0%Z).
    unfold Nlt.
    erewrite N_of_Z_preserve_compare...
      fold_compare.
     omega.
    omega.
   simpl...
  unfold Nradix. unfold Nlt.
  erewrite N_of_Z_preserve_compare.
    fold_compare.
   omega.
  omega.
 elim H3...
inversion H. rewrite <- H1.
eapply Cons_Nproper.
   replace 0%N with (N_of_Z 0%Z).
    intro.
    erewrite N_of_Z_preserve_compare in H5.
      fold_compare_H H5.
     omega.
    omega.
   simpl...
  unfold Nradix. unfold Nlt.
  erewrite N_of_Z_preserve_compare.
    fold_compare.
   omega.
  omega.
 rewrite H1. intro_discri.
rewrite <- H1 in *. specialize (IHzs H4).
unfold map in IHzs...
Qed.

Lemma Zproper_cons : forall z zs,
 Zproper (z::zs) ->
 {(0<z<radix)%Z /\ zs=nil} +
 {(0<=z<radix)%Z /\ zs<> nil /\ Zproper zs}.
Proof with auto with mydb.
intros z zs H.
induction zs.
 left. split...
 inversion H...
 elim H3...
right. split.
 inversion H...
split.
 intro_discri.
inversion H...
Qed.

Lemma unfoldr_by_radix_proper : forall n,
 Zproper (unfoldr_by_radix n).
Proof with auto with mydb.
intros n.
eapply unfoldr_by_radix_ind.
  intros...
 intros n0 p Hn0 r Heucl.
 div_eucl Heucl.
 replace (radix*0+r)%Z with r in H by ring.
 assert((0<r<radix)%Z).
  assert((r<>0)%Z).
   rewrite <- H. intro_discri.
  omega.
 eapply Single_Zproper...
intros n0 p Hn0 q r Heucl Hproper IHproper.
div_eucl Heucl.
destruct q.
  elim Hproper.
 eapply Cons_Zproper...
 erewrite unfoldr_by_radix_equation.
 replace (N_of_Z (Zpos p0)) with (Npos p0) by auto.
 tuple_eucl (Zpos p0) q' r'.
 destruct q'; intro_discri.
elim_neg H.
Qed.

Lemma foldr_by_radix_nonzero : forall ns:list N,
 Nproper ns -> ns <> nil -> (foldr_by_radix ns <> 0)%N.
Proof with auto with mydb.
induction ns.
 intros. elim H0...
intros. inversion H.
 simpl. intro.
 add_H (Nplus_eq_N0 _ _ H5). destruct H6.
 rewrite H6 in H3.
 elim_ineq H3.
specialize(IHns H6 H5).
simpl. intro. add_H (Nplus_eq_N0 _ _ H7).
destruct H8.
add_H (Nmult_eq_N0 _ _ H9). destruct H10.
 assert((Z_of_N (N_of_Z radix) = 0)%Z).
  rewrite H10...
  erewrite Z_of_N_of_Z in H11.
  rewrite H11 in Hradix. omega.
 omega.
elim IHns...
Qed.

Theorem foldr_unfoldr_by_radix : forall n,
  foldr_by_radix (map N_of_Z (unfoldr_by_radix n)) = n.
Proof with auto with mydb.
intro n.
remember (unfoldr_by_radix n) as l.
generalize dependent n.
induction l.
 intros n Heql.
 rewrite unfoldr_by_radix_equation in Heql.
 destruct n...
 tuple_eucl (Zpos p) q r; destruct q;
 discriminate Heql.
intros n0 Hal. simpl.
erewrite unfoldr_by_radix_equation in Hal.
destruct n0; try discriminate Hal.
tuple_eucl (Zpos p) q r; destruct q.
  inversion Hal. simpl.
  assert((r = Zpos p)%Z).
   div_eucl Heqp0. rewrite H. ring.
  replace (N_of_Z r + N_of_Z radix * 0)%N with
  (N_of_Z r) by ring.
  rewrite H...
 inversion Hal. specialize(IHl (Npos p0) H1).
 rewrite <- H1. rewrite IHl.
 div_eucl Heqp0.
 replace (N_of_Z r + N_of_Z radix * Npos p0)%N
 with (N_of_Z (radix*Zpos p0+r)%Z).
  rewrite <- H...
 replace (Npos p0) with (N_of_Z (Zpos p0)) by auto.
 erewrite (N_of_Z_preserve_mult radix (Zpos p0)).
   erewrite (N_of_Z_preserve_plus r (radix*Zpos p0)%Z).
     replace (radix*Zpos p0+r)%Z with (r+radix*Zpos p0)%Z by ring...
    omega.
   eapply Zmult_le_0_compat...
  omega.
 auto with mydb.
div_eucl Heqp0. elim_neg H.
Qed.

Theorem unfoldr_foldr_by_radix : forall ns:list N,
  Nproper ns ->
  map N_of_Z (unfoldr_by_radix (foldr_by_radix ns)) = ns.
Proof with auto with mydb.
induction ns...
remember (foldr_by_radix ns) as n0. simpl.
rewrite <- Heqn0.
remember (a + N_of_Z radix * n0)%N as n1.
intros Hproper.
erewrite unfoldr_by_radix_equation.
destruct n1.
 symmetry in Heqn1.
 add_H (Nplus_eq_N0 _ _ Heqn1). destruct H.
 add_H (Nmult_eq_N0 _ _ H0). destruct H1.
  assert((Z_of_N (N_of_Z radix) = 0)%Z).
   rewrite H1...
  erewrite Z_of_N_of_Z in H2.
   add_H radix_pos. rewrite H2 in H3. elim_ineq H3.
  add_H radix_pos. omega.
 inversion Hproper.
  rewrite H in H4. elim_ineq H4.
 specialize(IHns H7). rewrite H1 in IHns.
 simpl in IHns. rewrite <- IHns in H6.
 elim H6...
tuple_eucl (Zpos p) q r. div_eucl Heqp0.
assert((Zpos p = radix * Z_of_N n0 + Z_of_N a)%Z).
 replace (Zpos p) with (Z_of_N (Npos p)) by auto.
 rewrite Heqn1. erewrite <- Z_of_N_preserve_plus.
 erewrite <- Z_of_N_preserve_mult.
 erewrite Z_of_N_of_Z... ring.
rewrite H in H1.
add_H (Zdiv_mod_unique radix q (Z_of_N n0) r (Z_of_N a)).
rewrite Zabs_radix in H2.
specialize(H2 H0).
assert((0<=Z_of_N a<radix)%Z).
 inversion Hproper.
  split.
   replace 0%Z with (Z_of_N 0%N) by auto...
   unfold Zle. erewrite Z_of_N_preserve_compare.
   fold_compare...
  replace radix with (Z_of_N Nradix).
   unfold Zlt. erewrite Z_of_N_preserve_compare.
   fold_compare...
  unfold Nradix. erewrite Z_of_N_of_Z...
 split.
  replace 0%Z with (Z_of_N 0%N) by auto...
  unfold Zle. erewrite Z_of_N_preserve_compare.
  unfold Nle in H5...
 replace radix with (Z_of_N Nradix).
  unfold Zlt. erewrite Z_of_N_preserve_compare.
  unfold Nlt in H6...
 unfold Nradix. erewrite Z_of_N_of_Z...
specialize(H2 H3 H1). destruct H2.
destruct q.
  assert((n0 = 0)%N).
   destruct n0...
   simpl_discri H2.
  assert(ns=nil).
   destruct ns...
   inversion Hproper.
   elim (foldr_by_radix_nonzero (n::ns) H11 H10)...
   rewrite <- Heqn0...
  rewrite H6 in *. simpl. rewrite H4.
  rewrite N_of_Z_of_N...
 rewrite H2. erewrite N_of_Z_of_N.
 simpl. rewrite H4. erewrite N_of_Z_of_N.
 inversion Hproper.
  rewrite <- H6 in Heqn0. simpl in Heqn0.
  rewrite Heqn0...
 rewrite (IHns H10)...
elim_neg H.
Qed.

Definition encode_by_radix(n:N):list N :=
  map N_of_Z (unfoldr_by_radix n).
Definition decode_by_radix(ns:list N):N :=
  foldr_by_radix ns.

Theorem decode_encode_radix : forall n,
  decode_by_radix (encode_by_radix n) = n.
Proof.
unfold decode_by_radix.
unfold encode_by_radix.
eapply foldr_unfoldr_by_radix.
Qed.

Theorem encode_Nproper : forall n,
 Nproper (encode_by_radix n).
Proof with auto.
unfold encode_by_radix.
intros. eapply Zproper_is_Nproper.
eapply unfoldr_by_radix_proper.
Qed.

Lemma decode_by_radix_eq_0 : forall ns,
 Nproper ns -> decode_by_radix ns = 0%N ->
 ns = nil.
Proof with auto.
induction ns.
 intros...
intros. induction ns.
 simpl in H0.
 replace (a + N_of_Z radix * 0)%N with a in H0 by ring.
 inversion H.
  rewrite H0 in H2. unfold Nlt in H2.
  simpl_discri H2.
 elim H5...
inversion H.
rewrite <- H2 in *. specialize(IHns H6).
assert(a::ns0<>nil) by intro_discri.
elim (foldr_by_radix_nonzero (a::ns0) H H7)...
Qed.

Theorem encode_decode_radix : forall ns,
  Nproper ns ->
  encode_by_radix (decode_by_radix ns) = ns.
Proof with auto with mydb.
intros.
unfold decode_by_radix.
unfold encode_by_radix.
eapply unfoldr_foldr_by_radix...
Qed.

End fold_unfold_N.

Lemma radix_2 : (2 >= 2)%Z.
Proof. omega. Qed.
Lemma radix_10 : (10 >= 2)%Z.
Proof. omega. Qed.
Lemma radix_128 : (128 >= 2)%Z.
Proof. omega. Qed.
Lemma radix_256 : (256 >= 2)%Z.
Proof. omega. Qed.

(** Sample usage
Eval compute in (encode_by_radix 10%Z radix_10 0%N).
  = nil
Eval compute in (encode_by_radix 10%Z radix_10 123%N).
  = 3%N :: 2%N :: 1%N :: nil
Eval compute in (decode_by_radix 10%Z nil).
  = 0%N
Eval compute in (decode_by_radix 10%Z (3%N::2%N::1%N::nil)).
  = 123%N
*)

(** itoa : Z -> string *)

Require Import Ascii.
Require Import String.

Definition N_to_ascii : forall n:N, (n<10)%N -> ascii.
refine(fun n =>
  match n with
  | 0%N => fun _ => "0"%char
  | 1%N => fun _ => "1"%char
  | 2%N => fun _ => "2"%char
  | 3%N => fun _ => "3"%char
  | 4%N => fun _ => "4"%char
  | 5%N => fun _ => "5"%char
  | 6%N => fun _ => "6"%char
  | 7%N => fun _ => "7"%char
  | 8%N => fun _ => "8"%char
  | 9%N => fun _ => "9"%char
  | _ => fun _ => False_rec _ _
  end).
Proof with auto.
         unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
        unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
       unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
      unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
     unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
    unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
   unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
  unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
 unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
unfold Nlt in _H; simpl in _H; destruct p2; discriminate _H.
Defined.

Definition ns_to_asciis_aux : forall ns:list N,
 Nproper 10%Z ns -> list ascii.
refine(fix f (ns:list N):(Nproper 10%Z ns)->list ascii :=
  match ns as ns0 return (Nproper 10%Z ns0 -> list ascii) with
  | nil => fun _ => nil
  | n::ns' => fun _ => (N_to_ascii n _) :: (f ns' _)
  end).
Proof with auto.
 inversion _H.
  unfold Nradix in H2. simpl in H2...
 unfold Nradix in H2. simpl in H2...
inversion _H...
eapply Nil_Nproper.
Defined.

Definition N_to_asciis(n:N):list ascii.
Proof with auto.
remember(encode_by_radix 10%Z radix_10 n).
assert(Nproper 10%Z l).
 rewrite Heql. eapply encode_Nproper.
exact (ns_to_asciis_aux l H).
Defined.

Fixpoint asciis_to_string(cs:list ascii):string :=
match cs with
| nil => EmptyString
| c::cs' => String c (asciis_to_string cs')
end.

Definition itoa(z:Z):string :=
match z with
| Z0 => "0"%string
| Zpos p =>
  asciis_to_string (rev (N_to_asciis (Npos p)))
| Zneg p => String "-"%char (
  asciis_to_string (rev (N_to_asciis (Npos p))))
end.

(*
Eval compute in (itoa (-1234)%Z).
  = "-1234"%string
*)


Require Import Coercions.

Definition comparisonLt a : bool :=
match a with
| Lt => true
| Eq => false
| Gt => false
end.

Definition comparisonLe a : bool :=
match a with
| Lt => true
| Eq => true
| Gt => false
end.

Definition comparisonGt a : bool :=
match a with
| Lt => false
| Eq => false
| Gt => true
end.

Definition comparisonGe a : bool :=
match a with
| Lt => false
| Eq => true
| Gt => true
end.

Lemma compareLt : forall a, comparisonLt a -> a=Lt.
Proof.
induction a; auto; contradiction.
Qed.

Lemma compareLe : forall a, comparisonLt a -> {a=Lt}+{a=Eq}.
Proof.
induction a; auto; contradiction.
Qed.


(****************************************************************************)
(****************************************************************************)
(*This file proves SN after embedding Presburger*)
(****************************************************************************)
(****************************************************************************)

Require Import PIntp.
Require Import AbsSNT.

Import PSem PSyn.

Module SNP := Abs_SN_Theory PresburgerTheory PresburgerSem IntpPresburger.

Import SNP.
Import SN_CC_Real.
Import SN.
Import PresburgerTheory PresburgerSem IntpPresburger.

Lemma SN_P : forall e x y,
  (exists hyp a b s,
    x = Sub (intp_foterm a) s /\
    y = Sub (intp_foterm b) s /\
    wf_clsd_env (intp_hyp hyp) /\
    typ_sub e s (intp_hyp hyp) /\
    deriv hyp (eq_foterm a b)) ->
  eq_typ e x y.
Proof. apply SN_T. Qed.


(** -- Trotterize.v -- **)
(**
 * Compiler that takes H_Program to QasmProgram.
 * The main step uses the "Trotterization" algorithm.
 *)

Require Import String.
Require Import Reals.
Require Import List.
Require Import HSF_Syntax.
Require Import Qasm.
Require Import Semantics.
Require Import PauliRotations.
Require Import MatrixExponential.

(* AST Transform of an one-local term *)
Definition makeQT1 (p : Pauli) (theta : HScalar) (loc : nat) :=
  match p with
  | Pauli_I => []
  | Pauli_X => [QasmTerm1 (Rx theta) loc]
  | Pauli_Y => [QasmTerm1 (Ry theta) loc]
  | Pauli_Z => [QasmTerm1 (Rz theta) loc]
  end.

(* Correctness of above *)
Lemma makeQT1_correct :
  forall (num_qubits : nat) (p : Pauli) (theta : HScalar) (loc : nat),
    (loc < num_qubits)%nat ->
    QasmInstsSemantics
        num_qubits
          (makeQT1 p theta loc)
          (padIs num_qubits (PauliToExpM p (sem_HScalar theta)) loc).
Proof.
  intros.
  induction p.
  - simpl.
    unfold RIGate.
    Search padIs.
    rewrite padIs_scale.
    exists (/ (Cexp (- sem_HScalar theta / 2))).
    rewrite Mscale_assoc.
    Locate "/".
    Search Cinv.
    rewrite Cinv_l.
    rewrite Mscale_1_l.
    unfold padIs.
    Search kron.
    rewrite id_kron.
    rewrite id_kron.
    assert (Simpl_LHS : (2 ^ loc * 2 * 2 ^ (num_qubits - loc - 1) = 2 ^ num_qubits)%nat).
    (* Arithmetics... *)
    admit.
    rewrite Simpl_LHS.
    reflexivity.
    apply Cexp_nonzero.
  - simpl.
    eexists.
    eexists.
    split.
    exists R1.
    rewrite Mscale_1_l.
    reflexivity.
    split.
    exists R1.
    rewrite Mscale_1_l.
    reflexivity.
    exists R1.
    rewrite Mscale_1_l.
    Search I.
    rewrite Mmult_1_r.
    reflexivity.
    Print reflect.
    Search padIs.
    apply padIs_WF.
    admit. (* RXGate WF... Need to prove *)
    assumption.
  - simpl.
    eexists.
    eexists.
    split.
    exists R1.
    rewrite Mscale_1_l.
    reflexivity.
    split.
    exists R1.
    rewrite Mscale_1_l.
    reflexivity.
    exists R1.
    rewrite Mscale_1_l.
    Search I.
    rewrite Mmult_1_r.
    reflexivity.
    Print reflect.
    Search padIs.
    apply padIs_WF.
    admit. (* RYGate WF... Need to prove *)
    assumption.
  - simpl.
    eexists.
    eexists.
    split.
    exists R1.
    rewrite Mscale_1_l.
    reflexivity.
    split.
    exists R1.
    rewrite Mscale_1_l.
    reflexivity.
    exists R1.
    rewrite Mscale_1_l.
    Search I.
    rewrite Mmult_1_r.
    reflexivity.
    Print reflect.
    Search padIs.
    apply padIs_WF.
    admit. (* RZGate WF... Need to prove *)
    assumption.
Admitted.

(* More constants *)
Definition HScPI := HScReal PI "pi".
Definition HScPI2 := HScReal (PI / 2) "(pi/2)".
Definition HScZero := HScReal 0 "0".

(* Hard-coded gates *)
Definition QasmTYZ := QasmU HScPI2 HScZero HScPI2.
Definition QasmTYZ_dag := QasmU HScPI2 HScPI2 HScPI.

(* AST transform of a 2-local term *)
Definition makeQT2 (p1 p2 : Pauli)
           (theta : HScalar)
           (loc1 loc2 : nat) : list QasmTerm :=
  match (p1, p2) with
  | (Pauli_I, _) => makeQT1 p2 theta loc2
  | (_, Pauli_I) => makeQT1 p1 theta loc1
  | (Pauli_X, Pauli_X) => [QasmTerm2 (Rxx theta) loc1 loc2]
  | (Pauli_X, Pauli_Y) => [QasmTerm1 QasmH loc1; QasmTerm1 QasmTYZ loc2;
                           QasmTerm2 (Rzz theta) loc1 loc2;
                           QasmTerm1 QasmH loc1; QasmTerm1 QasmTYZ_dag loc2]
  | (Pauli_X, Pauli_Z) => [QasmTerm1 QasmH loc1;
                           QasmTerm2 (Rzz theta) loc1 loc2;
                           QasmTerm1 QasmH loc1]
  | (Pauli_Y, Pauli_X) => [QasmTerm1 QasmTYZ loc1; QasmTerm1 QasmH loc2;
                           QasmTerm2 (Rzz theta) loc1 loc2;
                           QasmTerm1 QasmTYZ_dag loc1; QasmTerm1 QasmH loc2]
  | (Pauli_Y, Pauli_Y) => [QasmTerm1 QasmTYZ loc1; QasmTerm1 QasmTYZ loc2;
                           QasmTerm2 (Rzz theta) loc1 loc2;
                           QasmTerm1 QasmTYZ_dag loc1; QasmTerm1 QasmTYZ_dag loc2]
  | (Pauli_Y, Pauli_Z) => [QasmTerm1 QasmTYZ loc1;
                           QasmTerm2 (Rzz theta) loc1 loc2;
                           QasmTerm1 QasmTYZ_dag loc1]
  | (Pauli_Z, Pauli_X) => [QasmTerm1 QasmH loc2;
                           QasmTerm2 (Rzz theta) loc1 loc2;
                           QasmTerm1 QasmH loc2]
  | (Pauli_Z, Pauli_Y) => [QasmTerm1 QasmTYZ loc2;
                           QasmTerm2 (Rzz theta) loc1 loc2;
                           QasmTerm1 QasmTYZ_dag loc2]
  | (Pauli_Z, Pauli_Z) => [QasmTerm2 (Rzz theta) loc1 loc2]
  end.

(* TODO Correctness of above *)
(*
Lemma makeQT2_correct :
  forall theta loc1 loc2,
    loc1 =? loc2 = false ->
    matrix_exponential (makeQT2 p1 p2 theta loc1 loc2)
*)

(* Conversion from natural numbers to HScalar type *)
(* TODO should unify naming style/convention *)
Definition natToHSc (n : nat) := HScReal (INR n) (string_of_nat n).

(**
 * Takes a TIH_Term and a total duration t to constructs quantum circuit
 * that runs the Hamiltonian evolution for a short time-slice of duration (t / nSlices).
 *)
Definition sliceTerm (decls : list string)
           (duration : HScalar)
           (term : TIH_Term)
           (nSlices : nat) : option (list QasmTerm) :=
  let theta := HScDiv (HScMult (natToHSc 2) (HScMult duration term.(hScale))) (natToHSc (nSlices)) in
  match term.(hPaulis) with
  | [] => Some []
  | [HIdOp site p] =>
      match find_qubit decls site with
      | None => None
      | Some loc => Some (makeQT1 p theta loc)
      end
  | [HIdOp site1 p1; HIdOp site2 p2] =>
      match (find_qubit decls site1, find_qubit decls site2) with
      | (Some loc1, Some loc2) => if loc1 =? loc2 then None else Some (makeQT2 p1 p2 theta loc1 loc2)
      | _ => None
      end
  | _ => None (* Too nonlocal *)
  end.

(* Correctness of above *)
Lemma sliceTermCorrect :
  forall decls duration term nSlices,
    sliceTerm decls duration term nSlices = None \/
      exists q_insts,
        sliceTerm decls duration term nSlices = Some q_insts /\
        exists Hi,
          (interpret_TIH_Term decls term = Some Hi) /\
          exists sem, (
           matrix_exponential (scale (- Ci * (sem_HScalar duration) / INR nSlices) Hi) sem /\
           QasmInstsSemantics (length decls) q_insts sem).
Proof.
  intros.
  destruct term.
  destruct hPaulis as [| p1].
  - (* Empty term; impossible AST? *)
    right.
    exists [].
    split.
    auto.
    exists (scale (sem_HScalar hScale) (I (2 ^ length decls))).
    split.
    + auto.
    + exists (scale (Cexp (- (sem_HScalar hScale) * (sem_HScalar duration) / INR nSlices))
                    (I (2 ^ length decls))).
      split.
      ++ rewrite Mscale_assoc.
         (* linear algebra incoming *)
         (* somehow apply mexp_scale? *)
         admit.
      ++ simpl.
         exists (/ Cexp (- sem_HScalar hScale * sem_HScalar duration / INR nSlices)).
         rewrite Mscale_assoc.
         rewrite Cinv_l.
         apply Mscale_1_l.
         apply Cexp_nonzero.
  - destruct hPaulis as [| p2].
    + (* 1-local *)
      destruct p1.
      case_eq (find_qubit decls loc).
      ++ (* qubit found *)
        intros.
        unfold sliceTerm.
        simpl.
        rewrite H.
        right.
        eexists. (* q_insts *)
        split.
        reflexivity.
        (* interpret TIH term *)
        unfold interpret_TIH_Term.
        unfold hPaulis.
        unfold interpret_HPaulis.
        rewrite <- interpret_HPauli'_correct.
        simpl.
        rewrite H.
        rewrite Mmult_1_r.
        eexists. (* TIH term exists *)
        split.
        reflexivity.
        exists (padIs
                  (length decls)
                  (PauliToExpM p (2 * sem_HScalar duration / INR nSlices * sem_HScalar hScale))
                  n).
        split.
        * (* Semantics is correct for hprog *)
          rewrite Mscale_assoc.
          rewrite <- padIs_scale.
          apply mexp_padIs.

           assert (lhs_simpl :
                    - Ci * sem_HScalar duration / INR nSlices * sem_HScalar hScale =
                      - Ci * (sem_HScalar duration / INR nSlices * sem_HScalar hScale)%R).
           admit. (* Arithmetic *)
           rewrite lhs_simpl.
           assert (rhs_simpl
                    : (2 * sem_HScalar duration / INR nSlices * sem_HScalar hScale)%R =
                        (2 * (sem_HScalar duration / INR nSlices * sem_HScalar hScale))%R ).
           admit. (* Arithmetic *)
           rewrite rhs_simpl.
           apply PauliToExpM_correct2t.
        * (* Qasm semantic matches *)
          Print makeQT1_correct.
          assert (HScalar_simpl :
                   sem_HScalar (HScDiv
                                  (HScMult (natToHSc 2) (HScMult duration hScale))
                                  (natToHSc nSlices))
                   = (2 * sem_HScalar duration / INR nSlices * sem_HScalar hScale)%R).
          (* HScalar computation... *)
          (* Don't want to deal with this right now. *)
          admit.
          rewrite <- HScalar_simpl.
          apply makeQT1_correct.
          admit. (* TODO find_qubit result should be in range *)
        * apply padIs_WF.
          Search PauliToMatrix.
          apply PauliToMatrix_WF.
          admit. (* again find_qubit output range *)
        ++ (* error case: site not found in decl *)
           intros.
           left.
           unfold sliceTerm.
           simpl.
           rewrite H.
           reflexivity.
    + destruct hPaulis as [| p3].
      * (* 2-local *)
        (* TODO this is going to be bad... *)
        destruct p1 as [site1 pauli1].
        destruct p2 as [site2 pauli2].
        case_eq (find_qubit decls site1).
        ** (* loc1 found *)
          intro loc1.
          intros.
          case_eq (find_qubit decls site2).
          *** (* loc2 found *)
            intro loc2.
            intros.
            case_eq (loc1 =? loc2).
            **** (* error: not really 2-local *)
              intros.
              left.
              unfold sliceTerm.
              simpl.
              rewrite H.
              rewrite H0.
              rewrite H1.
              reflexivity.
            **** (* TODO this will be bad *)
              intros.
              right.
              eexists.
              split.
              ***** (* q_insts *)
                unfold sliceTerm.
              simpl.
              rewrite H.
              rewrite H0.
              rewrite H1.
              simpl.
              reflexivity.
              ***** (* Hi *)

              admit.
          *** (* error: site2 not found *)
            left.
            unfold sliceTerm.
            simpl.
            rewrite H.
            rewrite H0.
            reflexivity.
        ** (* error: loc1 not found *)
          intros.
          left.
          unfold sliceTerm.
          simpl.
          rewrite H.
          reflexivity.
      * (* Too non-local *)
        left.
        unfold sliceTerm.
        simpl.
        destruct p1.
        destruct p2.
        reflexivity.
Admitted.

(* Given a list of TIH_terms, run each of them for a short time-slice. *)
Fixpoint sliceTerms (decls : list string)
         (duration : HScalar)
         (terms : list TIH_Term)
         (nSlices : nat) :=
  match terms with
  | head :: tail =>
      match (sliceTerm decls duration head nSlices, sliceTerms decls duration tail nSlices) with
      | (Some head_insts, Some tail_insts) => Some (head_insts ++ tail_insts)
      | _ => None
      end
  | [] => Some []
  end.

Definition sliceInst (decls : list string) (inst : HSF_Term) (nSlices : nat) :=
  sliceTerms decls inst.(Duration) inst.(Hamiltonian) nSlices.

Fixpoint accSlices (slice : list QasmTerm) (nSlices : nat) :=
  match nSlices with
  | O => []
  | S pr => slice ++ (accSlices slice pr)
  end.

(* The Trotterization algorithm for simulating Hamiltonian evolutions *)
Definition trotterizeInst (decls : list string) (inst : HSF_Term) (nSlices : nat) :=
  match sliceInst decls inst nSlices with
  | Some slice => Some (accSlices slice nSlices)
  | None => None
  end.

(* TODO State and prove correctness of above *)
(* Base on the approximation formula of matrix exponentials *)
(* Print matexp_approx. *)

(* Compilation of multiple instructions *)
Fixpoint trotterizeInsts (decls : list string) (insts : list HSF_Term) (nSlices : nat) :=
  match insts with
  | head :: tail =>
      match (trotterizeInst decls head nSlices, trotterizeInsts decls tail nSlices) with
      | (Some qasm_head, Some qasm_tail) => Some (qasm_head ++ qasm_tail)
      | _ => None
      end
  | [] => Some []
  end.

(**
 * Compilation results.
 * Maybe should just be an inductive type as follows:
 * `successful (output : QasmProgram) | failure`
 * or even just (optional QasmProgram) is fine... *)
Record trotterize_result := makeTrotRes
{
  successful : bool;
  output : QasmProgram;
}.

(* unnecessary *)
Definition idProg := makeQasmProg 0 [].

(* Overall compilation of H_Program *)
Definition trotterize (prog : H_Program) (nSlices : nat) :=
  match trotterizeInsts prog.(Decls) prog.(Terms) nSlices with
  | Some qasm_insts => makeTrotRes true (makeQasmProg (count_sites prog) qasm_insts)
  | None => makeTrotRes false idProg
  end.

(* Correctness of compilation *)
(* Part of the proof should probably be moved back as part of correctness of trotterizeInst *)
Theorem trotterize_correct :
  forall (hprog : H_Program) (correct_sem : Square (dims hprog)),
    (sem_program hprog correct_sem) ->
      ((forall nSlices, (trotterize hprog nSlices).(successful) = false) (* Cannot Trotterize *) \/
      ((forall nSlices, (trotterize hprog nSlices).(successful) = true) (* Can Trotterize *) /\
        exists (qasm_sem : nat -> (Square (dims hprog))),
          (forall nSlices, QasmSemantics (trotterize hprog nSlices).(output) (qasm_sem nSlices)) /\
          seq_conv (MatrixMetricSpace (dims hprog)) qasm_sem correct_sem
      )).
Proof.
  intro hprog.
  destruct hprog.
  generalize dependent Decls.
  induction Terms.
  - intros.
    right.
    intros.
    split.
    + auto.
    + exists (fun (_ : nat) => I (2 ^ (length Decls))).
      split.
      * intros.
        unfold QasmSemantics.
        simpl.
        exists 1.
        apply Mscale_1_l.
      * intro eps.
        intros.
        exists 1%nat.
        intros.
        simpl.
        assert (distzero : @dist_mats (dims (makeHProg Decls []))
                                      (I (2 ^ (length Decls)))
                                      (I (2 ^ (length Decls))) = 0).
        apply dist_mats_refl.
        reflexivity.
        (* TODO Prove that correct_sem = I and rewrite *)
        (*
        rewrite distzero.
        auto.
         *)
        admit.
  - intro decls.
    intro hprog_sem.
    intro hprog_sem_correct.
    inversion hprog_sem_correct; subst.
    clear Hdims.
    specialize (IHTerms decls).
    apply IHTerms in HP.
    destruct HP.
    + (* Cannot Trotterize *)
      left.
      intro nSlices.
      specialize (H nSlices).
      unfold trotterize.
      simpl.
      unfold trotterize in H.
      simpl in H.
      (* TODO *)
      admit.
    + destruct H as [CanTrotterizeTail QasmSemTail].
      right.
      split.
      * (* Can trotterize *)
        intro nSlices.
        specialize (CanTrotterizeTail nSlices).
        admit.
      * (* Exists semantics *)
        admit.
Admitted.


Set Warnings "-notation-overridden,-parsing".
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice.
From mathcomp Require Import fintype ssralg finalg.
Require Import ZArith ZArith.Znumtheory.
From Tweetnacl.High Require Import prime_and_legendre Zmodp GRing_tools.
From Reciprocity Require Import Reciprocity.Reciprocity.
Import BinInt.

Require Import Ring.
Open Scope ring_scope.
Import GRing.Theory.

Local Lemma a_2_4 : (Zmodp.pi 486662) ^+ 2 - 4%:R = Zmodp.pi 236839902240.
Proof.
rewrite expr2 Zmodp_mulE /= Zmodp_oppE /= /Zmodp.p -lock /= Zmodp_addE //=.
Qed.

Lemma a_not_square (x : Zmodp.type) : x ^+ 2 != (Zmodp.pi 486662) ^+ 2 - 4%:R.
Proof.
rewrite a_2_4.
have Prime:(Znumtheory.prime Zmodp.p).
  rewrite /Zmodp.p -lock ; apply curve25519_numtheory_prime.
have Prime2:= ZmodP_mod2_eq_1.
replace (BinInt.Z.sub (BinInt.Z.pow 2 255) 19) with Zmodp.p in Prime2.
2: rewrite /Zmodp.p -lock //.
have Eulers_Criterion := Eulers_criterion Zmodp.p Prime Prime2 (Zmodp.repr (Zmodp.pi 236839902240)).
rewrite /legendre in Eulers_Criterion.
destruct (ClassicalDescription.excluded_middle_informative _).
- rename e into H.
  exfalso.
  move: H.
  rewrite piK /p -lock //.
- destruct (ClassicalDescription.excluded_middle_informative _).
  + rename e into H.
    exfalso.
    move: Eulers_Criterion.
    rewrite piK /p.
    2: rewrite -lock //.
    replace (236839902240 ^ ((locked (2 ^ 255 - 19)%Z - 1) / 2) mod locked (2 ^ 255 - 19)%Z)
    with ((-1) mod (2^255 - 19)) %Z.
    rewrite -lock //=.
    apply legendre_compute.
  + rename n0 into H.
    apply /negP => Hx.
    apply H.
    move: Hx.
    move /eqP => Hx.
    apply (f_equal (fun x => Zmodp.repr x)) in Hx.
    exists (Zmodp.repr x).
    move: Hx.
    rewrite expr2.
    rewrite Z.pow_2_r.
    rewrite modZp => <- //.
Qed.

Lemma two_not_square (x : Zmodp.type) : x ^+ 2 != 2%:R.
Proof.
have ->: 2%:R = Zmodp.pi 2.
rewrite /GRing.natmul /= /GRing.add /= /Zmodp.add ; f_equal ; rewrite piK /p -?lock //.
have Prime:(Znumtheory.prime Zmodp.p).
  rewrite /Zmodp.p -lock ; apply curve25519_numtheory_prime.
have Prime2:= ZmodP_mod2_eq_1.
replace (BinInt.Z.sub (BinInt.Z.pow 2 255) 19) with Zmodp.p in Prime2.
2: rewrite /Zmodp.p -lock //.
have Eulers_Criterion := Eulers_criterion Zmodp.p Prime Prime2 (Zmodp.repr (Zmodp.pi 2)).
rewrite /legendre in Eulers_Criterion.
destruct (ClassicalDescription.excluded_middle_informative _).
- rename e into H.
  exfalso.
  move: H.
  rewrite modZp piK /p -?lock //=.
- destruct (ClassicalDescription.excluded_middle_informative _).
  + rename e into H.
    exfalso.
    move: Eulers_Criterion.
    rewrite piK /p.
    2: rewrite -lock //.
    replace (2 ^ ((locked (2 ^ 255 - 19)%Z - 1) / 2) mod locked (2 ^ 255 - 19)%Z)
    with ((-1) mod (2^255 - 19)) %Z.
    rewrite -lock //=.
    apply legendre_compute2.
  + rename n0 into H.
    apply /negP => Hx.
    apply H.
    move: Hx.
    move /eqP => Hx.
    apply (f_equal (fun x => Zmodp.repr x)) in Hx.
    exists (Zmodp.repr x).
    move: Hx.
    rewrite expr2.
    rewrite Z.pow_2_r.
    rewrite modZp => <- //.
Qed.

Open Scope Z.

Lemma x_square_minus_x: forall (x:Zmodp.type),
  exists (y:Zmodp.type), (y^+2 = x \/ (Zmodp.pi 2)* y^+2 = x)%R.
Proof.
  move => x.
  have Prime:(Znumtheory.prime Zmodp.p).
    rewrite /Zmodp.p -lock ; apply curve25519_numtheory_prime.
  have Prime2:= ZmodP_mod2_eq_1.
  replace (BinInt.Z.sub (BinInt.Z.pow 2 255) 19) with Zmodp.p in Prime2.
  2: rewrite /Zmodp.p -lock //.
  have Eulers_Criterion := Eulers_criterion Zmodp.p Prime Prime2 (Zmodp.repr x).
  rewrite /legendre in Eulers_Criterion.
  destruct (ClassicalDescription.excluded_middle_informative _).
  + exists Zmodp.zero.
    left.
    have ->: Zmodp.zero ^+2 = Zmodp.zero => //.
    move/modZp0/eqP:e -> => //.
  + destruct (ClassicalDescription.excluded_middle_informative _).
    move: e => [y Hy].
    exists (Zmodp.pi y).
    left.
    apply val_inj => /=.
    move: Hy.
    rewrite modZp => <-.
    rewrite Z.mul_mod_idemp_l; last by rewrite /p -lock.
    rewrite Z.mul_mod_idemp_r; last by rewrite /p -lock.
    f_equal ; ring.
  + (* Okayyyy So we cannot *create* y, thus we will have to redo it. *)
    have Eulers_Criterion2 := Eulers_criterion Zmodp.p Prime Prime2 (28948022309329048855892746252171976963317496166410141009864396001978282409975 *  (Zmodp.repr x)).
    rewrite /legendre in Eulers_Criterion2.
    destruct (ClassicalDescription.excluded_middle_informative _).
    * exfalso.
      clear Eulers_Criterion Eulers_Criterion2 n0 Prime2.
      rewrite modZp in n.
      have HP : 0 <= (Zmodp.repr x) < p by rewrite -modZp ; apply Z.mod_pos_bound ; rewrite /p -lock.
      move: n.
      have Hp : p <> 0 by rewrite /p -lock.
      have : Znumtheory.rel_prime p 28948022309329048855892746252171976963317496166410141009864396001978282409975.
        apply Znumtheory.rel_prime_sym.
        apply Znumtheory.rel_prime_le_prime => //=.
        by rewrite /p -lock.
      move: e.
      move/(Znumtheory.Zmod_divide (28948022309329048855892746252171976963317496166410141009864396001978282409975 * Zmodp.repr x) p Hp).
      move/Znumtheory.Gauss.
      move=> H/H.
      move/Znumtheory.Zdivide_bounds.
      move=> H'/H'.
      have ->: Z.abs p = p by rewrite /p -lock.
      have ->: Z.abs (Zmodp.repr x) = (Zmodp.repr x).
        rewrite Z.abs_eq_iff; omega.
      move => H''.
      omega.
    * destruct (ClassicalDescription.excluded_middle_informative _).
    clear Eulers_Criterion Eulers_Criterion2 n0 Prime2.
    move: e => [y Hy].
    exists (Zmodp.pi y).
    right.
    apply eq_inv_2.
    apply val_inj => /=.
    rewrite Z.mul_mod_idemp_l; last by rewrite /p -lock.
    rewrite Z.mul_mod_idemp_r; last by rewrite /p -lock.
    move: Hy.
    have ->: y^2 = y*y by ring.
    have ->: 28948022309329048855892746252171976963317496166410141009864396001978282409975 mod p = 28948022309329048855892746252171976963317496166410141009864396001978282409975 => //.
    by rewrite /p -lock.
    * exfalso.
      have Hp : p <> 0 by rewrite /p -lock.
      clear n0 n1 n2.
      move: Eulers_Criterion2.
      rewrite Z.pow_mul_l.
      rewrite -Zmult_mod_idemp_l.
      rewrite -Zmult_mod_idemp_r.
      rewrite -Eulers_Criterion.
      clear n Prime2 Prime Eulers_Criterion.
      have <-: -1 mod p = 28948022309329048855892746252171976963317496166410141009864396001978282409975 ^ ((p - 1) / 2) mod p.
      rewrite /p.
      have Hn : 0 < locked (2 ^ 255 - 19) by rewrite -lock.
      have := legendre_compute28948022309329048855892746252171976963317496166410141009864396001978282409975.
      have := Zpow_facts.Zpower_mod 28948022309329048855892746252171976963317496166410141009864396001978282409975 ((locked (2 ^ 255 - 19) - 1) / 2) (locked (2 ^ 255 - 19)) Hn.
      rewrite -lock.
      remember (28948022309329048855892746252171976963317496166410141009864396001978282409975 ^ ((2 ^ 255 - 19 - 1) / 2) mod (2 ^ 255 - 19)) as m.
      remember ((28948022309329048855892746252171976963317496166410141009864396001978282409975 mod (2 ^ 255 - 19)) ^ ((2 ^ 255 - 19 - 1) / 2) mod (2 ^ 255 - 19)) as m'.
      remember (-1 mod (2 ^ 255 - 19)) as m''.
      clear Heqm Heqm' Heqm''.
      move => -> -> //.
      rewrite /p -lock; compute ; congruence.
Qed.

Close Scope Z.

Lemma forall_x_2_0_sqrt (x:Zmodp.type) : x ^+ 2 = 0 -> x = 0.
Proof.
  move/eqP.
  rewrite sqrf_eq0.
  move/eqP => -> //.
Qed.

Lemma x_y_dif_0 (x y:Zmodp.type) : x != 0 \/ y != 0 -> (x != 0 /\ y == 0) \/ (x == 0 /\ y != 0) \/ (x != 0 /\ y != 0).
Proof.
move/orP.
have := orNb (y == 0).
have := orNb (x == 0).
case (x == 0) ; case (y == 0) => //= => _ _ _ ; auto.
Qed.

Lemma x2_eq_2_y2 : forall (x y:Zmodp.type), x != 0 \/ y != 0 -> x ^+2 - 2%:R * y^+2 != 0.
Proof.
move => x y.
move/x_y_dif_0 => [|[]] [].
+ move/eqP => Hx /eqP => ->.
  ring_simplify_this; rewrite -expr2.
  by apply/eqP => Hx2 ; apply Hx; move/forall_x_2_0_sqrt:Hx2.
+ move/eqP => ->.
  ring_simplify_this; rewrite -expr2.
  move/eqP => Hy.
  apply/eqP => Hy2 ; apply Hy.
  move/eqP:Hy2.
  rewrite oppr_eq0.
  by move/eqP/time_2_eq_0/forall_x_2_0_sqrt.
+ move => Hx Hy.
apply/eqP.
move/GRing.subr0_eq.
move/(f_equal (fun t => t / (y^+2))).
have Hy2 : y^+2 != 0 by apply/eqP=> Hy2 ; move/eqP: Hy => Hy ; apply Hy; move/forall_x_2_0_sqrt:Hy2.
rewrite -(mulrA 2%:R) (mulfV Hy2).
have ->: 2%:R * 1 = 2%:R :> Zmodp.type by ring_simplify_this.
rewrite -exprVn.
rewrite -exprMn.
apply/eqP.
apply two_not_square.
Qed.

Close Scope ring_scope.


Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.NullableDescr.
Require Export Parser.DescriptionInd.
Require Export Parser.Matches.

Definition nullable_ind { A }: Syntax A -> A -> Prop := descr_ind nullable_descr.

Lemma nullable_ind_sound:
  forall A (s: Syntax A) (v: A),
    nullable_ind s v ->
    matches s nil v.
Proof.
  unfold nullable_ind; intros.
  remember (Some v) as opt.
  induction H; repeat light || options || rules || destruct_match || invert_constructor_equalities;
    eauto with matches.
Qed.

Lemma nullable_ind_complete:
  forall A (s: Syntax A) (v: A),
    matches s nil v ->
    nullable_ind s v.
Proof.
  unfold nullable_ind; intros.
  remember [] as forgotten.
  remember [] as ts in H.
  induction H;
    repeat light || lists; eauto 3 with descr_ind lights.
Qed.

Lemma nullable_ind_correct:
  forall A (s: Syntax A) v,
    nullable_ind s v <-> matches s nil v.
Proof.
  lights; eauto using nullable_ind_sound, nullable_ind_complete.
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import tacs rel.

Set Implicit Arguments.

Definition square X (R : X -> X -> Prop) := forall f a b, R f a -> R f b -> exists g, R a g /\ R b g.

Section square_crt.

  Variables (X : Type) (R : X -> X -> Prop) (HR : @square X R).

  Let ri_square_1 n f a b :
           f [R,1>> a
        -> f [R,n>> b
        -> exists g, a [R,n>> g
                  /\ b [R,1>> g.
  Proof.
    revert f a.
    induction n as [ | n IHn ]; intros f a Ha Hf; simpl in Hf.
    subst; exists a; simpl; auto.
    destruct Hf as (x & H1 & H2).
    apply rel_iter_one in Ha.
    destruct (HR Ha H1) as (c & H3 & H4).
    rewrite rel_iter_one in H4.
    destruct (IHn _ _ H4 H2) as (g & H5 & H6).
    exists g; split; auto.
    exists c; auto.
  Qed.

  Theorem rel_iter_square n m f a b :
           f [R,n>> a
        -> f [R,m>> b
        -> exists g, a [R,m>> g
                  /\ b [R,n>> g.
  Proof.
    revert m f a b; induction n as [ | n IHn ]; intros m f a b Ha Hb; simpl in Ha.
    subst; exists b; simpl; auto.
    destruct Ha as (x & H1 & H2).
    rewrite rel_iter_one in H1.
    destruct (ri_square_1 _ _ H1 Hb) as (g & H3 & H4).
    destruct (IHn _ _ _ _ H2 H3) as (h & H5 & H6).
    exists h; simpl; split; auto.
    exists g; split; auto.
    apply rel_iter_one; auto.
  Qed.

  Theorem square_crt : square (crt R).
  Proof.
    intros f a b.
    do 2 rewrite rel_iter_eq_crt.
    intros (na & Ha) (nb & Hb).
    destruct rel_iter_square with (1 := Ha) (2 := Hb)
      as (g & H1 & H2); auto.

  Admitted.

End square_crt.

Definition confluent X (R : X -> X -> Prop) := square (crt R).
Definition church_rosser X (R : X -> X -> Prop) :=
    forall a b, crst R a b <-> exists f, crt R a f /\ crt R b f.

Section confluent_church_rosser.

  Variable (X : Type) (R : X -> X -> Prop) (HR : @confluent X R).

  Fact confluent_church_rosser : church_rosser R.
  Proof.
    intros a b; split.
    induction 1 as [ x y | x | x y _ (f & H1 & H2) | x y z _ (a & H1 & H2) _ (b & H3 & H4)].
    exists y; split; [ constructor 1 | constructor 2]; auto.
    exists x; split; constructor 2; auto.
    exists f; auto.
    destruct (HR H2 H3) as (f & ? & ?).
    exists f; split.
    constructor 3 with a; auto.
    constructor 3 with b; auto.

    intros (f & H1 & H2).
    constructor 4 with f.
    apply crt_inc_crst; auto.
    constructor 3.
    apply crt_inc_crst; auto.
  Qed.

End confluent_church_rosser.

Section church_rosser_confluent.

  Variable (X : Type) (R : X -> X -> Prop) (HR : @church_rosser X R).

  Fact church_rosser_confluent : confluent R.
  Proof.
    intros f a b Ha Hb.
    apply HR.
    constructor 4 with f.
    constructor 3.
    apply crt_inc_crst; auto.
    apply crt_inc_crst; auto.
  Qed.

End church_rosser_confluent.


Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Math013.

Coq < Require Import Arith.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]

Coq < Load CpdtTactics.

Coq < Goal forall x, x + 2 = x + 1 + 1.
1 subgoal

  ============================
   forall x : nat, x + 2 = x + 1 + 1

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined


(* Time-stamp: "2018-02-08 18:19:03 pierre" *)
(****************************************************************)
(*                        dollar.v                              *)
(*                                                              *)
(**          © Pierre Lescanne  (December 2015)                 *)
(*                                                              *)
(*              LIP (ENS-Lyon, CNRS, INRIA)                     *)
(*                                                              *)
(*                                                              *)
(*  Developed in  V8.4pl4               January -- May   2016   *)
(****************************************************************)
Section Dollar.

Add LoadPath ".".

Require Import games_Choice_Dependent.
Require Import Omega.

(* Setting sets for agents and choices *)
Inductive AliceBob : Set := | Alice | Bob.
Inductive DorR : Set := | d | r.
Definition Choice: AliceBob -> Set := fun a => DorR.

Arguments StratProf [Agent Utility Choice].
Arguments Game [Agent Utility Choice].
Arguments UAssignment [Agent Utility Choice] s H a.
Arguments game [Agent Utility Choice] s.
Arguments StratProf_decomposition [Agent Utility Choice] s.
Arguments Convergent [Agent Utility Choice] s.
Arguments AlwaysConvergent [Agent Utility Choice] s.
Arguments convLeaf [Agent Utility Choice] f.
Arguments convNode [Agent Utility Choice] a c next _.
Arguments StratProf_identity [Agent Utility Choice] s.
Arguments SPE [Agent Utility Choice] preference  s.
Arguments Uassign [Agent Utility Choice] s a u.
Arguments good [Agent Utility Choice] preference s.
Arguments gEqual [Agent Utility Choice] g1 g2.
Arguments Divergent  [Agent Utility Choice] s.
Arguments AlwaysGood  [Agent Utility Choice] preference s.

Notation "<< f >>" := (sLeaf AliceBob nat Choice f).
Notation "<< a , c , next >>" :=
  (sNode AliceBob nat Choice a c next).
Notation "[ x , y ]" :=
  (fun a:AliceBob => match a with Alice => x | Bob => y end).
Notation "<| f |>" := (gLeaf  AliceBob nat Choice f).
Notation "<| a , next |>" := (gNode AliceBob nat Choice a next).

Notation "s1 +++ s2" :=
  (fun c:DorR => match c with d => s1 | r => s2 end)
  (at level 30).
Notation "↓ s " := (Convergent s) (at level 5).
Notation "⇓ s" := (AlwaysConvergent s)
                    (at level 15).
Notation "↑ s " := (Divergent s) (at level 5).
Notation "g == g'" := (gEqual g g') (at level 80).

Ltac decomp := rewrite <- StratProf_decomposition;  simpl.

(* --------------------------------- *)
(**    Dollar Auction                *)
(* --------------------------------- *)

(* Definitions *)
CoFixpoint dollarAcBs n := <<Alice, r, <<[n+1,n]>> +++ dollarBsAc n>>
  with dollarBsAc n := <<Bob, d, <<[n+1,n+1]>> +++ dollarAcBs (n+1)>>.

CoFixpoint dollarAsBc n := <<Alice, d, <<[n+1,n]>> +++ dollarBcAs n>>
  with dollarBcAs n := <<Bob, r, <<[n+1,n+1]>> +++ dollarAsBc (n+1)>>.

CoFixpoint dollarAcBc n := <<Alice, r, <<[n+1,n]>> +++ dollarBcAc n>>
  with dollarBcAc n := <<Bob, r, <<[n+1,n+1]>> +++ dollarAcBc (n+1)>>.

(* Lemmas on utility assignments *)

(* A continues Bob stops *)

Lemma UassignDolAcBsA: forall n, Uassign (dollarAcBs n) Alice (n+1).
Proof.
  intro n.
  rewrite <- StratProf_decomposition with (s:=dollarAcBs n); simpl.
  rewrite <- StratProf_decomposition with (s:=dollarBsAc n); simpl.
  apply UassignNode.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignDolAcBsB: forall n, Uassign (dollarAcBs n) Bob (n+1).
Proof.
  intro n.
  rewrite <- StratProf_decomposition with (s:=dollarAcBs n); simpl.
  apply UassignNode.
  rewrite <- StratProf_decomposition with (s:=dollarBsAc n); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignDolBsAcA: forall n, Uassign (dollarBsAc n) Alice (n+1).
Proof.
  intro n.
  rewrite <- StratProf_decomposition with (s:=dollarBsAc n); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignDolBsAcB: forall n, Uassign (dollarBsAc n) Bob (n+1).
Proof.
  intro n.
  rewrite <- StratProf_decomposition with (s:=dollarBsAc n); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

(* A stops Bob continues *)
Lemma UassignDolAsBcA: forall n, Uassign (dollarAsBc n) Alice (n+1).
Proof.
  intro n.
  rewrite <- StratProf_decomposition with (s:=dollarAsBc n); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignDolAsBcB: forall n, Uassign (dollarAsBc n) Bob n.
Proof.
  intro n.
  rewrite <- StratProf_decomposition with (s:=dollarAsBc n); simpl.
  apply UassignNode.
  apply UassignLeaf.
Qed.

Lemma UassignDolBcAsA: forall n, Uassign (dollarBcAs n) Alice (n+1+1).
Proof.
  intro n.
  rewrite <- StratProf_decomposition with (s:=dollarBcAs n); simpl.
  apply UassignNode.
  apply UassignDolAsBcA.
Qed.

Lemma UassignDolBcAsB: forall n, Uassign (dollarBcAs n) Bob (n+1).
Proof.
  intro n.
  rewrite <- StratProf_decomposition with (s:=dollarBcAs n); simpl.
  apply UassignNode.
  apply UassignDolAsBcB.
Qed.

(* Lemmas on Convergence of strategy profiles *)

Lemma ConvergentDolBsAc: forall n, ↓ (dollarBsAc n).
Proof.
  intro n; decomp; apply ConvNode; apply ConvLeaf.
Qed.

Lemma ConvergentDolAcBs: forall n, ↓ (dollarAcBs n).
Proof.
  intro n; decomp; apply ConvNode; apply ConvergentDolBsAc.
Qed.

Lemma ConvergentDolAsBc: forall n, ↓ (dollarAsBc n).
Proof.
  intro n; decomp; apply ConvNode; apply ConvLeaf.
Qed.

Lemma ConvergentDolBcAs: forall n, ↓ (dollarBcAs n).
Proof.
  intro n; decomp; apply ConvNode; apply ConvergentDolAsBc.
Qed.

(* Lemmas on Always Convergence of strategy profiles *)

Lemma AlwsConvDolAcBs: forall n, ⇓ (dollarAcBs n).
Proof.
  cofix AlwsConvDolAcBs.
  intro n;
  decomp;
  apply AlwaysNode; [apply ConvNode; apply ConvergentDolBsAc |
                     induction c';
                       [apply AlwaysLeaf | decomp; apply AlwaysNode];
                       [apply ConvNode; apply ConvLeaf |
                        induction c'; [apply AlwaysLeaf | apply AlwsConvDolAcBs]]].
Qed.

Lemma AlwsConvDolBsAc: forall n, ⇓ (dollarBsAc n).
Proof.
  intro n;
  decomp; apply AlwaysNode;
  [apply ConvNode; apply ConvLeaf |
   induction c';
     [apply AlwaysLeaf |
      apply AlwsConvDolAcBs]].
Qed.

Lemma AlwsConvDolBcAs: forall n, ⇓ (dollarBcAs n).
Proof.
  cofix AlwsConvDolBcAs;
  intro;
  decomp; apply AlwaysNode;
  [apply ConvNode; apply ConvergentDolAsBc |
   induction c';
     [apply AlwaysLeaf |
      decomp; apply AlwaysNode;
      [apply ConvNode; apply ConvLeaf |
       induction c';  [apply AlwaysLeaf | apply AlwsConvDolBcAs]]]].
Qed.

Lemma AlwsConvDolAsBc:forall n,  ⇓ (dollarAsBc n).
Proof.
  intro n;
  decomp; apply AlwaysNode;
  [apply ConvNode; apply ConvLeaf |
   induction c'; [apply AlwaysLeaf | apply AlwsConvDolBcAs]].
Qed.

(* Equality of the underlying game *)
Lemma sameGameBcAc_BsAc: forall n, game (dollarBcAc n) == game (dollarBsAc n).
Proof.
  cofix sameGameBcAc_BsAc;
  intro n;
  rewrite <- StratProf_decomposition with (s:=dollarBcAc n);
  rewrite <- StratProf_decomposition with (s:=dollarBsAc n);
  simpl;
  rewrite gameNode; rewrite gameNode; apply gEqualNode;
  induction c; [apply refGEqual |
                rewrite <- StratProf_decomposition with (s:=dollarAcBc (n+1));
                  rewrite <- StratProf_decomposition with (s:=dollarAcBs (n+1));
                  simpl;
                  rewrite gameNode; rewrite gameNode; apply gEqualNode];
  induction c; [apply refGEqual | apply sameGameBcAc_BsAc].
Qed.

Lemma sameGameAcBc_AcBs: forall n, game (dollarAcBc n) == game (dollarAcBs n).
Proof.
  intro n;
  rewrite <- StratProf_decomposition with (s:=dollarAcBc n);
  rewrite <- StratProf_decomposition with (s:=dollarAcBs n);
  simpl;
  rewrite gameNode; rewrite gameNode; apply gEqualNode;
  induction c; [apply refGEqual | apply sameGameBcAc_BsAc].
Qed.

Lemma sameGameBcAs_BcAc: forall n, game (dollarBcAc n) == game (dollarBcAs n).
Proof.
  cofix sameGameBcAc_BsAc;
  intro n;
  rewrite <- StratProf_decomposition with (s:=dollarBcAc n);
  rewrite <- StratProf_decomposition with (s:=dollarBcAs n);
  simpl;
  rewrite gameNode; rewrite gameNode; apply gEqualNode;
  induction c;
  [apply refGEqual |
  rewrite <- StratProf_decomposition with (s:=dollarAcBc (n+1));
  rewrite <- StratProf_decomposition with (s:=dollarAsBc (n+1));
  simpl;
  rewrite gameNode; rewrite gameNode; apply gEqualNode;
  induction c; [apply refGEqual | apply sameGameBcAc_BsAc]].
Qed.

Lemma sameGameAcBc_AsBc: forall n, game (dollarAcBc n) == game (dollarAsBc n).
Proof.
  intro n;
  rewrite <- StratProf_decomposition with (s:=dollarAcBc n);
  rewrite <- StratProf_decomposition with (s:=dollarAsBc n);
  simpl;
  rewrite gameNode; rewrite gameNode; apply gEqualNode;
  induction c; [apply refGEqual | apply sameGameBcAs_BcAc].
Qed.

(* SPE *)
Lemma SPEDolAcBs: forall n, SPE ge (dollarAcBs n).
Proof.
  cofix SPEDolAcBs;
  intro n;
  decomp;
  apply SPENode with (c':=r)(u:=n+1)(u':=n+1);
  [apply AlwaysNode; [apply ConvNode;apply ConvergentDolBsAc | induction c'; [apply AlwaysLeaf | apply AlwsConvDolBsAc]] |
   apply UassignDolBsAcA |
   apply UassignDolBsAcA |
   auto |
   decomp;
   apply SPENode with (c':=r)(u:=n+1)(u':=n+1+1);
   [apply AlwaysNode; [apply ConvNode;  apply ConvLeaf | induction c'; [apply AlwaysLeaf| apply AlwsConvDolAcBs]] |
    apply UassignDolAcBsB |
    apply UassignLeaf |
    omega |
    apply SPEDolAcBs]].
Qed.

Lemma SPEDolBsAc: forall n, SPE ge (dollarBsAc n).
Proof.
  cofix SPEDolBsAc;
  intro n;
  decomp;
  apply SPENode with (c':=r)(u:=n+1)(u':=n+1+1);
  [apply AlwaysNode; [apply ConvNode; apply ConvLeaf | induction c';[apply AlwaysLeaf | apply AlwsConvDolAcBs]] |
   apply UassignDolAcBsB |
   apply UassignLeaf |
   omega |
   apply SPEDolAcBs].
Qed.

Lemma SPEDolAsBc: forall n, SPE ge (dollarAsBc n).
Proof.
  cofix SPEDolAsBc;
  intro n;
  decomp;
  apply SPENode with (c':=r)(u:=n+1)(u':=n+1+1);
  [apply AlwaysNode; [apply ConvNode; apply ConvLeaf |
                      induction c';[apply AlwaysLeaf | apply AlwsConvDolBcAs]] |
   apply UassignDolBcAsA |
   apply UassignLeaf |
   omega |
   decomp;
   apply SPENode with (c':=r)(u:=n+1)(u':=n+1);
   [apply AlwaysNode; [apply ConvNode; apply ConvergentDolAsBc |
                       induction c'; [apply AlwaysLeaf | apply AlwsConvDolAsBc]] |
    apply UassignDolAsBcB |
    apply UassignDolAsBcB |
    auto |
    apply SPEDolAsBc]].
Qed.

Lemma SPEDolBcAs: forall n, SPE ge (dollarBcAs n).
Proof.
  intro n; decomp; apply SPENode with (c':=r)(u:=n+1)(u':=n+1);
  [apply AlwaysNode; [apply ConvNode; apply ConvergentDolAsBc |
                      induction c'; [apply AlwaysLeaf | apply AlwsConvDolAsBc]] |
   apply UassignDolAsBcB |
   apply UassignDolAsBcB |
   auto |
   apply SPEDolAsBc].
Qed.

(* Good *)
Lemma GoodDolAcBc: forall n, good ge (dollarAcBc n).
Proof.
  intro n;
  decomp;
  apply goodNode with (next':= <<[n+1,n]>> +++ dollarBcAs n);
  split;
  [rewrite gameNode; rewrite gameNode; apply gEqualNode;
   induction c; [ apply refGEqual | apply sameGameBcAs_BcAc]|
   apply SPENode with (c':=r)(u:=n+1+1)(u':=n+1+1);
     [apply AlwaysNode; [apply ConvNode; apply ConvergentDolBcAs |
                         induction c'; [apply AlwaysLeaf |  apply AlwsConvDolBcAs]] |
      apply UassignDolBcAsA |
      apply UassignDolBcAsA |
      auto |
      apply SPEDolBcAs]].
Qed.

Lemma GoodDolBcAc: forall n, good ge (dollarBcAc n).
Proof.
  intro n; decomp; decomp;
  apply goodNode with (next':= <<[n+1,n+1]>> +++ dollarAsBc (n + 1));
  split;
  [rewrite gameNode; rewrite gameNode; apply gEqualNode;
   induction c; [rewrite gameLeaf; apply gEqualLeaf| apply sameGameAcBc_AsBc] |
   apply SPENode with (c':=r)(u:=n+1)(u':=n+1);
     [apply AlwaysNode; [apply ConvNode; apply ConvergentDolAsBc |
                         induction c'; [apply AlwaysLeaf | apply AlwsConvDolAsBc]] |
      apply UassignDolAsBcB |
      apply UassignDolAsBcB |
      auto |
      apply SPEDolAsBc]].
Qed.

(* Always Good AcBc *)
Lemma AlwaysGoodDolAcBc: forall n, AlwaysGood ge (dollarAcBc n).
Proof.
  cofix AlwaysGoodDolAcBc;
  intro n; decomp; apply AlwaysNode;
  [replace (<< Alice, r, << [n+1, n] >> +++ dollarBcAc n >>) with (dollarAcBc n);
    [apply GoodDolAcBc | rewrite <- StratProf_decomposition with (s:=dollarAcBc n); simpl; reflexivity]|
    induction c';
    [apply AlwaysLeaf |
     decomp; apply AlwaysNode;
     [replace (<< Bob, r, << [n+1, n+1] >> +++ dollarAcBc (n + 1)>>) with (dollarBcAc n);
       [apply GoodDolBcAc | rewrite <- StratProf_decomposition with (s:=dollarBcAc n);  simpl; reflexivity]|
      induction c'; [ apply AlwaysLeaf | apply AlwaysGoodDolAcBc]]]].
Qed.

(* Divergent *)
Lemma DivergenceDolAcBc: forall n, ↑ (dollarAcBc n).
Proof.
  cofix DivergenceDolAcBc;
  intro n;
  decomp; apply divNode;
  decomp; apply divNode;
  apply DivergenceDolAcBc.
Qed.

End Dollar.


(*

   We show here that under certain circumstances, finding tail bounds for work-like recurrences
   can be reduced to finding bounds for span-like recurrences of the form covered in span2.v.

 *)
From discprob.basic Require Import base order nify.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp span2.
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".

Section work_bound_sec.

Variable X: eqType.
Variable size: X → 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 g1 g2: R → R.
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 / g2 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.
Variable g_cont: ∀ x, d < x → continuity_pt g2 x.

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

Hypothesis Trec:
  ∀ x r, P x → 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 => fst xy + snd xy)) (r - a (size x))).

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

Hypothesis hP: ∀ x n, P x → P (fst ((h x) n)) ∧ P (snd ((h x) n)).
Hypothesis hg1range_sum:
  ∀ x n, size x > d → g1 (size (fst ((h x) n))) + g1 (size (snd ((h x) n))) ≤ g1 (size x).
Hypothesis hg2range_sum:
  ∀ x n, size x > d → g2 (size (fst ((h x) n))) + g2 (size (snd ((h x) n))) ≤ g2 (size x).
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 g1_pos: ∀ x, g1 x > 0.
Hypothesis g2_pos: ∀ x, g2 x > 0.
Hypothesis gmin: R.
Hypothesis g_below: ∀ x, x ≤ d → g2 x = gmin.
Hypothesis aglower: ∀ x, x ≤ d → a x / g2 x = 0.
Hypothesis ag_nonneg: ∀ x, a x / g2 x ≥ 0.
Hypothesis ag_mono: Rmono (λ x, a x / g2 x).
Hypothesis ag_pos: ∀ x, d < x → 0 < a x / g2 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.
Hypothesis g1d: ∀ x, x > d → g1 x ≥ 1.
Hypothesis g1pos: ∀ x, 0 ≤ x → 0 ≤ g1 x.
Hypothesis g1_mono: Rmono g1.

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.

(* 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 / gmin  ≤ umin.

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

Definition H (x: X) : rrvar (ΩT x) := rvar_comp (T x) (λ v, v / (g2 (size x))).

Definition Kg r z := pr (rvar_dist (H z)) (λ n, Rgt_dec ((H z) n) r).

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

Lemma Kg_K r z: g2 (size z) > 0 → Kg r z = K (g2 (size z) * r) z.
Proof.
  intros Hsize.
  rewrite /Kg /K /H.
  rewrite pr_gt_alt_comp pr_gt_alt.
  apply eq_bigr => i ?.
  destruct (Rgt_dec) as [Hlt|Hge]; rewrite /is_left.
  - rewrite /Rdiv in Hlt. apply (Rmult_lt_compat_r (g2 (size z))) in Hlt; last first.
    { fourier. }
    rewrite Rmult_assoc Rinv_l in Hlt; last first.
    { apply Rgt_not_eq; eauto. }
    rewrite Rmult_1_r Rmult_comm in Hlt.
    destruct (Rgt_dec) => //=.
  - apply Rnot_gt_ge in Hge.
    rewrite /Rdiv in Hge. apply (Rmult_ge_compat_r (g2 (size z))) in Hge; last first.
    { left. eauto. }
    rewrite Rmult_assoc Rinv_l in Hge; last first.
    { apply Rgt_not_eq; eauto. }
    rewrite Rmult_1_r Rmult_comm in Hge.
    apply Rge_not_lt in Hge.
    destruct (Rgt_dec) => //=.
Qed.

Lemma K_Kg r z: g2 (size z) > 0 → K r z = Kg (r / g2 (size z)) z.
Proof.
  intros; rewrite Kg_K; eauto. replace (g2 (size z) * (r / g2 (size z))) with r; auto.
  field. apply Rgt_not_eq; eauto.
Qed.

Lemma Hrec:
  ∀ x r, P x → size x > d →  pr_gt (H x) r ≤ \big[Rplus/0]_(x' : imgT (h x))
                        ((pr_eq (h x) (sval x')) *
                         pr_gt (rvar_comp (rvar_pair (H (fst (sval x'))) (H (snd (sval x'))))
                                        (fun xy => Rmax (fst xy) (snd xy)))
                                              (r - a (size x) / g2 (size x))).
Proof.
 intros.
 rewrite /pr_gt. specialize (Kg_K); rewrite /Kg; intros ->; last by eauto.
 etransitivity. rewrite /K. apply Trec; auto.
 apply Rle_bigr => i Hin.
 apply Rmult_le_compat_l.
 { rewrite /pr_eq. apply Rge_le, ge_pr_0. }
 rewrite /pr_gt /pr.
 rewrite ?SeriesC_fin_big.
 rewrite -?big_mkcondr.
 apply Rle_bigr' => i' Hin'; auto.
 * intros. split; last reflexivity.
   move /andP in Hin'. destruct Hin' as (Hin'&Hgt).
   apply /andP; split; auto.
   destruct (Rgt_dec) as [Hgt'|?] => //= ; [].
   destruct (Rgt_dec) as [?|Hngt] => //=; [].
   exfalso; apply Hngt.
   destruct i as (i&?). rewrite //=.
   assert (∃ n, h x n = i) as (n&Hh).
   { apply img_alt. done. }
   subst.
   generalize Hgt'; intros Hlt%Rgt_lt.
   apply (Rplus_lt_compat_r (a (size x))) in Hlt.
   rewrite /Rminus Rplus_assoc Rplus_opp_l Rplus_0_r in Hlt.
   apply (Rmult_lt_compat_l (/g2 (size x))) in Hlt; last first.
   { apply Rinv_0_lt_compat. apply g2_pos; auto. }
   rewrite -Rmult_assoc Rinv_l in Hlt; last first.
   { apply Rgt_not_eq; eauto. }
   rewrite Rmult_1_l in Hlt.
   rewrite ?Rmult_plus_distr_l in Hlt.
   rewrite /Rminus.
   apply (Rplus_lt_compat_r (- (/ g2 (size x) * a (size x)))) in Hlt.
   rewrite /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r in Hlt.
   rewrite /Rdiv. rewrite Rmult_comm. rewrite //= in Hlt.
   eapply Rlt_le_trans.
   { rewrite Rmult_comm. apply Hlt. }
   assert (T ((h x) n).1 i'.1 =
   ( g2 (size ((h x) n).1) * (T ((h x) n).1) i'.1 * / g2 (size ((h x) n).1))) as Hdiv1.
   { rewrite Rmult_comm -Rmult_assoc Rinv_l; first by rewrite Rmult_1_l.
     apply Rgt_not_eq, g2_pos. }
   assert (T ((h x) n).2 i'.2 =
   ( g2 (size ((h x) n).2) * (T ((h x) n).2) i'.2 * / g2 (size ((h x) n).2))) as Hdiv2.
   { rewrite Rmult_comm -Rmult_assoc Rinv_l; first by rewrite Rmult_1_l.
     apply Rgt_not_eq, g2_pos. }
   rewrite {1}Hdiv1.
   rewrite {1}Hdiv2.
   apply Rmax_case_strong => Hle.
   ** etransitivity.
      { apply Rplus_le_compat_l.
        apply Rmult_le_compat_l.
        { apply Rinv_pos, g2_pos. }
        rewrite Rmult_assoc.
        apply Rmult_le_compat_l.
        { left. apply g2_pos. }
        apply Hle.
      }
      rewrite Rmult_assoc.
      rewrite -Rmult_plus_distr_l.
      rewrite (Rmult_comm (T _ _)).
      rewrite -Rmult_plus_distr_r.
      rewrite -Rmult_assoc.
      rewrite -[a in _ ≤ a]Rmult_1_l. apply Rmult_le_compat_r.
      { rewrite Rmult_comm. apply Rle_mult_inv_pos.
        - apply Rge_le, T_non_neg.
        - apply g2_pos.
      }
      apply (Rmult_le_reg_l (g2 (size x))).
      { apply g2_pos. }
      rewrite -Rmult_assoc Rinv_r //; last first.
      { apply Rgt_not_eq, g2_pos. }
      rewrite Rmult_1_l Rmult_1_r. eauto.
   ** etransitivity.
      { apply Rplus_le_compat_r.
        apply Rmult_le_compat_l.
        { apply Rinv_pos, g2_pos. }
        rewrite Rmult_assoc.
        apply Rmult_le_compat_l.
        { left. apply g2_pos. }
        rewrite Rmult_comm; apply Hle.
      }
      rewrite Rmult_assoc.
      rewrite -Rmult_plus_distr_l.
      rewrite -Rmult_plus_distr_r.
      rewrite -Rmult_assoc.
      rewrite -[a in _ ≤ a]Rmult_1_l. apply Rmult_le_compat_r.
      { apply Rle_mult_inv_pos.
        - apply Rge_le, T_non_neg.
        - apply g2_pos.
      }
      apply (Rmult_le_reg_l (g2 (size x))).
      { apply g2_pos. }
      rewrite -Rmult_assoc Rinv_r //; last first.
      { apply Rgt_not_eq, g2_pos. }
      rewrite Rmult_1_l Rmult_1_r. eauto.
 * intros. apply Rge_le, pmf_pos.
Qed.

Lemma Kg_work_bound:
  ∀ r x, P x → Kg r x ≤ span2.D g1 (λ x, a x / g2 x) m u u' d (umin)  r (size x).
Proof.
  intros.
  eapply span_bound; eauto.
  - intros. apply continuity_pt_div; auto.
    apply Rgt_not_eq, g2_pos; fourier.
  - apply Hrec.
  - rewrite /H //=.  intros.
    rewrite g_below /Rdiv; eauto.
Qed.

Lemma work_bound: ∀ r x, P x → K r x ≤ span2.D g1 (λ x, a x / g2 x) m u u' d umin (r / g2 (size x)) (size x).
  intros. rewrite K_Kg; last apply g2_pos.
  apply Kg_work_bound; auto.
Qed.

Lemma work_bound_simple w x:
  g1 (size x) > 1 →
  size x > d →
  P x → pr_gt (T x) (g2 (size x) * u (size x) + INR w * a (size x))
              ≤ g1 (size x) * (m (size x) / size x) ^ w.
Proof.
  set (r := g2 (size x) * (u (size x)) + INR w * (a (size x))).
  intros.
  transitivity (span2.D g1 (λ x, a x / g2 x) m u u' d umin (r / g2 (size x)) (size x)).
  - apply work_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) / g2 (size x) > 0) as Hag by (apply ag_pos; nra).
         specialize (g2_pos (size x)).
         assert (a (size x) > 0).
         { apply Rgt_lt, (Rmult_lt_compat_r (g2 (size x))) in Hag; last by nra.
           rewrite /Rdiv Rmult_assoc Rinv_l in Hag; last by nra.
           nra.
         }
         specialize (pos_INR w).
         intros. rewrite S_INR in Hle. exfalso.
         rewrite /Rdiv Rmult_plus_distr_r in Hle.
         rewrite /Rdiv in Hag.
         rewrite Rmult_comm in Hle.
         rewrite -Rmult_assoc in Hle.
         rewrite Rinv_l in Hle; last nra.
         rewrite Rmult_1_l in Hle. 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.
         specialize (g2_pos (size x)).
         rewrite /Rdiv Rmult_comm -Rmult_assoc Rinv_l; last by nra.
         rewrite Rmult_1_l.
         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) / g2 (size x) > 0) as Hag by (apply ag_pos; nra).
         specialize (g2_pos (size x)).
         assert (a (size x) > 0).
         { apply Rgt_lt, (Rmult_lt_compat_r (g2 (size x))) in Hag; last by nra.
           rewrite /Rdiv Rmult_assoc Rinv_l in Hag; last by nra.
           nra.
         }
         specialize (pos_INR w).
         intros. rewrite S_INR in Hle. exfalso.
         rewrite /Rdiv Rmult_plus_distr_r in Hle.
         rewrite /Rdiv in Hag.
         rewrite Rmult_comm in Hle.
         rewrite -Rmult_assoc in Hle.
         rewrite Rinv_l in Hle; last nra.
         rewrite Rmult_1_l in Hle. nra.
     }
     rewrite //=.
     assert ((round (λ x0 : R, a x0 / g2 x0) u
         ((g2 (size x) * u (size x) + INR w * a (size x)) / g2 (size x))
         (size x)) = (Z_of_nat w)) as Hround.
     {
       rewrite /round.
       assert ((((g2 (size x) * u (size x) + INR w * a (size x)) / g2 (size x)
                 - u (size x)) / (a (size x) / g2 (size x))) = INR w) as ->.
       { assert (a (size x) / g2 (size x) > 0) as Hag by (apply ag_pos; nra).
         specialize (g2_pos (size x)).
         assert (a (size x) > 0).
         { apply Rgt_lt, (Rmult_lt_compat_r (g2 (size x))) in Hag; last by nra.
           rewrite /Rdiv Rmult_assoc Rinv_l in Hag; last by nra.
           nra.
         }
         field.
         split; nra.
       }
        rewrite INR_IZR_INZ Rceil_IZR. done.
     }
     rewrite Hround //= INR_IZR_INZ.
     rewrite (Rmult_comm (IZR _)).
     assert ((g2 (size x) * u (size x) + a (size x) * IZR (Z.of_nat w)) / g2 (size x)
             - a (size x) / g2 (size x) * IZR (Z.of_nat w)
             = u (size x)) as ->.
     { field. specialize (g2_pos (size x)); nra.  }
     rewrite u'_inv_above; last by nra.
     rewrite /Rdiv. rewrite (Rmult_assoc (g1 (size x))).
     rewrite Rinv_r; last by nra. rewrite Rmult_1_r.
      rewrite Nat2Z.id. nra.
Qed.

End work_bound_sec.


From stdpp Require Export tactics.
From stdpp Require Import options.

CoInductive stream (A : Type) : Type := scons : A → stream A → stream A.
Arguments scons {_} _ _ : assert.
Delimit Scope stream_scope with stream.
Bind Scope stream_scope with stream.
Open Scope stream_scope.
Infix ":.:" := scons (at level 60, right associativity) : stream_scope.

Definition shead {A} (s : stream A) : A := match s with x :.: _ => x end.
Definition stail {A} (s : stream A) : stream A := match s with _ :.: s => s end.

CoInductive stream_equiv' {A} (s1 s2 : stream A) : Prop :=
  scons_equiv' :
    shead s1 = shead s2 → stream_equiv' (stail s1) (stail s2) →
    stream_equiv' s1 s2.
Instance stream_equiv {A} : Equiv (stream A) := stream_equiv'.

Reserved Infix "!.!" (at level 20).
Fixpoint slookup {A} (i : nat) (s : stream A) : A :=
  match i with O => shead s | S i => stail s !.! i end
where "s !.! i" := (slookup i s).

Global Instance stream_fmap : FMap stream := λ A B f,
  cofix go s := f (shead s) :.: go (stail s).

Fixpoint stake {A} (n : nat) (s : stream A) :=
  match n with 0 => [] | S n => shead s :: stake n (stail s) end.
CoFixpoint srepeat {A} (x : A) : stream A := x :.: srepeat x.

Section stream_properties.
Context {A : Type}.
Implicit Types x y : A.
Implicit Types s t : stream A.

Lemma scons_equiv s1 s2 : shead s1 = shead s2 → stail s1 ≡ stail s2 → s1 ≡ s2.
Proof. by constructor. Qed.
Global Instance equal_equivalence : Equivalence (≡@{stream A}).
Proof.
  split.
  - now cofix FIX; intros ?; constructor.
  - now cofix FIX; intros ?? [??]; constructor.
  - cofix FIX; intros ??? [??] [??]; constructor; etrans; eauto.
Qed.
Global Instance scons_proper x : Proper ((≡) ==> (≡)) (scons x).
Proof. by constructor. Qed.
Global Instance shead_proper : Proper ((≡) ==> (=@{A})) shead.
Proof. by intros ?? [??]. Qed.
Global Instance stail_proper : Proper ((≡) ==> (≡@{stream A})) stail.
Proof. by intros ?? [??]. Qed.
Global Instance slookup_proper i : Proper ((≡@{stream A}) ==> (=)) (slookup i).
Proof. by induction i as [|i IH]; intros s1 s2 Hs; simpl; rewrite Hs. Qed.
End stream_properties.