(** proves Theorem 4.7 in Fiore & Saville, List Objects with Algebraic Structures, FSCD'17

    also instantiates it to present a variant of Lemma 4.8 in that paper

author: Ralph Matthes
formulation of Theorem 4.7 inspired by code provided by Ambroise Lafont available at https://github.com/amblafont/Skew-Monoidalcategories

2022
 *)

Require Import UniMath.Foundations.PartD.

Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Chains.Chains.
Require Import UniMath.CategoryTheory.Chains.Adamek.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration_alt.

Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Import BifunctorNotations.

Local Open Scope cat.

Local Notation carrier := (alg_carrier _ ).

Section A.

  Context {D C B A : category}
    (OC : Initial C)
    (chC : Colims_of_shape nat_graph C)
    (* (chA : Colims_of_shape nat_graph A) - superfluous assumption in the paper *)
    {J : C ⟶ A} (OJ : isInitial _ (J (InitialObject OC)))
    (omegaJ : is_omega_cocont J)
    {F : bifunctor D C C}
    (omegaF : ∏ d , is_omega_cocont (leftwhiskering_functor F d))
    (G : bifunctor B A A)
    (* (omegaG : ∏ b , is_omega_cocont (leftwhiskering_functor G b)) - superfluous assumption in the paper *)
    {K : D ⟶ B}
    (h : binat_trans (compose_bifunctor_with_functor F J)
           (compose_functor_with_bifunctor K J G)).

  Let OA : Initial A := make_Initial _ OJ.

  Context {a : A} {d : D} (α : A ⟦ (K d) ⊗_{G} a , a ⟧).

  Let iniChd : chain C := (initChain OC (leftwhiskering_functor F d)).

  Let μFd : category_FunctorAlg (leftwhiskering_functor F d)
      := (InitialObject (colimAlgInitial OC (omegaF d) (chC iniChd))).

  Definition statement_Thm47 : UU :=
        ∃! (β : A ⟦ J (carrier μFd) , a ⟧),
                h d (carrier μFd) · K d ⊗^{G}_{l} β · α  =
                # J (alg_map (leftwhiskering_functor F d) μFd) · β.

  Definition Thm47 : statement_Thm47.
  Proof.
    red.
    set (Mendler := GenMendlerIteration OC chC (leftwhiskering_functor F d) (omegaF d) a J OJ omegaJ).
    transparent assert (ψ : (ψ_source a J ⟹ ψ_target (leftwhiskering_functor F d) a J)).
    { use make_nat_trans.
      - intros y f.
        cbn; red.
        exact (h d y · (K d) ⊗^{G}_{l} f · α).
      - intros y y' f. cbn in f. apply funextsec. intro g. cbn in g. red in g. cbn.
        repeat rewrite assoc. apply cancel_postcomposition.
        rewrite bifunctor_leftcomp.
        rewrite assoc. apply cancel_postcomposition.
        apply pathsinv0, (pr12 h).
    }
    set (Mendlerinst := Mendler ψ).
    use tpair.
    - exists (pr11 Mendlerinst).
      apply pathsinv0. exact (pr21 Mendlerinst).
    - intro t.
      induction t as [β βeq].
      assert (Mendlerinst2 := pr2 Mendlerinst (β,,!βeq)).
      use subtypePath.
      { intro g. apply A. }
      apply (maponpaths pr1) in Mendlerinst2.
      etrans.
      { exact Mendlerinst2. }
      apply idpath.
  Defined.

End A.

Section B.

  Context {C : category } (Mon_V : monoidal C)
    (OC : Initial C) (chC : Colims_of_shape nat_graph C)
    {F : bifunctor C C C} (omegaF : ∏ c , is_omega_cocont (leftwhiskering_functor F c))
    (** Lemma 4.8 in the paper asks for global omega-cocontinuity of [F] *)
    (p : C).
    (** we formulate the statement for each [p] individually *)

  Let J : C ⟶ C := rightwhiskering_functor Mon_V p.
  Let G : bifunctor C C C := compose_functor_with_bifunctor J (functor_identity C) F.

  (** the next two lemmas are no longer needed without the continuity requirement on [G] of the theorem *)
  Local Lemma lwG_is_lwF (c : C) : leftwhiskering_functor G c = leftwhiskering_functor F (c ⊗_{Mon_V} p).
  Proof.
    apply functor_eq.
    { apply C. }
    apply idpath.
  Qed.

  Local Lemma omegaG (c : C) : is_omega_cocont (leftwhiskering_functor G c).
  Proof.
    rewrite lwG_is_lwF. apply omegaF.
  Qed.

  Context (OJ : isInitial _ (J (InitialObject OC))) (omegaJ : is_omega_cocont J)
    (h: binat_trans (compose_bifunctor_with_functor F J)
          (compose_functor_with_bifunctor (functor_identity C) J G))
    (** the target functor of [h] is "morally" [compose_functor_with_bifunctor J J F],
        hence [h] qualifies as strength data for [F], in the sense of p.3 of the paper, however
        with only naturality in the arguments to [F] and w/o the coherence conditions  *)
    (z c : C) (γ : C ⟦ (z ⊗_{ Mon_V} p) ⊗_{ F} c, c ⟧).

  Definition statement_Lemma_48 : UU
    := statement_Thm47 (D:=C)(B:=C)(A:=C) OC chC omegaF (* omegaG *) (K:=functor_identity C) G h (a:=c)(d:=z) γ.

  Let cc : ColimCocone (initChain OC (leftwhiskering_functor F z))
      := chC (initChain OC (leftwhiskering_functor F z)).

  Local Lemma statement_Lemma_48_ok : statement_Lemma_48 =
         ∃! β : C ⟦ colim cc ⊗_{ Mon_V} p, c ⟧,
                h z (colim cc) · (z ⊗_{ Mon_V} p) ⊗^{ F}_{l} β · γ =
                colim_algebra_mor OC (omegaF z) cc ⊗^{ Mon_V}_{r} p · β.
  Proof.
    apply idpath.
  Qed.

  Definition Lemma48 : statement_Lemma_48.
  Proof.
    red. apply Thm47.
    - exact OJ.
    - exact omegaJ.
  Defined.

End B.


Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Rupicola.Lib.Api.
Require Import Crypto.Bedrock.Group.ScalarMult.CSwap.
Require Import bedrock2.Semantics.
Require Import coqutil.Tactics.Tactics.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.Bedrock.Group.Loops.
Require Import Crypto.Bedrock.Group.ScalarMult.LadderStep.
Require Import Crypto.Bedrock.Group.ScalarMult.MontgomeryLadder.
Require Import Crypto.Curves.Montgomery.XZ.
Require Import Crypto.Curves.Montgomery.XZProofs.
Require Import Crypto.Util.Loops.

Section Equivalence.
  Context {field_parameters : FieldParameters}.

  (*TODO: which of ladderstep_gallina and M.xzladderstep should we change? either?*)
  Definition reorder_pairs {A B C D} (p : \<<A , B , C , D\>>) : (A*B)*(C*D) :=
    (P2.car p, P2.car (P2.cdr p),((P2.car (P2.cdr (P2.cdr p))),(P2.cdr (P2.cdr (P2.cdr p))))).

  (* TODO: should M.montladder change to accomodate this? *)
  Definition to_pair {A B} p : A*B := (P2.car p, P2.cdr p).

  Lemma invert_reorder_pairs {A B C D} (p : \<<A , B , C , D\>>) w x y z
    : reorder_pairs p = (w,x, (y,z)) <-> p = \<w,x,y,z\>.
  Proof.
    destruct p as [? [? [? ?]]].
    cbv.
    intuition congruence.
  Qed.

  Lemma ladderstep_gallina_equiv X1 P1 P2 :
    reorder_pairs (ladderstep_gallina _ a24 X1 (fst P1) (snd P1) (fst P2) (snd P2)) =
    @M.xzladderstep
      _ F.add F.sub F.mul a24 X1 P1 P2.
  Proof.
    intros. cbv [ladderstep_gallina M.xzladderstep].
    destruct P1 as [x1 z1]. destruct P2 as [x2 z2].
    cbv [Rewriter.Util.LetIn.Let_In nlet]. cbn [fst snd].
    rewrite !F.pow_2_r; trivial.
  Qed.

  Lemma montladder_gallina_equiv scalarbits n point :
    montladder_gallina _ a24 scalarbits n point =
    @M.montladder _ F.zero F.one F.add F.sub F.mul F.inv
      a24 (fun b x y => to_pair (cswap b x y)) (Z.of_nat scalarbits) (Z.testbit n) point.
  Proof.
    cbv [montladder_gallina M.montladder Rewriter.Util.LetIn.Let_In stack].
    do 5 (unfold nlet at 1); cbn [fst snd P2.car P2.cdr].
    rewrite downto_while.
    match goal with
    | |- ?lhs = ?rhs =>
      match lhs with context [while ?ltest ?lbody ?fuel ?linit] =>
      match rhs with context [while ?rtest ?rbody ?fuel ?rinit] =>
      rewrite (while.preservation ltest lbody rtest rbody
        (fun s1 s2 => s1 = let '(x2, z2, x3, z3, swap, i) := s2 in
        (\<x2, z2, x3, z3, swap\>, i))) with (init2:=rinit)
    end end end.
    { rewrite !Nat2Z.id. destruct (while _ _ _ _) eqn:? at 1 2.
      destruct_products; reflexivity. }
    { intros. destruct_products. congruence. }
    { intros. destruct_products. Prod.inversion_prod. LtbToLt.Z.ltb_to_lt. subst.
      rewrite !Z2Nat.id by lia.
      cbv [nlet].
      repeat match goal with
             | H : (_,_) = (_,_) |- _ => inversion H; subst; clear H
             | _ => progress BreakMatch.break_match
             | _ => progress BreakMatch.break_match_hyps
             end.
      rewrite <- ladderstep_gallina_equiv, invert_reorder_pairs  in Heqp2.
      cbn [fst snd] in Heqp2.
      unfold to_pair in Heqp0;
      inversion Heqp0; subst; clear Heqp0.
      unfold to_pair in Heqp1;
        inversion Heqp1; subst; clear Heqp1.
      set (ladderstep_gallina _ _ _ _ _ _ _) in *.
      rewrite Heqp2. reflexivity. }
    { reflexivity. }
  Qed.

End Equivalence.


Require Import FreeVarsExpr.
Require Import Syntax.
Require Import StringSet.
Require Import Option.
Require Import Union.
Import StringSet.

Set Implicit Arguments.

Local Notation e_free_vars := FreeVarsExpr.free_vars.

Fixpoint free_vars (s : Syntax.Stmt) :=
  match s with
    | Syntax.Skip => empty
    | Syntax.Seq a b => union (free_vars a) (free_vars b)
    | Syntax.If cond t f => union (union (e_free_vars cond) (free_vars t)) (free_vars f)
    | Syntax.While cond body => union (e_free_vars cond) (free_vars body)
    | Syntax.Call var f args =>
      union
        (union
           (default empty (option_map singleton var))
           (e_free_vars f))
        (union_list (List.map e_free_vars args))
    | Syntax.Label x lbl => singleton x
    | Syntax.Assign x e => union (singleton x) (e_free_vars e)
  end.


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

(*i $Id: PSeries_reg.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Ranalysis1.
Require Import Max.
Require Import Even.
Open Local Scope R_scope.

Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.

(** Uniform convergence *)
Definition CVU (fn:nat -> R -> R) (f:R -> R) (x:R)
  (r:posreal) : Prop :=
  forall eps:R,
    0 < eps ->
    exists N : nat,
      (forall (n:nat) (y:R),
        (N <= n)%nat -> Boule x r y -> Rabs (f y - fn n y) < eps).

(** Normal convergence *)
Definition CVN_r (fn:nat -> R -> R) (r:posreal) : Type :=
  { An:nat -> R &
    { l:R |
      Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n) l /\
      (forall (n:nat) (y:R), Boule 0 r y -> Rabs (fn n y) <= An n) } }.

