(*
Copyright © 2006-2008 Russell O’Connor
Copyright © 2020 Vincent Semeria

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

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

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

(* Backwards compatibility for Hint Rewrite locality attributes *)
Set Warnings "-unsupported-attributes".

Local Open Scope Q_scope.
Local Open Scope uc_scope.

(**
** Natural Integer Powers
Positive integer powers is faster than repeated multiplication.

It is uniformly continuous on an interval [[-c,c]].
*)

(* We first define repeated multiplication to prove correctness. *)
Fixpoint CRpower_slow (x : CR) (n : nat) { struct n }
  := match n with
     | O => 1%CR
     | S p => (x * CRpower_slow x p)%CR
     end.

Lemma CRpower_slow_wd : forall (x y : CR) (n : nat),
    msp_eq x y -> msp_eq (CRpower_slow x n) (CRpower_slow y n).
Proof.
  induction n.
  - intros. reflexivity.
  - intros. simpl (CRpower_slow x (S n)).
    rewrite (IHn H). rewrite H. reflexivity.
Qed.

Lemma Qpower_positive_abs_le : forall (q:Q) (c : Qpos) (n : positive),
    Qabs q <= `c
    -> Qabs (Qpower_positive q n) <= Qpower_positive (` c) n.
Proof.
  intros q c.
  induction n.
  - intros. simpl (Qpower_positive q n~1).
    rewrite Qabs_Qmult.
    simpl (Qpower_positive (` c) n~1).
    apply (Qle_trans _ (`c * Qabs (Qpower_positive q n * Qpower_positive q n))).
    apply Qmult_le_compat_r. exact H.
    apply Qabs_nonneg. apply Qmult_le_l.
    apply Qpos_ispos.
    rewrite Qabs_Qmult.
    apply (Qle_trans _ (Qpower_positive (`c) n * Qabs (Qpower_positive q n))).
    apply Qmult_le_compat_r. apply IHn. exact H.
    apply Qabs_nonneg.
    rewrite Qmult_comm.
    apply Qmult_le_compat_r. apply IHn. exact H.
    apply Qpower_pos_positive, Qpos_nonneg.
  - intros. simpl (Qpower_positive q n~0).
    rewrite Qabs_Qmult. simpl.
    apply (Qle_trans _ (Qpower_positive (`c) n * Qabs (Qpower_positive q n))).
    apply Qmult_le_compat_r. apply IHn. exact H.
    apply Qabs_nonneg.
    rewrite Qmult_comm.
    apply Qmult_le_compat_r. apply IHn. exact H.
    apply Qpower_pos_positive, Qpos_nonneg.
  - intros. exact H.
Qed.

 (* The derivative of fun z => z^p is fun z => p * z^(p-1)
   which is bounded by p*c^(p-1) on [-c,c]. *)