Definition CVN_R (fn:nat -> R -> R) : Type := forall r:posreal, CVN_r fn r.

Definition SFL (fn:nat -> R -> R)
  (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l })
  (y:R) : R := let (a,_) := cv y in a.

(** In a complete space, normal convergence implies uniform convergence *)
Lemma CVN_CVU :
  forall (fn:nat -> R -> R)
    (cv:forall x:R, {l:R | Un_cv (fun N:nat => SP fn N x) l })
    (r:posreal), CVN_r fn r -> CVU (fun n:nat => SP fn n) (SFL fn cv) 0 r.
Proof.
  intros; unfold CVU in |- *; intros.
  unfold CVN_r in X.
  elim X; intros An X0.
  elim X0; intros s H0.
  elim H0; intros.
  cut (Un_cv (fun n:nat => sum_f_R0 (fun k:nat => Rabs (An k)) n - s) 0).
  intro; unfold Un_cv in H3.
  elim (H3 eps H); intros N0 H4.
  exists N0; intros.
  apply Rle_lt_trans with (Rabs (sum_f_R0 (fun k:nat => Rabs (An k)) n - s)).
  rewrite <- (Rabs_Ropp (sum_f_R0 (fun k:nat => Rabs (An k)) n - s));
    rewrite Ropp_minus_distr';
      rewrite (Rabs_right (s - sum_f_R0 (fun k:nat => Rabs (An k)) n)).
  eapply sum_maj1.
  unfold SFL in |- *; case (cv y); intro.
  trivial.
  apply H1.
  intro; elim H0; intros.
  rewrite (Rabs_right (An n0)).
  apply H8; apply H6.
  apply Rle_ge; apply Rle_trans with (Rabs (fn n0 y)).
  apply Rabs_pos.
  apply H8; apply H6.
  apply Rle_ge;
    apply Rplus_le_reg_l with (sum_f_R0 (fun k:nat => Rabs (An k)) n).
  rewrite Rplus_0_r; unfold Rminus in |- *; rewrite (Rplus_comm s);
    rewrite <- Rplus_assoc; rewrite Rplus_opp_r; rewrite Rplus_0_l;
      apply sum_incr.
  apply H1.
  intro; apply Rabs_pos.
  unfold R_dist in H4; unfold Rminus in H4; rewrite Ropp_0 in H4.
  assert (H7 := H4 n H5).
  rewrite Rplus_0_r in H7; apply H7.
  unfold Un_cv in H1; unfold Un_cv in |- *; intros.
  elim (H1 _ H3); intros.
  exists x; intros.
  unfold R_dist in |- *; unfold R_dist in H4.
  rewrite Rminus_0_r; apply H4; assumption.
Qed.

(** Each limit of a sequence of functions which converges uniformly is continue *)
Lemma CVU_continuity :
  forall (fn:nat -> R -> R) (f:R -> R) (x:R) (r:posreal),
    CVU fn f x r ->
    (forall (n:nat) (y:R), Boule x r y -> continuity_pt (fn n) y) ->
    forall y:R, Boule x r y -> continuity_pt f y.
Proof.
  intros; unfold continuity_pt in |- *; unfold continue_in in |- *;
    unfold limit1_in in |- *; unfold limit_in in |- *;
      simpl in |- *; unfold R_dist in |- *; intros.
  unfold CVU in H.
  cut (0 < eps / 3);
    [ intro
      | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
        [ assumption | apply Rinv_0_lt_compat; prove_sup0 ] ].
  elim (H _ H3); intros N0 H4.
  assert (H5 := H0 N0 y H1).
  cut (exists del : posreal, (forall h:R, Rabs h < del -> Boule x r (y + h))).
  intro.
  elim H6; intros del1 H7.
  unfold continuity_pt in H5; unfold continue_in in H5; unfold limit1_in in H5;
    unfold limit_in in H5; simpl in H5; unfold R_dist in H5.
  elim (H5 _ H3); intros del2 H8.
  set (del := Rmin del1 del2).
  exists del; intros.
  split.
  unfold del in |- *; unfold Rmin in |- *; case (Rle_dec del1 del2); intro.
  apply (cond_pos del1).
  elim H8; intros; assumption.
  intros;
    apply Rle_lt_trans with (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - f y)).
  replace (f x0 - f y) with (f x0 - fn N0 x0 + (fn N0 x0 - f y));
  [ apply Rabs_triang | ring ].
  apply Rle_lt_trans with
    (Rabs (f x0 - fn N0 x0) + Rabs (fn N0 x0 - fn N0 y) + Rabs (fn N0 y - f y)).
  rewrite Rplus_assoc; apply Rplus_le_compat_l.
  replace (fn N0 x0 - f y) with (fn N0 x0 - fn N0 y + (fn N0 y - f y));
  [ apply Rabs_triang | ring ].
  replace eps with (eps / 3 + eps / 3 + eps / 3).
  repeat apply Rplus_lt_compat.
  apply H4.
  apply le_n.
  replace x0 with (y + (x0 - y)); [ idtac | ring ]; apply H7.
  elim H9; intros.
  apply Rlt_le_trans with del.
  assumption.
  unfold del in |- *; apply Rmin_l.
  elim H8; intros.
  apply H11.
  split.
  elim H9; intros; assumption.
  elim H9; intros; apply Rlt_le_trans with del.
  assumption.
  unfold del in |- *; apply Rmin_r.
  rewrite <- Rabs_Ropp; rewrite Ropp_minus_distr'; apply H4.
  apply le_n.
  assumption.
  apply Rmult_eq_reg_l with 3.
  do 2 rewrite Rmult_plus_distr_l; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
    rewrite Rinv_r_simpl_m.
  ring.
  discrR.
  discrR.
  cut (0 < r - Rabs (x - y)).
  intro; exists (mkposreal _ H6).
  simpl in |- *; intros.
  unfold Boule in |- *; replace (y + h - x) with (h + (y - x));
    [ idtac | ring ]; apply Rle_lt_trans with (Rabs h + Rabs (y - x)).
  apply Rabs_triang.
  apply Rplus_lt_reg_r with (- Rabs (x - y)).
  rewrite <- (Rabs_Ropp (y - x)); rewrite Ropp_minus_distr'.
  replace (- Rabs (x - y) + r) with (r - Rabs (x - y)).
  replace (- Rabs (x - y) + (Rabs h + Rabs (x - y))) with (Rabs h).
  apply H7.
  ring.
  ring.
  unfold Boule in H1; rewrite <- (Rabs_Ropp (x - y)); rewrite Ropp_minus_distr';
    apply Rplus_lt_reg_r with (Rabs (y - x)).
  rewrite Rplus_0_r; replace (Rabs (y - x) + (r - Rabs (y - x))) with (pos r);
    [ apply H1 | ring ].
Qed.

(**********)
Lemma continuity_pt_finite_SF :
  forall (fn:nat -> R -> R) (N:nat) (x:R),
    (forall n:nat, (n <= N)%nat -> continuity_pt (fn n) x) ->
    continuity_pt (fun y:R => sum_f_R0 (fun k:nat => fn k y) N) x.
Proof.
  intros; induction  N as [| N HrecN].
  simpl in |- *; apply (H 0%nat); apply le_n.
  simpl in |- *;
    replace (fun y:R => sum_f_R0 (fun k:nat => fn k y) N + fn (S N) y) with
    ((fun y:R => sum_f_R0 (fun k:nat => fn k y) N) + (fun y:R => fn (S N) y))%F;
    [ idtac | reflexivity ].
  apply continuity_pt_plus.
  apply HrecN.
  intros; apply H.
  apply le_trans with N; [ assumption | apply le_n_Sn ].
  apply (H (S N)); apply le_n.
Qed.

(** Continuity and normal convergence *)
Lemma SFL_continuity_pt :
  forall (fn:nat -> R -> R)
    (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l })
    (r:posreal),
    CVN_r fn r ->
    (forall (n:nat) (y:R), Boule 0 r y -> continuity_pt (fn n) y) ->
    forall y:R, Boule 0 r y -> continuity_pt (SFL fn cv) y.
Proof.
  intros; eapply CVU_continuity.
  apply CVN_CVU.
  apply X.
  intros; unfold SP in |- *; apply continuity_pt_finite_SF.
  intros; apply H.
  apply H1.
  apply H0.
Qed.

Lemma SFL_continuity :
  forall (fn:nat -> R -> R)
    (cv:forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }),
    CVN_R fn -> (forall n:nat, continuity (fn n)) -> continuity (SFL fn cv).
Proof.
  intros; unfold continuity in |- *; intro.
  cut (0 < Rabs x + 1);
    [ intro | apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ] ].
  cut (Boule 0 (mkposreal _ H0) x).
  intro; eapply SFL_continuity_pt with (mkposreal _ H0).
  apply X.
  intros; apply (H n y).
  apply H1.
  unfold Boule in |- *; simpl in |- *; rewrite Rminus_0_r;
    pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r;
      apply Rplus_lt_compat_l; apply Rlt_0_1.
Qed.

(** As R is complete, normal convergence implies that (fn) is simply-uniformly convergent *)
Lemma CVN_R_CVS :
  forall fn:nat -> R -> R,
    CVN_R fn -> forall x:R, { l:R | Un_cv (fun N:nat => SP fn N x) l }.
Proof.
  intros; apply R_complete.
  unfold SP in |- *; set (An := fun N:nat => fn N x).
  change (Cauchy_crit_series An) in |- *.
  apply cauchy_abs.
  unfold Cauchy_crit_series in |- *; apply CV_Cauchy.
  unfold CVN_R in X; cut (0 < Rabs x + 1).
  intro; assert (H0 := X (mkposreal _ H)).
  unfold CVN_r in H0; elim H0; intros Bn H1.
  elim H1; intros l H2.
  elim H2; intros.
  apply Rseries_CV_comp with Bn.
  intro; split.
  apply Rabs_pos.
  unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
    rewrite Rminus_0_r.
  pattern (Rabs x) at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
    apply Rlt_0_1.
  exists l.
  cut (forall n:nat, 0 <= Bn n).
  intro; unfold Un_cv in H3; unfold Un_cv in |- *; intros.
  elim (H3 _ H6); intros.
  exists x0; intros.
  replace (sum_f_R0 Bn n) with (sum_f_R0 (fun k:nat => Rabs (Bn k)) n).
  apply H7; assumption.
  apply sum_eq; intros; apply Rabs_right; apply Rle_ge; apply H5.
  intro; apply Rle_trans with (Rabs (An n)).
  apply Rabs_pos.
  unfold An in |- *; apply H4; unfold Boule in |- *; simpl in |- *;
    rewrite Rminus_0_r; pattern (Rabs x) at 1 in |- *;
      rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rlt_0_1.
  apply Rplus_le_lt_0_compat; [ apply Rabs_pos | apply Rlt_0_1 ].
Qed.


From Hammer Require Import Hammer.

From compcert Require Import Core.
Require Import Psatz.

Section Fprop_relative.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Section Fprop_relative_generic.

Variable fexp : Z -> Z.
Context { prop_exp : Valid_exp fexp }.

Section relative_error_conversion.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Lemma relative_error_lt_conversion :
forall x b, (0 < b)%R ->
(x <> 0 -> Rabs (round beta fexp rnd x - x) < b * Rabs x)%R ->
exists eps,
(Rabs eps < b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_lt_conversion".
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].

exists 0%R.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...

specialize (Hxb Hx0).
exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_lt_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

Lemma relative_error_le_conversion :
forall x b, (0 <= b)%R ->
(Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R ->
exists eps,
(Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_le_conversion".
intros x b Hb0 Hxb.
destruct (Req_dec x 0) as [Hx0|Hx0].

exists 0%R.
split.
now rewrite Rabs_R0.
rewrite Hx0, Rmult_0_l.
apply round_0...

exists ((round beta fexp rnd x - x) / x)%R.
split. 2: now field.
unfold Rdiv.
rewrite Rabs_mult.
apply Rmult_le_reg_r with (Rabs x).
now apply Rabs_pos_lt.
rewrite Rmult_assoc, <- Rabs_mult.
rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.

Lemma relative_error_le_conversion_inv :
forall x b,
(exists eps,
(Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R) ->
(Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_le_conversion_inv".
intros x b (eps, (Beps, Heps)).
assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|].
rewrite Heps; replace (_ - _)%R with (eps * x)%R; [|ring].
now rewrite Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|].
Qed.

Lemma relative_error_le_conversion_round_inv :
forall x b,
(exists eps,
(Rabs eps <= b)%R /\ x = (round beta fexp rnd x * (1 + eps))%R) ->
(Rabs (round beta fexp rnd x - x) <= b * Rabs (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_le_conversion_round_inv".
intros x b.
set (rx := round _ _ _ _).
intros (eps, (Beps, Heps)).
assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|].
rewrite Heps; replace (_ - _)%R with (- (eps * rx))%R; [|ring].
now rewrite Rabs_Ropp, Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|].
Qed.

End relative_error_conversion.

Variable emin p : Z.
Hypothesis Hmin : forall k, (emin < k)%Z -> (p <= k - fexp k)%Z.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error :
forall x,
(bpow emin <= Rabs x)%R ->
(Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error".
intros x Hx.
assert (Hx': (x <> 0)%R).
intros T; contradict Hx; rewrite T, Rabs_R0.
apply Rlt_not_le, bpow_gt_0.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply error_lt_ulp...
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

Theorem relative_error_ex :
forall x,
(bpow emin <= Rabs x)%R ->
exists eps,
(Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_ex".
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
intros _.
now apply relative_error.
Qed.

Theorem relative_error_F2R_emin :
forall m, let x := F2R (Float beta m emin) in
(x <> 0)%R ->
(Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs x)%R.
Proof. hammer_hook "Relative" "Relative.relative_error_F2R_emin".
intros m x Hx.
apply relative_error.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_F2R_emin_ex :
forall m, let x := F2R (Float beta m emin) in
exists eps,
(Rabs eps < bpow (-p + 1))%R /\ round beta fexp rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_F2R_emin_ex".
intros m x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_F2R_emin.
Qed.

Theorem relative_error_round :
(0 < p)%Z ->
forall x,
(bpow emin <= Rabs x)%R ->
(Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_round".
intros Hp x Hx.
assert (Hx': (x <> 0)%R).
intros T; contradict Hx; rewrite T, Rabs_R0.
apply Rlt_not_le, bpow_gt_0.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply error_lt_ulp.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x _ Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
omega.
Qed.

Theorem relative_error_round_F2R_emin :
(0 < p)%Z ->
forall m, let x := F2R (Float beta m emin) in
(x <> 0)%R ->
(Rabs (round beta fexp rnd x - x) < bpow (-p + 1) * Rabs (round beta fexp rnd x))%R.
Proof. hammer_hook "Relative" "Relative.relative_error_round_F2R_emin".
intros Hp m x Hx.
apply relative_error_round.
exact Hp.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N :
forall x,
(bpow emin <= Rabs x)%R ->
(Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof. hammer_hook "Relative" "Relative.relative_error_N".
intros x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply error_le_half_ulp.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
assert (emin < ex)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
apply He.
Qed.

Theorem relative_error_N_ex :
forall x,
(bpow emin <= Rabs x)%R ->
exists eps,
(Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_ex".
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N.
Qed.

Theorem relative_error_N_F2R_emin :
forall m, let x := F2R (Float beta m emin) in
(Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_F2R_emin".
intros m x.
destruct (Req_dec x 0) as [Hx|Hx].

rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.

apply relative_error_N.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

Theorem relative_error_N_F2R_emin_ex :
forall m, let x := F2R (Float beta m emin) in
exists eps,
(Rabs eps <= /2 * bpow (-p + 1))%R /\ round beta fexp (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_F2R_emin_ex".
intros m x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_F2R_emin.
Qed.

Theorem relative_error_N_round :
(0 < p)%Z ->
forall x,
(bpow emin <= Rabs x)%R ->
(Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_round".
intros Hp x Hx.
apply Rle_trans with (/2 * ulp beta fexp x)%R.
now apply error_le_half_ulp.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
now apply IZR_lt.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
rewrite ulp_neq_0; trivial.
unfold cexp.
destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
apply (lt_bpow beta).
apply Rle_lt_trans with (2 := proj2 He).
exact Hx.
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
rewrite <- bpow_plus.
apply bpow_le.
generalize (Hmin ex).
omega.
apply Rmult_le_compat_l.
apply bpow_ge_0.
generalize He.
apply round_abs_abs...
clear rnd valid_rnd x Hx Hx' He.
intros rnd valid_rnd x _ Hx.
rewrite <- (round_generic beta fexp rnd (bpow (ex - 1))).
now apply round_le.
apply generic_format_bpow.
ring_simplify (ex - 1 + 1)%Z.
generalize (Hmin ex).
omega.
Qed.

Theorem relative_error_N_round_F2R_emin :
(0 < p)%Z ->
forall m, let x := F2R (Float beta m emin) in
(Rabs (round beta fexp (Znearest choice) x - x) <= /2 * bpow (-p + 1) * Rabs (round beta fexp (Znearest choice) x))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_round_F2R_emin".
intros Hp m x.
destruct (Req_dec x 0) as [Hx|Hx].

rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.

apply relative_error_N_round with (1 := Hp).
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.

End Fprop_relative_generic.

Section Fprop_relative_FLX.

Variable prec : Z.
Variable Hp : Z.lt 0 prec.

Lemma relative_error_FLX_aux :
forall k, (prec <= k - FLX_exp prec k)%Z.
Proof. hammer_hook "Relative" "Relative.relative_error_FLX_aux".
intros k.
unfold FLX_exp.
omega.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLX :
forall x,
(x <> 0)%R ->
(Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_FLX".
intros x Hx.
destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

Theorem relative_error_FLX_ex :
forall x,
exists eps,
(Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_FLX_ex".
intros x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLX.
Qed.

Theorem relative_error_FLX_round :
forall x,
(x <> 0)%R ->
(Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_FLX_round".
intros x Hx.
destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error_round with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLX :
forall x,
(Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLX".
intros x.
destruct (Req_dec x 0) as [Hx|Hx].

rewrite Hx, round_0...
unfold Rminus.
rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
rewrite Rmult_0_r.
apply Rle_refl.

destruct (mag beta x) as (ex, He).
specialize (He Hx).
apply relative_error_N with (ex - 1)%Z...
intros k _.
apply relative_error_FLX_aux.
apply He.
Qed.

Definition u_ro := (/2 * bpow (-prec + 1))%R.

Lemma u_ro_pos : (0 <= u_ro)%R.
Proof. hammer_hook "Relative" "Relative.u_ro_pos". apply Rmult_le_pos; [lra|apply bpow_ge_0]. Qed.

Lemma u_ro_lt_1 : (u_ro < 1)%R.
Proof. hammer_hook "Relative" "Relative.u_ro_lt_1".
unfold u_ro; apply (Rmult_lt_reg_l 2); [lra|].
rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, Rmult_1_r; [|lra].
apply (Rle_lt_trans _ (bpow 0));
[apply bpow_le; omega|simpl; lra].
Qed.

Lemma u_rod1pu_ro_pos : (0 <= u_ro / (1 + u_ro))%R.
Proof. hammer_hook "Relative" "Relative.u_rod1pu_ro_pos".
apply Rmult_le_pos; [|apply Rlt_le, Rinv_0_lt_compat];
assert (H := u_ro_pos); lra.
Qed.

Lemma u_rod1pu_ro_le_u_ro : (u_ro / (1 + u_ro) <= u_ro)%R.
Proof. hammer_hook "Relative" "Relative.u_rod1pu_ro_le_u_ro".
assert (Pu_ro := u_ro_pos).
apply (Rmult_le_reg_r (1 + u_ro)); [lra|].
unfold Rdiv; rewrite Rmult_assoc, Rinv_l; [|lra].
assert (0 <= u_ro * u_ro)%R; [apply Rmult_le_pos|]; lra.
Qed.

Theorem relative_error_N_FLX' :
forall x,
(Rabs (round beta (FLX_exp prec) (Znearest choice) x - x)
<= u_ro / (1 + u_ro) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLX'".
intro x.
assert (Pu_ro : (0 <= u_ro)%R).
{ apply Rmult_le_pos; [lra|apply bpow_ge_0]. }
destruct (Req_dec x 0) as [Zx|Nzx].
{ rewrite Zx, Rabs_R0, Rmult_0_r, round_0...
now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. }
set (ufpx := bpow (mag beta x - 1)%Z).
set (rx := round _ _ _ _).
assert (Pufpx : (0 <= ufpx)%R); [now apply bpow_ge_0|].
assert (H_2_1 : (Rabs (rx - x) <= u_ro * ufpx)%R).
{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _);
[now apply FLX_exp_valid|right].
unfold ulp, cexp, FLX_exp, u_ro, ufpx; rewrite (Req_bool_false _ _ Nzx).
rewrite Rmult_assoc, <-bpow_plus; do 2 f_equal; ring. }
assert (H_2_3 : (ufpx + Rabs (rx - x) <= Rabs x)%R).
{ apply (Rplus_le_reg_r (- ufpx)); ring_simplify.
destruct (Rle_or_lt 0 x) as [Sx|Sx].
{ apply (Rle_trans _ (Rabs (ufpx - x))).
{ apply round_N_pt; [now apply FLX_exp_valid|].
apply generic_format_bpow; unfold FLX_exp; lia. }
rewrite Rabs_minus_sym, Rabs_pos_eq.
{ now rewrite Rabs_pos_eq; [right; ring|]. }
apply (Rplus_le_reg_r ufpx); ring_simplify.
now rewrite <-(Rabs_pos_eq _ Sx); apply bpow_mag_le. }
apply (Rle_trans _ (Rabs (- ufpx - x))).
{ apply round_N_pt; [now apply FLX_exp_valid|].
apply generic_format_opp, generic_format_bpow; unfold FLX_exp; lia. }
rewrite Rabs_pos_eq; [now rewrite Rabs_left; [right|]|].
apply (Rplus_le_reg_r x); ring_simplify.
rewrite <-(Ropp_involutive x); apply Ropp_le_contravar; unfold ufpx.
rewrite <-mag_opp, <-Rabs_pos_eq; [apply bpow_mag_le|]; lra. }
assert (H : (Rabs ((rx - x) / x) <= u_ro / (1 + u_ro))%R).
{ assert (H : (0 < ufpx + Rabs (rx - x))%R).
{ apply Rplus_lt_le_0_compat; [apply bpow_gt_0|apply Rabs_pos]. }
apply (Rle_trans _ (Rabs (rx - x) / (ufpx + Rabs (rx - x)))).
{ unfold Rdiv; rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos|].
now rewrite (Rabs_Rinv _ Nzx); apply Rinv_le. }
apply (Rmult_le_reg_r ((ufpx + Rabs (rx - x)) * (1 + u_ro))).
{ apply Rmult_lt_0_compat; lra. }
field_simplify; [try unfold Rdiv; rewrite ?Rinv_1, ?Rmult_1_r| |]; lra. }
revert H; unfold Rdiv; rewrite Rabs_mult, (Rabs_Rinv _ Nzx); intro H.
apply (Rmult_le_reg_r (/ Rabs x)); [now apply Rinv_0_lt_compat, Rabs_pos_lt|].
now apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0|lra].
Qed.

Theorem relative_error_N_FLX_ex :
forall x,
exists eps,
(Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLX_ex".
intros x.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_FLX.
Qed.

Theorem relative_error_N_FLX'_ex :
forall x,
exists eps,
(Rabs eps <= u_ro / (1 + u_ro))%R /\
round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLX'_ex".
intros x.
apply relative_error_le_conversion...
{ apply u_rod1pu_ro_pos. }
now apply relative_error_N_FLX'.
Qed.

Lemma relative_error_N_round_ex_derive :
forall x rx,
(exists eps, (Rabs eps <= u_ro / (1 + u_ro))%R /\ rx = (x * (1 + eps))%R) ->
exists eps, (Rabs eps <= u_ro)%R /\ x = (rx * (1 + eps))%R.
Proof. hammer_hook "Relative" "Relative.relative_error_N_round_ex_derive".
intros x rx (d, (Bd, Hd)).
assert (Pu_ro := u_ro_pos).
assert (H := Rabs_le_inv _ _ Bd).
assert (H' := u_rod1pu_ro_le_u_ro); assert (H'' := u_ro_lt_1).
destruct (Req_dec rx 0) as [Zfx|Nzfx].
{ exists 0%R; split; [now rewrite Rabs_R0|].
rewrite Rplus_0_r, Rmult_1_r, Zfx.
now rewrite Zfx in Hd; destruct (Rmult_integral _ _ (sym_eq Hd)); [|lra]. }
destruct (Req_dec x 0) as [Zx|Nzx].
{ now exfalso; revert Hd; rewrite Zx, Rmult_0_l. }
set (d' := ((x - rx) / rx)%R).
assert (Hd' : (Rabs d' <= u_ro)%R).
{ unfold d'; rewrite Hd.
replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra].
unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp.
rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra].
apply (Rmult_le_reg_r (1 + d)); [lra|].
rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra].
apply (Rle_trans _ _ _ Bd).
unfold Rdiv; apply Rmult_le_compat_l; [now apply u_ro_pos|].
apply (Rle_trans _ (1 - u_ro / (1 + u_ro))); [right; field|]; lra. }
now exists d'; split; [|unfold d'; field].
Qed.

Theorem relative_error_N_FLX_round_ex :
forall x,
exists eps,
(Rabs eps <= u_ro)%R /\
x = (round beta (FLX_exp prec) (Znearest choice) x * (1 + eps))%R.
Proof. hammer_hook "Relative" "Relative.relative_error_N_FLX_round_ex".
intro x; apply relative_error_N_round_ex_derive, relative_error_N_FLX'_ex.
Qed.

Theorem relative_error_N_FLX_round :
forall x,
(Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs(round beta (FLX_exp prec) (Znearest choice) x))%R.
Proof. hammer_hook "Relative" "Relative.relative_error_N_FLX_round".
intro x.
apply relative_error_le_conversion_round_inv, relative_error_N_FLX_round_ex.
Qed.

End Fprop_relative_FLX.

Section Fprop_relative_FLT.

Variable emin prec : Z.
Variable Hp : Z.lt 0 prec.

Lemma relative_error_FLT_aux :
forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z.
Proof. hammer_hook "Relative" "Relative.relative_error_FLT_aux".
intros k Hk.
unfold FLT_exp.
generalize (Zmax_spec (k - prec) emin).
omega.
Qed.

Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.

Theorem relative_error_FLT :
forall x,
(bpow (emin + prec - 1) <= Rabs x)%R ->
(Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_FLT".
intros x Hx.
apply relative_error with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_FLT_F2R_emin :
forall m, let x := F2R (Float beta m emin) in
(x <> 0)%R ->
(Rabs (round beta (FLT_exp emin prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_FLT_F2R_emin".
intros m x Zx.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_lt_0_compat.
apply bpow_gt_0.
now apply Rabs_pos_lt.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
now apply relative_error_FLT.
Qed.

Theorem relative_error_FLT_F2R_emin_ex :
forall m, let x := F2R (Float beta m emin) in
exists eps,
(Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_FLT_F2R_emin_ex".
intros m x.
apply relative_error_lt_conversion...
apply bpow_gt_0.
now apply relative_error_FLT_F2R_emin.
Qed.

Theorem relative_error_FLT_ex :
forall x,
(bpow (emin + prec - 1) <= Rabs x)%R ->
exists eps,
(Rabs eps < bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) rnd x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_FLT_ex".
intros x Hx.
apply relative_error_lt_conversion...
apply bpow_gt_0.
intros _; now apply relative_error_FLT.
Qed.

Variable choice : Z -> bool.

Theorem relative_error_N_FLT :
forall x,
(bpow (emin + prec - 1) <= Rabs x)%R ->
(Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLT".
intros x Hx.
apply relative_error_N with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_N_FLT_ex :
forall x,
(bpow (emin + prec - 1) <= Rabs x)%R ->
exists eps,
(Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLT_ex".
intros x Hx.
apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_FLT.
Qed.

Theorem relative_error_N_FLT_round :
forall x,
(bpow (emin + prec - 1) <= Rabs x)%R ->
(Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLT_round".
intros x Hx.
apply relative_error_N_round with (emin + prec - 1)%Z...
apply relative_error_FLT_aux.
Qed.

Theorem relative_error_N_FLT_F2R_emin :
forall m, let x := F2R (Float beta m emin) in
(Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLT_F2R_emin".
intros m x.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
apply Rabs_pos.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
now apply relative_error_N_FLT.
Qed.

Theorem relative_error_N_FLT_F2R_emin_ex :
forall m, let x := F2R (Float beta m emin) in
exists eps,
(Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLT_F2R_emin_ex".
intros m x.
apply relative_error_le_conversion...
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
now apply relative_error_N_FLT_F2R_emin.
Qed.

Theorem relative_error_N_FLT_round_F2R_emin :
forall m, let x := F2R (Float beta m emin) in
(Rabs (round beta (FLT_exp emin prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLT_exp emin prec) (Znearest choice) x))%R.
Proof with auto with typeclass_instances. hammer_hook "Relative" "Relative.relative_error_N_FLT_round_F2R_emin".
intros m x.
destruct (Rlt_or_le (Rabs x) (bpow (emin + prec - 1))) as [Hx|Hx].
rewrite round_generic...
unfold Rminus.
rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rmult_le_pos.
apply Rlt_le.
apply (RinvN_pos 1).
apply bpow_ge_0.
apply Rabs_pos.
apply generic_format_FLT_FIX...
apply Rlt_le.
apply Rlt_le_trans with (1 := Hx).
apply bpow_le.
apply Zle_pred.
apply generic_format_FIX.
now exists (Float beta m emin).
apply relative_error_N_round with (emin := (emin + prec - 1)%Z)...
apply relative_error_FLT_aux.
Qed.

Lemma error_N_FLT_aux :
forall x,
(0 < x)%R ->
exists eps, exists  eta,
(Rabs eps <= /2 * bpow (-prec + 1))%R /\
(Rabs eta <= /2 * bpow (emin))%R      /\
(eps*eta=0)%R /\
round beta (FLT_exp emin prec) (Znearest choice) x = (x * (1 + eps) + eta)%R.
Proof. hammer_hook "Relative" "Relative.error_N_FLT_aux".
intros x Hx2.
case (Rle_or_lt (bpow (emin+prec)) x); intros Hx.

destruct relative_error_N_ex with (FLT_exp emin prec) (emin+prec)%Z prec choice x
as (eps,(Heps1,Heps2)).
now apply FLT_exp_valid.
intros; unfold FLT_exp.
rewrite Zmax_left; omega.
rewrite Rabs_right;[assumption|apply Rle_ge; now left].
exists eps; exists 0%R.
split;[assumption|split].
rewrite Rabs_R0; apply Rmult_le_pos.
apply Rlt_le, pos_half_prf.
apply bpow_ge_0.
split;[apply Rmult_0_r|idtac].
now rewrite Rplus_0_r.

exists 0%R; exists (round beta (FLT_exp emin prec) (Znearest choice) x - x)%R.
split.
rewrite Rabs_R0; apply Rmult_le_pos.
apply Rlt_le, pos_half_prf.
apply bpow_ge_0.
split.
apply Rle_trans with (/2*ulp beta (FLT_exp emin prec) x)%R.
apply error_le_half_ulp.
now apply FLT_exp_valid.
apply Rmult_le_compat_l.
apply Rlt_le, pos_half_prf.
rewrite ulp_neq_0.
2: now apply Rgt_not_eq.
apply bpow_le.
unfold FLT_exp, cexp.
rewrite Zmax_right.
omega.
destruct (mag beta x) as (e,He); simpl.
assert (e-1 < emin+prec)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2:=Hx).
rewrite <- (Rabs_pos_eq x) by now apply Rlt_le.
now apply He, Rgt_not_eq.
omega.
split ; ring.
Qed.

Theorem relative_error_N_FLT'_ex :
forall x,
exists eps eta : R,
(Rabs eps <= u_ro prec / (1 + u_ro prec))%R /\
(Rabs eta <= /2 * bpow emin)%R /\
(eps * eta = 0)%R /\
round beta (FLT_exp emin prec) (Znearest choice) x
= (x * (1 + eps) + eta)%R.
Proof. hammer_hook "Relative" "Relative.relative_error_N_FLT'_ex".
intro x.
set (rx := round _ _ _ x).
assert (Pb := u_rod1pu_ro_pos prec).
destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs x)) as [MX|Mx].
{ destruct (relative_error_N_FLX'_ex prec Hp choice x) as (d, (Bd, Hd)).
exists d, 0%R; split; [exact Bd|]; split.
{ rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]. }
rewrite Rplus_0_r, Rmult_0_r; split; [reflexivity|].
now rewrite <- Hd; apply round_FLT_FLX. }
assert (H : (Rabs (rx - x) <= /2 * bpow emin)%R).
{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _);
[now apply FLT_exp_valid|].
rewrite ulp_FLT_small; [now right|now simpl|].
apply (Rlt_le_trans _ _ _ Mx), bpow_le; lia. }
exists 0%R, (rx - x)%R; split; [now rewrite Rabs_R0|]; split; [exact H|].
now rewrite Rmult_0_l, Rplus_0_r, Rmult_1_r; split; [|ring].
Qed.

Theorem relative_error_N_FLT'_ex_separate :
forall x,
exists x' : R,
round beta (FLT_exp emin prec) (Znearest choice) x'
= round beta (FLT_exp emin prec) (Znearest choice) x /\
(exists eta, Rabs eta <= /2 * bpow emin /\ x' = x + eta)%R /\
(exists eps, Rabs eps <= u_ro prec / (1 + u_ro prec) /\
round beta (FLT_exp emin prec) (Znearest choice) x'
= x' * (1 + eps))%R.
Proof. hammer_hook "Relative" "Relative.relative_error_N_FLT'_ex_separate".
intro x.
set (rx := round _ _ _ x).
destruct (relative_error_N_FLT'_ex x) as (d, (e, (Bd, (Be, (Hde0, Hde))))).
destruct (Rlt_or_le (Rabs (d * x)) (Rabs e)) as [HdxLte|HeLedx].
{ exists rx; split; [|split].
{ apply round_generic; [now apply valid_rnd_N|].
now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
{ exists e; split; [exact Be|].
unfold rx; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze].
{ now rewrite Zd, Rplus_0_r, Rmult_1_r. }
exfalso; revert HdxLte; rewrite Ze, Rabs_R0; apply Rle_not_lt, Rabs_pos. }
exists 0%R; split; [now rewrite Rabs_R0; apply u_rod1pu_ro_pos|].
rewrite Rplus_0_r, Rmult_1_r; apply round_generic; [now apply valid_rnd_N|].
now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
exists x; split; [now simpl|split].
{ exists 0%R; split;
[rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]|ring]. }
exists d; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze].
{ split; [exact Bd|].
assert (Ze : e = 0%R); [|now rewrite Ze, Rplus_0_r].
apply Rabs_eq_R0, Rle_antisym; [|now apply Rabs_pos].
now revert HeLedx; rewrite Zd, Rmult_0_l, Rabs_R0. }
now rewrite Ze, Rplus_0_r.
Qed.

End Fprop_relative_FLT.

Theorem error_N_FLT :
forall (emin prec : Z), (0 < prec)%Z ->
forall (choice : Z -> bool),
forall (x : R),
exists eps eta : R,
(Rabs eps <= /2 * bpow (-prec + 1))%R /\
(Rabs eta <= /2 * bpow emin)%R /\
(eps * eta = 0)%R /\
(round beta (FLT_exp emin prec) (Znearest choice) x
= x * (1 + eps) + eta)%R.
Proof. hammer_hook "Relative" "Relative.error_N_FLT".
intros emin prec Pprec choice x.
destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
{ assert (Pmx : (0 < - x)%R).
{ now rewrite <- Ropp_0; apply Ropp_lt_contravar. }
destruct (@error_N_FLT_aux emin prec Pprec
(fun t : Z => negb (choice (- (t + 1))%Z))
(- x)%R Pmx)
as (d,(e,(Hd,(He,(Hde,Hr))))).
exists d; exists (- e)%R; split; [exact Hd|split; [|split]].
{ now rewrite Rabs_Ropp. }
{ now rewrite Ropp_mult_distr_r_reverse, <- Ropp_0; apply f_equal. }
rewrite <- (Ropp_involutive x), round_N_opp.
now rewrite Ropp_mult_distr_l_reverse, <- Ropp_plus_distr; apply f_equal. }
{ assert (Ph2 : (0 <= / 2)%R).
{ apply (Rmult_le_reg_l 2 _ _ Rlt_0_2).
rewrite Rmult_0_r, Rinv_r; [exact Rle_0_1|].
apply Rgt_not_eq, Rlt_gt, Rlt_0_2. }
exists 0%R; exists 0%R; rewrite Zx; split; [|split; [|split]].
{ now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. }
{ now rewrite Rabs_R0; apply Rmult_le_pos; [|apply bpow_ge_0]. }
{ now rewrite Rmult_0_l. }
now rewrite Rmult_0_l, Rplus_0_l, round_0; [|apply valid_rnd_N]. }
now apply error_N_FLT_aux.
Qed.

End Fprop_relative.


(* Atoms for locally nameless *)

From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq path.

Require Import FinMap.ordtype.

Require Import Omega.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Module Type ATOM.

  Parameter atom : Set.
  Definition t := atom.

  (* atoms can be compared to booleans *)

  Parameter eq_atom : atom -> atom -> bool.
  Parameter eq_reflect : forall (a b : atom), ssrbool.reflect (a = b) (eq_atom a b).
  Parameter atom_eqMixin : Equality.mixin_of atom.
  Canonical atom_eqType := EqType atom atom_eqMixin.

  (* atoms can be ordered with an irreflexive order *)

  Parameter ltn : atom -> atom -> bool.
  Parameter ltn_irreflexive : forall x : atom, ltn x x = false.
  Parameter ltn_transitive : forall y x z : atom,
      ltn x y -> ltn y z -> ltn x z.
  Parameter ltn_total : forall a b : atom, [|| ltn a b, eq_atom a b | ltn b a].
  Parameter atom_ordMixin : Ordered.mixin_of atom_eqType.
  Canonical atom_ordType := OrdType atom atom_ordMixin.

  Parameter fresh : seq atom -> atom.

  Parameter fresh_not_in : forall l, (fresh l) \notin l.

  Parameter nat_of : atom -> nat.
End ATOM.

Module Atom : ATOM.

  (* begin hide *)
  Definition atom := nat.
  Definition t := atom.

  Definition eq_atom (a b : nat) : bool := ssrnat.eqn a b.

  Lemma eq_reflect a b :  ssrbool.reflect (a = b) (eq_atom a b).
  Proof. by apply: ssrnat.eqnP. Qed.

  Definition atom_eqMixin := EqMixin Atom.eq_reflect.
  Canonical atom_eqType := EqType atom atom_eqMixin.

  (* equality and ordered *)

  Definition ltn a b := a  < b.
  Lemma ltn_irreflexive : forall x : nat, x < x = false.
  Proof.
    intros ; apply ssrnat.ltnn.
  Qed.

  Definition ltn_transitive := ssrnat.ltn_trans.

  Lemma ltn_total : forall a b : nat, [|| a < b, a == b | b < a].
  Proof.
    move=> a b.
    rewrite/lt/eq.
    case ssrnat.ltngtP ; move=>H ; intuition ; rewrite Bool.orb_comm ; intuition.
  Qed.

  Definition atom_ordMixin : Ordered.mixin_of atom_eqType :=
    @OrdMixin
      atom_eqType
      ltn
      ltn_irreflexive
      ltn_trans
      ltn_total.
  Canonical atom_ordType := OrdType atom atom_ordMixin.

  Fixpoint fresh' a (l : seq atom) :=
    match l with
    | [::] => a +1
    | x::xs => fresh' (maxn x a) xs
    end.

  Definition fresh l := fresh' 0 l.

  Lemma fresh_not_head a a' l : a <= a' -> fresh' a' l != a.
  Proof.
    elim: l a' => [|  a'' l IHl] a' Le_a_a'.
      by rewrite /fresh' neq_ltn addn1 ltnS orb_idl.
    by rewrite /fresh' maxnC; apply IHl; rewrite leq_max orb_idr.
  Qed.

  Lemma fresh_not_in l : fresh l \notin l.
  Proof.
    suff fresh'_not_in a : fresh' a l \notin l by apply fresh'_not_in.
    elim: l a =>  // a' l IHl a.
      by rewrite /fresh/fresh' in_cons Bool.negb_orb fresh_not_head ?(IHl (maxn a' a)) ?leq_maxl.
  Qed.

  Definition nat_of (x : atom) := x.
  (* end hide *)
End Atom.

(** We make [atom], [fresh], [fresh_not_in] and [atom_fresh_for_list] available
    without qualification. *)

Notation atom := Atom.atom.
Notation fresh := Atom.fresh.
Notation fresh_not_in := Atom.fresh_not_in.

Canonical atom_eqType := EqType Atom.atom Atom.atom_eqMixin.
Canonical atom_ordType := OrdType Atom.atom Atom.atom_ordMixin.


Require Import Metalib.Metatheory.
Require Import Bool.

From STLCZK Require Import GaloisField.
From STLCZK Require Import Stlc.
From STLCZK Require Import R1cs.
From STLCZK Require Import Ltac.
Require Import Coqprime.elliptic.ZEll.
From Coq Require Import Vectors.VectorDef.
From Coq Require Import Init.Nat.
From Coq Require Import Lists.List.

Generalizable All Variables.

Module Normalize(PF: GaloisField).
  Import PF.
  Include Stlc PF.
  Import ListNotations.
  Local Open Scope nat_scope.

  Fixpoint normalize' (k: nat)(e: exp): exp :=
    match e with
    | <{ if true then e else _ }> => e
    | <{ if false then _ else e }> => e
    | <{ (\_: t, e1) e2 }> =>
      open_exp_wrt_exp_rec k (normalize' (S k) e1) (normalize' k e2)
    | <{ \_: _, _ }> => e (** Don't go under binders for HNF, skip heads in normalize'' *)
    | <{ (if c then \_:_, b1 else \_:_, b2) e }> =>
      let e' := normalize' k e in
      <{ if {normalize' k c}
         then {open_exp_wrt_exp_rec k (normalize' (S k) b1) e'}
         else {open_exp_wrt_exp_rec k (normalize' (S k) b2) e'} }>
    | <{ let e1 in e2 }> =>
      open_exp_wrt_exp_rec k (normalize' (S k) e2) (normalize' k e1)
    | <{ e1 e2 }> => tm_app (normalize' k e1) (normalize' k e2)
    | <{ e1 == e2 }> => <{ {normalize' k e1} == {normalize' k e2} }>
    | <{ ! e }> => <{ ! {normalize' k e} }>
    | <{ if c then e1 else e2 }> =>
      <{ if {normalize' k c} then {normalize' k e1} else {normalize' k e2} }>
    | <{ fp f1 + fp f2 }> =>
      let s := pkplus f1 f2 in
      <{ fp s }>
    | <{ fp f1 - fp f2 }> =>
      let s := pksub f1 f2 in
      <{ fp s }>
    | <{ fp f1 * fp f2 }> =>
      let s := pkmul f1 f2 in
      <{ fp s }>
    | <{ true && true }> => <{ true }>
    | <{ false && _ }> => <{ false }>
    | <{ _ && false }> => <{ false }>
    | <{ _ || true }> => <{ true }>
    | <{ true || _ }> => <{ true }>
    | <{ false || false }> => <{ false }>
    | tm_binop e1 op e2 => tm_binop (normalize' k e1) op (normalize' k e2)
    | o => o
    end.

  Fixpoint normalize''(e: exp)(k: nat)(gas: nat): option exp :=
    match gas with
    | 0%nat => None
    | S g' => let e' := normalize' k e in
             if eq_exp e' e then
               Some e'
             else
               normalize'' e' k  g'
    end.

  Fixpoint normalize(e: exp)(k: nat)(gas: nat): option exp :=
    match e with
    | <{ \_: t, e }> => match normalize e (S k) gas with
                       | Some e' => Some <{ \_: t, e' }>
                       | None => None
                       end
    | e => normalize'' e k gas
    end.

  Definition foo :=
    <{ \_: Field,
           \_: Bool,
               (if #0 then
                 (\_: Field, #0 + #0)
               else
                 (\_: Field, #0 * #0)
               ) #1
     }>.

  Definition bar' :=
    <{ \_: Field,
           (\_: Field, #0 - #0) #0
     }>.

  Definition bar :=
    <{ \_: Field,
           let (\_: Field, #0 - #0) in
           #0 #1
     }>.
  Compute normalize foo 0 10.
  Compute normalize bar 0 10.

  Lemma normalize_fixpoint: forall e,
      exists g, g > 0 -> normalize e g = e.
  Proof.
    induction e; cbn; try (exists 1; reflexivity).
    - destruct IHe.
      exists x.
      rewrite H.
      now reflexivity.
  Defined.

End Normalize.


From Coq Require Import Arith.Arith.
From Coq Require Import Lists.List.

From Elo Require Export Array.
From Elo Require Export Map.
From Elo Require Export Core.

Ltac splits n :=
  match n with
  | O => fail
  | S O => idtac
  | S ?n' => split; [| splits n']
  end.

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

Definition is_value t :=
  match t with
  | TM_Nil | TM_Num _ | TM_Arr _ _ | TM_Loc _ | TM_Fun _ _ _ _ => true
  | _ => false
  end.

Lemma value_equivalence_true : forall t,
  value t <-> is_value t = true.
Proof.
  intros t. split; induction t; intros H;
  try inversion H; auto using is_value, value.
Qed.

Lemma value_equivalence_false : forall t,
  ~ value t <-> is_value t = false.
Proof.
  intros t.
  assert (H : is_value t = false <-> is_value t <> true).
  { split; destruct t; try discriminate || contradiction || reflexivity. }
  split; rewrite H; rewrite <- value_equivalence_true; trivial.
Qed.

Lemma value_does_not_step : forall v eff t,
  value v -> ~ (v --[eff]--> t).
Proof.
  intros * Hv Hstep. destruct Hv; inversion Hstep.
Qed.

(* ------------------------------------------------------------------------- *)
(* Safe Types -------------------------------------------------------------- *)
(* ------------------------------------------------------------------------- *)

Lemma safe_type_equivalence : forall T,
  safe_type T <-> is_safe_type T = true.
Proof.
  intros T. split; induction T; intros H;
  try inversion H; auto using is_safe_type, safe_type.
Qed.

Definition safe_context Gamma :=
  forall id T, lookup Gamma id = Some T -> safe_type T.

Theorem safe_guarantees_safe_context : forall Gamma,
  safe_context (safe Gamma).
Proof.
  unfold safe_context, lookup, safe. intros Gamma id T.
  destruct (Gamma id); intros H; try discriminate.
  destruct is_safe_type eqn:E; inversion H.
  subst. apply safe_type_equivalence. assumption.
Qed.

Theorem safe_semantics : forall Gamma id T,
  lookup Gamma id = Some T ->
  (   safe_type T  -> lookup (safe Gamma) id = Some T) /\
  (~ (safe_type T) -> lookup (safe Gamma) id = None).
Proof.
  unfold lookup, safe. intros * H1. split;
  intros H2; destruct (Gamma id); inversion H1; subst;
  rewrite safe_type_equivalence in H2;
  try (apply Bool.not_true_is_false in H2);
  rewrite H2; reflexivity.
Qed.

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

Theorem deterministic_step : forall t eff t1 t2,
  t --[eff]--> t1 ->
  t --[eff]--> t2 ->
  t1 = t2.
Proof.
  intros * Hstep1. generalize dependent t2.
  induction Hstep1; intros * Hstep2; inversion Hstep2; subst;
  try solve
    [ congruence
    | match goal with
      | Hstep : ?v --[ _ ]--> _ , Hv : value ?v |- _ =>
          eapply value_does_not_step in Hstep; eauto; contradiction
      | F : TM_Nil         --[ _ ]--> _ |- _ => inversion F
      | F : TM_Num _       --[ _ ]--> _ |- _ => inversion F
      | F : TM_Arr _ _     --[ _ ]--> _ |- _ => inversion F
      | F : TM_Fun _ _ _ _ --[ _ ]--> _ |- _ => inversion F
      | F : TM_Loc _       --[ _ ]--> _ |- _ => inversion F
      | H : forall x, _ --[ _ ]--> x -> _ = x |- _ => erewrite H; eauto
      end
    ].
Qed.

Theorem deterministic_typing : forall mt Gamma t X Y,
  mt / Gamma |-- t is X ->
  mt / Gamma |-- t is Y ->
  X = Y.
Proof.
  intros * HX. generalize dependent Y.
  induction HX; intros Y HY; inversion HY; subst;
  try solve
    [ congruence
    | auto
    | match goal with
      | IH : forall T, ?mt / ?Gamma |-- ?t is T -> (_ _) = T,
        H : ?mt / ?Gamma |-- ?t is (_ _)
        |- _ = _ => apply IH in H; congruence
      end
    ].
Qed.

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

Inductive well_behaved_effect : effect -> mem -> Prop :=
  | well_behaved_none : forall m,
    well_behaved_effect EF_None m

  | well_behaved_spawn : forall m block,
    well_behaved_effect (EF_Spawn block) m

  | well_behaved_alloc : forall m v,
    well_behaved_effect (EF_Alloc (length m) v) m

  | well_behaved_load : forall m addr,
    well_behaved_effect (EF_Load addr (get_tm m addr)) m

  | well_behaved_store : forall m addr v,
    addr < length m ->
    well_behaved_effect (EF_Store addr v) m
  .

Definition well_typed_memory mt m :=
  length mt = length m /\
  (forall i, mt / empty |-- (get_tm m i) is (get_typ mt i)).

(* TODO: shouldn't this T match with the second one from the preservation rule? *)
Definition well_typed_threads mt ths := forall i,
  exists T, mt / empty |-- (get_tm ths i) is T.

Definition well_typed_program mt m ths :=
  well_typed_memory mt m /\
  well_typed_threads mt ths.

Definition finished ths :=
  forall i, value (get_tm ths i).

Inductive extends' {A} : list A -> list A -> Prop :=
  | extends_nil : forall mt,
    extends' mt nil
  | extends_cons : forall x mt mt',
    extends' mt mt' ->
    extends' (x :: mt) (x :: mt').

Infix "extends" := extends' (at level 50, left associativity).

(* ------------------------------------------------------------------------- *)
(* Auxiliary Lemmas -------------------------------------------------------- *)
(* ------------------------------------------------------------------------- *)

Lemma extends_refl : forall {A} (mt : list A),
  mt extends mt.
Proof.
  induction mt; auto using @extends'.
Qed.

Lemma extends_add : forall {A} (mt : list A) a,
  (add mt a) extends mt.
Proof.
  induction mt; eauto using @extends'.
Qed.

Lemma extends_length : forall {A} (mt mt' : list A) i,
  i < length mt' ->
  mt extends mt' ->
  i < length mt.
Proof.
  intros *. generalize dependent mt. generalize dependent i.
  induction mt'; intros * Hlen Hext.
  - inversion Hlen.
  - inversion Hext. destruct i;
    eauto using PeanoNat.Nat.lt_0_succ, Lt.lt_n_S, Lt.lt_S_n.
Qed.

Lemma extends_lookup : forall (mt mt' : list typ) i,
  i < length mt' ->
  mt extends mt' ->
  get_typ mt' i = get_typ mt i.
Proof.
  intros *. generalize dependent mt. generalize dependent i.
  induction mt'; intros * Hlen Hext.
  - inversion Hlen.
  - inversion Hext. subst. destruct i.
    + reflexivity.
    + unfold get_typ, get. simpl in *. eauto using Lt.lt_S_n.
Qed.

Lemma safe_preserves_inclusion : forall Gamma Gamma',
  Gamma includes Gamma' ->
  (safe Gamma) includes (safe Gamma').
Proof.
  unfold Map.includes', safe. intros * H *.
  destruct (Gamma k) eqn:E1; destruct (Gamma' k) eqn:E2;
  solve [ intros F; inversion F
        | eapply H in E2; rewrite E1 in E2; inversion E2; subst; trivial
        ].
Qed.

Lemma update_safe_includes_safe_update : forall Gamma id T,
  (update (safe Gamma) id T) includes (safe (update Gamma id T)).
Proof.
  unfold Map.includes', update, Map.update', safe. intros *.
  destruct String.eqb; trivial.
  destruct is_safe_type; trivial.
  intros F. inversion F.
Qed.

Lemma memory_weakening : forall mt mt' Gamma t T,
  mt extends mt' ->
  mt' / Gamma |-- t is T ->
  mt  / Gamma |-- t is T.
Proof.
  intros * Hext Htype.
  induction Htype; eauto using @well_typed_term, extends_length;
  subst; erewrite extends_lookup; eauto using extends_length, @well_typed_term.
Qed.

Lemma concurrent_memory_weakening : forall mt mt' ths,
  mt' extends mt ->
  well_typed_threads mt ths ->
  well_typed_threads mt' ths.
Proof.
  intros * Hext Hths. intros i.
  specialize (Hths i) as [? ?]. eexists.
  eauto using memory_weakening.
Qed.

Lemma context_weakening : forall mt Gamma Gamma' t T,
  Gamma includes Gamma' ->
  mt / Gamma' |-- t is T ->
  mt / Gamma  |-- t is T.
Proof.
  intros * Hinc Htype.
  generalize dependent Gamma.
  induction Htype; intros * Hinc;
  eauto 6 using @well_typed_term, safe_preserves_inclusion,
    update_preserves_inclusion.
Qed.

Lemma context_weakening_empty : forall mt Gamma t T,
  mt / empty |-- t is T ->
  mt / Gamma |-- t is T.
Proof.
  intros * Htype.
  eapply (context_weakening _ _ empty); auto.
  discriminate.
Qed.

Lemma substitution_preserves_typing : forall mt Gamma id t u T U,
  mt / (update Gamma id U) |-- t is T ->
  mt / empty |-- u is U ->
  mt / Gamma |-- [id := u] t is T.
Proof with eauto using context_weakening, context_weakening_empty,
  lookup_update_kneq, update_overwrite, update_permutation,
  update_safe_includes_safe_update.

  intros * Ht Hu.
  generalize dependent T. generalize dependent Gamma.
  induction t; intros * Ht; inversion Ht; simpl; subst;
  eauto using @well_typed_term;
  try (destruct String.eqb eqn:E);
  try (apply String.eqb_eq in E; subst);
  try (apply String.eqb_neq in E).
  - rewrite lookup_update_keq in H1. inversion H1. subst...
  - apply T_Id_Val. rewrite <- H1. symmetry...
  - rewrite lookup_update_keq in H1. inversion H1. subst...
  - apply T_Id_Var. rewrite <- H1. symmetry...
  - eapply T_Spawn...
  - apply T_LetVal...
  - apply T_LetVal...
  - apply T_LetVar...
  - apply T_LetVar...
  - eapply T_LetFun...
  - eapply T_LetFun...
  - apply T_Fun...
  - apply T_Fun...
Qed.

Lemma alloc_value_has_type : forall mt t t' addr v T,
  mt / empty |-- t is T ->
  t --[EF_Alloc addr v]--> t' ->
  exists V, mt / empty |-- v is V.
Proof.
  remember empty as Gamma.
  intros * Htype. generalize dependent t'.
  induction Htype; intros * Hstep; inversion Hstep; subst; eauto.
Qed.

Lemma store_value_has_type : forall mt t t' addr v T,
  mt / empty |-- t is T ->
  t --[EF_Store addr v]--> t' ->
  mt / empty |-- v is (get_typ mt addr).
Proof.
  remember empty as Gamma.
  intros * Htype. generalize dependent t'.
  induction Htype; intros * Hstep;
  inversion Hstep; subst; eauto;
  solve [match goal with
    | H1 : _ / _ |-- ?v is _,
      H2 : _ / _ |-- _  is _
      |- _ / _ |-- ?v is _ =>
        inversion H2; subst; eauto
    end].
Qed.

Lemma spawn_block_has_type : forall mt t t' block T,
  mt / empty |-- t is T ->
  t --[EF_Spawn block]--> t' ->
  exists B, mt / empty |-- block is B.
Proof.
  remember empty as Gamma.
  intros * Htype. generalize dependent t'.
  induction Htype; intros * Hstep; inversion Hstep; subst; eauto.
Qed.

Lemma store_preserves_well_typed_memory : forall m mt t i,
  i < length m ->
  well_typed_memory mt m ->
  mt / empty |-- t is (get_typ mt i) ->
  well_typed_memory mt (set m i t).
Proof.
  intros * ? [Hlen ?] ?. split.
  - rewrite Hlen. apply set_preserves_length.
  - intros j. destruct (i =? j) eqn:E.
    + apply Nat.eqb_eq in E. subst. erewrite (get_i_set_i TM_Nil); auto.
    + apply Nat.eqb_neq in E. erewrite (get_i_set_j TM_Nil); auto.
Qed.

Lemma alloc_preserves_well_typed_memory : forall mt m t T,
  well_typed_memory mt m ->
  mt / empty |-- t is T ->
  well_typed_memory (add mt T) (add m t).
Proof.
  intros * [Hlen Hmem] Htype.
  split; auto using add_preserves_length. intros i.
  destruct (lt_eq_lt_dec i (length m)) as [[Hlt | Heq] | Hgt];
  unfold get_tm, get_typ in *; subst.
  - rewrite get_add_lt; trivial.
    rewrite <- Hlen in Hlt.
    rewrite get_add_lt; trivial.
    eauto using extends_add, memory_weakening.
  - rewrite get_add_last. rewrite <- Hlen. rewrite get_add_last.
    eauto using extends_add, memory_weakening.
  - rewrite get_add_gt; trivial.
    rewrite <- Hlen in Hgt.
    rewrite get_add_gt; trivial.
    apply T_Nil.
Qed.

Lemma step_preserves_well_typed_threads : forall mt ths t T i,
  i < length ths ->
  well_typed_threads mt ths ->
  mt / empty |-- t is T ->
  well_typed_threads mt (set ths i t).
Proof.
  intros * Hlen Htype Hstep.
  intros i'. destruct (i =? i') eqn:E.
  - apply Nat.eqb_eq in E. subst.
    rewrite (get_i_set_i TM_Nil); eauto.
  - apply Nat.eqb_neq in E. apply not_eq_sym in E.
    rewrite (get_i_set_j TM_Nil); eauto.
Qed.

Lemma spawn_preserves_well_typed_threads : forall mt ths t T,
  well_typed_threads mt ths ->
  mt / empty |-- t is T ->
  well_typed_threads mt (add ths t).
Proof.
  intros * Hths Htype.
  intros i. destruct (lt_eq_lt_dec i (length ths)) as [[? | Heq] | Hlt].
  - specialize (Hths i) as [? ?]. rewrite (get_add_lt TM_Nil); eauto.
  - subst. rewrite (get_add_last TM_Nil). eauto.
  - rewrite (get_add_gt TM_Nil); eauto using T_Nil.
Qed.

Definition is_alloc_or_load eff :=
  match eff with
  | EF_Alloc _ _ | EF_Load _ _ => true
  | _ => false
  end.

Lemma limited_preservation : forall mt m t t' eff T,
  well_typed_memory mt m ->
  mt / empty |-- t is T ->
  t --[eff]--> t' ->
  is_alloc_or_load eff = false ->
  mt / empty |-- t' is T.
Proof.
  remember empty as Gamma.
  intros * [Hlen Hmem] Htype Hstep Heff.
  generalize dependent t'.
  induction Htype; intros * Hstep; inversion Hstep; subst;
  solve
    [ discriminate Heff
    | eauto using substitution_preserves_typing, @well_typed_term
    | match goal with
      | Htype : _ / _ |-- _ is _ |- _ =>
        inversion Htype; subst;
        eauto using substitution_preserves_typing, @well_typed_term
      end
    ].
Qed.

Lemma alloc_preservation : forall mt t t' v T V,
  mt / empty |-- t is T ->
  mt / empty |-- v is V ->
  t --[EF_Alloc (length mt) v]--> t' ->
  (add mt V) / empty |-- t' is T.
Proof.
  remember empty as Gamma.
  intros * Htype ? Hstep. generalize dependent t'.
  assert (R : forall T, T = get_typ (add mt T) (length mt)).
  { intros. eauto using get_add_last. }
  induction Htype; intros * Hstep; inversion Hstep; subst;
  eauto using @well_typed_term, extends_add, memory_weakening;
  match goal with
  | H1 : mt / _ |-- v is ?T1, H2 : mt / _ |-- v is ?T2 |- _ =>
    eapply (deterministic_typing _ _ _ T1 T2) in H1; eauto; subst
  end;
  try match goal with
  |- _ / _ |-- _ is _ ?T =>
    rewrite (R T); eauto using @well_typed_term, length_lt_add
  end.
  - eapply substitution_preserves_typing;
    eauto using extends_add, memory_weakening.
    assert (R' : forall T, TY_Ref T = TY_Ref (get_typ (add mt T) (length mt))).
    { intros. f_equal. eauto using get_add_last. }
    rewrite R'. eauto using @well_typed_term, length_lt_add.
Qed.

Lemma load_preservation : forall mt m t t' addr T,
  well_typed_memory mt m ->
  mt / empty |-- t is T ->
  t --[EF_Load addr (get_tm m addr)]--> t' ->
  mt / empty |-- t' is T.
Proof.
  remember empty as Gamma.
  intros * [Hlen Hmem] Htype Hstep. generalize dependent t'.
  induction Htype; intros * Hstep; inversion Hstep; subst;
  try solve [ eauto using @well_typed_term
            | repeat match goal with
              | H : _ / _ |-- _ is _ |- _ => inversion H; subst; eauto
              end
            ].
Qed.

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

Theorem preservation : forall mt m m' ths ths' ceff,
  well_typed_program mt m ths ->
  m / ths ==> m' / ths' # ceff ->
  exists mt',
    mt' extends mt /\
    well_typed_program mt' m' ths'.
Proof.
  intros * [Hmem Hths] Hcstep.
  inversion Hcstep; subst; destruct (Hths i) as [? ?].
  (* None *)
  - eexists. splits 3; eauto using extends_refl.
    intros i'. destruct (i =? i') eqn:E.
    + apply Nat.eqb_eq in E. subst.
      rewrite (get_i_set_i TM_Nil); trivial.
      specialize (Hths i') as [? ?]. eexists.
      eauto using limited_preservation.
    + apply Nat.eqb_neq in E. apply not_eq_sym in E.
      rewrite (get_i_set_j TM_Nil); trivial.
  (* Alloc *)
  - rewrite <- (proj1 Hmem) in *.
    assert (exists V, mt / empty |-- v is V) as [V ?].
    { eauto using alloc_value_has_type. }
    exists (add mt V). splits 3;
    eauto using extends_add,
      alloc_preserves_well_typed_memory,
      step_preserves_well_typed_threads,
      concurrent_memory_weakening,
      alloc_preservation.
  (* Load *)
  - eexists. splits 3; eauto using extends_refl.
    eauto using step_preserves_well_typed_threads, load_preservation.
  (* Store *)
  - eexists. splits 3; eauto using extends_refl;
    eauto using store_preserves_well_typed_memory,
      store_value_has_type,
      step_preserves_well_typed_threads,
      limited_preservation.
  (* Spawn *)
  - eexists. splits 3; eauto using extends_refl.
    assert (exists B, mt / empty |-- block is B) as [? ?].
    { eauto using spawn_block_has_type. }
    eauto using spawn_preserves_well_typed_threads,
      step_preserves_well_typed_threads,
      limited_preservation.
Qed.

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

Lemma well_typed_threads_tail : forall mt th ths,
  well_typed_threads mt (th :: ths) ->
  well_typed_threads mt ths.
Proof.
  intros * Hths. intros i.
  specialize (Hths (S i)) as [T Htype].
  eexists. eauto.
Qed.

Lemma concurrent_step_weakening : forall m m' th ths ths' ceff,
  m / ths ==> m' / ths' # ceff ->
  exists ceff', m / (th :: ths) ==> m' / (th :: ths') # ceff'.
Proof.
  intros * Hcstep.
  inversion Hcstep; subst;
  solve [rewrite set_tail || rewrite add_set_tail; eauto using cstep, lt_n_S].
Qed.

Lemma memory_length : forall mt m i,
  well_typed_memory mt m ->
  (i < length mt) -> (i < length m).
Proof.
  intros * [Hlen _]. rewrite Hlen. trivial.
Qed.

Lemma limited_progress : forall mt m t T,
  well_typed_memory mt m ->
  mt / empty |-- t is T ->
  value t \/ exists t' eff',
    t --[eff']--> t' /\
    well_behaved_effect eff' m.
Proof.
  remember empty as Gamma.
  intros * Hmem Htype.
  induction Htype; subst; auto using value; right;
  try match goal with F : lookup empty _ = Some _ |- _ => inversion F end;
  repeat match goal with
    IH : _ -> _ \/ _ |- _ => specialize (IH eq_refl) as [? | [? [? [? ?]]]]
  end;
  try solve [eexists; eexists; split; eauto using step, well_behaved_effect];
  repeat match goal with
    Hv : value ?t , Htype : _ / _ |-- ?t is _ |- _ =>
      destruct Hv; inversion Htype; subst
  end;
  eexists; eexists; split;
  eauto using memory_length, step, value, well_behaved_effect.
Qed.

Theorem progress : forall m mt ths,
  well_typed_program mt m ths ->
  (finished ths \/ exists m' ths' ceff, m / ths ==> m' / ths' # ceff).
Proof.
  intros * [Hmem Hths].
  induction ths as [| th ths IH].
  - left. intros i. destruct i; auto using value.
  - destruct (is_value th) eqn:E.
    + apply value_equivalence_true in E.
      destruct (IH (well_typed_threads_tail _ _ _ Hths)) as [? | [? [? [? ?]]]].
      * left. intros i. destruct i; eauto.
      * right. eexists. eexists. eauto using concurrent_step_weakening.
    + apply value_equivalence_false in E. right.
      specialize (IH (well_typed_threads_tail _ _ _ Hths)) as [? | IH].
      * destruct (Hths 0) as [T Htype].
        unfold get_tm in Htype. simpl in Htype.
        assert (value th \/
          exists th' eff, th --[eff]--> th' /\ well_behaved_effect eff m)
        as [? | [? [eff [? Heff]]]];
        eauto using limited_progress; try contradiction.
        destruct eff; inversion Heff; subst;
        eauto using cstep, Nat.lt_0_succ.
      * specialize IH as [? [? [? ?]]].
        eexists. eexists. eauto using concurrent_step_weakening.
Qed.

(*
Corollary soundness : forall mt m m' ths ths',
  well_typed_program mt m ths ->
  m / ths ==>* m' / ths' ->
  ~ (cstuck m' ths').
Proof.
Qed.
*)


Require Import Karazin.SortingTheory.comparable.

Section SortingProblem.
  Variables (X : Set) (cmp : X -> X -> cmpout).
  Context `{HC : Comparable X cmp}.

  Inductive array : Set :=
  | array0 : array
  | arrayn : array -> X -> array.

End SortingProblem.


Require Import Arith.

From CoqMTL Require Export Base.
From CoqMTL Require Import Misc.Monoid.

(** Haskell-style [Foldable]. I have no idea about the intended categorical
    semantics. The definition is based on [foldMap] while [foldr] and [foldl]
    are moved outside and are implemented in terms of [foldMap].

    There's one law I haven't thought much about and it's stated uglily
    (a definition of monoid homomorphisms would help a lot). *)
Class Foldable (T : Type -> Type) : Type :=
{
  foldMap : forall {A : Type} {M : Monoid}, (A -> M) -> T A -> M;
  foldMap_law :
    forall (A : Type) (B C : Monoid) (f : A -> B) (g : B -> C),
      g neutr = neutr -> (forall x y : B, g (op x y) = op (g x) (g y)) ->
        foldMap (f .> g) = foldMap f .> g
}.

(** A monoid instance for functions with composition and identity. It is
    needed to define [foldr] and [foldl] using [foldMap]. *)
#[refine]
#[export]
Instance Endo (A : Type) : Monoid :=
{
  carr := A -> A;
  op := @compose A A A;
  neutr := id;
}.
Proof. all: hs. Defined.

(** Utility functions taken from Haskell's Data.Foldable. *)
Section FoldableFuns.

Variable A B C : Type.
Variable T : Type -> Type.
Variable inst : Foldable T.
Variable M : Monoid.

(** Note that [foldr'], [foldl'] are not present because laziness is not a
    problem while [foldr1] and [foldl1] are not present because the case
    of an empty structure just cannot be omitted. *)
Definition foldr
  {A B : Type} (f : A -> B -> B) (dflt : B) (t : T A) : B :=
    @foldMap T inst A (Endo B) (fun a : A => f a) t dflt.

Definition foldl
  {A B : Type} (f : B -> A -> B) (dflt : B) (t : T A) : B :=
    @foldMap T inst A (Endo B) (fun a : A => flip f a) t dflt.

Definition fold (t : T M) : M := foldr op neutr t.

Definition isEmpty (ta : T A) : bool :=
  foldr (fun _ _ => false) true ta.

Definition size (ta : T A) : nat :=
  foldr (fun _ n => S n) 0 ta.

Definition toListF (ta : T A) : list A :=
  foldr (fun h t => h :: t) [] ta.

Definition elem (cmp : A -> A -> bool) (a : A) (ta : T A) : bool :=
  foldr (fun x y => if cmp a x then true else y) false ta.

Definition maxF (tn : T nat) : nat :=
  foldr (fun n m => if leb n m then m else n) 0 tn.

Definition maxBy (cmp : A -> A -> bool) (dflt : A) (ta : T A) : A :=
  foldr (fun x xs => if cmp x xs then xs else x) dflt ta.

Definition minBy (cmp : A -> A -> bool) (dflt : A) (ta : T A) : A :=
  maxBy (fun a a' => negb (cmp a a')) dflt ta.

Definition andF (tb : T bool) : bool :=
  foldr (fun p q => andb p q) true tb.

Definition orF (tb : T bool) : bool :=
  foldr (fun p q => orb p q) false tb.

Definition allF (f : A -> bool) (ta : T A) : bool :=
  foldr (fun x xs => andb (f x) xs) true ta.

Definition anyF (f : A -> bool) (ta : T A) : bool :=
  foldr (fun x xs => orb (f x) xs) false ta.

Definition findFirst (f : A -> bool) (ta : T A) : option A :=
  foldr (fun x xs => if f x then Some x else xs) None ta.

Definition count (f : A -> bool) (ta : T A) : nat :=
  foldr (fun x n => if f x then S n else n) 0 ta.

Definition findAll (f : A -> bool) (ta : T A) : list A :=
  foldr (fun x xs => if f x then x :: xs else xs) [] ta.

End FoldableFuns.

Arguments foldr {T inst A B} _ _ _.
Arguments foldl {T inst A B} _ _ _.
Arguments isEmpty {A T inst} _.
Arguments size {A T inst} _.
Arguments toListF {A T inst} _.
Arguments elem {A T inst} _ _ _.
Arguments maxF {T inst} _.
Arguments maxBy {A T inst} _ _ _.
Arguments minBy {A T inst} _ _ _.
Arguments maxBy {A T inst} _ _ _.
Arguments findFirst {A T inst} _ _.
Arguments count {A T inst} _ _.
Arguments findAll {A T inst} _ _.
Arguments andF {T inst} _.
Arguments orF {T inst} _.
Arguments allF {A T inst} _ _.
Arguments anyF {A T inst} _ _.


Require Export parser.
Require Export refine.

Definition TS: IA := parse
"IA [s1,s2,s3,s4,s5,s6,s7] (s1) [acceptT, endT, newT, startM, endM] [startT, logM] []
[s1->(acceptT)s1, s1->(newT)s2, s2->(startT)s3, s3->(endT)s1, s1->(startM)s4,
s4->(endM)s1, s4->(newT)s5, s5->(startT)s6, s6->(endT)s7, s7->(logM)s4]".

Definition SV: IA := parse
"IA [u1,u2,u3,u4,u5] (u1) [mOn, logM, logF] [startM, endM] []
 [u1->(mOn)u2, u1->(logF)u1, u2->(startM)u3, u3->(logM)u3, u3->(logF)u4,
 u4->(logM)u5, u5->(endM)u1]".

Eval compute in IAutomaton.b_compatible TS SV. (*true*)

Definition TS_SV: IA := IAutomaton.composition TS SV.
(*Eval compute in :> TS_SV.*)
(*"IA [s4_u5, s7_u4, s6_u4, s7_u3, s5_u4, s6_u3, s4_u4, s5_u3, s4_u3,
s3_u1, s1_u2, s1_u1, s2_u1] (s1_u1) [logF, mOn, newT, endT, acceptT] [startT]
[logM, endM, startM] [s1_u1->(newT)s2_u1, s1_u1->(acceptT)s1_u1,
s1_u1->(logF)s1_u1, s1_u1->(mOn)s1_u2, s2_u1->(startT)s3_u1,
s1_u2->(acceptT)s1_u2, s2_u1->(logF)s2_u1, s1_u2->(startM)s4_u3,
s4_u3->(newT)s5_u3, s3_u1->(endT)s1_u1, s4_u3->(logF)s4_u4,
s3_u1->(logF)s3_u1, s5_u3->(startT)s6_u3, s4_u4->(newT)s5_u4,
s5_u3->(logF)s5_u4, s6_u3->(endT)s7_u3, s5_u4->(startT)s6_u4,
s6_u3->(logF)s6_u4, s6_u4->(endT)s7_u4, s7_u3->(logF)s7_u4,
s7_u3->(logM)s4_u3, s7_u4->(logM)s4_u5, s4_u5->(endM)s1_u1]"*)

(*SME-NI: true *)
Definition TS_SV_hid: IA :=
 IAutomaton.hiding TS_SV (ASet.GenActs [&"mOn"]).

Definition TS_SV_rep: IA :=
 IAutomaton.replacement TS_SV (&"tau") (ASet.GenActs [&"mOn"]).

Eval compute in SMENI_refinement TS_SV_rep TS_SV_hid. (*false*)


Load List.

Inductive signature : Type :=
  | Signature (arg_types : list Type) (return_type : Type).

Definition signature_to_fun_type s :=
  match s with
  | Signature arg_types return_type =>
    (fix f arg_types :=
      match arg_types with
      | [] => return_type
      | arg_type :: arg_types' => arg_type -> f arg_types'
      end
    ) arg_types
  end.

Definition signature_to_cost_fun_type s :=
  match s with
  | Signature arg_types _ =>
    (fix f arg_types :=
      match arg_types with
      | [] => nat : Type
      | arg_type :: arg_types' => arg_type -> f arg_types'
      end
    ) arg_types
  end.

Class Cost s (fun_ : signature_to_fun_type s) := {
  cost_fun: signature_to_cost_fun_type s;
}.

Arguments cost_fun {s} fun_ {Cost}.

Section Cost_consDefiniton.

#[local] Instance Cost_cons first_arg_type arg_types return_type fun_
  (_ : Cost (Signature (first_arg_type :: arg_types) return_type) fun_) a :
  Cost (Signature arg_types return_type) (fun_ a) | 1000 := {
  cost_fun := (cost_fun fun_ a)
}.

End Cost_consDefiniton.

Definition big_o {A} f g :=
  {c : nat | forall (a : A), f a <= c * (g a)}.

Definition constant {A} f :=
  big_o f (fun (_ : A) => 1).

Definition unary_cost_constant {A} {R} {fun_} (cost : Cost (Signature [A] R) fun_) :=
  constant (@cost_fun _ _ cost).

Definition binary_cost_constant {A} {B} {R} {fun_} (cost : Cost (Signature [A; B] R) fun_) :=
  constant (fun '(a, b) => (@cost_fun _ _ cost) a b).

Definition app_cost {A} := ltac2:(Cost.refine_compute_cost [] 3 '@app []) A.

Theorem app_cost_linear :
  forall {A},
  big_o
    (fun '(l1, l2) => app_cost l1 l2)
    (fun '(l1, l2) => 1 + length (l1 : list A) + length (l2 : list A)).
Proof.
  intros ?. exists 7. intros (l1, l2). induction l1.
  - simpl. lia.
  - simpl. lia.
Qed.

Definition length_cost {A} := ltac2:(Cost.refine_compute_cost [] 1 (eval red in (@length A)) []).

Section Example.

#[export] Instance length_Cost {A} : Cost (Signature [_] _) (@length A) := {
  cost_fun := length_cost;
}.

End Example.

Theorem length_cost_linear :
  forall {A}, big_o length_cost (fun (l : list A) => 1 + length l).
Proof.
  exists 3. intros l. induction l.
  - simpl. lia.
  - simpl. lia.
Qed.

Definition filter_cost {A} predicate {predicate_Cost: Cost (Signature [_] _) predicate} :=
  ltac2:(
    Cost.refine_compute_cost
    [(('predicate, 1), '(@cost_fun _ _ predicate_Cost))]
    1
    (eval red in (@filter A predicate))
    []
  ).

Theorem filter_cost_linear_when_predicate_cost_constant :
  forall {A} predicate {predicate_Cost: Cost _ predicate},
  unary_cost_constant predicate_Cost ->
  big_o (filter_cost predicate) (fun (l : list A) => 1 + length l).
Proof.
  intros ? ? ? ?. destruct H as (c & H). exists (c + 6). intros l. induction l.
  - simpl. lia.
  - simpl. specialize (H a). destruct (predicate a); lia.
Qed.

Theorem filter_cost_linear_when_predicate_cost_constant_binary :
  forall {A B} (predicate : A -> B -> bool) {predicate_Cost: Cost (Signature [_; _] _) predicate},
  binary_cost_constant predicate_Cost ->
  big_o
    (fun '(a, l) => @filter_cost _ (predicate a) (Cost_cons _ _ _ _ _ _) l)
    (fun '(_, l) => 1 + length l).
Proof.
  intros ? ? ? ? ?. destruct H as (c & H). exists (c + 6). intros (a, l). induction l.
  - simpl. lia.
  - simpl. rename a0 into b. specialize (H (a, b)). destruct (predicate a b); lia.
Qed.

Check filter_cost_linear_when_predicate_cost_constant_binary.

Section Example.

Definition tirivial_predicate := fun (_ : nat) => true.

#[export] Instance tirivial_predicate_Cost : Cost (Signature [_] _) tirivial_predicate := {
  cost_fun := ltac2:(Cost.refine_compute_cost [] 1 'tirivial_predicate []);
}.

Compute filter_cost tirivial_predicate [1; 2; 3].

Theorem tirivial_predicate_cost_constant : unary_cost_constant tirivial_predicate_Cost.
Proof.
  exists 1. intros ?. simpl. lia.
Qed.

Theorem tirivial_filter_filter :
  big_o (filter_cost tirivial_predicate) (fun l => 1 + length l).
Proof.
  apply filter_cost_linear_when_predicate_cost_constant. apply tirivial_predicate_cost_constant.
Qed.

End Example.


Require Export Iron.Language.SystemF2Effect.Value.Relation.TyJudge.

(* A well typed expression is well formed *)
Lemma typex_wfX
 :  forall ke te se sp x t e
 ,  TypeX  ke te se sp x t e
 -> wfX (length ke) (length te) (length se) x.
Proof.
 intros. gen ke te se sp t e.
 induction x using exp_mutind with
  (PV := fun v => forall ke te se sp t1
      ,  TypeV ke te se sp v t1
      -> wfV (length ke) (length te) (length se) v);
   rip; inverts_type; try burn.

 Case "VLam".
  spec IHx H8. burn.

 Case "VLAM".
  eapply WfV_VLAM.
  spec IHx H7. simpl in IHx.
  rewrite <- length_liftTE in IHx.
  rewrite <- length_liftTE in IHx.
  auto.

 Case "XLet".
  spec IHx1 H10.
  spec IHx2 H11.
  burn.

 Case "XNew".
  eapply WfX_XNew.
  spec IHx H7.
  rrwrite (length (ke :> KRegion) = S (length ke)) in IHx.
  rewrite <- length_liftTE in IHx.
  rewrite <- length_liftTE in IHx.
  burn.
Qed.
Hint Resolve typex_wfX.