Lemma Qdiff_power : forall (n : nat) (x y : Q) (c : Qpos),
    (-`c <= x <= `c)
    -> (-`c <= y <= `c)
    -> Qabs (x^Z.of_nat n - y^Z.of_nat n)
      <= Qabs(x-y) * (Z.of_nat n#1) * (`c) ^ (Z.pred (Z.of_nat n)).
Proof.
  induction n.
  - intros. apply Qmult_le_0_compat.
    apply Qmult_le_0_compat. apply Qabs_nonneg.
    discriminate. apply (Qpos_nonneg (Qpos_power c (Z.pred (Z.of_nat 0)))).
  - intros. change (S n) with (1 + n)%nat.
    rewrite Nat2Z.inj_add, Qpower_plus', Qpower_plus'.
    simpl (x ^ Z.of_nat 1).
    simpl (y ^ Z.of_nat 1).
    setoid_replace (x * x ^ Z.of_nat n - y * y ^ Z.of_nat n)%Q
      with ((x-y)*x ^ Z.of_nat n + y * (x ^ Z.of_nat n - y ^ Z.of_nat n))%Q
      by (unfold equiv, stdlib_rationals.Q_eq; ring).
    apply (Qle_trans _ _ _ (Qabs_triangle _ _)).
    rewrite Qabs_Qmult, Qabs_Qmult.
    apply (Qle_trans _ (Qabs (x-y) * (`c) ^ Z.of_nat n
             + Qabs (x - y) * (Z.of_nat n # 1) * ` c ^ Z.pred (Z.of_nat n) * Qabs y)).
    apply Qplus_le_compat.
    + rewrite Qmult_comm, (Qmult_comm (Qabs (x-y))).
      apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
      destruct n. apply Qle_refl.
      apply Qpower_positive_abs_le.
      apply AbsSmall_Qabs, H.
    + rewrite Qmult_comm. apply Qmult_le_compat_r.
      2: apply Qabs_nonneg. apply IHn. exact H. exact H0.
    + clear IHn.
      rewrite <- Qmult_assoc, <- Qmult_assoc, <- Qmult_plus_distr_r.
      rewrite Qmult_comm, <- Qmult_assoc, (Qmult_comm (Qabs (x-y))).
      apply Qmult_le_compat_r. 2: apply Qabs_nonneg.
      apply (Qle_trans _ (` c ^ Z.of_nat n + (Z.of_nat n # 1) * (` c ^ (Z.of_nat n)))).
      apply Qplus_le_r.
      rewrite Qmult_comm, (Qmult_comm (Z.of_nat n # 1)).
      apply Qmult_le_compat_r.
      apply (Qle_trans _ (`c ^ Z.of_nat 1 * ` c ^ Z.pred (Z.of_nat n))).
      rewrite Qmult_comm. apply Qmult_le_compat_r.
      simpl. apply AbsSmall_Qabs. exact H0.
      apply Qpower_pos. apply Qpos_nonneg.
      rewrite <- Qpower_plus. 2: apply Qpos_nonzero.
      replace (Z.of_nat 1 + Z.pred (Z.of_nat n))%Z with (Z.of_nat n).
      apply Qle_refl.
      rewrite Z.add_1_l. rewrite Z.succ_pred. reflexivity.
      unfold Qle; simpl. rewrite Z.mul_1_r. apply Nat2Z.is_nonneg.
      rewrite <- (Qmult_1_l (` c ^ Z.of_nat n)) at 1.
      rewrite <- Qmult_plus_distr_l.
      setoid_replace (1 + (Z.of_nat n # 1)) with (Z.of_nat 1 + Z.of_nat n#1).
      rewrite Qmult_comm.
      rewrite (Qmult_comm (Z.of_nat 1 + Z.of_nat n#1)).
      apply Qmult_le_compat_r.
      replace (Z.pred (Z.of_nat 1 + Z.of_nat n)) with (Z.of_nat n).
      apply Qle_refl.
      rewrite <- Nat2Z.inj_add. rewrite Nat2Z.inj_succ.
      rewrite <- Zpred_succ. reflexivity.
      rewrite <- Nat2Z.inj_add. discriminate.
      unfold equiv, stdlib_rationals.Q_eq, Qeq, Qplus, Qnum, Qden.
      simpl (1*1)%Z. rewrite Z.mul_1_r, Z.mul_1_r.
      simpl (1*1)%positive. rewrite Z.mul_1_r. reflexivity.
    + rewrite <- Nat2Z.inj_add. discriminate.
    + rewrite <- Nat2Z.inj_add. discriminate.
Qed.

Section CRpower_N.

Variable n : N. (* Binary integers are faster than unary integers *)

(* To compute x^n, we bound x by c and the modulus becomes
   fun e => e / (n * c^(n-1)) *)
Definition Qpower_N_modulus (c:Qpos) (e:Qpos) : QposInf :=
  match n with
  | N0 => QposInfinity
  | Npos p => Qpos2QposInf (e* Qpos_inv ((p#1)*Qpos_power c (Z.pred (Zpos p))))
  end.

Lemma Qpower_N_uc_prf (c:Qpos) :
  @is_UniformlyContinuousFunction
    Q_as_MetricSpace Q_as_MetricSpace
    (fun x => Qpower (QboundAbs c x) (Z_of_N n)) (Qpower_N_modulus c).
Proof.
 unfold Qpower_N_modulus.
 destruct n as [|p].
 - simpl. intros e x y E. apply ball_refl, Qpos_nonneg.
 - clear n. intros e x y E. unfold ball_ex in E.
   simpl (Z.of_N (N.pos p)).
   apply AbsSmall_Qabs.
   apply AbsSmall_Qabs in E.
   assert (-` c <= QboundAbs c x ∧ QboundAbs c x <= ` c).
   { split. apply Qmax_ub_l.
     apply Qmax_lub.
     apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
     apply Qpos_nonneg. apply Qmin_lb_l. }
   assert (- ` c <= QboundAbs c y ∧ QboundAbs c y <= ` c).
   { split. apply Qmax_ub_l.
     apply Qmax_lub.
     apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
     apply Qpos_nonneg. apply Qmin_lb_l. }
   pose proof (positive_nat_Z p).
   rewrite <- H1.
   apply (Qle_trans _ _ _ (Qdiff_power (Pos.to_nat p) _ _ c H H0)).
   clear H H0.
   rewrite <- Qmult_assoc.
   apply (Qle_trans _ (Qabs (x-y) * ((Z.pos p # 1) * ` c ^ Z.pred (Z.pos p)))).
   rewrite H1.
   apply Qmult_le_compat_r.
   apply QboundAbs_contract.
   apply (Qpos_nonneg ((p#1) * Qpos_power c (Z.pred (Z.pos p)))).
   apply (Qle_trans _ (`e * / proj1_sig ((Z.pos p # 1)%Q ↾ eq_refl * Qpos_power c (Z.pred (Z.pos p)))%Qpos * ((Z.pos p # 1) * ` c ^ Z.pred (Z.pos p)))).
   apply Qmult_le_compat_r.
   apply E.
   apply (Qpos_nonneg ((p#1) * Qpos_power c (Z.pred (Z.pos p)))).
   rewrite Qmult_comm, Qmult_assoc.
   apply Qle_shift_div_r.
   apply (Qpos_ispos ((p#1) * Qpos_power c (Z.pred (Z.pos p)))).
   rewrite Qmult_comm. apply Qle_refl.
Qed.

Definition Qpower_N_uc (c:Qpos) :  Q_as_MetricSpace --> Q_as_MetricSpace :=
Build_UniformlyContinuousFunction (Qpower_N_uc_prf c).

(** CRpower_positive_bounded works on [[-c,c]]. *)
Definition CRpower_N_bounded (c:Qpos) : CR --> CR :=
Cmap QPrelengthSpace (Qpower_N_uc c).

End CRpower_N.

Lemma Cmap_wd_bounded
  : forall (Y : MetricSpace)
      (f g : Q_as_MetricSpace --> Y) (x : CR) (c : Qpos),
    (forall q:Q, -`c <= q <= `c -> msp_eq (f q) (g q))
    -> (- ' (proj1_sig c) <= x /\ x <= ' (proj1_sig c))%CR
    -> msp_eq (Cmap_fun QPrelengthSpace f x) (Cmap_fun QPrelengthSpace g x).
Proof.
  intros.
  setoid_replace x with (CRboundAbs c x).
  2: symmetry; apply CRboundAbs_Eq; apply H0.
  pose (fun e => QposInf_min (mu f e) (mu g e)) as mufg.
  assert (∀ e : Qpos, QposInf_le (mufg e) (mu f e)).
  { intro e. unfold QposInf_le, mufg.
    destruct (mu f e). 2: trivial.
    simpl. destruct (mu g e). 2: apply Qle_refl.
    apply Qpos_min_lb_l. }
  pose proof (uc_prf_smaller f mufg H1). clear H1.
  setoid_replace f with (Build_UniformlyContinuousFunction H2).
  2: apply ucEq_equiv; intro q; reflexivity.
  assert (∀ e : Qpos, QposInf_le (mufg e) (mu g e)).
  { intro e. unfold QposInf_le, mufg.
    destruct (mu g e). 2: trivial.
    simpl. destruct (mu f e). 2: apply Qle_refl.
    apply Qpos_min_lb_r. }
  pose proof (uc_prf_smaller g mufg H1). clear H1.
  setoid_replace g with (Build_UniformlyContinuousFunction H3).
  2: apply ucEq_equiv; intro q; reflexivity.
  intros e1 e2.
  assert (forall y, eq (QposInf_bind (fun e : Qpos => e) y) y) as elim_bind.
  { intro y. destruct y; reflexivity. }
  simpl.
  rewrite elim_bind, elim_bind. clear elim_bind.
  assert (forall a, Qmax (- ` c) (Qmin (` c) a) <= ` c).
  { intro a. apply Qmax_lub.
    apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
    apply Qpos_nonneg. apply Qmin_lb_l. }
  rewrite Qplus_0_r.
  destruct (mufg e1) as [q|] eqn:des.
  - rewrite H.
    apply (mu_sum QPrelengthSpace e2 (cons e1 nil)
                  (Build_UniformlyContinuousFunction H3)).
    simpl. rewrite des. simpl. destruct (mufg e2) eqn:des2.
    simpl. apply AbsSmall_Qabs.
    apply (Qle_trans _ (Qabs (approximate x q - approximate x q0))).
    apply QboundAbs_contract.
    apply AbsSmall_Qabs. apply (regFun_prf x).
    simpl. trivial.
    split. apply Qmax_ub_l. apply H1.
  - rewrite <- H.
    apply (mu_sum QPrelengthSpace e2 (cons e1 nil) f).
    simpl. unfold mufg in des.
    destruct (mu f e1) as [q|]. exfalso.
    simpl in des. destruct (mu g e1); inversion des.
    simpl. trivial.
    split. apply Qmax_ub_l. apply H1.
Qed.

Lemma CRpower_N_bounded_step : forall (n:N) (c:Qpos) (x : CR),
    (forall e, - (proj1_sig c) <= approximate x e)
    -> (forall e, approximate x e <= proj1_sig c)
    -> (CRpower_N_bounded (1+n) c x
       == x * CRpower_N_bounded n c x)%CR.
Proof.
  assert (forall i j : Q, i<=j -> Qmax i j == j)%Q as elim_max.
  { intros. apply (Qle_max_r i j), H. }
  assert (forall i j : Q, j<=i -> Qmin i j == j)%Q as elim_min.
  { intros. apply (Qle_min_r i j), H. }
  intros.
  assert (x <= ' ` c)%CR as xupper.
  { intro e. simpl. unfold Cap_raw. simpl.
    apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
    rewrite <- Qle_minus_iff. apply H0. }
  assert (- ' ` c <= x)%CR as xlower.
  { intro e. simpl. unfold Cap_raw. simpl.
    apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
    rewrite <- Qle_minus_iff. apply H. }
  destruct n as [|n].
  - setoid_replace (CRpower_N_bounded 0 c x) with 1%CR.
    2: intros e1 e2; apply Qball_Reflexive; rewrite Qplus_0_r; apply (Qpos_nonneg (e1+e2)).
    rewrite CRmult_1_r. simpl (1+0)%N.
    intros e1 e2. simpl.
    rewrite Qplus_0_r.
    rewrite elim_min. 2: apply H0.
    rewrite elim_max. 2: apply H.
    setoid_replace (` e1 + ` e2)%Q
      with (` (e1 * Qpos_inv (1 ↾ eq_refl * Qpos_power c 0))%Qpos + ` e2).
    apply (regFun_prf x).
    apply Qplus_comp. 2: reflexivity.
    simpl. change (/ (1*1)) with 1.
    rewrite Qmult_1_r. reflexivity.
  - rewrite CRmult_comm.
    pose (Qpos_max c (Qpos_power c (Z_of_N (N.pos n)))) as b.
    rewrite <- (CRmult_bounded_mult c).
    2: exact xlower. 2: exact xupper.
    rewrite (CRmult_bounded_weaken c b).
    2: exact xlower. 2: exact xupper. 2: apply Qpos_max_ub_l.
    rewrite (CRmult_uncurry_eq b).
    unfold CRpower_N_bounded.
    transitivity (Cmap QPrelengthSpace
                       (uc_compose (Qmult_uncurry b)
                                   (uc_compose (together (Qpower_N_uc (N.pos n) c)
                                                        (uc_id Q_as_MetricSpace))
                                               (diag Q_as_MetricSpace)))
                       x).
    + apply Cmap_wd_bounded with (c:=c).
      intros q H1. destruct H1.
      apply Qball_0.
      change (Qpower_positive (Qmax (- ` c) (Qmin (` c) q)) (1+n)
              ==
  Qmax (- ` b) (Qmin (` b) (Qpower_positive (Qmax (- ` c) (Qmin (` c) q)) n)) *
  Qmax (- ` b) (Qmin (` b) q)).
      rewrite (elim_min _ q). 2: exact H2.
      rewrite (elim_max _ q). 2: exact H1.
      2: exact (conj xlower xupper).
      rewrite (elim_min _ q).
      rewrite (elim_max _ q).
      rewrite Qpower_plus_positive. simpl.
      rewrite Qmult_comm. apply Qmult_comp. 2: reflexivity.
      assert (Qabs q <= `c).
      { apply AbsSmall_Qabs. split. exact H1. exact H2. }
      pose proof (Qpower_positive_abs_le q c n H3). clear H3.
      apply AbsSmall_Qabs in H4. destruct H4.
      rewrite elim_min, elim_max. reflexivity.
      apply (Qle_trans _ (-(Qpower_positive (`c) n))).
      apply Qopp_le_compat.
      apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))).
      exact H3.
      apply (Qle_trans _ (Qpower_positive (`c) n)).
      exact H4.
      apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))).
      apply (Qle_trans _ (-`c)). apply Qopp_le_compat, Qpos_max_ub_l.
      exact H1.
      apply (Qle_trans _ (`c)). apply H2. apply Qpos_max_ub_l.
    + rewrite (fast_MonadLaw2 QPrelengthSpace
                              (ProductMS_prelength QPrelengthSpace QPrelengthSpace)).
      apply Cmap_wd. apply ucEq_equiv. intro a; reflexivity.
      intros e1 e2. split.
      rewrite Qplus_0_r.
      apply (mu_sum QPrelengthSpace e2 (cons e1 nil) (Qpower_N_uc (N.pos n) c)).
      apply (@ball_weak_le Q_as_MetricSpace
            (proj1_sig (Qpos_min
                   (e1 *
                    Qpos_inv
                      ((n # 1) *
                       Qpos_power c (Z.pred (Zpos n)) )) e1
             + (e2 *
                    Qpos_inv
                      ((n # 1) *
                       Qpos_power c (Z.pred (Zpos n)) )))%Qpos)).
      apply Qplus_le_l.
      apply Qpos_min_lb_l.
      apply (regFun_prf x).
      apply (@ball_weak_le Q_as_MetricSpace
            (proj1_sig (Qpos_min
                   (e1 *
                    Qpos_inv
                      ((n # 1) *
                       Qpos_power c (Z.pred (Zpos n)) )) e1
             + e2)%Qpos)).
      apply Qplus_le_l.
      rewrite Qplus_0_r.
      apply Qpos_min_lb_r.
      apply (regFun_prf x).
    + intro e. simpl.
      unfold Cap_raw; simpl.
      apply (Qle_trans _ 0).
      apply (Qopp_le_compat 0), Qpos_nonneg.
      rewrite <- Qle_minus_iff.
      apply (Qle_trans _ (-Qpower_positive (` c) n)).
      apply Qopp_le_compat.
      apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))).
      assert (forall i j :Q, -j <= i -> -i <= j).
      { intros. rewrite <- (Qopp_involutive j).
        apply Qopp_le_compat, H1. }
      apply H1. clear H1.
      apply (Qle_trans _ _ _ (Qle_Qabs _)).
      rewrite Qabs_opp.
      apply (Qpower_positive_abs_le
                    (Qmax (- ` c)
                          (Qmin (` c)
          (approximate x
             ((1 # 2) * e *
              Qpos_inv
                ((n # 1) *
                 Qpos_power c
                            (Z.pred (Zpos n)) ))%Qpos))) c n).
      apply AbsSmall_Qabs. split. apply Qmax_ub_l.
      apply Qmax_lub.
      apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
      apply Qpos_nonneg. apply Qmin_lb_l.
    + intro e. simpl.
      unfold Cap_raw; simpl.
      apply (Qle_trans _ 0).
      apply (Qopp_le_compat 0), Qpos_nonneg.
      rewrite <- Qle_minus_iff.
      apply (Qle_trans _ _ _ (Qle_Qabs _)).
      apply (Qle_trans _ (Qpower_positive (` c) n)).
      apply (Qpower_positive_abs_le
                    (Qmax (- ` c)
                          (Qmin (` c)
          (approximate x
             ((1 # 2) * e *
              Qpos_inv
                ((n # 1) *
                 Qpos_power c
                            (Z.pred (Zpos n)) ))%Qpos))) c n).
      apply AbsSmall_Qabs. split. apply Qmax_ub_l.
      apply Qmax_lub.
      apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
      apply Qpos_nonneg. apply Qmin_lb_l.
      apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))).
Qed.

Lemma CRpower_N_bounded_correct : forall (n:N) (c:Qpos) (x : CR),
    (- (' (proj1_sig c)) <= x /\ x <= 'proj1_sig c)%CR
    -> (CRpower_slow x (N.to_nat n) == CRpower_N_bounded n c x)%CR.
Proof.
  assert (∀ (n : nat) (c : Qpos) (x : CR),
    (forall e, - (proj1_sig c) <= approximate x e)
    -> (forall e, approximate x e <= proj1_sig c)
    → msp_eq (CRpower_slow x n) (CRpower_N_bounded (N.of_nat n) c x)).
  induction n.
  - intros. intros e1 e2. simpl. apply Qball_Reflexive.
    rewrite Qplus_0_r.
    apply (Qpos_nonneg (e1+e2)).
  - intros. change (S n) with (1+n)%nat.
    rewrite Nnat.Nat2N.inj_add.
    change (N.of_nat 1) with 1%N.
    rewrite CRpower_N_bounded_step. 2: exact H.
    change (CRpower_slow x (1 + n)) with (x * CRpower_slow x n)%CR.
    apply CRmult_wd. reflexivity. apply IHn. exact H.
    exact H0. exact H0.
  - intros.
    transitivity (CRpower_N_bounded (N.of_nat (N.to_nat n)) c x).
    2: rewrite Nnat.N2Nat.id; reflexivity.
    transitivity (CRpower_N_bounded (N.of_nat (N.to_nat n)) c (CRboundAbs c x)).
    transitivity (CRpower_slow (CRboundAbs c x) (N.to_nat n)).
    apply CRpower_slow_wd. symmetry.
    apply CRboundAbs_Eq. apply H0. apply H0.
    apply H. intro e. simpl. apply Qmax_ub_l.
    intros e. apply Qmax_lub.
    apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg.
    apply Qpos_nonneg. apply Qmin_lb_l.
    apply Cmap_wd. apply ucEq_equiv; intro a; reflexivity.
    apply CRboundAbs_Eq. apply H0. apply H0.
Qed.

Lemma CRpower_N_bounded_weaken : forall (n:N) (c1 c2:Qpos) x,
    ((- (' (proj1_sig c1)) <= x /\ x <= 'proj1_sig c1)
     -> (proj1_sig c1 <= proj1_sig c2)%Q ->
     CRpower_N_bounded n c1 x == CRpower_N_bounded n c2 x)%CR.
Proof.
 intros n c1 c2 x Hx Hc.
 simpl in x.
 rewrite <- CRpower_N_bounded_correct.
 rewrite <- CRpower_N_bounded_correct.
 reflexivity. 2: exact Hx. destruct Hx.
 split.
 - apply (@CRle_trans _ (-'(proj1_sig c1))%CR).
   apply CRopp_le_compat, CRle_Qle, Hc. exact H.
 - apply (CRle_trans H0). apply CRle_Qle, Hc.
Qed.

(** [CRpower_positive_bounded] is should be used when a known bound
on the absolute value of x is available. *)
#[global]
Instance CRpower_N: Pow CR N := λ x n, ucFun (CRpower_N_bounded n (CR_b (1#1) x)) x.
Arguments CRpower_N x%type n%N.

Lemma CRpower_N_bounded_N_power : forall (n : N) (c:Qpos) (x:CR),
((- (' (proj1_sig c)) <= x /\ x <= 'proj1_sig c) ->
CRpower_N_bounded n c x == CRpower_N x n)%CR.
Proof.
 intros n c x Hc.
 assert (- ('proj1_sig (CR_b (1#1) x)) <= x
         /\ x <= ('proj1_sig (CR_b (1#1) x)))%CR as Hx.
 { split.
   rewrite -> CRopp_Qopp.
   apply CR_b_lowerBound.
  apply CR_b_upperBound. }
 unfold CRpower_N.
 generalize (CR_b (1#1) x) Hx.
 clear Hx.
 intros d Hd.
 destruct (Qlt_le_dec (proj1_sig c) (proj1_sig d)).
 apply CRpower_N_bounded_weaken. exact Hc. apply Qlt_le_weak, q.
 symmetry. apply CRpower_N_bounded_weaken; assumption.
Qed.

Lemma CRpower_N_correct : forall (n:N) x,
    (CRpower_slow x (N.to_nat n) == CRpower_N x n)%CR.
Proof.
 intros n x.
 rewrite <- (CRpower_N_bounded_N_power n (CR_b (1#1) x)).
 apply CRpower_N_bounded_correct.
 split. apply (CR_b_lowerBound (1#1) x).
 apply CR_b_upperBound.
 split. apply (CR_b_lowerBound (1#1) x).
 apply CR_b_upperBound.
Qed.

Lemma CRpower_N_correct' : forall (n:nat) x,
    (CRpower_slow x n == CRpower_N x (N_of_nat n))%CR.
Proof.
 intros n x.
 etransitivity; [| apply CRpower_N_correct].
 now rewrite Nnat.nat_of_N_of_nat.
Qed.

#[global]
Hint Rewrite CRpower_N_correct' : IRtoCR.

#[global]
Instance: Proper (eq ==> QposEq ==> @msp_eq _) Qpower_N_uc.
Proof.
  intros p1 p2 Ep e1 e2 Ee. apply ucEq_equiv.
  intro x.
  apply ball_closed.
  intros e epos.
  simpl. unfold QposEq in Ee.
  rewrite Ep, Ee.
  apply Qball_Reflexive.
  rewrite Qplus_0_l.
  apply Qlt_le_weak, epos.
Qed.

#[global]
Instance: Proper (eq ==> QposEq ==> @msp_eq _) CRpower_N_bounded.
Proof.
  intros p1 p2 Ep e1 e2 Ee.
  apply ucEq_equiv.
  intro x. simpl. rewrite Ep, Ee. reflexivity.
Qed.

#[global]
Instance: Proper (@msp_eq _ ==> eq ==> @msp_eq _) CRpower_N.
Proof.
 intros x1 x2 Hx ? n Hn. subst.
 transitivity (CRpower_N_bounded n (CR_b (1 # 1) x1) x2).
  change (ucFun (CRpower_N_bounded n (CR_b (1#1) x1)) x1==ucFun (CRpower_N_bounded n (CR_b (1#1) x1)) x2)%CR.
  apply uc_wd; assumption.
 apply CRpower_N_bounded_N_power.
 split; rewrite <- Hx.
  rewrite -> CRopp_Qopp.
  apply CR_b_lowerBound.
 apply CR_b_upperBound.
Qed.
(* end hide *)

#[global]
Instance: NatPowSpec CR N _.
Proof.
  split; unfold pow.
    apply _.
   intros x. change (cast Q CR 1 = CR1). now apply rings.preserves_1.
  intros x n.
  rewrite <- CRpower_N_correct.
  rewrite Nnat.nat_of_Nplus.
  simpl.
  rewrite CRpower_N_correct. reflexivity.
Qed.


From ExtLib.Structures Require Export
     Monads.
From ExtLib.Structures Require Import
     Functor Applicative.
Require Import List.
Import ListNotations.

From QuickChick Require Import Tactics.

Import MonadNotation.
Open Scope monad_scope.

Set Bullet Behavior "Strict Subproofs".

(* A lazy list *)
(* Laziness is implemented by just thunking the computation for the tail
   of a cons-cell. Since each such tail is used exactly once, there is no
   point in using ocaml's 'lazy' that memoizes computation and results in
   unnecessary overheads.
 *)
Inductive LazyList (A : Type) : Type :=
| lnil : LazyList A
| lcons : A -> (unit -> (LazyList A)) -> LazyList A.

Arguments lnil {A}.
Arguments lcons {A} _ _.

Fixpoint lazy_append {A : Type} (l1 : LazyList A) (l2 : LazyList A) : LazyList A :=
  match l1 with
  | lnil => l2
  | lcons x l1' => lcons x (fun _ => (lazy_append (l1' tt) l2))
  end.

Fixpoint lazy_append' {A : Type} (l1 : LazyList A) (l2 : unit -> LazyList A) : LazyList A :=
  match l1 with
  | lnil => l2 tt

(*
    match l2 tt with
    | lnil => lsing x
    | l2' => lcons x (fun _ => l2')
    end
*)
  | lcons x l1' => lcons x (fun _ => (lazy_append' (l1' tt) l2))
  end.

Fixpoint lazy_take {A : Type} (n : nat) (l : LazyList A) : LazyList A :=
  match n with
  | 0 => lnil
  | S n' => match l with
            | lnil => lnil
            | lcons h ts => lcons h (fun _ => (lazy_take n' (ts tt)))
            end
  end.

(* Functor instace for LazyList *)
Fixpoint mapLazyList {A B : Type} (f : A -> B) (l : LazyList A) : LazyList B :=
  match l with
  | lnil => lnil
  | lcons x l' => lcons (f x) (fun _ => (mapLazyList f (l' tt)))
  end.

#[global] Instance FunctorLazyList : Functor LazyList :=
  {
    fmap := @mapLazyList
  }.

(* Monad and applicative instances for LazyList *)
(* Injecting into a monad must crucially use the singleton constructor. *)
Definition retLazyList {A : Type} (a : A) : LazyList A :=
  lcons a (fun _ => lnil).
(*   lcons _ a (fun _ => (lnil _)). *)

Fixpoint concatLazyList {A : Type} (l : LazyList (LazyList A)) : LazyList A :=
  match l with
  | lnil => lnil
  | lcons x l' => lazy_append x (concatLazyList (l' tt))
  end.

Definition bindLazyList {A B : Type} (l : LazyList A) (f : A -> LazyList B) : LazyList B :=
  concatLazyList (mapLazyList f l).

#[global] Instance MonadLazyList : Monad LazyList :=
  {
    ret := @retLazyList;
    bind := @bindLazyList
  }.

Definition apLazyList {A B : Type} (lab : LazyList (A -> B)) (la : LazyList A) : LazyList B :=
  ab <- lab;;
  a <- la;;
  ret (ab a).

#[global] Instance ApplicativeLazyList : Applicative LazyList :=
  {
    pure := @retLazyList;
    ap := @apLazyList
  }.

Definition apComp {F: Type -> Type} `{Functor F} {A B C : Type} (f : B -> C) (fab : F (A -> B)) : F (A -> C) :=
  fmap (fun g => fun a => f (g a)) fab.

(* Guard definition, because ExtLib doesn't have Alternative *)
Definition guard (b : bool) : LazyList unit :=
  match b with
  | true => ret tt
  | false => lnil
  end.

(* Lazy list in *)
Fixpoint In_ll {A : Type} (a : A) (l : LazyList A) : Prop :=
  match l with
  | lnil => False
  | lcons h ts => h = a \/ In_ll a (ts tt)
  end.

Fixpoint All_ll {A : Type} (P : A -> Prop) (l : LazyList A) : Prop :=
  match l with
  | lnil => True
  | lcons h ts => P h /\ All_ll P (ts tt)
  end.

From Coq Require Import ssreflect.
Lemma lazy_in_map_iff :
  forall (A B : Type) (f : A -> B) (l : LazyList A) (y : B),
  In_ll y (mapLazyList f l) <-> (exists x : A, f x = y /\ In_ll x l).
Proof.
  move => A B f l; induction l => y; split => [HIn | [x [Hfx HIn]]].
  - inversion HIn.
  - inversion HIn.
  - simpl in *.
    destruct HIn as [Hf | HIn].
    + exists a; split; auto.
    + apply H in HIn.
      destruct HIn as [x [Hf HIn]].
      exists x; split; auto.
  - destruct HIn as [Hf | HIn]; subst; simpl in *; auto.
    right; apply H.
    exists x; auto.
Qed.

    (*
Section Ind.

  Variable A : Type.
  Variable P : LazyList A -> Prop.
  Variable Hnil  : P (lnil).
  Variable Hsing : forall (a : A), P (lsing a).
  Variable Hcons : forall (a : A) (l : LazyList A), P l -> P (lcons a (fun _ => l)).

  Fixpoint better_ll_ind (l : LazyList A) : P l :=
    match l with
    | lnil => Hnil
    | lsing x => Hsing x
    | lcons a tl => @Hcons a (tl tt) (better_ll_ind (tl tt))
    end.

End Ind.
 *)

Lemma lazy_in_app_or :
  forall (A : Type) (l m : LazyList A) (a : A), In_ll a (lazy_append l m) -> In_ll a l \/ In_ll a m.
Proof.
  intros A l.
  induction l; intros m h Hyp; simpl in *; auto.
  - destruct Hyp; subst; simpl in *; auto.
    rewrite or_assoc.
    apply H in H0.
    destruct H0; auto.
Qed.

Lemma lazy_in_or_app :
  forall (A : Type) (l m : LazyList A) (a : A), In_ll a l \/ In_ll a m -> In_ll a (lazy_append l m).
Proof.
  intros A l.
  induction l; intros m h HIn; simpl in *.
  - destruct HIn as [Contra | HIn]; [ contradiction | auto ].
  - destruct HIn as [[HEq | HIn] | HIn]; subst; simpl in *; auto.
Qed.

Fixpoint LazyList_to_list {A : Type} (l : LazyList A) : list A :=
  match l with
  | lnil => nil
  | lcons x x0 => x :: LazyList_to_list (x0 tt)
  end.

Fixpoint list_to_LazyList {A : Type} (l : list A) : LazyList A :=
  match l with
  | nil => lnil
  | cons x x0 => lcons x (fun _ => (list_to_LazyList x0))
  end.

Theorem nil_lazylist :
  forall A (l : LazyList A),
    [] = LazyList_to_list l -> l = lnil.
Proof.
  intros A l H.
  destruct l; simpl in *; auto; inversion H.
Qed.

Theorem lazy_in_map:
  forall (A B : Type) (f : A -> B) (l : LazyList A) (x : A), In_ll x l -> In_ll (f x) (fmap f l).
Proof.
  intros A B f l.
  induction l; intros x HIn.
  - inversion HIn.
  - destruct HIn as [Hax | Hin]; subst; auto.
    + left. auto.
    + right. auto.
Qed.

Lemma lazy_append_nil_r :
  forall {B : Type} (b : B) l,
    In_ll b l ->
    In_ll b (lazy_append l lnil).
Proof.
  intros B b l H.
  induction l.
  - inversion H.
  - simpl in *. firstorder.
Qed.

Lemma lazy_append_sing_r :
  forall {B : Type} (b x : B) l,
    In_ll b l ->
    In_ll b (lazy_append l (lcons x (fun _ => lnil))).
Proof.
  intros B b x l H.
  induction l.
  - inversion H.
  - simpl in *. firstorder.
Qed.

Lemma lazy_append_in_l :
  forall {B : Type} ll (b : B) l,
    In_ll b l ->
    In_ll b (lazy_append l ll).
Proof.
  intros B ll; induction ll; intros b l0 HIn.
  - auto using lazy_append_nil_r.
  - induction l0.
    + inversion HIn.
    + simpl in *. firstorder.
Qed.

Lemma lazy_append_in_r :
  forall {B : Type} (b : B) l ll,
    In_ll b ll ->
    In_ll b (lazy_append l ll).
Proof.
  intros B b l ll H.
  induction l; simpl; auto.
Qed.

Lemma lazy_concat_in :
  forall {B : Type} (b : B) l ll,
    In_ll b l ->
    In_ll l ll ->
    In_ll b (concatLazyList ll).
Proof.
  intros B b l ll Hb Hbll.
  induction ll; simpl in *; subst; auto.
  destruct Hbll as [Hal | Hinl]; subst;
    auto using lazy_append_in_l, lazy_append_in_r.
Qed.

Fixpoint join_list_lazy_list {A : Type} (l : list (LazyList A)) : LazyList A :=
  match l with
  | nil => lnil
  | cons h ts => lazy_append h (join_list_lazy_list ts)
  end.

Fixpoint joint_list_lazy_list_list {A : Type} (l : list (LazyList A)) : list A :=
  match l with
  | nil => nil
  | cons h ts => (LazyList_to_list h) ++ (joint_list_lazy_list_list ts)
  end.

Fixpoint lazy_seq {A : Type}
           (s : A -> A) (lo : A) (len : nat) :=
  match len with
  | O => lnil
  | S len' => lcons lo (fun tt => lazy_seq s (s lo) len')
  end.

Definition mapLazyListProof {A B : Type}
         (l : LazyList A)
         (f : forall (x : A), In_ll x l -> B) :
  LazyList B.
Proof.
  induction l.
  - apply lnil.
  - apply lcons.
    + apply (f a).
      left; reflexivity.
    + specialize (X tt).
      refine (fun u => _).
      apply X.
      intros x In.
      apply (f x).
      right; auto.
Defined.

Definition bindLazyListPf {A B : Type}
           (l : LazyList A)
           (f : forall (x : A),
               In_ll x l -> LazyList B) : LazyList B :=
  (concatLazyList (mapLazyListProof l f)).

Fixpoint filter_LazyList {A} (p : A -> bool) (l : LazyList A) :=
  match l with
  | lnil => lnil
  | lcons h t => if p h then
                   lcons h (fun tt => filter_LazyList p (t tt))
                 else filter_LazyList p (t tt)
  end.

Require Import Coq.Logic.ClassicalFacts.

Axiom EM : excluded_middle.

Lemma In_ll_Dec {A : Type} (* {_ : Dec_Eq A} *) (x : A) l :
  (LazyList.In_ll x l) \/ (~ LazyList.In_ll x l ).
Proof.
  induction l.
  - right. intros Hc; inv Hc.
  - assert (Hem := EM (x = a)). destruct Hem.
    + left; eauto. left; eauto.
    + destruct (H tt).
      * left. right. eassumption.
      * right. intros Hc. inv Hc; eauto.
Qed.

Lemma lazy_concat_in' :
  forall {B : Type} (b : B) ll,
    LazyList.In_ll b (LazyList.concatLazyList ll) ->
    exists l, LazyList.In_ll b l /\ LazyList.In_ll l ll.
Proof.
  intros B b ll Hbll.
  induction ll; simpl in *; subst; auto.
  - exfalso; eauto.
  - eapply LazyList.lazy_in_app_or in Hbll. inv Hbll; eauto.
    eapply H in H0. destruct H0 as [l' [Hin1 Hin2]].
    eexists. split; eauto.
Qed.


From stdpp Require Import gmap.

(** Abstract Notion of Timestamps with Total Order. *)

Section Time.

  Class DB_time := {
    Time : Type;
    TM_lt' : relation Time;
    TM_lt := strict TM_lt';
    TM_lt_TO :> TotalOrder (TM_lt);
    TM_EqDecision :> EqDecision Time;
   }.

  Class Timed {dbt: DB_time} (T : Type) := time : T → Time.

  Notation "t1 '<ₜ' t2" :=
    (TM_lt (time t1) (time t2)) (at level 70, no associativity).
  Notation "t1 '≤ₜ' t2" :=
    (TM_lt (time t1) (time t2) ∨ (time t1 = time t2)) (at level 70, no associativity).
  Notation "t1 '=ₜ' t2" :=
    (time t1 = time t2) (at level 70, no associativity).

  Definition IsMaximum {T : Type} `{!DB_time} `{!EqDecision T}
             `{!Countable T} `{!Timed T} (X : gset T) (mx : T) :=
    mx ∈ X ∧ ∀ t, t ∈ X → (¬ t = mx) → t <ₜ mx.

  Class Maximals_Computing `{!DB_time} :=
    {
      Maximum : ∀ {T : Type} `{!EqDecision T} `{!Countable T}
           `{!Timed T} (X : gset T), option T;
      Maximum_correct : ∀ {T : Type} `{!EqDecision T} `{!Countable T}
           `{!Timed T} (X : gset T),
          (∀ x y, x ∈ X → y ∈ X → x =ₜ y → x = y) →
          (∀ x, Maximum X = Some x ↔ IsMaximum X x);
    }.

  End Time.

Notation "s '<ₜ@{' d '}' t" :=
  (TM_lt (@time d _ _ s) (@time d _ _ t))
    (at level 70, no associativity, format "s  '<ₜ@{' d '}'  t").
Notation "s '≤ₜ@{' d '}' t" :=
  (TM_lt (@time d _ _ s) (@time d _ _ t) ∨  (@time d _ _ s) = (@time d _ _ t))
    (at level 70, no associativity, format "s  '≤ₜ@{' d '}'  t").
Notation "s '=ₜ@{' d '}' t" :=
  ((@time d _ _ s) = (@time d _ _ t))
    (at level 70, no associativity, format "s  '=ₜ@{' d '}'  t").

Notation "s '<ₜ' t" :=
  (TM_lt (time s) (time t)) (at level 70, no associativity).
Notation "s '≤ₜ' t" :=
  (TM_lt (time s) (time t) ∨ (time s = time t)) (at level 70, no associativity).
Notation "s '=ₜ' t" :=
  (time s = time t) (at level 70, no associativity).


(** This is a toy example to demonstrate how to specify and prove correct a C function using C light *)

From Coq Require Import String List ZArith Psatz.
From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs Memory Values ClightBigstep Events Maps.

(* Specification of the strlen function *)
Inductive strlen (m : mem) (b : block) (ofs : ptrofs) : nat -> Prop :=
| LengthZero: Mem.loadv Mint8signed m (Vptr b ofs) = Some (Vint Int.zero) -> strlen m b ofs 0
| LengthSucc: forall n c,
    Z.of_nat (S n) < Int.modulus -> (* no int overflow *)
    Ptrofs.unsigned ofs + 1 < Ptrofs.modulus -> (* no ofs overflow *)
    strlen m b (Ptrofs.add ofs Ptrofs.one) n ->
    Mem.loadv Mint8signed m (Vptr b ofs)  = Some (Vint c) ->
    c <> Int.zero ->
    strlen m b ofs (S n).

(* strlen C light AST *)
Definition _output : ident := 4%positive.
Definition _input : ident := 3%positive.
Definition _t'1 : ident := 7%positive.
Definition _t'2 : ident := 8%positive.

Definition f_strlen := {|
  fn_return := tuint;
  fn_callconv := cc_default;
  fn_params := ((_input, (tptr tuchar)) :: nil);
  fn_vars := nil;
  fn_temps := ((_output, tuint) :: (_t'1, (tptr tschar)) :: (_t'2, tschar) :: nil);
  fn_body :=
(Ssequence
  (Sset _output (Econst_int (Int.repr 0) tint))
  (Ssequence
    (Sloop
      (Ssequence
        (Ssequence
          (Ssequence
            (Sset _t'1 (Etempvar _input (tptr tschar)))
            (Sset _input
              (Ebinop Oadd (Etempvar _t'1 (tptr tschar))
                (Econst_int (Int.repr 1) tint) (tptr tschar))))
          (Ssequence
            (Sset _t'2 (Ederef (Etempvar _t'1 (tptr tschar)) tschar))
            (Sifthenelse (Etempvar _t'2 tschar) Sskip Sbreak)))
        (Sset _output
          (Ebinop Oadd (Etempvar _output tuint) (Econst_int (Int.repr 1) tint)
            tuint)))
      Sskip)
    (Sreturn (Some (Etempvar _output tuint)))))
                          |}.

Definition f_strlen_loop :=
  (Sloop
      (Ssequence
        (Ssequence
          (Ssequence
            (Sset _t'1 (Etempvar _input (tptr tschar)))
            (Sset _input
              (Ebinop Oadd (Etempvar _t'1 (tptr tschar))
                (Econst_int (Int.repr 1) tint) (tptr tschar))))
          (Ssequence
            (Sset _t'2 (Ederef (Etempvar _t'1 (tptr tschar)) tschar))
            (Sifthenelse (Etempvar _t'2 tschar) Sskip Sbreak)))
        (Sset _output
          (Ebinop Oadd (Etempvar _output tuint) (Econst_int (Int.repr 1) tint)
            tuint)))
      Sskip).

Definition f_strlen_loop_body := (Ssequence
        (Ssequence
          (Ssequence
            (Sset _t'1 (Etempvar _input (tptr tschar)))
            (Sset _input
              (Ebinop Oadd (Etempvar _t'1 (tptr tschar))
                (Econst_int (Int.repr 1) tint) (tptr tschar))))
          (Ssequence
            (Sset _t'2 (Ederef (Etempvar _t'1 (tptr tschar)) tschar))
            (Sifthenelse (Etempvar _t'2 tschar) Sskip Sbreak)))
        (Sset _output
          (Ebinop Oadd (Etempvar _output tuint) (Econst_int (Int.repr 1) tint)
                  tuint))).

(* Our goal is to prove that the C light AST is equivalent satisfies the spec: in this context it means that the C light AST evaluates to the correct value wrt to big step operational semantics *)

(* Some useful notation and tactics *)

Definition chunk : memory_chunk := Mint8signed.
Definition VintZ := fun (z : Z) => Vint (Int.repr z).
Definition VintN:= fun n => Vint (Int.repr(Z_of_nat n)).

Notation gso := PTree.gso.
Notation gss := PTree.gss.

(* Tactics for arithmetic on ptrofs, now they are ad hoc, TODO: automatize translation from ptrofs to Z *)

Ltac ints_to_Z :=
  repeat rewrite Int.unsigned_repr_eq; repeat rewrite Zmod_small.

Ltac ptrofs_to_Z :=
  repeat rewrite Ptrofs.unsigned_repr_eq; repeat rewrite Zmod_small.

Ltac ptrofs_compute_add_mul :=
      simpl; unfold Ptrofs.add; unfold Ptrofs.mul; unfold Ptrofs.of_intu; unfold Ptrofs.of_int;
      repeat rewrite Ptrofs.unsigned_repr_eq;  repeat rewrite Int.unsigned_repr_eq; repeat rewrite Zmod_small.

Ltac ints_compute_add_mul :=
      simpl; unfold Int.add; unfold Int.mul;
      repeat rewrite Int.unsigned_repr_eq;  repeat rewrite Int.unsigned_repr_eq; repeat rewrite Zmod_small.

Ltac seq1 := eapply exec_Sseq_1.
Ltac seq2 := eapply exec_Sseq_2.
Ltac sset := eapply exec_Sset.
Ltac loop := eapply exec_Sloop_loop.

(* can make more generic to repeatedly apply gso *)
Ltac gso_assumption :=
  match goal with
  | [ H : ?P ! ?I = Some ?W |- (PTree.set _ _ ?P) ! ?I = Some ?Z ] => rewrite gso
  | [ H : ?P ! ?Q = Some ?W |-  ?P ! ?Q = Some ?Z ] => apply H
  | [ |- _ <> _ ] => cbv ; congruence
  end.

Proposition char_not_zero : forall c, c <> Int.zero -> true = (negb (Int.eq c Int.zero)).
Proof.
  intros.
  replace (Int.eq c Int.zero) with false.
  auto.
  rewrite Int.eq_false; intuition.
Qed.

Parameter ge : genv.
Parameter e : env.
(* Test *)
Lemma strlen_correct_test: forall m b ofs le,
    strlen m b ofs 2%nat ->
    le!_input = Some (Vptr b ofs) ->
    (* C light expression f_strlen returns O and assigns O to output variable *)
    exists t le', exec_stmt ge e le m f_strlen.(fn_body) t le' m (Out_return (Some ((VintZ 2),tuint))) /\ (le'!_output) = Some (VintZ 2).
Proof.
  intros until le. intro Spec.
  inversion_clear Spec. inversion_clear H1. inversion_clear H6.
  repeat eexists.
  - seq1.
    -- sset. (* evaluate expression *) repeat econstructor.
    -- seq1.
      * (* loop 1 *)
        loop. repeat econstructor. repeat gso_assumption. eapply gss. repeat econstructor.
        rewrite gso. apply gss. cbv. congruence. apply H2.
        apply gss.
        econstructor.
        replace (negb (Int.eq c Int.zero)) with true by (apply (char_not_zero c); assumption).
        econstructor.
         rewrite gso. rewrite gso. rewrite gso. apply gss. 1-3: cbv; congruence.
        repeat econstructor. econstructor. econstructor.

        (* loop 2 *)
        loop. repeat econstructor.
        rewrite gso. rewrite gso. apply gss. 1-2: cbv; congruence. apply gss.
        repeat econstructor.
        rewrite gso. apply gss. cbv; congruence.
        replace (Ptrofs.add ofs
          (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
             (ptrofs_of_int Signed (Int.repr 1)))) with (Ptrofs.add ofs Ptrofs.one) by (auto with ptrofs).
        apply H7.
        apply gss.
        econstructor.
        replace (negb (Int.eq c0 Int.zero)) with true by (apply (char_not_zero c0); assumption).
        econstructor.
        rewrite gso. rewrite gso. rewrite gso. apply gss. 1-3: cbv; congruence.
        repeat econstructor. econstructor. econstructor.

         (* exit loop *)
        eapply exec_Sloop_stop1.
        seq2. seq1. seq1. econstructor. econstructor. rewrite gso. rewrite gso. apply gss. 1-2: cbv; congruence.
        repeat econstructor.
        apply gss.
        repeat econstructor.
        seq1. repeat econstructor.
        rewrite gso. apply gss. cbv ; congruence.
        replace (Ptrofs.add
          (Ptrofs.add ofs
             (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
                (ptrofs_of_int Signed (Int.repr 1))))
          (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
             (ptrofs_of_int Signed (Int.repr 1))))  with (Ptrofs.add (Ptrofs.add ofs Ptrofs.one) Ptrofs.one) by (auto with ptrofs).
        apply H1.
        repeat econstructor.
        apply gss.
        econstructor.
        replace (negb (Int.eq Int.zero Int.zero)) with false by (auto with ints).
        econstructor.
        cbv; congruence.
        econstructor.
      * (* return statement *)
        repeat econstructor.  rewrite gso.  rewrite gso. rewrite gso.  eapply gss. all: cbv; congruence.
  - rewrite gso.  rewrite gso.  rewrite gso. eapply gss. all: cbv; congruence.
Qed.
(* Helper lemmas about the specification *)

 (* add more lemmas from Compcert to ptrofs hints *)
Lemma int_ptrofs_mod_eq : (Int.modulus = Ptrofs.modulus).
Proof.
  cbv; split; congruence.
Qed.

Hint Resolve Ptrofs.mul_one Ptrofs.add_zero int_ptrofs_mod_eq : ptrofs.

Lemma strlen_to_len_0 : forall len m b ofs, strlen m b ofs len -> strlen m b (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat len))) O.
Proof.
  induction len; intros.
  - simpl.  replace (Ptrofs.repr 0) with Ptrofs.zero by (auto with ptrofs).
    replace (Ptrofs.add ofs Ptrofs.zero) with ofs by (auto with ptrofs).
    assumption.
  - inversion_clear H.
    replace (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S len)))) with
    (Ptrofs.add (Ptrofs.add ofs Ptrofs.one) (Ptrofs.repr (Z.of_nat len))).
    apply (IHlen m b (Ptrofs.add ofs Ptrofs.one) H2).
    { rewrite Nat2Z.inj_succ.
      replace  (Z.succ (Z.of_nat len)) with ((Z.of_nat len) + 1) by (auto with zarith).
      unfold Ptrofs.one.
      symmetry.
      rewrite Ptrofs.add_assoc.
      f_equal.
      ptrofs_compute_add_mul.
      all: pose  int_ptrofs_mod_eq; try nia.
      f_equal. auto with zarith. }
Qed.

Lemma strlen_to_mem : forall len m b ofs, strlen m b ofs len ->
                                     forall i, (i < len)%nat -> exists c, Mem.loadv chunk m (Vptr b (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))) = Some (Vint c) /\ c <> Int.zero.
Proof.
  induction len.
  - intros. omega.
  -  induction i; intro; inversion_clear H.
     +  replace (Ptrofs.repr (Z.of_nat 0)) with Ptrofs.zero by (simpl; auto with ptrofs).
        replace (Ptrofs.add ofs Ptrofs.zero) with ofs by (auto with ptrofs).
       exists c. exact (conj H4 H5).
    +  assert (i < len)%nat by omega. pose (IHlen m b (Ptrofs.add ofs Ptrofs.one) H3 i H).
       replace (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S i)))) with  (Ptrofs.add (Ptrofs.add ofs Ptrofs.one) (Ptrofs.repr (Z.of_nat i))).
       assumption.
       {
         rewrite Nat2Z.inj_succ.
         replace  (Z.succ (Z.of_nat i)) with ((Z.of_nat i) + 1) by (auto with zarith).
         unfold Ptrofs.one.
         ptrofs_compute_add_mul.
         f_equal.
         nia.
         all: pose int_ptrofs_mod_eq; try nia.
         destruct ofs; simpl in *.
         nia.
       }
Qed.

(* Correctness statements *)

Lemma strlen_loop_correct_gen :
  forall len i m b ofs le,
    (* we read a C string of length len + i from memory and len + i is a valid integer *)
    strlen m b ofs (len + i) ->
    (* THEN there is a trace t and local environment le' such that: *)
    forall t le',
      (* if output equals i in the starting local environment le *)
      le!_output = Some (VintN i) ->
      (* if input is an address [b,ofs + i] in the starting local environment *)
      le!_input = Some (Vptr b (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))) ->     (* then loop of strlen function executes to le' with output assigned len + i *)
      exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ le'!_output = Some (VintN (len + i)).
Proof.

(* A generalization of loop correctness *)
Lemma strlen_loop_correct_gen :
  forall len i m b ofs le,
    (* we read a C string of length len + i from memory and len + i is a valid integer *)
    strlen m b ofs (len + i) ->
    (* THEN there is a trace t and local environment le' such that: *)
    exists t le',
      (* if output equals i in the starting local environment le *)
      le!_output = Some (VintN i) ->
      (* if input is an address [b,ofs + i] in the starting local environment *)
      le!_input = Some (Vptr b (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))) ->     (* then loop of strlen function executes to le' with output assigned len + i *)
      exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ le'!_output = Some (VintN (len + i)).
Proof.
  assert (Int.modulus <= Ptrofs.modulus) as B.
  { cbv. destruct Archi.ptr64. 1-2: congruence. }
  induction len; intros until le; intro Spec.
  - (* Base case *)
    simpl in Spec.
    repeat eexists.
    (* Exit the loop *)
    eapply exec_Sloop_stop1. seq2. repeat econstructor.
    apply H0.
    eapply gss.
    repeat econstructor.
    rewrite gso. apply gss. cbv. congruence.
    (* Derive memory assumptions from the specification *)
    pose (Spec_mem := strlen_to_len_0 i m b ofs Spec).
    inversion_clear Spec_mem.
    apply H1.
    apply gss.
    econstructor.
    replace (negb (Int.eq Int.zero Int.zero)) with false by (auto with ints).
    econstructor.
    cbv; congruence. econstructor.
    repeat (rewrite gso).
    replace (0 + i)%nat with i by lia.
    assumption.
    1-3: cbv; congruence.
  - (* Ind. Step *)
    assert (exists char, Mem.loadv Mint8signed m (Vptr b  (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))) = Some (Vint char) /\ char <> Int.zero) as Mem.
    { refine (strlen_to_mem (S len + i) m b ofs Spec i _). omega. }
    destruct Mem as [char Mem].
    (* apply I.H. to le' after one step when starting with i and [b,ofs + i]  *)
    pose (le'' :=  (PTree.set _output (VintN (S i))
       (PTree.set _t'2 (Vint char) (PTree.set _input
               (Vptr b  (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S i)))))
          (PTree.set _t'1
               (Vptr b  (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i))))
                      le))))).
    pose (IH := IHlen (S i)  m b ofs le'').
    assert ( exists (t : trace) (le' : temp_env),
       le'' ! _output = Some (VintN (S i)) ->
       le''! _input = Some (Vptr b  (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S i))))) ->
       exec_stmt ge e le'' m f_strlen_loop t le' m
         Out_normal /\
       le' ! _output = Some (VintN (len + S i))) as Step.
    { eapply IH.
      replace (len + S i)%nat with (S len + i)%nat by omega.
      assumption. }
    destruct Step as [s Step]. destruct Step as [t Step].
    (* Do one loop on the goal: then apply IH *)
    repeat eexists.
    loop. repeat econstructor.
    apply H0.
    eapply gss.
    repeat econstructor.
    rewrite gso. apply gss. cbv; congruence.
    simpl. ptrofs_to_Z.
    apply Mem.
    apply gss.
    econstructor.
    replace (negb (Int.eq char Int.zero)) with true by (apply (char_not_zero char); apply Mem).
    econstructor.
    repeat (rewrite gso). apply H. 1-3: cbv; congruence.
    repeat econstructor. econstructor. econstructor.
    fold f_strlen_loop.
    replace (PTree.set _output
       (Vint (Int.add (Int.repr (Z.of_nat i)) (Int.repr 1)))
       (PTree.set _t'2 (Vint char)
          (PTree.set _input
             (Vptr b
                (Ptrofs.add
                   (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))
                   (Ptrofs.mul
                      (Ptrofs.repr (sizeof ge tschar))
                      (ptrofs_of_int Signed (Int.repr 1)))))
             (PTree.set _t'1
                (Vptr b
                   (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i))))
                le)))) with le''.
  eapply Step.
  apply gss.
  unfold le''. rewrite gso. rewrite gso. apply gss.
  1-2: cbv; congruence.

  { inversion Spec.
    unfold le''.
    replace (Vint (Int.add (Int.repr (Z.of_nat i)) (Int.repr 1))) with (VintN (S i)).
    replace (Ptrofs.add
                (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))
                (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
                            (ptrofs_of_int Signed (Int.repr 1)))) with (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S i)))).
    reflexivity.
    + rewrite Nat2Z.inj_succ.
      replace  (Z.succ (Z.of_nat i)) with ((Z.of_nat i) + 1) by (auto with zarith).
      simpl.
      replace  (Ptrofs.repr 1) with Ptrofs.one by (auto with ptrofs).
      replace  (Ptrofs.of_ints (Int.repr 1)) with Ptrofs.one by (auto with ptrofs).
      replace  (Ptrofs.mul Ptrofs.one Ptrofs.one) with (Ptrofs.one) by (auto with ptrofs).
      unfold Ptrofs.one.
      symmetry.
      rewrite Ptrofs.add_assoc.
      f_equal.
      ptrofs_compute_add_mul.
      auto.
      all: pose int_ptrofs_mod_eq; try nia.
    + unfold VintN.
      f_equal.
      ints_compute_add_mul.
      f_equal.
      lia.
      cbv. econstructor. 1-2: congruence.
      nia.
      }
  destruct Step.
  apply gss.
  unfold le''. rewrite gso. rewrite gso. apply gss.
  1-2: cbv; congruence.
  replace (S len + i)%nat with (len + S i)%nat by omega.
  assumption.
Qed.

(* Correctness of the loop execution *)
Lemma strlen_loop_correct: forall len m b ofs le, strlen m b ofs len -> exists t le', le!_output = Some (VintN O) ->
                                                                                le!_input = Some (Vptr b ofs) ->

      exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ le'!_output = Some (VintN len).
Proof.
  intros.
  replace ofs with (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat O))) by (auto with ptrofs).
  replace len with (len + O)%nat by lia.
  eapply strlen_loop_correct_gen.
  replace (len + O)%nat with len by omega.
  assumption.
Qed.

(* Full correctness statement *)
Lemma strlen_correct: forall len m b ofs le, strlen m b ofs len -> exists t le', le!_input = Some (Vptr b ofs) ->
                                                                               exec_stmt ge e le  m f_strlen.(fn_body) t le' m (Out_return (Some ((VintN len),tuint))).
Proof.
  intros.
  pose (Loop := strlen_loop_correct len  _ _ _ (PTree.set _output (Vint Int.zero) le) H). destruct Loop as [t Loop]. destruct Loop as [le' Loop].
  repeat eexists.
  intro input.
  assert ((PTree.set _output (Vint Int.zero) le) ! _output =
          Some (VintN 0)) as O by (apply gss).
  assert ((PTree.set _output (Vint Int.zero) le) ! _input =
          Some (Vptr b ofs)) as I.
  { rewrite gso. assumption. cbv; congruence. }
  destruct (Loop O I) as [Exec Out].
  seq1.
  repeat econstructor.
  seq1. fold f_strlen_loop.
  eapply Exec.
  repeat econstructor.
  eapply Out.
Qed.

(* Specification of the strlen function on integers *)

Definition no_int_overflow (i : int) := 0 < Int.unsigned i + 1 < Int.modulus.
Definition no_pointer_overflow (i : ptrofs) := 0 < Ptrofs.unsigned i + 1 < Int.modulus.

Definition Int_succ := fun i : int => Int.add i Int.one.

Inductive strlen_int (m : mem) (b : block) (ofs : ptrofs) : int -> Prop :=
| LengthZeroInt: Mem.loadv Mint8signed m (Vptr b ofs) = Some (Vint Int.zero) -> strlen_int m b ofs Int.zero
| LengthSuccInt: forall n c,
    no_pointer_overflow ofs -> (* this condition is superflous *)
    no_int_overflow n ->
    Mem.loadv Mint8signed m (Vptr b ofs)  = Some (Vint c) ->
    c <> Int.zero ->
    strlen_int m b (Ptrofs.add ofs Ptrofs.one) n ->
    strlen_int m b ofs (Int_succ n).

Lemma strlen_refine : forall m b ofs i, strlen_int m b ofs i -> strlen m b ofs (Z.to_nat (Int.unsigned i)).
Proof.
  intros.
  induction H.
  replace (Z.to_nat (Int.unsigned Int.zero)) with O by (auto with ints; nia).
  econstructor.
  assumption.
  replace (Z.to_nat (Int.unsigned (Int_succ n))) with (S (Z.to_nat (Int.unsigned n))).
  econstructor.
  unfold no_int_overflow in H0.
  replace  (S (Z.to_nat (Int.unsigned n))) with  ((Z.to_nat (Int.unsigned n)) + 1)%nat by omega.
  destruct n; simpl in *; try nia.
  Search Z.of_nat.
  rewrite Nat2Z.inj_add.
  Search Z.of_nat (Z.to_nat _).

  replace (Z.of_nat (Z.to_nat intval)) with intval.
  replace (Z.of_nat 1) with 1 by nia.
  nia.
  symmetry.
  (eapply Z2Nat.id).
  nia.
  unfold no_pointer_overflow in H.
  pose int_ptrofs_mod_eq;   nia.
  (* true *)
  assumption.
  apply H1.
  assumption.

  unfold no_int_overflow in H.
  unfold Int_succ.
  replace  (Int.unsigned (Int.add n Int.one)) with (Int.unsigned n + 1).
  replace  (S (Z.to_nat (Int.unsigned n))) with  ((Z.to_nat (Int.unsigned n)) + 1)%nat by omega.
  Search Z.to_nat.
  rewrite Z2Nat.inj_add.
  replace  (Z.to_nat 1) with 1%nat.
  auto.
  symmetry.
  unfold Z.to_nat.
  nia.
  destruct n; simpl in *; nia.
  nia.
  ints_compute_add_mul.
  all: replace (Int.unsigned Int.one) with 1 by (auto with ints).
  auto. unfold no_int_overflow in H0. nia.
  Qed.

(* Full correctness statement *)
Lemma strlen_correct_int: forall len m b ofs le,
      strlen_int m b ofs len -> exists t le',
      le!_input = Some (Vptr b ofs) ->
      exec_stmt ge e le  m f_strlen.(fn_body) t le' m (Out_return (Some ((Vint len),tuint))).
Proof.
  intros until le; intro Spec.
  pose (strlen_refine _ _ _ _  Spec) as S.
  pose (strlen_correct _ _ _  _  le   S).
  replace (VintN (Z.to_nat (Int.unsigned len))) with (Vint len) in e0.
  assumption.
  unfold VintN.
  f_equal.
  replace (Z.of_nat (Z.to_nat (Int.unsigned len))) with (Int.unsigned len).
  auto with ints.
  rewrite Z2Nat.id.
  auto.
  destruct len; simpl in *. nia.
Qed.

(* Functional spec *)
(* true if the integer value read is zero - end of string *)

Definition is_null (v : Values.val) :=
  match v with
  | Vint zero => true
  | _ => false
  end.

Definition INTSIZE := (nat_of_Z Int.modulus).

Fixpoint strlen_fun_spec (m : mem) (b : block) (ofs : ptrofs) (l: Z) (intrange : nat) {struct intrange} : option int :=
      match intrange with
      | O => None (* out of intrange *)
      | S n => match Mem.loadv chunk m (Vptr b ofs) with
              | Some v =>
                if is_null v
                then Some (Int.repr l) else strlen_fun_spec m b (Ptrofs.add ofs Ptrofs.one) (l + 1) n
              | None => None
              end
      end.

Definition strlen_fun (m : mem) (b: block) (ofs : ptrofs) :=  strlen_fun_spec m b ofs 0 INTSIZE.

(* Full correctness statement *)
Lemma strlen_correct_fun: forall len m b ofs le, strlen_fun m b ofs = Some len ->
                                            exists t le', le!_input = Some (Vptr b ofs) ->
      exec_stmt ge e le  m f_strlen.(fn_body) t le' m (Out_return (Some ((Vint len),tuint))).
Admitted.

(* Conditions about the f_strlen loop: an illustration *)

(* On empty string C light function evaluates to 0 *)
Lemma strlen_correct_loop_empty_string :
  forall ge e m b ofs le,
    strlen m b ofs O ->

    exists t le',
      le!_output = Some (VintN O) ->
      le!_input = Some (Vptr b ofs) ->
      exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ le'!_output = Some (VintN O).
Proof.
  intros.
  replace O with (0 + 0)%nat by lia.
  replace ofs with (Ptrofs.add ofs Ptrofs.zero) by (auto with ptrofs).
  eapply strlen_loop_correct_gen.
  simpl.
  assumption.
Qed.

(* If 0 is read from memory at [b,ofs + len] the output is set to len *)
Lemma strlen_loop_break_correct:  forall ge e m b ofs outp le,
      ofs + Z.of_nat outp < Ptrofs.modulus ->
      0 <= ofs < Ptrofs.modulus ->
      0 <= Z.of_nat outp < Ptrofs.modulus ->

      (* IF before the loop *s = [b,ofs + outp] and i = outp *)
      le!_input = Some (Vptr b (Ptrofs.repr (ofs + Z.of_nat outp))) ->
      le!_output = Some (VintN outp) ->

      (* and the guard condition is false *)
      Mem.load Mint8signed m b (ofs + (Z_of_nat outp)) = Some (Vint (Int.repr 0)) ->

      (* THEN loop executes to an environment with i = outp [i.e., i stays unchanged] + memory is unchanged *)
      exists t le', exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ (le'!_output) = Some (VintN outp).
Proof.
  intros.
  repeat eexists.
  eapply exec_Sloop_stop1.
  seq2. seq1. seq1.
  repeat econstructor.
  apply H2.
  repeat econstructor.
  apply gss.
  repeat econstructor.
  seq1.
  repeat econstructor.
  rewrite gso. apply gss. cbv ; congruence.
  simpl.
  replace (Ptrofs.unsigned (Ptrofs.repr (ofs + Z.of_nat outp))) with (ofs + Z.of_nat outp).
  apply H4.
  { ptrofs_compute_add_mul. all: lia. }
  repeat econstructor.
  apply gss.
  econstructor.
  replace (negb (Int.eq Int.zero Int.zero)) with false by (auto with ints).
  econstructor.
  cbv; congruence.
  econstructor.
  repeat (rewrite gso). assumption.
  all: cbv; congruence.
Qed.

Lemma strlen_loop_body_correct: Archi.ptr64 = false -> forall len ge e m b ofs le,
      0 <= ofs < Ptrofs.modulus ->
      Z_of_nat len < Int.modulus ->
      ofs + Z_of_nat len < Ptrofs.modulus ->

      le!_input = Some (Vptr b (Ptrofs.repr (ofs + Z.of_nat len))) ->
      le!_output = Some (VintN len) ->

      (exists c, Mem.load chunk m b (ofs + Z.of_nat len) = Some (Vint c) /\c <> Int.zero) ->

      exists t le', exec_stmt ge e le m f_strlen_loop_body t le' m Out_normal /\ le'!_output = Some (VintN (S len)).
Proof.
  intros.
  destruct H5 as [p].
  repeat eexists.
  repeat seq1.
  repeat econstructor. apply H3. repeat econstructor.
  apply gss.
  repeat econstructor.
  repeat econstructor.
  rewrite gso. apply gss. cbv; congruence.
  simpl.
  replace (Ptrofs.unsigned (Ptrofs.repr (ofs + Z.of_nat len))) with (ofs + Z.of_nat len).
  apply H5.
  { ptrofs_compute_add_mul. all: lia. }
  repeat econstructor.
  apply gss.
  econstructor.
  replace (negb (Int.eq p Int.zero)) with true.
  repeat econstructor.
  { replace (Int.eq p Int.zero) with false.
          auto.
          rewrite Int.eq_false.
          reflexivity.
          apply H5. }
  repeat econstructor.
  repeat (rewrite gso).
  apply H4. 1-3: cbv; congruence.
  repeat econstructor.
  unfold VintN.
  replace (Int.add (Int.repr (Z.of_nat len)) (Int.repr 1)) with (Int.repr (Z.of_nat (S len))).
  apply gss.
  { ints_compute_add_mul.
    f_equal.
    lia.
    split; try lia. cbv; auto.
    lia. }
Qed.


Require Export Arith.EqNat.
Require Export Arith.Lt.
Require Export Arith.Compare_dec.
Require Export List.
Require Import String.
Open Scope string_scope.
Require Import TacticsSF.
Require Import TacticsCPDT.
Require Import Process.
Require Import List.
Require Import PrettyPrinter.
Require Import TypeAssignmentPoly.
Require Import ResultBasics.
Require Import ExampleCommon.
Require Import ExampleRecursion.

(* ------------ abp-send ------------------*)

(*
  proc send_i(x, in, err1) =
   err1!i;err1!x;send_i(x, in, err1)   Send message x (maybe a duplicate)
   +err1?(1 − i);send_i(x, in, err1)   Ignore duplicate ack 1−i
   +err1?i;in?y;send_{1-i}(y, in, err1)  New ack i, send next message y from in
*)

Definition abp_sendA_procR (i : bool) : procR :=
(* err1!i;err1!x;send_i(x, in, err1) *)
(OutputR (var_value_of_string "err1") (token_value_of_bool i)
  (OutputR (var_value_of_string "err1") (var_value_of_string "x")
    (RecurseR ("send_"++(string_of_bool i))
      ((var_value_of_string "x") :: (var_value_of_string "in")
        :: (var_value_of_string "err1") :: nil)))).

Definition abp_sendB_procR (i : bool) : procR :=
(* err1?z;[z=(1 − i)];send_i(x, in, err1) *)
(InputR (var_value_of_string "err1")
  (IsEqR (ValVariable (Var (Bound 0))) (token_value_of_bool (negb i))
    (RecurseR ("send_"++(string_of_bool i)) ((var_value_of_string "x")
      :: (var_value_of_string "in") :: (var_value_of_string "err1") :: nil)))).

Definition abp_sendC_procR (i : bool) : procR :=
(* err1?z;[z=i];in?y;send_{1-i}(y, in, err1) *)
(InputR (var_value_of_string "err1")
  (IsEqR (ValVariable (Var (Bound 0))) (token_value_of_bool i)
    (InputR (var_value_of_string "in")
      (RecurseR ("send_"++(string_of_bool (negb i)))
        ((ValVariable (Var (Bound 0))) :: (var_value_of_string "in")
          :: (var_value_of_string "err1") :: nil))))).

(*
   err1!i;err1!x;send_i(x, in, err1)
+  err1?z;[z=(1 − i)];send_i(x, in, err1)
+  err1?z;[z=i];in?y;send_{1-i}(y, in, err1)
*)
Definition abp_send_procR (i : bool) : procR :=
  SumR (abp_sendA_procR i) (SumR (abp_sendB_procR i) (abp_sendC_procR i)).

Definition abp_send x inp err1 :=
  let mkTriple i := (String.append "send_" (string_of_bool i),
      "x" :: "in" :: "err1" :: nil, abp_send_procR i) in
  createRecProc (map mkTriple (false :: true :: nil)) "send_false"
    (x :: inp :: err1 :: nil).

Definition abp_send_test : proc :=
  abp_send (var_value_of_string "qx") (var_value_of_string "qin")
    (var_value_of_string "qerr1").

(*

NOTES:

Eval compute in abp_send_test.

Eval compute in
  (undebruijn_proc 50
    ("send_false" % "send_true" %
      (("xc" % "x" % "xin" % "xerr1" % (("d" % $$) ^^ (("z" % "d" % $$) ^^ ("z" % "y" % "d" % $$)))) ^^
        (("xc" % "x" % "xin" % "xerr1" % (("d" % $$) ^^ (("z" % "d" % $$) ^^ ("z" % "y" % "d" % $$)))) ^^ $$) ^^
        ("c" % $$))
    )
    abp_send_test
  ).

*)


(* $Id: CSums.v,v 1.13 2003/03/11 13:35:54 lcf Exp $ *)

Require Export CGroups.
Require Export PolyList.
Require Export Peano_dec.

(* Tex_Prose
\chapter{Sums}

\begin{convention}
Let \verb!G! be a group.
\end{convention}
*)

Section Sums.

Variable G : CGroup. (* Sum1 and Sum use subtraction *)

(* Begin_Tex_Verb *)
Fixpoint Sumlist [l:(list G)] : G :=
  Cases l of
    nil => (Zero::G)
  | (cons x k) => x[+](Sumlist k)
  end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Fixpoint Sumx [n:nat] : ((i:nat)(lt i n)->G)->G :=
  <[n:nat](((i:nat)(lt i n)->G)->G)>
  Cases n of
    O => [_:(i:nat)(lt i O)->G](Zero::G)
  | (S m) => [f:(i:nat)(lt i (S m))->G]
      (Sumx m [i:nat][l:(lt i m)](f i (lt_S ? ? l)))
        [+](f m (lt_n_Sn m))
  end.
(* End_Tex_Verb *)

(* Tex_Prose
It is sometimes useful to view a function defined on $\{0,\ldots,i-1\}$ as a function on the natural numbers which evaluates to $0$ when the input is greater than or equal to $i$.
*)

(* Begin_Tex_Verb *)
Definition part_tot_nat_fun [n:nat][f:(i:nat)(lt i n)->G] : nat->G.
(* End_Tex_Verb *)
Intros n f i.
Elim (le_lt_dec n i).
 Intro a; Apply (Zero::G).
Intro b; Apply (f i b).
Defined.

(* Begin_Tex_Verb *)
Lemma part_tot_nat_fun_ch1 : (n:nat)(f:(i:nat)(lt i n)->G)
  (nat_less_n_fun ?? f)->
  (i:nat)(Hi:(lt i n))(part_tot_nat_fun n f i)[=](f i Hi).
(* End_Tex_Verb *)
Intros n f Hf i Hi.
Unfold part_tot_nat_fun.
Elim le_lt_dec; Intro.
 ElimType False; Apply (le_not_lt n i); Auto.
Simpl; Apply Hf; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma part_tot_nat_fun_ch2 : (n:nat)(f:(i:nat)(lt i n)->G)
  (i:nat)(Hi:(le n i))(part_tot_nat_fun n f i)[=]Zero.
(* End_Tex_Verb *)
Intros n f i Hi.
Unfold part_tot_nat_fun.
Elim le_lt_dec; Intro.
 Simpl; Algebra.
ElimType False; Apply (le_not_lt n i); Auto.
Qed.

(* Begin_Tex_Verb *)
Fixpoint Sum0 [n:nat] : (nat->G)->G := [f:nat->G]
(* Sum i=0..(n-1) *)
  Cases n of
    O => (Zero::G)
  | (S m) => (Sum0 m f)[+](f m)
  end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Sum1 : nat->nat->(nat->G)->G :=
(* Sum i=m..(n-1) *)
  [m,n:nat][f:nat->G]((Sum0 n f)[-](Sum0 m f)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Sum : nat->nat->(nat->G)->G :=
(* Sum i=m..n *)
  [m,n:nat](Sum1 m (S n)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Sum2 [m,n:nat][h:(i:nat)(le m i)->(le i n)->G] : G.
(* End_Tex_Verb *)
Intros m n h.
Apply (Sum m n).
Intro i.
Elim (le_lt_dec m i); Intro H.
 Elim (le_lt_dec i n); Intro H0.
  Apply (h i H H0).
 Apply (Zero::G).
Apply (Zero::G).
Defined.

(* Begin_Tex_Verb *)
Lemma Sum_one : (n:nat)(f:nat->G)(Sum n n f)[=](f n).
(* End_Tex_Verb *)
Intros n f.
Unfold Sum.
Unfold Sum1.
Simpl.
Step_final ((f n)[+](Sum0 n f))[-](Sum0 n f).
Qed.

Hints Resolve Sum_one : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_empty : (n:nat)(f:nat->G)(lt O n)->
  (Sum n (pred n) f)[=]Zero.
(* End_Tex_Verb *)
Intros n f H.
Unfold Sum.
Rewrite <- (S_pred ?? H).
Unfold Sum1; Algebra.
Qed.

Hints Resolve Sum_empty : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_Sum : (l,m,n:nat)(f:nat->G)
  (Sum l m f)[+](Sum (S m) n f)[=](Sum l n f).
(* End_Tex_Verb *)
Intros l m n f.
Unfold Sum.
Unfold Sum1.
Step ((Sum0 (S n) f)[-](Sum0 (S m) f))[+]((Sum0 (S m) f)[-](Sum0 l f)).
Step (((Sum0 (S n) f)[-](Sum0 (S m) f))[+](Sum0 (S m) f))[-](Sum0 l f).
Step ((Sum0 (S n) f)[-]((Sum0 (S m) f)[-](Sum0 (S m) f)))[-](Sum0 l f).
Step ((Sum0 (S n) f)[-]Zero)[-](Sum0 l f).
Step ((Sum0 (S n) f)[+][--]Zero)[-](Sum0 l f).
Step_final ((Sum0 (S n) f)[+]Zero)[-](Sum0 l f).
Qed.

Hints Resolve Sum_Sum : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_first : (m,n:nat)(f:nat->G)
  (Sum m n f) [=] (f m)[+](Sum (S m) n f).
(* End_Tex_Verb *)
Intros m n f.
Unfold Sum.
Unfold Sum1.
Step_rht ((f m)[+](Sum0 (S n) f))[-](Sum0 (S m) f).
Step_rht ((Sum0 (S n) f)[+](f m))[-](Sum0 (S m) f).
Step_rht (Sum0 (S n) f)[+]((f m)[-](Sum0 (S m) f)).
Unfold cg_minus.
Apply bin_op_wd_unfolded.
Algebra.
Simpl.
Step_rht (f m)[+][--]((f m)[+](Sum0 m f)).
Step_rht (f m)[+]([--](f m)[+][--](Sum0 m f)).
Step_rht ((f m)[+][--](f m))[+][--](Sum0 m f).
Step_rht Zero[+][--](Sum0 m f).
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_last : (m,n:nat)(f:nat->G)
  (Sum m (S n) f) [=] (Sum m n f)[+](f (S n)).
(* End_Tex_Verb *)
Intros m n f.
Unfold Sum.
Unfold Sum1.
Simpl.
Unfold cg_minus.
Step_lft (Sum0 n f)[+](f n)[+] ((f (S n))[+][--](Sum0 m f)).
Step_rht (Sum0 n f)[+](f n)[+] ([--](Sum0 m f)[+](f (S n))).
Algebra.
Qed.

Hints Resolve Sum_last : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_last' : (m,n:nat)(f:nat->G)(lt O n) ->
  (Sum m n f) [=] (Sum m (pred n) f)[+](f n).
(* End_Tex_Verb *)
Intros m n f H. Induction n.
 Elim (lt_n_n (0) H).
Apply Sum_last.
Qed.

(* Tex_Prose
We add some extensionality results which will be quite useful when working with integration.
*)

(* Begin_Tex_Verb *)
Lemma Sum0_strext :
  (f,g:?)(n:nat)((Sum0 n f)[#](Sum0 n g))->
  {i:nat | (lt i n) & ((f i)[#](g i))}.
(* End_Tex_Verb *)
Intros f g n H.
Induction n.
 Simpl in H.
 Elim (ap_irreflexive_unfolded ?? H).
Simpl in H.
Cut {i:nat | (lt i n) & ((f i)[#](g i))}+((f n)[#](g n)).
Intro H0.
Elim H0; Intro H1.
 Elim H1; Intros i H2 H3; Exists i; Auto with arith.
Exists n; Auto with arith.

Cut ((Sum0 n f)[#](Sum0 n g))+((f n)[#](g n)).
Intro H0; Elim H0; Intro H1.
 Left; Apply Hrecn; Assumption.
Auto.

Apply bin_op_strext_unfolded with (!csg_op G).
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_strext : (f,g:?)(m,n:nat)
  (le m (S n))->((Sum m n f)[#](Sum m n g))->
  {i:nat | (le m i)/\(le i n) & ((f i)[#](g i))}.
(* End_Tex_Verb *)
Intros f g m n H H0.
Induction n.
 Elim (le_lt_eq_dec ?? H); Intro H2.
  Cut m=O.
  Intro H1.
  Rewrite H1; Exists O; Auto.
  Rewrite H1 in H0.
  Step (Sum O O f); Stepr (Sum O O g); Assumption.

  Inversion H2; [Auto | Inversion H3].
 ElimType False.
 Cut O=(pred (1)); [Intro H3 | Auto].
 Rewrite H3 in H0.
 Rewrite H2 in H0.
 Apply (ap_irreflexive_unfolded G Zero).
 EApply ap_well_def_lft_unfolded.
  EApply ap_well_def_rht_unfolded.
   Apply H0.
  Apply Sum_empty; Auto.
 Apply Sum_empty; Auto.
Elim (le_lt_eq_dec ?? H); Intro Hmn.
 Cut ((Sum m n f)[#](Sum m n g))+((f (S n))[#](g (S n))).
 Intro H1; Elim H1; Intro H2.
  Cut {i:nat | (le m i)/\(le i n) & ((f i)[#](g i))}.
  Intro H3; Elim H3; Intros i H4 H5; Elim H4; Intros H6 H7; Clear H1 H4.
  Exists i; Try Split; Auto with arith.

  Apply Hrecn; Auto with arith.
 Exists (S n); Try Split; Auto with arith.

 Apply bin_op_strext_unfolded with (!csg_op G).
 Step (Sum m (S n) f); Stepr (Sum m (S n) g); Assumption.
Clear Hrecn.
ElimType False.
Cut (S n)=(pred (S (S n))); [Intro H1 | Auto].
Rewrite H1 in H0.
Rewrite Hmn in H0.
Apply (ap_irreflexive_unfolded G Zero).
EApply ap_well_def_lft_unfolded.
 EApply ap_well_def_rht_unfolded.
  Apply H0.
 Apply Sum_empty; Auto with arith.
Apply Sum_empty; Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_strext : (n:nat)(f,g:(i:nat)(lt i n)->G)
  (nat_less_n_fun ?? f)->(nat_less_n_fun ?? g)->
  ((Sumx ? f)[#](Sumx ? g))->
  {N:nat & {HN:(Clt N n) &
    (f N (Clt_to ?? HN))[#](g N (Clt_to ?? HN))}}.
(* End_Tex_Verb *)
Intro n; Induction n.
Intros f g H H0 H1.
Elim (ap_irreflexive_unfolded ?? H1).
Intros f g H H0 H1.
Simpl in H1.
Elim (bin_op_strext_unfolded ?????? H1); Clear H1; Intro H1.
 Cut (nat_less_n_fun ?? [i:nat][l:(lt i n)](f i (lt_S ?? l))); [Intro H2 | Red; Intros; Apply H; Assumption].
 Cut (nat_less_n_fun ?? [i:nat][l:(lt i n)](g i (lt_S ?? l))); [Intro H3 | Red; Intros; Apply H0; Assumption].
 Elim (Hrecn ?? H2 H3 H1); Intros N HN.
 Elim HN; Clear HN; Intros HN H'.
 Exists N.
 Cut (Clt N (S n)); [Intro H4 | Apply toCProp_lt; Apply lt_S; Apply Clt_to; Assumption].
 Exists H4.
 EApply ap_well_def_lft_unfolded.
  EApply ap_well_def_rht_unfolded.
   Apply H'.
  Algebra.
 Algebra.
Exists n.
Exists (toCProp_lt ?? (lt_n_Sn n)).
EApply ap_well_def_lft_unfolded.
 EApply ap_well_def_rht_unfolded.
  Apply H1.
 Algebra.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum0_strext' : (f,g:?)
  (n:nat)((Sum0 n f)[#](Sum0 n g))->
  {i:nat & ((f i)[#](g i))}.
(* End_Tex_Verb *)
Intros f g n H.
Elim (Sum0_strext ??? H); Intros i Hi Hi'; Exists i; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_strext' : (f,g:?)(m,n:nat)
  ((Sum m n f)[#](Sum m n g))->{i:nat & ((f i)[#](g i))}.
(* End_Tex_Verb *)
Intros f g m n H.
Unfold Sum Sum1 in H.
Elim (cg_minus_strext ????? H); Intro H1;
 Elim (Sum0_strext ??? H1);
 Intros i Hi Hi'; Exists i; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum0_wd : (m:nat)(f,f':nat->G)((i:nat)(f i)[=](f' i)) ->
                (Sum0 m f)[=](Sum0 m f').
(* End_Tex_Verb *)
Intros m f f' H.
Elim m; Simpl; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_wd : (m,n:nat)(f,f':nat->G)((i:nat)(f i)[=](f' i)) ->
               (Sum m n f)[=](Sum m n f').
(* End_Tex_Verb *)
Intros m n f f' H.
Unfold Sum.
Unfold Sum1.
Unfold cg_minus.
Apply bin_op_wd_unfolded.
 Apply Sum0_wd; Exact H.
Apply un_op_wd_unfolded.
Apply Sum0_wd; Exact H.
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_wd : (n:nat)(f,g:(i:nat)(lt i n)->G)
  ((i:nat)(H:(lt i n))(f i H)[=](g i H))->
  ((Sumx ? f)[=](Sumx ? g)).
(* End_Tex_Verb *)
Intro n; Elim n; Intros; Simpl; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_wd' :
  (m,n:nat)(le m (S n)) -> (f,f':nat->G)
    ((i:nat)(le m i) -> (le i n) -> ((f i)[=](f' i))) ->
      (Sum m n f)[=](Sum m n f').
(* End_Tex_Verb *)
Intros m n. Induction n; Intros H f f' H0.
 Generalize (toCle ?? H); Clear H; Intro H.
 Inversion H.
  Unfold Sum. Unfold Sum1. Step_final (Zero::G).
 Inversion H2.
 Step (f (0)). Step_rht (f' (0)). Apply H0; Auto.
 Rewrite H3; Auto.
Elim (le_lt_eq_dec m (S (S n)) H); Intro H1.
 Step (Sum m n f)[+](f (S n)).
 Stepr (Sum m n f')[+](f' (S n)).
 Apply bin_op_wd_unfolded; Auto with arith.
Rewrite H1.
Unfold Sum. Unfold Sum1. Step_final (Zero::G).
Qed.

(* Begin_Tex_Verb *)
Lemma Sum2_wd : (m,n:nat)(le m (S n))->
  (f,g:(i:nat)(le m i)->(le i n)->G)
  ((i:nat)(Hm:(le m i))(Hn:(le i n))(f i Hm Hn)[=](g i Hm Hn))->
  (Sum2 ?? f)[=](Sum2 ?? g).
(* End_Tex_Verb *)
Intros m n H f g H0.
Unfold Sum2.
Apply Sum_wd'.
 Assumption.
Intros i H1 H2.
Elim le_lt_dec; Intro H3; [Simpl | ElimType False; Apply (le_not_lt i n); Auto].
Elim le_lt_dec; Intro H4; [Simpl | ElimType False; Apply (le_not_lt m i); Auto].
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum0_plus_Sum0 : (f,g:nat->G)(m:nat)
                     (Sum0 m [i:nat]((f i)[+](g i))) [=]
                     ((Sum0 m f) [+] (Sum0 m g)).
(* End_Tex_Verb *)
Intros f g m.
Elim m.
 Simpl; Algebra.
Intros n H.
Simpl.
Step (Sum0 n f)[+](Sum0 n g) [+] ((f n)[+](g n)).
Step (Sum0 n f)[+]((Sum0 n g) [+] ((f n)[+](g n))).
Step (Sum0 n f)[+]((Sum0 n g) [+] (f n)[+](g n)).
Step (Sum0 n f)[+]((f n) [+] (Sum0 n g)[+](g n)).
Step (Sum0 n f)[+]((f n) [+] (Sum0 n g))[+](g n).
Step_final (Sum0 n f)[+](f n) [+] (Sum0 n g)[+](g n).
Qed.
Hints Resolve Sum0_plus_Sum0 : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_plus_Sum : (f,g:nat->G)(m,n:nat)
                     (Sum m n [i:nat]((f i)[+](g i))) [=]
                     ((Sum m n f) [+] (Sum m n g)).
(* End_Tex_Verb *)
Intros f g m n.
Unfold Sum.
Unfold Sum1.
Step_lft ((Sum0 (S n) f) [+] (Sum0 (S n) g))[-] ((Sum0 m f) [+](Sum0 m g)).
Step_lft ((((Sum0 (S n) f) [+] (Sum0 (S n) g)) [-] (Sum0 m f)) [-] (Sum0 m g)).
Unfold cg_minus.
Step_rht ((Sum0 (S n) f)[+][--](Sum0 m f)
            [+](Sum0 (S n) g))[+][--](Sum0 m g).
Apply bin_op_wd_unfolded.
 Step_lft (Sum0 (S n) f)[+]((Sum0 (S n) g)[+][--](Sum0 m f)).
 Step_lft (Sum0 (S n) f)[+]([--](Sum0 m f)[+](Sum0 (S n) g)).
 Algebra.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_plus_Sumx : (n:nat)(f,g:(i:nat)(lt i n)->G)
  (Sumx ? f)[+](Sumx ? g)[=]
    (Sumx ? [i:nat][Hi:(lt i n)](f i Hi)[+](g i Hi)).
(* End_Tex_Verb *)
Intro n; Induction n.
 Intros; Simpl; Algebra.
Intros f g; Simpl.
Apply eq_transitive_unfolded with ((Sumx ? [i:nat][l:(lt i n)](f i (lt_S i n l)))[+](Sumx ? [i:nat][l:(lt i n)](g i (lt_S i n l))))[+]
  ((f n (lt_n_Sn n))[+](g n (lt_n_Sn n))).
 LetTac Sf:=(Sumx ? [i:nat][l:(lt i n)](f i (lt_S i n l))).
 LetTac Sg:=(Sumx ? [i:nat][l:(lt i n)](g i (lt_S i n l))).
 LetTac fn:=(f n (lt_n_Sn n)); LetTac gn:=(g n (lt_n_Sn n)).
 Step Sf[+]fn[+]Sg[+]gn.
 Step Sf[+](fn[+]Sg)[+]gn.
 Step Sf[+](Sg[+]fn)[+]gn.
 Step_final Sf[+]Sg[+]fn[+]gn.
Apply bin_op_wd_unfolded; Algebra.
Apply Hrecn with f:=[i:nat][l:(lt i n)](f i (lt_S i n l)) g:=[i:nat][l:(lt i n)](g i (lt_S i n l)).
Qed.

(* Begin_Tex_Verb *)
Lemma Sum2_plus_Sum2 : (m,n:nat)(le m (S n))->
  (f,g:(i:nat)(le m i)->(le i n)->G)
  (Sum2 ?? f)[+](Sum2 ?? g)[=]
    (Sum2 ?? [i,Hm,Hn:?](f i Hm Hn)[+](g i Hm Hn)).
(* End_Tex_Verb *)
Intros m n H f g.
Unfold Sum2; Simpl.
Apply eq_symmetric_unfolded.
EApply eq_transitive_unfolded.
 2: Apply Sum_plus_Sum.
Apply Sum_wd; Intro i.
Elim le_lt_dec; Intro H0; Simpl; Elim le_lt_dec; Intro H1; Simpl; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma inv_Sum0 : (f:nat->G)(n:nat)
                     (Sum0 n [i:nat]([--](f i))) [=]
                     ([--](Sum0 n f)).
(* End_Tex_Verb *)
Intros f n.
Induction n.
 Simpl; Algebra.
Simpl.
Step_final ([--](Sum0 n f)) [+] ([--](f n)).
Qed.

Hints Resolve inv_Sum0 : algebra.

(* Begin_Tex_Verb *)
Lemma inv_Sum : (f:nat->G)(m,n:nat)
                     (Sum m n [i:nat]([--](f i))) [=]
                     ([--](Sum m n f)).
(* End_Tex_Verb *)
Intros f a b.
Unfold Sum.
Unfold Sum1.
Step ([--](Sum0 (S b) f)) [-] ([--](Sum0 a f)).
Step ([--](Sum0 (S b) f)) [+] [--] ([--](Sum0 a f)).
Step_final [--]((Sum0 (S b) f) [+] ([--](Sum0 a f))).
Qed.

Hints Resolve inv_Sum : algebra.

(* Begin_Tex_Verb *)
Lemma inv_Sumx : (n:nat)(f:(i:nat)(lt i n)->G)
  [--](Sumx ? f)[=](Sumx ? [i:nat][Hi:(lt i n)][--](f i Hi)).
(* End_Tex_Verb *)
Intro n; Induction n.
 Simpl; Algebra.
Intro f; Simpl.
Step ([--](Sumx ? [i:nat][l:(lt i n)](f i (lt_S i n l))))[+]([--](f n (lt_n_Sn n))).
Apply bin_op_wd_unfolded.
 Apply Hrecn with f:=[i:nat][l:(lt i n)](f i (lt_S i n l)).
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma inv_Sum2 : (m,n:nat)(le m (S n))->
  (f:(i:nat)(le m i)->(le i n)->G)
  [--](Sum2 ?? f)[=](Sum2 ?? [i,Hm,Hn:?][--](f i Hm Hn)).
(* End_Tex_Verb *)
Intros m n H f.
Unfold Sum2; Simpl.
Apply eq_symmetric_unfolded.
EApply eq_transitive_unfolded.
 2: Apply inv_Sum.
Apply Sum_wd; Intro i.
Elim le_lt_dec; Intro; Simpl; Elim le_lt_dec; Intro; Simpl; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_minus_Sum : (f,g:nat->G)(m,n:nat)
                      (Sum m n [i:nat]((f i)[-](g i))) [=]
                      ((Sum m n f) [-] (Sum m n g)).
(* End_Tex_Verb *)
(* WHAT A MISERY TO PROVE THIS *)
Intros f g a b.
Step (Sum a b [i:nat]((f i)[+] ([--](g i)))).
Cut (Sum a b [i:nat]((f i)[+]( ([j:nat]([--](g j))) i))) [=]
    (Sum a b f)[+](Sum a b [j:nat]([--](g j))).
Intro H.
Step (Sum a b f)[+](Sum a b [j:nat]([--](g j))).
Step_final ((Sum a b f) [+][--] (Sum a b g)).

Change (Sum a b [i:nat]((f i)[+]( ([j:nat]([--](g j))) i))) [=]
       (Sum a b f)[+](Sum a b [j:nat]([--](g j))).
Apply Sum_plus_Sum.
Qed.

Hints Resolve Sum_minus_Sum : algebra.

(* Begin_Tex_Verb *)
Lemma Sumx_minus_Sumx : (n:nat)(f,g:(i:nat)(lt i n)->G)
  (Sumx ? f)[-](Sumx ? g)[=](Sumx ? [i,Hi:?](f i Hi)[-](g i Hi)).
(* End_Tex_Verb *)
Intros n f g; Unfold cg_minus.
EApply eq_transitive_unfolded.
 2: Apply Sumx_plus_Sumx with f:=f g:=[i:nat][Hi:(lt i n)][--](g i Hi).
Apply bin_op_wd_unfolded; Algebra.
Apply inv_Sumx.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum2_minus_Sum2 : (m,n:nat)(le m (S n))->
  (f,g:(i:nat)(le m i)->(le i n)->G)
  (Sum2 ?? f)[-](Sum2 ?? g)[=]
    (Sum2 ?? [i,Hm,Hn:?](f i Hm Hn)[-](g i Hm Hn)).
(* End_Tex_Verb *)
Intros m n H f g; Unfold cg_minus.
EApply eq_transitive_unfolded.
 2: Apply Sum2_plus_Sum2 with f:=f g:=[i:nat][Hm:(le m i)][Hn:(le i n)][--](g i Hm Hn); Assumption.
Apply bin_op_wd_unfolded.
 Algebra.
Apply inv_Sum2; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_apzero : (f:nat->G)(m,n:nat)(le m n) ->
  ((Sum m n f) [#] Zero) ->
    {i:nat | (le m i)/\(le i n) & ((f i) [#] Zero)}.
(* End_Tex_Verb *)
Intros a k l H H0. Induction l.
 Exists (0). Split; Auto. Cut k=O.
 Intro H'. Rewrite H' in H0.
 Step (Sum (0) (0) a).
 Inversion H. Auto.
Elim (le_lt_eq_dec k (S l) H); Intro HH.
Cut ((Sum k l a) [#] Zero) + ((a (S l)) [#] Zero). Intro H1.
Elim H1; Clear H1; Intro H1.
 Elim Hrecl; Auto with arith.
 Intro i. Intros H2 H6. Exists i; Auto.
 Elim H2; Intros H3 H4; Auto.
Exists (S l); Try Split; Auto with arith.

Apply cg_add_ap_zero.
Apply ap_well_def_lft_unfolded with (Sum k (S l) a). Auto.
Apply Sum_last.

Rewrite HH in H0.
Exists (S l); Auto.
Step (Sum (S l) (S l) a).
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_zero : (f:nat->G)(m,n:nat)(le m (S n)) ->
  ((i:nat)(le m i) -> (le i n) -> (f i) [=] Zero) ->
    (Sum m n f) [=] Zero.
(* End_Tex_Verb *)
Intros a k l H H0. Induction l.
 Elim (le_lt_eq_dec ?? H); Clear H; Intro H.
  Replace k with O. Step (a O). Apply H0. Auto.
  Auto with arith. Auto. Inversion H. Auto. Inversion H2.
 Rewrite H.
 Unfold Sum. Unfold Sum1. Algebra.
Elim (le_lt_eq_dec k (S (S l)) H); Intro HH.
 Step (Sum k l a)[+](a (S l)).
 Stepr Zero[+](Zero::G).
 Apply bin_op_wd_unfolded.
  Apply Hrecl; Auto with arith.
 Apply H0; Auto with arith.
Rewrite HH.
Unfold Sum. Unfold Sum1. Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_term : (f:nat->G)(m,i,n:nat)(le m i) -> (le i n) ->
  ((j:nat)(le m j) -> (~j=i) -> (le j n) -> (f j) [=] Zero) ->
    (Sum m n f) [=] (f i).
(* End_Tex_Verb *)
Intros a k i0 l H H0 H1.
Step (Sum k i0 a)[+](Sum (S i0) l a).
Stepr (a i0)[+]Zero.
Apply bin_op_wd_unfolded.
 Elim (O_or_S i0); Intro H2.
  Elim H2; Intros m Hm.
  Rewrite <- Hm.
  Step (Sum k m a)[+](a (S m)).
  Stepr Zero[+](a (S m)).
  Apply bin_op_wd_unfolded.
   Apply Sum_zero. Rewrite Hm; Auto.
   Intros i H3 H4. Apply H1. Auto. Omega. Omega.
  Algebra.
 Rewrite <- H2 in H. Rewrite <- H2.
 Generalize (toCle ?? H); Clear H; Intro H.
 Inversion H. Algebra.
Apply Sum_zero. Auto with arith.
Intros. Apply H1. Omega. Omega. Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum0_shift : (f,g:nat->G)(n:nat)
  ((i:nat)((f i) [=] (g (S i)))) ->
    (g (0))[+](Sum0 n f) [=] (Sum0 (S n) g).
(* End_Tex_Verb *)
Intros a b l H. Induction l.
 Simpl; Algebra.
Simpl.
Step (b (0))[+](Sum0 l a)[+](a l).
Step_final (Sum0 (S l) b)[+](a l).
Qed.

Hints Resolve Sum0_shift : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_shift : (f,g:nat->G)(m,n:nat)
  ((i:nat)((f i) [=] (g (S i)))) ->
    (Sum m n f) [=] (Sum (S m) (S n) g).
(* End_Tex_Verb *)
Unfold Sum. Unfold Sum1. Intros a b k l H.
Step (((Sum0 (S l) a)[+](b (0)))[-](b (0)))[-](Sum0 k a).
Step ((Sum0 (S l) a)[+](b (0)))[-]((b (0))[+](Sum0 k a)).
Step_final ((b (0))[+](Sum0 (S l) a))[-]((b (0))[+](Sum0 k a)).
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_Sum0 : (n,f,g:?)((i:nat)(Hi:(lt i n))
  (f i Hi)[=](g i))->(Sumx n f)[=](Sum0 n g).
(* End_Tex_Verb *)
Intro; Induction n; Simpl; Algebra.
Qed.

End Sums.

Implicits Sum [1].
Implicits Sum0 [1].
Implicits Sumx [1 2].
Implicits Sum2 [1 2 3].

Section More_Sums.

Variable G:CGroup.

(* Tex_Prose
The next results are useful for calculating some special Sums, often referred to as ``Mengolli Sums''.
*)

(* Begin_Tex_Verb *)
Lemma Mengolli_Sum : (n:nat)(f:(i:nat)(le i n)->G)
  (g:(i:nat)(lt i n)->G)(nat_less_n_fun' ?? f)->
  ((i:nat)(H:(lt i n))
    ((g i H)[=](f (S i) H)[-](f i (lt_le_weak ?? H))))->
  (Sumx g)[=]((f n (le_n n))[-](f O (le_O_n n))).
(* End_Tex_Verb *)
Intro n; Induction n; Intros f g Hf H; Simpl.
 Step (f O (le_n O))[-](f O (le_n O)).
 Apply cg_minus_wd; Algebra.
Apply eq_transitive_unfolded with ((f ? (le_n (S n)))[-](f ? (le_S ?? (le_n n))))[+]((f ? (le_S ?? (le_n n)))[-](f O (le_O_n (S n)))).
 EApply eq_transitive_unfolded.
  Apply cm_commutes_unfolded.
 Apply bin_op_wd_unfolded.
  EApply eq_transitive_unfolded.
   Apply H.
  Apply cg_minus_wd; Apply Hf; Algebra.
 LetTac f':=[i:nat][H:(le i n)](f i (le_S ?? H)).
 LetTac g':=[i:nat][H:(lt i n)](g i (lt_S ?? H)).
 Apply eq_transitive_unfolded with (f' n (le_n n))[-](f' O (le_O_n n)).
  Apply Hrecn.
   Red; Intros; Unfold f'; Apply Hf; Algebra.
  Intros i Hi.
  Unfold f'; Unfold g'.
  EApply eq_transitive_unfolded.
   Apply H.
  Apply cg_minus_wd; Apply Hf; Algebra.
 Unfold f'; Apply cg_minus_wd; Apply Hf; Algebra.
Stepr ((f (S n) (le_n (S n)))[+]Zero)[-](f O (le_O_n (S n))).
Stepr ((f (S n) (le_n (S n)))[+]([--](f n (le_S ?? (le_n n)))[+](f n (le_S ?? (le_n n)))))[-](f O (le_O_n (S n))).
Step_final (((f (S n) (le_n (S n)))[+][--](f n (le_S ?? (le_n n))))[+](f n (le_S ?? (le_n n))))[-](f O (le_O_n (S n))).
Qed.

(* Begin_Tex_Verb *)
Lemma Mengolli_Sum_gen : (f,g:nat->G)
  ((n:nat)(g n)[=]((f (S n))[-](f n)))->
  (m,n:nat)(le m (S n))->(Sum m n g)[=]((f (S n))[-](f m)).
(* End_Tex_Verb *)
Intros f g H m n; Induction n; Intro Hmn.
 Elim (le_lt_eq_dec ?? Hmn); Intro H0.
  Cut m=O; [Intro H1 | Inversion H0; Auto with arith; Inversion H2].
  Rewrite H1.
  EApply eq_transitive_unfolded; [Apply Sum_one | Apply H].
 Cut O=(pred (1)); [Intro H1 | Auto].
 Rewrite H0; Stepr (Zero::G); Rewrite H1; Apply Sum_empty.
 Auto with arith.
Simpl in Hmn; Elim (le_lt_eq_dec ?? Hmn); Intro H0.
 Apply eq_transitive_unfolded with ((f (S (S n)))[-](f (S n)))[+]((f (S n))[-](f m)).
  EApply eq_transitive_unfolded.
   Apply Sum_last.
  EApply eq_transitive_unfolded.
   Apply cm_commutes_unfolded.
  Apply bin_op_wd_unfolded; [Apply H | Apply Hrecn].
  Auto with arith.
 Stepr ((f (S (S n)))[+]Zero)[-](f m).
 Stepr ((f (S (S n)))[+]([--](f (S n))[+](f (S n))))[-](f m).
 Step_final (((f (S (S n)))[+][--](f (S n)))[+](f (S n)))[-](f m).
Rewrite H0.
Stepr (Zero::G).
Cut (S n)=(pred (S (S n))); [Intro H2 | Auto].
Rewrite H2; Apply Sum_empty.
Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma str_Mengolli_Sum_gen : (f,g:nat->G)(m,n:nat)(le m (S n))->
  ((i:nat)(le m i)->(le i n)->(g i)[=]((f (S i))[-](f i)))->
  (Sum m n g)[=]((f (S n))[-](f m)).
(* End_Tex_Verb *)
Intros f g m n H H0.
Apply eq_transitive_unfolded with (Sum m n [i:nat](f (S i))[-](f i)).
 Apply Sum_wd'; Assumption.
Apply Mengolli_Sum_gen; [Intro; Algebra | Assumption].
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_to_Sum : (n:nat)(lt O n)->(f:(i:nat)(lt i n)->G)
  (nat_less_n_fun ?? f)->
  (Sumx f)[=](Sum O (pred n) (part_tot_nat_fun ?? f)).
(* End_Tex_Verb *)
Intro n; Induction n; Intros H f Hf.
ElimType False; Inversion H.
Cut (le O n); [Intro H0 | Auto with arith].
Elim (le_lt_eq_dec ?? H0); Clear H H0; Intro H.
 Simpl.
 Pattern 6 n; Rewrite (S_pred ?? H).
 EApply eq_transitive_unfolded.
  2: Apply eq_symmetric_unfolded; Apply Sum_last.
 Apply bin_op_wd_unfolded.
  EApply eq_transitive_unfolded.
   Apply Hrecn; Auto.
   Red; Intros; Apply Hf; Auto.
  Apply Sum_wd'.
   Auto with arith.
  Intros i H1 H2.
  Cut (lt i n); [Intro | Omega].
  EApply eq_transitive_unfolded.
   Apply part_tot_nat_fun_ch1 with Hi:=H0.
   Red; Intros; Apply Hf; Auto.
  Apply eq_symmetric_unfolded.
  EApply eq_transitive_unfolded.
   Apply part_tot_nat_fun_ch1 with Hi:=(lt_S ?? H0).
   Red; Intros; Apply Hf; Auto.
  Algebra.
 Rewrite <- (S_pred ?? H).
Apply eq_symmetric_unfolded; Apply part_tot_nat_fun_ch1; Auto.
Generalize f Hf; Clear Hf f; Rewrite <- H.
Simpl; Intros f Hf.
EApply eq_transitive_unfolded.
 2: Apply eq_symmetric_unfolded; Apply Sum_one.
Step (f O (lt_n_Sn O)).
Apply eq_symmetric_unfolded; Apply part_tot_nat_fun_ch1; Auto.
Qed.

End More_Sums.

Hints Resolve Sum_one Sum_Sum Sum_first Sum_last Sum_last' Sum_wd
  Sum_plus_Sum: algebra.
Hints Resolve Sum_minus_Sum inv_Sum inv_Sum0 : algebra.


Require Export D.

(** **** Exercise: 4 stars (hoare_asgn_wrong)  *)
(** The assignment rule looks backward to almost everyone the first
    time they see it.  If it still seems backward to you, it may help
    to think a little about alternative "forward" rules.  Here is a
    seemingly natural one:
      ------------------------------ (hoare_asgn_wrong)
      {{ True }} X ::= a {{ X = a }}
    Give a counterexample showing that this rule is incorrect
    (informally). Hint: The rule universally quantifies over the
    arithmetic expression [a], and your counterexample needs to
    exhibit an [a] for which the rule doesn't work. *)

Theorem hoare_asgn_wrong:
  exists a, ~ {{ fun st => True }} X ::= a {{ fun st => st X = aeval st a}}.
Proof.
  exists (APlus (AId X) (ANum 1)). unfold not. intros Hcontra.
  simpl in Hcontra. unfold hoare_triple in Hcontra.
  assert ((t_update empty_state X 1) X = (t_update empty_state X 1) X + 1).
  { eapply Hcontra. apply E_Ass. reflexivity. reflexivity. }
  simpl in H. inversion H.
Qed.


Require Export SystemFR.Syntax.

Require Export SystemFR.Tactics.
Require Export SystemFR.ListSetLemmas.
Require Export SystemFR.AssocList.
Require Export SystemFR.ListUtils.
Require Export SystemFR.EqualWithRelation.
Require Export SystemFR.EquivalentWithRelation.

Require Import PeanoNat.

Open Scope list_scope.

Fixpoint idrel (l: list nat) :=
  match l with
  | nil => nil
  | x :: xs => (x,x) :: idrel xs
  end.

Lemma idrel_lookup:
  forall l x,
    x ∈ l ->
    lookup PeanoNat.Nat.eq_dec (idrel l) x = Some x.
Proof.
  induction l; steps.
Qed.

Lemma idrel_lookup_swap:
  forall l x,
    x ∈ l ->
    lookup PeanoNat.Nat.eq_dec (swap (idrel l)) x = Some x.
Proof.
  induction l; steps.
Qed.

Lemma equal_with_idrel:
  forall t, equal_with_relation type_var (idrel (pfv t type_var)) t t.
Proof.
  intros; apply equal_with_relation_refl2; steps;
    eauto using idrel_lookup, idrel_lookup_swap.
Qed.

Lemma idrel_lookup_fail:
  forall l x,
    (x ∈ l -> False) ->
    lookup PeanoNat.Nat.eq_dec (idrel l) x = None.
Proof.
  induction l; steps.
Qed.

Lemma idrel_lookup_swap_fail:
  forall l x,
    (x ∈ l -> False) ->
    lookup PeanoNat.Nat.eq_dec (swap (idrel l)) x = None.
Proof.
  induction l; steps.
Qed.

Lemma support_idrel:
  forall l, support (idrel l) = l.
Proof.
  induction l; steps.
Qed.

Lemma range_idrel:
  forall l, range (idrel l) = l.
Proof.
  induction l; steps.
Qed.

Lemma support_swap:
  forall l, support (swap l) = range l.
Proof.
  induction l; steps.
Qed.

Lemma range_swap:
  forall l, range (swap l) = support l.
Proof.
  induction l; steps.
Qed.

Lemma equivalent_rc_refl:
  forall rc, equivalent_rc rc rc.
Proof.
  unfold equivalent_rc; steps.
Qed.

Lemma equivalent_with_idrel:
  forall T (l: list nat) (x: nat) ρ t (equiv: T -> T -> Prop),
    (x ∈ l -> False) ->
    (forall v, equiv v v) ->
    equivalent_with_relation (idrel l) ρ ((x,t) :: ρ) equiv.
Proof.
  unfold equivalent_with_relation;
    repeat step || t_lookup ||
           rewrite support_idrel in * ||
           rewrite support_swap in * ||
           rewrite range_idrel in * ||
           rewrite range_swap in * ||
           (rewrite idrel_lookup in * by auto) ||
           (rewrite idrel_lookup_swap_fail in * by auto) ||
           apply equivalent_with_right.
Qed.

Lemma equivalent_with_idrel2:
  forall T (l: list nat) (x: nat) ρ t (equiv: T -> T -> Prop),
    (x ∈ l -> False) ->
    (forall v, equiv v v) ->
    equivalent_with_relation (idrel l) ((x,t) :: ρ) ρ equiv.
Proof.
  unfold equivalent_with_relation;
    repeat step || t_lookup ||
           rewrite support_idrel in * ||
           rewrite support_swap in * ||
           rewrite range_idrel in * ||
           rewrite range_swap in * ||
           (rewrite idrel_lookup in * by auto) ||
           (rewrite idrel_lookup_swap_fail in * by auto) ||
           apply equivalent_with_left.
Qed.

Ltac t_idrel :=
  rewrite support_idrel in * ||
  rewrite support_swap in * ||
  rewrite range_idrel in * ||
  rewrite range_swap in * ||
  (rewrite idrel_lookup in * by auto) ||
  (rewrite idrel_lookup_swap_fail in * by auto).

Lemma equivalent_with_relation_permute:
  forall T ρ1 ρ2 v M l (equiv: T -> T -> Prop),
    ~(M ∈ support ρ1) ->
    (forall v, equiv v v) ->
    equivalent_with_relation
      ((M, M) :: idrel l)
      (ρ1 ++ (M, v) :: ρ2)
      ((M, v) :: ρ1 ++ ρ2)
      equiv
.
Proof.
  unfold equivalent_with_relation, equivalent_with;
    repeat match goal with
           | |- exists r, Some ?R = Some r /\ _ => exists R
           | |- exists r, _ /\ equivalent_rc r ?R => exists R
           | H: _ |- _ => rewrite lookup_remove2 in H by steps
           | _ => rewrite lookup_remove2 by steps
           | _ => step || t_lookup_rewrite || t_idrel || t_lookup || list_utils ||
                 rewrite obvious_lookup in * by steps ||
                 t_lookupor || t_lookup_same
           end;
    eauto.
Qed.

Lemma idrel_lookup2:
  forall x y l eq_dec, lookup eq_dec (idrel l) x = Some y -> x = y /\ x ∈ l.
Proof.
  induction l; repeat step || eapply_any || instantiate_any.
Qed.

Ltac t_idrel_lookup2 :=
  match goal with
  | H: lookup _ (idrel ?l) ?x = Some ?y |- _ => pose proof (idrel_lookup2 _ _ _ _ H); clear H
  end.

Lemma swap_idrel:
  forall l, swap (idrel l) = idrel l.
Proof.
  induction l; steps.
Qed.

Lemma equivalent_with_relation_permute2:
  forall T ρ1 ρ2 v X Y l (equiv: T -> T -> Prop),
    ~(X ∈ support ρ1) ->
    (forall v, equiv v v) ->
    equivalent_with_relation
      ((Y, X) :: idrel l)
      ((Y, v) :: ρ1 ++ ρ2)
      (ρ1 ++ (X, v) :: ρ2)
      equiv
.
Proof.
  unfold equivalent_with_relation, equivalent_with;
    repeat match goal with
           | |- exists r, Some ?R = Some r /\ _ => exists R
           | |- exists r, _ /\ equivalent_rc r ?R => exists R
           | H: _ |- _ => rewrite lookup_remove2 in H by steps
           | _ => rewrite lookup_remove2 by steps
           | _ => step || t_lookup_rewrite || t_idrel || t_lookup || list_utils ||
                 rewrite obvious_lookup in * by steps ||
                 t_lookupor || t_lookup_same
           end;
    eauto.
Qed.