(** **********************************************************

Ralph Matthes

August 2022
*)

(** **********************************************************

constructs the bicategory of (elementarily defined) actegories
with lax morphisms as 1-cells

 ************************************************************)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.

Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.

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

Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Import BifunctorNotations.

Section A.

  Context {V : category} (Mon_V : monoidal V).

Section TheConstruction.

  Definition disp_actbicat_disp_ob_mor : disp_cat_ob_mor bicat_of_cats.
  Proof.
    exists (actegory Mon_V).
    exact (λ C D ActC ActD F, lineator_lax Mon_V ActC ActD F).
  Defined.

  Definition disp_actbicat_disp_id_comp : disp_cat_id_comp bicat_of_cats disp_actbicat_disp_ob_mor.
  Proof.
    split.
    - intros C F. apply identity_lineator_lax.
    - intros C D E ActC ActD ActE N O.
      apply comp_lineator_lax.
  Defined.

  Definition disp_actbicat_disp_catdata : disp_cat_data bicat_of_cats
    := (disp_actbicat_disp_ob_mor,,disp_actbicat_disp_id_comp).

  Definition bidisp_actbicat_disp_2cell_struct : disp_2cell_struct disp_actbicat_disp_ob_mor.
  Proof.
    intros C D F G ξ ActC ActD.
    exact (λ Fl Gl, is_linear_nat_trans (Fl : lineator_lax Mon_V ActC ActD F) (Gl : lineator_lax Mon_V ActC ActD G) ξ).
  Defined.

  Lemma isaprop_bidisp_actbicat_disp_2cell_struct
        {C D : bicat_of_cats}
        {F G : bicat_of_cats ⟦C,D⟧ }
        {ξ : prebicat_cells bicat_of_cats F G}
        {ActC : disp_actbicat_disp_catdata C}
        {ActD : disp_actbicat_disp_catdata D}
        (Fl : ActC -->[F] ActD)
        (Gl : ActC -->[G] ActD)
    : isaprop (bidisp_actbicat_disp_2cell_struct C D F G ξ ActC ActD Fl Gl).
  Proof.
    apply isaprop_is_linear_nat_trans.
  Qed.

  Definition bidisp_actbicat_disp_prebicat_1_id_comp_cells
    :  disp_prebicat_1_id_comp_cells bicat_of_cats
    := (disp_actbicat_disp_catdata,, bidisp_actbicat_disp_2cell_struct).

  Lemma bidisp_actbicat_disp_prebicat_ops :
    disp_prebicat_ops bidisp_actbicat_disp_prebicat_1_id_comp_cells.
  Proof.
    repeat split; cbn; unfold bidisp_actbicat_disp_2cell_struct, comp_lineator, identity_lineator.
    (** first 5 quantified equations for identity, then 5 quantified equations for composition *)
    - intros. apply is_linear_nat_trans_identity.
    - intros C D F ActC ActD lin v c.
      cbn.
      unfold comp_lineator_data, identity_lineator_lax.
      cbn.
      unfold identity_lineator_data.
      rewrite functor_id.
      do 2 rewrite id_right.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (bifunctor_leftid ActD). }
      apply pathsinv0, id_left.
    - intros C D F ActC ActD lin v c.
      cbn.
      unfold comp_lineator_data, identity_lineator_lax.
      cbn.
      unfold identity_lineator_data.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (bifunctor_leftid ActD). }
      apply id_right.
    - intros C D F ActC ActD lin v c.
      cbn.
      unfold comp_lineator_data, identity_lineator_lax.
      cbn.
      unfold identity_lineator_data.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (bifunctor_leftid ActD). }
      rewrite functor_id.
      apply pathsinv0, id_left.
    - intros C D F ActC ActD lin v c.
      cbn.
      unfold comp_lineator_data, identity_lineator_lax.
      cbn.
      unfold identity_lineator_data.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (bifunctor_leftid ActD). }
      do 2 rewrite id_left.
      apply id_right.
      (** now towards composition *)
    - intros C1 C2 C3 C4 F G H ActC1 ActC2 ActC3 ActC4 Fl Gl Hl v x.
      cbn.
      unfold comp_lineator_data, identity_lineator_lax.
      cbn.
      unfold comp_lineator_data.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (bifunctor_leftid ActC4). }
      rewrite id_right.
      rewrite id_left.
      repeat rewrite assoc'.
      apply maponpaths.
      apply functor_comp.
    - intros C1 C2 C3 C4 F G H ActC1 ActC2 ActC3 ActC4 Fl Gl Hl v x.
      cbn.
      unfold comp_lineator_data, identity_lineator_lax.
      cbn.
      unfold comp_lineator_data.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (bifunctor_leftid ActC4). }
      rewrite id_right.
      rewrite id_left.
      repeat rewrite assoc'.
      apply maponpaths.
      apply pathsinv0, functor_comp.
    - intros C D F G H α β ActC ActD Fl Gl Hl linα linβ v x.
      cbn.
      etrans.
      2: { apply cancel_postcomposition.
           apply pathsinv0, (bifunctor_leftcomp ActD). }
      rewrite assoc.
      etrans.
      { apply cancel_postcomposition.
        apply (linα v x). }
      repeat rewrite assoc'.
      apply maponpaths.
      apply linβ.
    - intros C D E F G1 G2 β ActC ActD ActE Fl G1l G2l linβ v x.
      cbn.
      unfold comp_lineator_data.
      assert (aux := linβ v (F x)).
      etrans.
      2: { rewrite assoc.
           apply cancel_postcomposition.
           exact aux. }
      clear aux.
      repeat rewrite assoc'.
      apply maponpaths.
      apply nat_trans_ax.
    - intros C D E F1 F2 G α ActC ActD ActE F1l F2l Gl linα v x.
      cbn.
      unfold comp_lineator_data.
      etrans.
      { rewrite assoc'.
        apply maponpaths.
        apply pathsinv0, functor_comp. }
      etrans.
      { do 2 apply maponpaths.
        apply linα. }
      rewrite functor_comp.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply pathsinv0, lineator_linnatleft.
   Qed.

  Definition bidisp_actbicat_disp_prebicat_data : disp_prebicat_data bicat_of_cats
    := (bidisp_actbicat_disp_prebicat_1_id_comp_cells,, bidisp_actbicat_disp_prebicat_ops).

  Definition bidisp_actbicat_disp_prebicat_laws : disp_prebicat_laws bidisp_actbicat_disp_prebicat_data.
  Proof.
    repeat split; intro; intros; apply isaprop_bidisp_actbicat_disp_2cell_struct.
  Qed.

  Definition bidisp_actbicat_disp_prebicat : disp_prebicat bicat_of_cats
    := (bidisp_actbicat_disp_prebicat_data,,bidisp_actbicat_disp_prebicat_laws).

  Definition bidisp_actbicat_disp_bicat : disp_bicat bicat_of_cats.
  Proof.
    refine (bidisp_actbicat_disp_prebicat,, _).
    red; intros ? ? ? ? ? ? ? ? ?.
    apply isasetaprop.
    apply isaprop_bidisp_actbicat_disp_2cell_struct.
  Defined.

  Lemma actbicat_disp_2cells_isaprop : disp_2cells_isaprop bidisp_actbicat_disp_bicat.
  Proof.
    red.
    intros.
    apply isaprop_bidisp_actbicat_disp_2cell_struct.
  Qed.

  Definition actbicat : bicat := total_bicat bidisp_actbicat_disp_bicat.

End TheConstruction.

Definition actbicat_disp_locally_groupoid : disp_locally_groupoid bidisp_actbicat_disp_bicat.
Proof.
  red. intros C D F G αiso ActC ActD Fl Gl islin.
  use tpair.
  - transparent assert (isnziα : (is_nat_z_iso (pr11 αiso))).
    { apply (nat_trafo_pointwise_z_iso_if_z_iso (pr2 D)). exact (pr2 αiso). }
    exact (is_linear_nat_trans_pointwise_inverse (Fl : lineator_lax _ _ _ _) (Gl : lineator_lax _ _ _ _) (pr1 αiso) isnziα islin).
  - split; apply isaprop_bidisp_actbicat_disp_2cell_struct.
Defined.

End A.


Require Import ZArith.
Require Export Specialise.
Require Import Denotational.
Require Import TranslateExp.
Require Import Tactics.
Require Import FunctionalExtensionality.
Require Export FinMap.
Require Import TimedTyping.

(********** reduction semantics **********)

(* This is the reduction relation *)

Inductive ScaleTrans : option R -> Trans -> Trans -> Prop :=
| scaleTrans_empty e : ScaleTrans e empty_trans empty_trans
| scaleTrans_scale v t : ScaleTrans (Some v) t (scale_trans v t)
.

Inductive Red : Contr -> EnvP -> ExtEnvP -> Contr -> Trans -> Prop :=
| red_zero env ext t c :t = empty_trans -> c = Zero -> Red Zero env ext c t
| red_let e e' env ext c c' c'' t : e' = specialiseExp e env ext ->
                                     Red c (fromLit e'::env) ext c' t ->
                                     c'' = (smartLet (translateExp (-1) e') c') ->
                                    Red (Let e c) env ext c'' t
| red_transf c c' t' p1 p2 env ext : c' = Zero -> t' = (singleton_trans c p1 p2 1) -> Red (Transfer c p1 p2) env ext c' t'
| red_scale e e' env ext c c' c'' t t' : e' = specialiseExp e env ext ->
                                   ScaleTrans (fromRLit e') t t' -> Red c env ext c' t ->
                                   c'' = (smartScale (translateExp (-1) e') c') ->
                                   Red (Scale e c) env ext c'' t'
| red_trans0 c env ext c' t : Red c env ext c' t -> Red (Translate 0 c) env ext c' t
| red_transS c env ext n c' t' : t' = empty_trans -> c' = Translate n c -> Red (Translate (S n) c) env ext c' t'
| red_both c1 c1' c2 c2' env ext t1 t2 c t : Red c1 env ext c1' t1 -> Red c2 env ext c2' t2 ->
                                             c = smartBoth c1' c2' -> t = add_trans t1 t2 ->
                                             Red (Both c1 c2) env ext c t
| red_if0_false env ext c1 c2 c' b t : fromBLit (specialiseExp b env ext) = Some false ->
                                         Red c2 env ext c' t -> Red (If b 0 c1 c2) env ext c' t
| red_ifS_false env ext c1 c2 n b c t : fromBLit (specialiseExp b env ext) = Some false ->
                                    c = If b n c1 c2 -> t = empty_trans ->
                                       Red (If b (S n) c1 c2) env ext c t
| red_if_true env ext c1 c2 c' n b t : fromBLit (specialiseExp b env ext) = Some true ->
                                         Red c1 env ext c' t -> Red (If b n c1 c2) env ext c' t
.

(* N.B. If rule red_ifS_false used (specialiseExp b env ext) for the
result contract, the rule would be unsound. *)

Hint Constructors Red.

Module Preservation.

  (* Proof of type preservation by Red *)

Lemma red_typed c c' envp extp t g:
  TypeEnvP g envp -> TypeExtP extp ->
  g |-C c -> Red c envp extp c' t ->  g |-C c'.
Proof.
  intros T1 T2 T R. generalize dependent g.
  induction R;intros;inversion T;subst;
  eauto 10 using smartLet_typed, smartBoth_typed, smartScale_typed, translateExp_type,specialiseExp_typed, fromLit_typed.
Qed.

Lemma tsub_tsub n m t : tsub n (tsub m t) = tsub (n + m) t.
Proof.
  unfold tsub. rewrite Z.opp_add_distr. apply tadd_tadd.
Qed.

Lemma map_tsub_tsub n m t : map (tsub n) (map (tsub m) t) = map (tsub (n + m)) t.
Proof.
  rewrite map_map. apply map_ext. apply tsub_tsub.
Qed.

Lemma succ_of_nat d : Z.of_nat d + 1 = Z.of_nat (S d).
Proof.
  rewrite Nat2Z.inj_succ. omega.
Qed.

Lemma all2_tle_tsub_1 ts : all2 tle (map (tsub 1) ts) ts.
Proof.
  apply all2_map_forall;intros. destruct x;simpl;constructor; omega.
Qed.

Open Scope time.

Lemma tle_tsub_1 t : tsub 1 t <= t.
Proof.
  destruct t;simpl;constructor; omega.
Qed.

Lemma tadd_tle d x y : (0 <= d)%Z -> x <= y ->  x <= tadd d y.
Proof.
  intros L T.
  destruct x, y; simpl in *;eauto;inversion T; constructor. omega.
Qed.

Lemma tadd_tle_1 x y : x <= y ->  x <= tadd 1 y.
Proof.
  intros T.
  destruct x, y; simpl in *;eauto;inversion T; constructor. omega.
Qed.

Ltac inv := match goal with
              | [T : ex _ |- _] => decompose [ex and] T;clear T
            end.

Lemma red_timed' c c' envp extp tr ts t:
  CausalC ts t c -> Red c envp extp c' tr -> exists t', CausalC (map (tsub 1) ts) t' c' /\ tsub 1 t <= t'.
Proof.
  intros T R. generalize dependent ts. generalize dependent t.
  induction R;intros;inversion T;subst;
  try apply IHR in  H6;try apply IHR in  H8;
  try apply IHR1 in  H5;try apply IHR2 in  H6;
  repeat inv;
  unfold tsub' in *; simpl in *; try rewrite tsub_0,map_tsub_0 in *;
  eauto 7 using smartLet_timed, smartBoth_timed, smartScale_timed, translateExp_timed,specialiseExp_timed.
  - eexists. split. apply smartScale_timed. econstructor;eauto. unfold tsub. simpl.
    assert (x = tadd (-1) (tadd 1 x)) as E. rewrite tadd_tadd. simpl. rewrite tadd_0. reflexivity.
    rewrite E. eapply translateExp_timed. apply specialiseExp_timed.
    eapply CausalE_open with (ts:=ts) (t:=t1);eauto using all2_tle_refl, tadd_tle_1.
    apply tsub_tadd_tle;assumption. unfold tsub. auto using tle_tadd.
  - eexists (tsub 1 t). split. econstructor.
    unfold tsub' in *. rewrite tsub_tsub, map_tsub_tsub. rewrite succ_of_nat.
    assumption. auto.
  - eexists (tmin x x0). split. apply smartBoth_timed. constructor.
    eapply CausalC_open with (t:=x0); auto using all2_tle_refl, tmin_tle_r.
    eapply CausalC_open with (t:=x); auto using all2_tle_refl, tmin_tle_l.
    unfold tmin. destruct (x <=? x0);auto.
  - eexists (tsub 1 t0). split. constructor;eauto.
    eapply CausalE_open with (ts:=ts). apply all2_tle_tsub_1. apply tle_refl. assumption.
    apply CausalC_open with (ts:=ts) (t:=t0). apply all2_tle_tsub_1. apply tle_tsub_1.
    assumption.  unfold tsub' in *. rewrite tsub_tsub, map_tsub_tsub. rewrite succ_of_nat.
    assumption. apply tle_refl.
Qed.

Lemma red_timed c c' envp extp tr ts t:
  CausalC ts t c -> Red c envp extp c' tr -> CausalC (map (tsub 1) ts) (tsub 1 t) c'.
Proof.
  intros C R. eapply red_timed' in R;eauto. decompose [ex and] R.
  eauto using  CausalC_open, all2_tle_refl.
Qed.

Theorem red_preservation g envp extp t c c' tr :
  TypeEnvP (map type g) envp -> TypeExtP extp ->
  TiTyC g t c -> Red c envp extp c' tr ->  TiTyC (map (sub_time 1) g) (tsub 1 t) c'.
Proof.
  intros Ev Ex T R. apply TiTyC_decompose in T. destruct T.
  rewrite TiTyC_decompose. split. rewrite map_map.
  rewrite map_ext with (g := type) by apply type_sub_time.
  eauto using red_typed.
  rewrite map_map.
  erewrite map_ext by apply time_sub_time.
  rewrite <- map_map.
  eauto using red_timed.
Qed.

End Preservation.

Import Preservation.

Module Soundness.

  (* Proof of soundness of Red according to denotational semantics *)

Theorem red_sound1 c c' env ext envp extp tr t g:
  g |-C c ->
      TypeEnv g env -> TypeExt ext ->
  Red c envp extp c' t ->
  ext_inst extp ext ->
  env_inst envp env ->
  C[|c|] env ext = Some tr -> tr O = t.
Proof.

  Ltac spec := repeat match goal with
                  | [T: fromRLit _ = Some _ |- _ ] => apply fromRLit_fromLit in T
                  | [T: fromBLit _ = Some _ |- _ ] => apply fromBLit_fromLit in T
                  | [T: fromLit _ = Some _ |- _ ] => eapply specialise_fromLit in T;eauto; try rewrite T in *
               end.
  intros T E X R I J S.
  generalize dependent env. generalize dependent ext. generalize dependent g. generalize dependent tr.
  induction R;intros; simpl in S; try option_inv' S; try solve [inversion S;auto|auto];inversion T;clear T;subst.
  - eapply IHR;eauto. eauto using Esem_typed  . constructor. intros.
    spec. inversion H3. reflexivity. assumption.
  - unfold scale_trace,compose. option_inv_auto. erewrite IHR;eauto. inversion H0.
    * apply scale_empty_trans.
    * symmetry in H3. spec. inversion H1. subst. simpl in H2. inversion H2. reflexivity.
  - erewrite <- IHR;eauto. rewrite adv_ext_0 in H1. rewrite delay_trace_0. assumption.
  - unfold add_trace. erewrite <- IHR1;eauto. erewrite <- IHR2;eauto.
  - spec. eapply IHR;eauto.
  - spec. option_inv_auto. reflexivity.
  - spec. eapply IHR;eauto. destruct n; simpl in S; rewrite H in S;assumption.
Qed.

Theorem red_sound2 c c' env ext envp extp t t1 t2 i g:
  g |-C c ->
      TypeEnv g env -> TypeExt ext ->
  Red c envp extp c' t ->
  ext_inst extp ext ->
  env_inst envp env ->
  C[|c|]env ext = Some t1 -> C[|c'|] env (adv_ext 1 ext) = Some t2
  -> t1 (S i) = t2 i.
Proof.
  intros T E X R I J S1 S2. generalize dependent t1. generalize dependent t2. generalize dependent env.
  generalize dependent ext. generalize dependent g.
  induction R; simpl in *;intros;inversion T;clear T;subst;try solve [inversion S1;inversion S2;eauto].
  - option_inv_auto. eapply IHR;eauto.
    eauto using Esem_typed.
    constructor. intros. spec. inversion H0. reflexivity. auto.
    erewrite smartLet_sound in S2;eauto. simpl in S2. option_inv_auto.
    rewrite translateExp_ext_opp in H2 by reflexivity.
    erewrite specialiseExp_sound in H2;eauto. rewrite H2 in H0. inversion H0. subst. auto.
  - option_inv_auto. spec. erewrite smartScale_sound in S2 by eauto 10 using red_typed.
    simpl in S2. option_inv_auto. rewrite translateExp_ext_opp in H8 by reflexivity.
    erewrite specialiseExp_sound in H8;eauto.
    unfold scale_trace, compose. erewrite IHR by eauto. f_equal.
    rewrite H8 in H3. inversion H3. subst. rewrite H9 in H4. inversion H4. reflexivity.
  - option_inv_auto. rewrite delay_trace_0. eapply IHR;eauto.
  - option_inv_auto. simpl in S2. option_inv_auto. rewrite delay_trace_S. f_equal.  rewrite adv_ext_iter in H1.
    rewrite Zpos_P_of_succ_nat in H0. rewrite Z.add_1_l in H1. rewrite H0 in H1. inversion H1. reflexivity.
  - option_inv_auto. erewrite smartBoth_sound in S2;eauto.
    * simpl in S2. option_inv_auto. unfold add_trace,compose. f_equal;eauto.
    * eauto 10 using red_typed.
  - spec. eapply IHR;eauto.
  - spec. option_inv_auto. rewrite delay_trace_S. rewrite delay_trace_0. simpl in S2.
    rewrite H1 in S2. inversion S2. reflexivity.
  - spec. eapply IHR;eauto. destruct n; simpl in S1; rewrite H in S1; assumption.
    Qed.

End Soundness.
Import Soundness.

Module Progress.

  (* Proof of progress of Red *)

Open Scope time.

Definition ext_def_until (ext : ExtEnvP) t :=
  forall l i, Time i <= t -> exists v, ext l i = Some v.

Definition env_def_until (env : EnvP) ts t :=
  all2 (fun v t' => time t' <= t -> exists v', v = Some v' /\ TypeVal v' (type t')) env ts.

Lemma fromLit_toLit v : fromLit (toLit v) = Some v.
Proof.
  destruct v;reflexivity.
Qed.

Lemma lookupEnvP_complete env tis ti v t:
  time ti <= t -> env_def_until env tis t -> TiTyV tis ti v
  -> exists v', lookupEnvP v env = Some v' /\ TypeVal v' (type ti).
Proof.
  intros M E T. generalize dependent env.
  induction T;intros;
  inversion E; subst; simpl; try rewr_assumption; eauto.
Qed.

Lemma add_time_0 t : add_time 0 t = t.
Proof.
  destruct t. destruct ti; simpl; try rewrite Z.add_0_r; reflexivity.
Qed.

Lemma map_add_time_0 ts : map (add_time 0) ts = ts.
Proof.
  erewrite map_ext. apply map_id. intros. auto using add_time_0.
Qed.

Lemma adv_ext_def_until ext t d :
  ext_def_until ext t ->
  ext_def_until (adv_ext (- Z.of_nat d) ext) (tadd' d t).
Proof.
  unfold ext_def_until. intros E. intros l i L. unfold adv_ext.
  assert (Time (- Z.of_nat d + i) <= t) as L'
  by (destruct t; simpl in *;inversion L; subst; constructor; omega).
  eapply E in L'. decompose [ex] L'. rewr_assumption. eauto.
Qed.

Lemma add_time_tle s t d : tadd' d s <= tadd' d t -> s <= t.
Proof.
  intro T. destruct s, t; simpl in *;inversion T;subst;constructor;omega.
Qed.

Lemma env_def_until_add_time d env ti tis :
  env_def_until env tis ti
  -> env_def_until env (map (add_time d) tis) (tadd' d ti).
Proof.
  unfold env_def_until. intros.
  rewrite <- map_id with (l:=env). apply all2_map'. eapply all2_impl in H.
  apply H. simpl. intros. rewrite type_add_time. rewrite time_add_time in *.
  eauto using add_time_tle.
Qed.

Lemma ext_def_until_adv d ext ti :
  (d <= 0)%Z -> ext_def_until ext ti -> ext_def_until (adv_ext d ext) ti.
Proof.
  unfold ext_def_until. intros L E l i Tl.
  assert (Time (d+i) <= ti) as Tl' by (inversion Tl; subst; constructor; omega).
  eauto.
Qed.

Lemma ext_def_until_step ext ti : ext_def_until ext ti -> ext_def_until (adv_ext (-1) ext) ti.
Proof.
  intros. apply ext_def_until_adv. omega. assumption.
Qed.

Lemma ext_def_until_tle t t' ext : t' <= t -> ext_def_until ext t -> ext_def_until ext t'.
Proof.
  unfold ext_def_until. eauto.
Qed.

Lemma env_def_until_tle ts t t' env : t' <= t -> env_def_until env ts t -> env_def_until env ts t'.
Proof.
  unfold env_def_until. intros l T. induction T;eauto.
Qed.

Lemma fromLit_real x : (exists v, fromLit x = Some v /\ TypeVal v REAL) -> exists v, x = OpE (RLit v) nil.
Proof.
  intro E. destruct E as [v E]. destruct E as [E1 E2]. inversion E2. subst.
  apply toLit_fromLit in E1. subst. simpl. eauto.
Qed.

Lemma fromLit_bool x : (exists v, fromLit x = Some v /\ TypeVal v BOOL) -> exists v, x = OpE (BLit v) nil.
Proof.
  intro E. destruct E as [v E]. destruct E as [E1 E2]. inversion E2. subst.
  apply toLit_fromLit in E1. subst. simpl. eauto.
Qed.

Ltac inv := match goal with
              | [T : all2 _  _ _ |- _] => inversion T; clear T;subst
              | [T : _ |- _] => first [apply fromLit_bool in T|apply fromLit_real in T];
                               let x := fresh in destruct T as [x T];rewrite T;clear T
              | [t : Ty |- _] => destruct t
              | [ |- context[match ?x with _ => _ end]] => destruct x
end.

Lemma specialiseOp_complete ts ti args op env ext :
  |-Op op ∶ ts => ti
  -> all2 (fun (e' : Exp) t' =>
             exists v : Val,
               fromLit (specialiseExp e' env ext) = Some v /\ |-V v ∶ t')  args ts
  -> exists v,  (specialiseOp op (map (fun e' : Exp => specialiseExp e' env ext) args)) >>= fromLit = Some v
               /\ TypeVal v ti.
Proof.
  intros TO As. destruct TO;repeat (inv;subst; simpl;eauto).
Qed.

(* [specialiseExp] always yields a literal, if given sufficiently
defined environments. *)

Lemma specialiseExp_complete t tis ti e ext env :
  time ti <= t -> TiTyE tis ti e -> ext_def_until ext t -> env_def_until env tis t -> TypeExtP ext
  -> exists v, fromLit (specialiseExp e env ext) = Some v /\ TypeVal v (type ti).
Proof.
  intros M T Ti E TE.
  generalize dependent env.   generalize dependent ext.
  generalize dependent ti. generalize dependent tis. generalize t.
  induction e using Exp_ind';intros.
  - inversion T. subst. clear T. simpl.
    assert (all2 (fun e' t' => exists v, fromLit (specialiseExp e' env ext) = Some v
                                               /\ TypeVal v t') args (map type ts')) as G.
    inversion H4. subst. clear H4 H1.
    induction H5;constructor.
    + inversion H. inversion H0. subst. eapply H4;eauto; rewr_assumption;
      eauto using ext_def_until_tle, env_def_until_tle.
    + inversion H0. inversion H. subst. apply IHall2;  eauto.
    + clear H. inversion H4. eapply specialiseOp_complete in G;eauto.
      destruct G as [v G]. destruct G as [G1 G2]. option_inv G1. rewr_assumption.
      simpl. eauto.
  - inversion T. subst. assert (exists v, ext l i = Some v) as D by eauto.
    decompose [ex] D. simpl. rewr_assumption. simpl.
    assert (TypeVal' (ext l i) (type ti)) as T' by eauto.
    rewr_assumption in T'. inversion T'. eauto using fromLit_toLit.
  - assert (exists v', lookupEnvP v env = Some v' /\ TypeVal v' (type ti)) as Hv
      by (inversion T; subst; eauto using lookupEnvP_complete).
    decompose [ex and] Hv. simpl. rewr_assumption. simpl. eauto using fromLit_toLit.
  - simpl. inversion T. subst. clear T. pose Ti as Ti'.
    apply adv_ext_def_until with (d:=d) in Ti'.
    eapply IHe2 in Ti';try rewrite time_add_time; eauto using env_def_until_add_time.
    decompose [ex and] Ti'. clear Ti'. rewrite type_add_time in *. rewr_assumption.
    assert (exists v : Val,
             Acc_sem
                (specialiseFun (specialiseExp e1) env
                   (adv_ext (- Z.of_nat d) ext)) d
                (Some x) = Some v /\ |-V v ∶ type ti) as G.
    clear H0 H3.
    generalize dependent env. generalize dependent ext. induction d;intros.
    + simpl in *. eauto.
    + simpl. pose E as E'. eapply IHd with (ext:=adv_ext (-1) ext) in E';eauto using ext_def_until_step.
      decompose [ex and] E'. repeat rewrite adv_ext_step'.
      rewr_assumption. unfold specialiseFun.
      eapply all2_cons with (y:=type ti @ TimeBot) in E;eauto.
      eapply IHe1 in E;eauto.
      rewrite H0 in *. auto. rewrite <- adv_ext_step. rewrite adv_ext_opp by omega. assumption.
    + decompose [ex and] G. rewr_assumption. simpl. eauto using fromLit_toLit.
Qed.

Lemma map_sub_time_0 ts : map (sub_time 0) ts = ts.
Proof.
  erewrite map_ext. apply map_id. intros. destruct a. destruct ti; simpl; repeat f_equal. omega.
Qed.

Lemma fromLit_fromRLit e :
  (exists v, fromLit e = Some v /\ TypeVal v REAL)
  -> exists r, fromRLit e = Some r.
Proof.
  intro E. decompose [ex and] E. destruct e;tryfalse. destruct op, args;tryfalse;simpl in *;eauto.
  inversion H0. subst. inversion H1.
Qed.

Lemma fromLit_fromBLit e :
  (exists v, fromLit e = Some v /\ TypeVal v BOOL)
  -> exists b, fromBLit e = Some b.
Proof.
  intro E. decompose [ex and] E. destruct e;tryfalse. destruct op, args;tryfalse;simpl in *;eauto.
  inversion H0. subst. inversion H1.
Qed.

Definition mk_env_inst : TyEnv -> EnvP -> Env :=
  zipWith (fun t v => match v with
                  | Some v' => v'
                  | None => match t with
                              | BOOL => BVal false
                              | REAL => RVal 0
                            end
                      end).

Lemma mk_env_inst_env_inst env tys : TypeEnvP tys env -> env_inst env (mk_env_inst tys env).
Proof.
  intros T. induction T;constructor;eauto. intros. destruct x; congruence.
Qed.

Lemma mk_env_inst_typed env tys : TypeEnvP tys env -> TypeEnv tys (mk_env_inst tys env).
Proof.
  intros T. induction T;constructor;eauto. intros. destruct x. inversion H. auto.
  destruct y;eauto.
Qed.

Definition mk_ext_inst (ext : ExtEnvP) : ExtEnv
  := fun l i => match ext l i with
                  | Some v => v
                  | None => match l with
                              | LabB _ => BVal false
                              | LabR _ => RVal 0
                            end
                end.

Lemma mk_ext_inst_ext_inst ext : ext_inst ext (mk_ext_inst ext).
Proof.
  unfold ext_inst, mk_ext_inst. intros. rewr_assumption. reflexivity.
Qed.

Lemma mk_ext_inst_typed ext: TypeExtP ext -> TypeExt (mk_ext_inst ext).
Proof.
  unfold TypeExt, TypeExtP, mk_ext_inst. intros.
  cases (ext l z) as E. assert (|-V' Some v ∶ t) as V. rewr_assumption. eauto.
  inversion V. auto. destruct H0;auto.
Qed.

Hint Resolve mk_ext_inst_ext_inst mk_env_inst_env_inst mk_ext_inst_typed mk_env_inst_typed : inst.

Lemma red_empty tis ti ext env c c' t' :
  Time 0 < ti -> TypeEnvP (map type tis) env -> TypeExtP ext -> TiTyC tis ti c ->
  Red c env ext c' t' -> t' = empty_trans.
Proof.
  intros L Tv Tx Tc R.
  rewrite TiTyC_decompose in Tc. destruct Tc as [Tc1 Tc2].
  inversion L. subst.
  pose Tc1 as Tc1'.
  apply Csem_typed_total
  with (env := mk_env_inst (map type tis) env)
       (ext := mk_ext_inst ext) in Tc1';
    eauto with inst.
  unfold total_trace in *. destruct Tc1' as [t Tc1'].
  pose Tc1' as S.
  eapply red_sound1 in S;eauto with inst.
  eapply CausalC_empty in Tc1';eauto. rewrite Tc1' in S. auto. simpl. auto.
Qed.

Lemma tle_tlt x y z: x <= y -> y < z -> x < z.
Proof.
  intros X Y. destruct X. destruct Y; constructor. inversion Y;subst. inversion Y. subst.
  constructor. omega.
Qed.

Theorem red_progress ti ti' tis c env ext :
  Time 0 <= ti -> TiTyC tis ti' c
  -> ext_def_until ext ti -> env_def_until env tis ti -> TypeExtP ext -> TypeEnvP (map type tis) env
  -> exists c' t', Red c env ext c' t'.
Proof.
  intros Ti T Ex Ev Te Tv.
  generalize dependent env. generalize dependent ext.
  induction T; simpl; intros;eauto.
  - (* Translate *)
    destruct d; eauto.
    assert (exists c' t', Red c env ext c' t') as IH by
        (eapply IHT; try rewrite tsub'_0;try rewrite map_sub_time_0;eauto).
    decompose [ex] IH. do 2 eexists. eauto.
  - (* Let *)
    assert (exists c' t', Red c (fromLit (specialiseExp e env ext) :: env) ext c' t') as IH
    by (eapply IHT;eauto; constructor;eauto using specialiseExp_complete;
        rewrite TiTyE_decompose in H; destruct H; eauto using fromLit_typed,specialiseExp_typed).
    decompose [ex] IH. do 2 eexists. econstructor;eauto.
  - (* Scale *)
    assert (exists c' t', Red c env ext c' t') as IH by (eapply IHT;eauto).
    decompose [ex] IH.
    cases (ti0 <=? ti) as TL.
    * rewrite tleb_tle in TL.
      eapply specialiseExp_complete in H0;eauto.
      apply fromLit_fromRLit in H0. decompose [ex] H0.
      do 2 eexists. econstructor;eauto.
      rewr_assumption. constructor.
    * rewrite tleb_tgt in TL.
      assert (Time 0 < ti0) as Ti' by eauto using tle_tlt.
      assert (x0 = empty_trans) as Em.
      eauto using red_empty. subst.
      do 2 eexists. econstructor;eauto.
      eapply scaleTrans_empty.
  - (* Both *)
    assert (exists c' t', Red c1 env ext c' t') as IH1 by (eapply IHT1;eauto).
    assert (exists c' t', Red c2 env ext c' t') as IH2 by (eapply IHT2;eauto).
    decompose [ex] IH1. decompose [ex] IH2. eauto.
  - (* If *)
    eapply specialiseExp_complete in H;simpl;eauto.
    apply fromLit_fromBLit in H. destruct H as [b H].
    destruct b.
    + assert (exists c' t', Red c1 env ext c' t') as IH1 by (eapply IHT1;eauto).
      decompose [ex] IH1. eapply red_if_true in H;eauto.
    + destruct d.
      * assert (exists c' t', Red c2 env ext c' t') as IH2 by
          (eapply IHT2;try rewrite tsub'_0;try rewrite map_sub_time_0;eauto).
        decompose [ex] IH2.
        eapply red_if0_false in H;eauto.
      * eapply red_ifS_false in H;eauto.
Qed.

End Progress.

Module Compute.

  (* Define Red as a computable function redfun and prove it correct  *)

Open Scope R.
Import SMap.

Definition lift2M {A B C} (f : A -> B -> C) (x : option (A * B)) : option C
  := liftM (fun x: (A * B) => let (x1,x2) := x in f x1 x2) x.

Program Definition scale_trans' (v : option R) (t : SMap) : option SMap :=
  match v with
  | None => if SMap.is_empty t then Some SMap.empty else None
  | Some v => Some (if Req_dec v 0 then SMap.empty else  SMap.map (fun x => v * x) _ t)
  end.

Next Obligation.
apply Rmult_integral in H0. destruct H0. tryfalse. assumption.
Qed.

(* Computable function that implements the reduction semantics. *)

Fixpoint redfun (c : Contr) (env : EnvP) (ext : ExtEnvP) : option (Contr * SMap) :=
  match c with
    | Zero => Some (Zero, SMap.empty)
    | Let e c => let e' := specialiseExp e env ext in
                 liftM (fun ct : Contr * SMap => let (c', t) := ct in (smartLet (translateExp (-1) e') c', t))
                       (redfun c (fromLit e'::env) ext)
    | Transfer c p1 p2 => Some (Zero, SMap.singleton c p1 p2 1 R1_neq_R0)
    | Scale e c => let e' := specialiseExp e env ext
                   in redfun c env ext  >>=
                      (fun ct => let (c', t) := ct in
                                 liftM (fun t' => (smartScale (translateExp (-1) e') c', t'))
                                       (scale_trans' (fromRLit e') t))
    | Translate n c => match n with
                         | O => redfun c env ext
                         | S n' => Some (Translate n' c, SMap.empty)
                       end
    | Both c1 c2 =>  liftM2 (fun (ct1 ct2 : Contr * SMap) => let (c1',t1) := ct1 in
                                     let (c2',t2) := ct2
                                     in (smartBoth c1' c2', SMap.union_with Rplus t1 t2))
                         (redfun c1 env ext) (redfun c2 env ext)
    | If b n c1 c2 => fromBLit (specialiseExp b env ext) >>=
                               (fun b' => if b' then redfun c1 env ext
                                          else match n with
                                                 | O => redfun c2 env ext
                                                 | S n' => Some (If b n' c1 c2,SMap.empty)
                                               end)
  end.

Definition smap_fun (m:SMap) (p1 p2 : Party) (a : Asset) : R := SMap.find p1 p2 a m.
Definition smap_fun_eq (m:SMap) f := forall p1 p2 a, SMap.find p1 p2 a m = f p1 p2 a.

Lemma smap_fun_empty : smap_fun SMap.empty = empty_trans.
Proof.
 do 3 (apply functional_extensionality;intro). unfold smap_fun.
 rewrite empty_find. reflexivity.
Qed.

Ltac eqb_eq := repeat rewrite andb_true_iff in *;repeat rewrite Party.eqb_eq in *; repeat rewrite Asset.eqb_eq in *.
Ltac eqb_refl := repeat rewrite Party.eqb_refl in *; repeat rewrite Asset.eqb_refl in *.

Lemma smap_fun_singleton p1 p2 a r p : smap_fun (singleton p1 p2 a r p) = singleton_trans p1 p2 a r.
Proof.
  unfold singleton_trans, smap_fun,find,singleton.
  do 3 (apply functional_extensionality;intro).
  cases (compare x x0) as C1. cases (Party.eqb p1 p2) as P1. reflexivity.
  rewrite compare_eq in C1. subst.
  cases (Party.eqb p1 x0 && Party.eqb p2 x0 && Asset.eqb a x1) as E1.
  eqb_eq. decompose [and] E1. subst. rewrite Party.eqb_refl in P1.
  tryfalse. reflexivity.
  cases (Party.eqb p1 p2) as P1;simpl. rewrite Party.eqb_eq in P1. rewrite <- compare_eq in P1.
  rewrite P1. rewrite FMap.empty_find. reflexivity.
  cases (compare p1 p2) as C2. rewrite compare_eq in C2. subst. rewrite Party.eqb_refl in P1. tryfalse.
  cases (FMap.find (x, x0, x1) (FMap.singleton (p1, p2, a) r)) as F1.
  apply FMap.find_singleton in F1. destruct F1 as [F1 F1']. inversion F1. subst.
  eqb_refl. reflexivity.  apply FMap.find_singleton_not in F1.
  cases (Party.eqb p1 x && Party.eqb p2 x0 && Asset.eqb a x1) as E1.
  eqb_eq. decompose [and] E1. subst. tryfalse.
  cases (Party.eqb p1 x0 && Party.eqb p2 x && Asset.eqb a x1) as E2.
  eqb_eq. decompose [and] E2. subst. rewrite compare_lt_gt in C1. tryfalse. reflexivity.
  cases (FMap.find (x, x0, x1) (FMap.singleton (p1, p2, a) (- r))) as F1.
  apply FMap.find_singleton in F1. destruct F1 as [F1 F1']. inversion F1. subst.
  tryfalse. apply FMap.find_singleton_not in F1.
  cases (Party.eqb p1 x && Party.eqb p2 x0 && Asset.eqb a x1) as E1.
  eqb_eq. decompose [and] E1. subst. tryfalse.
  cases (Party.eqb p1 x0 && Party.eqb p2 x && Asset.eqb a x1) as E2.
  eqb_eq. decompose [and] E2. subst. unfold FMap.singleton.
  rewrite FMap.add_find_new. reflexivity.
  cases (FMap.find (x, x0, x1) (FMap.singleton (p2, p1, a) (- r))) as F2.
  apply FMap.find_singleton in F2. destruct F2. inversion H. subst.
  eqb_refl. tryfalse. reflexivity.

  rewrite <- compare_lt_gt in C1.
  cases (Party.eqb p1 p2) as P1;simpl. rewrite Party.eqb_eq in P1. rewrite <- compare_eq in P1.
  rewrite P1. rewrite FMap.empty_find. reflexivity.
  cases (compare p1 p2) as C2. rewrite compare_eq in C2. subst. rewrite Party.eqb_refl in P1. tryfalse.
  cases (FMap.find (x0, x, x1) (FMap.singleton (p1, p2, a) r)) as F1.
  apply FMap.find_singleton in F1. destruct F1 as [F1 F1']. inversion F1. subst.
  cases (Party.eqb x0 x && Party.eqb x x0 && Asset.eqb x1 x1) as E1.
  eqb_eq. decompose [and] E1. subst x. rewrite <- compare_eq in H2. tryfalse.
  cases (Party.eqb x0 x0 && Party.eqb x x && Asset.eqb x1 x1). reflexivity.
  eqb_refl. tryfalse. apply FMap.find_singleton_not in F1.
  cases (Party.eqb p1 x && Party.eqb p2 x0 && Asset.eqb a x1) as E1. eqb_eq.
  decompose [and] E1. subst. rewrite compare_lt_gt in C1. tryfalse.
  cases (Party.eqb p1 x0 && Party.eqb p2 x && Asset.eqb a x1) as E2. eqb_eq.
  decompose [and] E2. subst. tryfalse. reflexivity.
  cases (FMap.find (x0, x, x1) (FMap.singleton (p2, p1, a) (- r))) as F1.
  apply FMap.find_singleton in F1. destruct F1 as [F1 F1']. inversion F1. subst.
  eqb_refl. simpl. apply Ropp_involutive.
  apply FMap.find_singleton_not in F1.
  cases (Party.eqb p1 x && Party.eqb p2 x0 && Asset.eqb a x1) as E1. eqb_eq.
  decompose [and] E1. subst. tryfalse.
  cases (Party.eqb p1 x0 && Party.eqb p2 x && Asset.eqb a x1) as E2. eqb_eq.
  decompose [and] E2. subst. tryfalse. reflexivity.
Qed.

Hint Constructors Red.

Ltac dprod := repeat match goal with
                       | [_: context[let (_,_) := ?x in _] |- _] => is_var x; destruct x
                       | [T: (_,_)=(_,_) |- _] => inversion T;clear T
                     end.

Lemma scale_trans_ScaleTrans (v : option R) t t' m m' :
  t' = smap_fun m' -> t = smap_fun m -> scale_trans' v m = Some m' -> ScaleTrans v t t'.
Proof.
  intros. destruct v. simpl in H1. inversion H1;clear H1. assert (t' = scale_trans r t) as S.
  subst. unfold smap_fun, scale_trans. repeat (apply functional_extensionality;intro).
  cases (Req_dec r 0) as E. rewrite empty_find. subst.
  rewrite Rmult_0_r. reflexivity.
  rewrite map_find. apply Rmult_comm. apply Rmult_0_r. intros. rewrite Ropp_mult_distr_r_reverse.
  reflexivity. rewrite S. econstructor.
  simpl in H1. cases (is_empty m) as R. inversion H1.
  rewrite empty_is_empty in R. subst. rewrite smap_fun_empty. constructor.
  tryfalse.
Qed.

Lemma smap_fun_add m1 m2 :  smap_fun (union_with Rplus m1 m2) = add_trans (smap_fun m1) (smap_fun m2).
Proof.
  unfold smap_fun, add_trans. repeat (apply functional_extensionality;intro). apply union_find.
Qed.

Theorem redfun_red c c' env ext t:
  redfun c env ext = Some (c', t) -> Red c env ext c' (smap_fun t) .
Proof.
  intro F. generalize dependent t. generalize dependent c'.
  generalize dependent ext. generalize dependent env.
  induction c;intros;simpl in *;try first[option_inv' F|injection F;intros];dprod;option_inv_auto;dprod;subst;
  eauto using smap_fun_empty, smap_fun_singleton, scale_trans_ScaleTrans, smap_fun_add.
  - destruct n; inversion F; auto using smap_fun_empty.
  - destruct x. auto. destruct n. auto. inversion H2. auto using smap_fun_empty.
Qed.

Lemma smap_fun_empty_compact m : smap_fun m = empty_trans -> m = SMap.empty.
Proof.
  destruct m as [M C]. intro F.
  apply empty_find_compact;eauto. intros.
  do 3 eapply equal_f in F.
  unfold smap_fun in F. rewrite F. reflexivity.
Qed.

Lemma ScaleTrans_scale_trans (v : option R) t t' m :
  t = smap_fun m -> ScaleTrans v t t' -> exists m', scale_trans' v m = Some m' /\ t' = smap_fun m'.
Proof.
  intros T S. inversion S.
  - subst. symmetry in H0. apply smap_fun_empty_compact in H0;auto.
    eexists. split. destruct v. simpl. cases (Req_dec r 0). reflexivity.
    rewrite -> H0. rewrite SMap.map_empty. reflexivity. simpl.
    cases (is_empty m). reflexivity. rewrite <- SMap.empty_is_empty in H0. tryfalse.
    rewrite smap_fun_empty. reflexivity.
  - simpl. cases (Req_dec v0 0) as R.
    eexists. split. reflexivity. subst.
    rewrite scale_trans_0. rewrite smap_fun_empty. reflexivity.
    eexists. split. reflexivity. subst. unfold smap_fun, scale_trans.
    do 3 (apply functional_extensionality;intro). rewrite map_find. apply Rmult_comm.
    apply Rmult_0_r. intros. rewrite Ropp_mult_distr_r_reverse. reflexivity.
Qed.

Theorem red_redfun c c' env ext t:
  Red c env ext c' t -> exists m, redfun c env ext = Some (c', m) /\ smap_fun m = t.
Proof.
  intro F. induction F; subst;
  repeat match goal with | [T : exists _, _ /\ _ |- _] => decompose [ex and] T; clear T;subst end;
  try solve[eexists;split;simpl;try reflexivity;eauto using smap_fun_empty,smap_fun_singleton, smap_fun_add;
  repeat match goal with | [T : _ = Some _ |- _] => rewrite T; clear T end;
  simpl;unfold pure,compose;simpl;try reflexivity].
  (* we only need to deal with scale *)
  - eapply ScaleTrans_scale_trans in H0. decompose [ex and] H0.
    eexists. split. simpl. rewrite H1. simpl.
    rewrite H3. simpl.
    unfold pure, compose. rewrite H2. reflexivity. auto. eauto.
  Qed.

End Compute.
Export Compute.


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

Require Export RReflection.
Require Export Bool.

Opaque csg_crr.
Opaque cm_crr.
Opaque cg_crr.
Opaque cr_crr.
Opaque csf_fun.
Opaque csbf_fun.
Opaque csr_rel.
Opaque cs_eq.
Opaque cs_neq.
Opaque cs_ap.
Opaque csg_unit.
Opaque csg_op.
Opaque cg_inv.
Opaque cg_minus.
Opaque cr_one.
Opaque cr_mult.
Opaque nexp_op.

Section RNormCorrect.

Variable F : CRing.
Variable val : Rvarindex->F.
Variable fun : Rfunindex->(PartFunct F).

Syntactic Definition II := (Rinterp F val fun).

(*
four kinds of Rexprs:

  I	(Rexpr_int _)
  V	(Rexpr_var _)
  M	(Rexpr_mult V M)
	I
  P	(Rexpr_plus M P)
	I

M: sorted on V
P: sorted on M, all M's not an I
*)

Fixpoint RMI_mult [e:Rexpr] : Rexpr->Rexpr := [f:Rexpr]
let d = (Rexpr_mult e f) in
  Cases e f of
    e (Rexpr_int ZERO) => (Rexpr_int ZERO)
  | (Rexpr_mult e1 e2) f => (Rexpr_mult e1 (RMI_mult e2 f))
  | (Rexpr_int i) (Rexpr_int j) => (Rexpr_int (Zmult i j))
  | _ _ => d
  end.

Opaque Zmult.
Lemma RMI_mult_corr : (e,f:Rexpr; x,y:F)
  (II e x)->(II f y)->(II (RMI_mult e f) x[*]y).
Cut (x,y:F)
     (II (Rexpr_int ZERO) y)->(II (Rexpr_int ZERO) x[*]y).
Cut (e1,e2,f:Rexpr; x,y:F)
     ((f:Rexpr; x,y:F)(II e2 x)->(II f y)->(II (RMI_mult e2 f) x[*]y))
     ->(II (Rexpr_mult e1 e2) x)
     ->(II f y)
     ->(II (Rexpr_mult e1 (RMI_mult e2 f)) x[*]y).
Cut (i,j:Z; x,y:F)
     (II (Rexpr_int i) x)
     ->(II (Rexpr_int j) y)
     ->(II (Rexpr_int (Zmult i j)) x[*]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_mult e f) x[*]y).
Induction e; Induction f; Simpl; Auto.
Induction z; Simpl; Auto.
Induction z0; Induction z; Simpl; Auto.
Induction z; Simpl; Auto.
Induction z; Simpl; Auto.
Induction f; Simpl; Auto.
Induction z; Simpl; Auto.
Induction z0; Simpl; Auto.
Intros; Apply Rinterp_mult with x y; Algebra.
Intros; Apply Rinterp_wd with ((zring (Zmult i j))::F).
Apply Rinterp_int; Algebra.
Inversion H. Inversion H0.
Step_final ((zring i)[*](zring j)::F).
Intros. Inversion H0.
Apply Rinterp_wd with x0[*](y0[*]y); Algebra .
Apply Rinterp_mult with x0 y0[*]y; Algebra.
Step (x0[*]y0)[*]y; Algebra.
Intros. Inversion H.
Apply Rinterp_wd with ((zring `0`)::F).
Apply Rinterp_int; Algebra .
Step (Zero::F).
Step x[*]Zero.
Step_final x[*](zring `0`).
Qed.
Transparent Zmult.

Fixpoint eq_nat [n:nat] : nat -> bool := [m:nat]
  Cases n m of
    (S n') (S m') => (eq_nat n' m')
  | O O => true
  | _ _ => false
  end.

Fixpoint lt_nat [n:nat] : nat -> bool := [m:nat]
  Cases n m of
    (S n') (S m') => (lt_nat n' m')
  | O (S _) => true
  | _ _ => false
  end.

Definition le_nat [n,m:nat] := (orb (eq_nat n m) (lt_nat n m)).

Definition eq_int [z:Z] : Z -> bool := [z':Z]
  Cases z z' of
    (POS n) (POS m) => (eq_nat (convert n) (convert m))
  | ZERO ZERO => true
  | (NEG n) (NEG m) => (eq_nat (convert n) (convert m))
  | _ _ => false
  end.

Definition lt_int [z:Z] : Z -> bool := [z':Z]
  Cases z z' of
    (POS n) (POS m) => (lt_nat (convert n) (convert m))
  | (POS n) _ => false
  | ZERO (POS n) => true
  | ZERO _ => false
  | (NEG n) (NEG m) => (lt_nat (convert m) (convert n))
  | (NEG n) _ => true
  end.

Definition le_int [z,z':Z] := (orb (eq_int z z') (lt_int z z')).

Fixpoint eq_Rexpr [e:Rexpr] : Rexpr -> bool := [f:Rexpr]
  Cases e f of
    (Rexpr_var n) (Rexpr_var m) => (eq_nat n m)
  | (Rexpr_int z) (Rexpr_int z') => (eq_int z z')
  | (Rexpr_plus e1 e2) (Rexpr_plus f1 f2) => (andb (eq_Rexpr e1 f1) (eq_Rexpr e2 f2))
  | (Rexpr_mult e1 e2) (Rexpr_mult f1 f2) => (andb (eq_Rexpr e1 f1) (eq_Rexpr e2 f2))
  | (Rexpr_part n e') (Rexpr_part m f') => (andb (eq_nat n m) (eq_Rexpr e' f'))
  | _ _ => false
  end.

Fixpoint lt_Rexpr [e:Rexpr] : Rexpr -> bool := [f:Rexpr]
  Cases e f of
    (Rexpr_var n) (Rexpr_var m) => (lt_nat n m)
  | (Rexpr_var n) _ => true
  | _ (Rexpr_var n) => false

  | (Rexpr_int z) (Rexpr_int z') => (lt_int z z')
  | (Rexpr_int _) _ => true
  | _ (Rexpr_int _) => false

  | (Rexpr_plus e1 e2) (Rexpr_plus f1 f2) => (orb (lt_Rexpr e1 f1) (andb (eq_Rexpr e1 f1) (lt_Rexpr e2 f2)))
  | (Rexpr_plus _ _) _ => true
  | _ (Rexpr_plus _ _) => false

  | (Rexpr_mult e1 e2) (Rexpr_mult f1 f2) => (orb (lt_Rexpr e1 f1) (andb (eq_Rexpr e1 f1) (lt_Rexpr e2 f2)))
  | (Rexpr_mult _ _) _ => true
  | _ (Rexpr_mult _ _) => false

  | (Rexpr_part n e') (Rexpr_part m f') => (orb (lt_nat n m) (andb (eq_nat n m) (lt_Rexpr e' f')))
  end.

Definition le_Rexpr [e,f:Rexpr] := (orb (eq_Rexpr e f) (lt_Rexpr e f)).

Lemma eq_nat_corr : (n,m:nat)((eq_nat n m)=true)->(n=m).
Induction n; Induction m; Simpl; Intros.
Trivial.
Inversion H0.
Inversion H0.
Rewrite (H n1 H1). Trivial.
Qed.

Lemma eq_int_corr : (n,m:Z)((eq_int n m)=true)->(n=m).
Induction n; Induction m; Simpl; Intros.
Trivial.
Inversion H.
Inversion H.
Inversion H.
Rewrite <- (convert_is_POS p). Rewrite <- (convert_is_POS p0).
Cut (convert p)=(convert p0). Auto. Apply eq_nat_corr. Assumption.
Inversion H.
Inversion H.
Inversion H.
Cut p=p0; Intros.
Rewrite H0; Auto.
Rewrite (anti_convert_pred_convert p). Rewrite (anti_convert_pred_convert p0).
Cut (convert p)=(convert p0). Intro. Auto. Apply eq_nat_corr. Assumption.
Qed.

Lemma eq_Rexpr_corr : (e,e':Rexpr)((eq_Rexpr e e')=true)->(e=e').
Induction e; Induction e'; Simpl; Intros; Try Inversion H3; Try Inversion H2; Try Inversion H1; Try Inversion H0; Try Inversion H.
Cut r=r0. Intro. Rewrite H0; Auto. Apply eq_nat_corr; Assumption.
Cut z=z0. Intro. Rewrite H0; Auto. Apply eq_int_corr; Assumption.
Clear H1 H2. Elim (andb_prop ?? H3); Intros.
Cut r=r1. Cut r0=r2. Intros. Rewrite H4; Rewrite H6. Auto.
Apply H0. Assumption. Apply H. Assumption.
Clear H1 H2. Elim (andb_prop ?? H3); Intros.
Cut r=r1. Cut r0=r2. Intros. Rewrite H4; Rewrite H6. Auto.
Apply H0. Assumption. Apply H. Assumption.
Clear H0. Elim (andb_prop ?? H1); Intros.
Cut r=r1. Cut r0=r2. Intros. Rewrite H4. Rewrite H5. Auto.
Apply H. Assumption. Apply eq_nat_corr. Assumption.
Qed.

Fixpoint RMV_mult [e:Rexpr] : Rexpr->Rexpr := [f:Rexpr]
let d = (Rexpr_mult e f) in
  Cases e f of
    (Rexpr_mult (Rexpr_var n) e') (Rexpr_var m) =>
      Cases (lt_nat n m) of
        true => (Rexpr_mult (Rexpr_var n) (RMV_mult e' f))
      | false => (Rexpr_mult f e)
      end
  | (Rexpr_mult (Rexpr_var n) e') (Rexpr_part _ _) =>
      (Rexpr_mult (Rexpr_var n) (RMV_mult e' f))
  | (Rexpr_mult (Rexpr_part _ _) e') (Rexpr_var _) =>
      (Rexpr_mult f e)
  | (Rexpr_mult (Rexpr_part n e') e0) (Rexpr_part m f') =>
      Cases (lt_Rexpr (Rexpr_part n e') f) of
        true => (Rexpr_mult (Rexpr_part n e') (RMV_mult e0 f))
      | false => (Rexpr_mult f e)
      end
  | (Rexpr_int i) f => (RMI_mult (Rexpr_mult f Rexpr_one) e)
  | _ _ => d
  end.

Opaque RMI_mult.
Lemma RMV_mult_corr : (e,f:Rexpr; x,y:F)
  (II e x)->(II f y)->(II (RMV_mult e f) x[*]y).
Cut (e1,e2,f:Rexpr; x,y:F)
     ((f:Rexpr; x,y:F)(II e2 x)->(II f y)->(II (RMV_mult e2 f) x[*]y))
     ->(II (Rexpr_mult e1 e2) x)
     ->(II f y)
     ->(II (Rexpr_mult e1 (RMV_mult e2 f)) x[*]y).
Cut (e,f:Rexpr; x,y:F)
     (II e x)->(II f y)->(II (RMI_mult (Rexpr_mult f Rexpr_one) e) x[*]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_mult f e) x[*]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_mult e f) x[*]y).
Intros H H0 H1 H2 e. Elim e.
Simpl; Auto.
Simpl; Auto.
Intros e1 H3 e2 H4.
Elim e1; Simpl; Auto.
Intros e1 H3 e2 H4.
Elim e1; Simpl; Auto.
Intros n f.
Elim f; Simpl; Auto.
Intro m.
Elim (lt_nat n m); Simpl; Auto.
Intros n f.
Intros H5 f0.
Elim f0; Simpl; Auto.
Intros f1 e0 H6.
Elim (orb (lt_nat n f1) (andb (eq_nat n f1) (lt_Rexpr f e0))); Simpl; Auto.
Intros n f.
Elim f; Simpl; Auto.
Intros; Apply Rinterp_mult with x y; Algebra.
Intros; Apply Rinterp_wd with y[*]x; Algebra.
Apply Rinterp_mult with y x; Algebra.
Intros; Apply Rinterp_wd with (y[*]One)[*]x.
Apply RMI_mult_corr; Auto.
Apply Rinterp_mult with y (One::F); Algebra .
Unfold Rexpr_one.
Apply Rinterp_int; Algebra .
Step_final x[*](y[*]One).
Intros. Inversion H0.
Apply Rinterp_wd with x0[*](y0[*]y).
Apply Rinterp_mult with x0 y0[*]y; Algebra.
Step_final (x0[*]y0)[*]y.
Qed.
Transparent RMI_mult.

Fixpoint RMM_mult [e:Rexpr] : Rexpr->Rexpr := [f:Rexpr]
let d = (Rexpr_mult e f) in
  Cases e f of
    (Rexpr_mult e1 e2) f => (RMV_mult (RMM_mult e2 f) e1)
  | (Rexpr_int i) f => (RMI_mult f e)
  | _ _ => d
  end.

Opaque RMV_mult RMI_mult.
Lemma RMM_mult_corr : (e,f:Rexpr; x,y:F)
  (II e x)->(II f y)->(II (RMM_mult e f) x[*]y).
Cut (e1,e2,f:Rexpr; x,y:F)
     ((f:Rexpr; x,y:F)(II e2 x)->(II f y)->(II (RMM_mult e2 f) x[*]y))
     ->(II (Rexpr_mult e1 e2) x)
     ->(II f y)
     ->(II (RMV_mult (RMM_mult e2 f) e1) x[*]y).
Cut (i:Z; f:Rexpr; x,y:F)
     (II (Rexpr_int i) x)->(II f y)->(II (RMI_mult f (Rexpr_int i)) x[*]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_mult e f) x[*]y).
Intros H H0 H1 e.
Elim e; Intros; Simpl; Auto.
Intros; Apply Rinterp_mult with x y; Algebra.
Intros; Apply Rinterp_wd with y[*]x; Algebra.
Apply RMI_mult_corr; Auto.
Intros. Inversion H0.
Apply Rinterp_wd with (y0[*]y)[*]x0.
Apply RMV_mult_corr; Auto.
Step x0[*](y0[*]y).
Step_final (x0[*]y0)[*]y.
Qed.
Transparent RMV_mult RMI_mult.

Fixpoint RMM_plus [e:Rexpr] : Rexpr->Rexpr := [f:Rexpr]
let d = (Rexpr_plus e f) in
  Cases e f of
    (Rexpr_mult (Rexpr_var n) e') (Rexpr_mult (Rexpr_var m) f') =>
      Cases (eq_nat n m) of
        true => (RMV_mult (RMM_plus e' f') (Rexpr_var n))
      | false => d
      end
  | (Rexpr_mult (Rexpr_part g arg) e') (Rexpr_mult (Rexpr_part h arg') f') =>
      Cases (andb (eq_nat g h) (eq_Rexpr arg arg')) of
        true => (RMV_mult (RMM_plus e' f') (Rexpr_part g arg))
      | false => d
      end
  | (Rexpr_int i) (Rexpr_int j) => (Rexpr_int (Zplus i j))
  | _ _ => d
  end.

Opaque RMV_mult.
Lemma RMM_plus_corr : (e,f:Rexpr; x,y:F)
  (II e x)->(II f y)->(II (RMM_plus e f) x[+]y).
Cut (i,j:Z; x,y:F)
     (II (Rexpr_int i) x)
     ->(II (Rexpr_int j) y)
     ->(II (Rexpr_int (Zplus i j)) x[+]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_plus e f) x[+]y).
Intros H H0 e; Elim e.
Simpl; Auto.
Intros z f; Elim f; Simpl; Auto.
Simpl; Auto.
Intros e1 H1 e2 H2.
Elim e1; Simpl; Auto.
Intros n f.
Elim f; Simpl; Auto.
Intros f1 H3 f2 H4.
Elim f1; Simpl; Auto.
Intro m.
Cut (eq_nat n m)=true->n=m.
Elim (eq_nat n m); Simpl; Auto.
Intros. Inversion H6. Inversion H7.
Apply Rinterp_wd with (y0[+]y1)[*]x0.
Apply RMV_mult_corr; Auto.
Step x0[*](y0[+]y1).
Step x0[*]y0[+]x0[*]y1.
Cut x0[=]x1. Intro.
Step_final x0[*]y0[+]x1[*]y1.
Apply refl_Rinterp with val fun (Rexpr_var n).
Assumption.
Rewrite (H5 (refl_equal ? true)). Assumption.
Intros; Apply eq_nat_corr; Auto.
Intros f e0 H3.
Intro f0.
Elim f0; Simpl; Auto.
Intros e3 H4 e4 H5.
Elim e3; Simpl; Auto.
Intros f1 e5 H6.
Cut (andb (eq_nat f f1) (eq_Rexpr e0 e5))=true->(f=f1).
Cut (andb (eq_nat f f1) (eq_Rexpr e0 e5))=true->e0=e5.
Elim (andb (eq_nat f f1) (eq_Rexpr e0 e5)); Simpl; Auto.
Intros. Inversion H9. Inversion H10. Apply Rinterp_wd with (y0[+]y1)[*]x0.
Apply RMV_mult_corr; Auto.
Stepr (x0[*]y0)[+](x1[*]y1). Step (y0[*]x0)[+](y1[*]x0).
Apply bin_op_wd_unfolded. Algebra. Stepr y1[*]x1. Apply mult_wd_rht.
Clear H6 H5 H4 H3 H2 H1.
Clear H9 H10.
Apply refl_Rinterp with val fun (Rexpr_part f e0).
Auto. Rewrite H7; Auto. Rewrite H8; Auto.
Intro. Elim (andb_prop ?? H7); Intros. Apply eq_Rexpr_corr; Auto.
Intro. Elim (andb_prop ?? H7); Intros. Apply eq_nat_corr; Auto.
Simpl; Auto.
Simpl; Auto.
Intros; Apply Rinterp_plus with x y; Algebra.
Intros. Inversion H. Inversion H0.
Apply Rinterp_wd with ((zring `i+j`)::F).
Apply Rinterp_int; Algebra.
Step_final ((zring i)[+](zring j)::F).
Qed.
Transparent RMV_mult.

Fixpoint eq_Rmonom [e:Rexpr] : Rexpr->bool := [f:Rexpr]
  Cases e f of
    (Rexpr_mult (Rexpr_var n) e') (Rexpr_mult (Rexpr_var m) f') =>
      (andb (eq_nat n m) (eq_Rmonom e' f'))
  | (Rexpr_mult (Rexpr_part n e1) e') (Rexpr_mult (Rexpr_part m f1) f') =>
      (andb (eq_nat n m) (andb (eq_Rmonom e' f') (eq_Rexpr e1 f1)))
  | (Rexpr_int _) (Rexpr_int _) => true
  | _ _ => false
  end.

Fixpoint lt_Rmonom [e:Rexpr] : Rexpr->bool := [f:Rexpr]
  Cases e f of
    (Rexpr_mult (Rexpr_var n) e') (Rexpr_mult (Rexpr_var m) f') =>
      (ifb (eq_nat n m) (lt_Rmonom e' f') (lt_nat n m))
  | (Rexpr_mult (Rexpr_var _) _) (Rexpr_mult (Rexpr_part _ _) _) => true
  | (Rexpr_mult (Rexpr_part n e1) e') (Rexpr_mult (Rexpr_part m f1) f') =>
      (ifb (eq_Rexpr (Rexpr_part n e1) (Rexpr_part m f1)) (lt_Rexpr e' f') (lt_Rexpr (Rexpr_part n e1) (Rexpr_part m f1)))
  | _ (Rexpr_int _) => true
  | _ _ => false
  end.

Fixpoint RPM_plus [e:Rexpr] : Rexpr->Rexpr := [f:Rexpr]
let d = (Rexpr_plus e f) in
  Cases e f of
    (Rexpr_plus e1 e2) (Rexpr_int _) => (Rexpr_plus e1 (RPM_plus e2 f))
  | (Rexpr_int i) (Rexpr_int j) => (RMM_plus e f)
  | (Rexpr_plus e1 e2) f =>
      Cases (eq_Rmonom e1 f) of
        true => (RPM_plus e2 (RMM_plus e1 f))
      | false =>
          Cases (lt_Rmonom e1 f) of
            true => (Rexpr_plus e1 (RPM_plus e2 f))
          | false => (Rexpr_plus f e)
          end
      end
  | (Rexpr_int i) f => (Rexpr_plus f e)
  | _ _ => d
  end.

Opaque RMM_plus.
Lemma RPM_plus_corr : (e,f:Rexpr; x,y:F)
  (II e x)->(II f y)->(II (RPM_plus e f) x[+]y).
Cut (e1,e2,f:Rexpr; x,y:F)
     ((f:Rexpr; x,y:F)(II e2 x)->(II f y)->(II (RPM_plus e2 f) x[+]y))
     ->(II (Rexpr_plus e1 e2) x)
     ->(II f y)
     ->(II (Rexpr_plus e1 (RPM_plus e2 f)) x[+]y).
Cut (e1,e2,f:Rexpr; x,y:F)
     ((f:Rexpr; x,y:F)(II e2 x)->(II f y)->(II (RPM_plus e2 f) x[+]y))
     ->(II (Rexpr_plus e1 e2) x)
     ->(II f y)
     ->(II (RPM_plus e2 (RMM_plus e1 f)) x[+]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (RMM_plus e f) x[+]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_plus e f) x[+]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_plus f e) x[+]y).
Intros H H0 H1 H2 H3 e. Elim e.
Simpl; Auto.
Intros z f; Elim f; Intros; Simpl; Auto.
Intros e1 H4 e2 H5 f. Simpl.
Elim (lt_Rmonom e1 f); Elim (eq_Rmonom e1 f); Elim f; Intros; Simpl; Auto.
Simpl; Auto.
Simpl; Auto.
Intros; Apply Rinterp_wd with y[+]x; Algebra.
Apply Rinterp_plus with y x; Algebra.
Intros; Apply Rinterp_plus with x y; Algebra.
Intros; Apply RMM_plus_corr; Auto.
Intros. Inversion H0.
Apply Rinterp_wd with y0[+](x0[+]y).
Apply H; Auto.
Apply RMM_plus_corr; Auto.
Step (y0[+]x0)[+]y.
Step_final (x0[+]y0)[+]y.
Intros. Inversion H0.
Apply Rinterp_wd with x0[+](y0[+]y).
Apply Rinterp_plus with x0 y0[+]y; Algebra .
Step_final (x0[+]y0)[+]y.
Qed.
Transparent RMM_plus.

Fixpoint RPP_plus [e:Rexpr] : Rexpr->Rexpr := [f:Rexpr]
let d = (Rexpr_plus e f) in
  Cases e f of
    (Rexpr_plus e1 e2) f => (RPM_plus (RPP_plus e2 f) e1)
  | (Rexpr_int i) f => (RPM_plus f e)
  | _ _ => d
  end.

Opaque RPM_plus.
Lemma RPP_plus_corr : (e,f:Rexpr; x,y:F)
  (II e x)->(II f y)->(II (RPP_plus e f) x[+]y).
Cut (e1,e2,f:Rexpr; x,y:F)
     ((f:Rexpr; x,y:F)(II e2 x)->(II f y)->(II (RPP_plus e2 f) x[+]y))
     ->(II (Rexpr_plus e1 e2) x)
     ->(II f y)
     ->(II (RPM_plus (RPP_plus e2 f) e1) x[+]y).
Cut (i:Z; f:Rexpr; x,y:F)
     (II (Rexpr_int i) x)->(II f y)->(II (RPM_plus f (Rexpr_int i)) x[+]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_plus e f) x[+]y).
Intros H H0 H1 e.
Elim e; Intros; Simpl; Auto.
Intros. Apply Rinterp_plus with x y; Algebra.
Intros. Apply Rinterp_wd with y[+]x; Algebra.
Apply RPM_plus_corr; Auto.
Intros. Inversion H0.
Apply Rinterp_wd with (y0[+]y)[+]x0.
Apply RPM_plus_corr; Auto.
Step x0[+](y0[+]y).
Step_final (x0[+]y0)[+]y.
Qed.
Transparent RPM_plus.

Fixpoint RPM_mult [e:Rexpr] : Rexpr->Rexpr := [f:Rexpr]
let d = (Rexpr_mult e f) in
  Cases e f of
    (Rexpr_plus e1 e2) f => (RPM_plus (RPM_mult e2 f) (RMM_mult e1 f))
  | (Rexpr_int i) _ => (RPM_plus (Rexpr_int ZERO) (RMI_mult f e))
  | _ _ => d
  end.

Opaque RPM_plus RMM_mult RMI_mult.
Lemma RPM_mult_corr : (e,f:Rexpr; x,y:F)
  (II e x)->(II f y)->(II (RPM_mult e f) x[*]y).
Cut (e1,e2,f:Rexpr; x,y:F)
     ((f:Rexpr; x,y:F)(II e2 x)->(II f y)->(II (RPM_mult e2 f) x[*]y))
     ->(II (Rexpr_plus e1 e2) x)
     ->(II f y)
     ->(II (RPM_plus (RPM_mult e2 f) (RMM_mult e1 f)) x[*]y).
Cut (i:Z; f:Rexpr; x,y:F)
     (II (Rexpr_int i) x)
     ->(II f y)
     ->(II (RPM_plus (Rexpr_int ZERO) (RMI_mult f (Rexpr_int i))) x[*]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_mult e f) x[*]y).
Intros H H0 H1 e.
Elim e; Intros; Simpl; Auto.
Intros. Apply Rinterp_mult with x y; Algebra.
Intros. Apply Rinterp_wd with (zring `0`)[+](y[*]x).
Apply RPM_plus_corr.
Apply Rinterp_int; Algebra .
Apply RMI_mult_corr; Auto.
Step Zero[+]y[*]x.
Step_final y[*]x.
Intros. Inversion H0.
Apply Rinterp_wd with y0[*]y[+]x0[*]y.
Apply RPM_plus_corr; Auto.
Apply RMM_mult_corr; Auto.
Step (y0[+]x0)[*]y.
Step_final (x0[+]y0)[*]y.
Qed.
Transparent RPM_plus RMM_mult RMI_mult.

Fixpoint RPP_mult [e:Rexpr] : Rexpr->Rexpr := [f:Rexpr]
let d = (Rexpr_mult e f) in
  Cases e f of
    (Rexpr_plus e1 e2) f => (RPP_plus (RPM_mult f e1) (RPP_mult e2 f))
  | (Rexpr_int i) f => (RPM_mult f e)
  | _ _ => d
  end.

Opaque RPP_plus RPM_mult.
Lemma RPP_mult_corr : (e,f:Rexpr; x,y:F)
  (II e x)->(II f y)->(II (RPP_mult e f) x[*]y).
Cut (e1,e2,f:Rexpr; x,y:F)
     ((f:Rexpr; x,y:F)(II e2 x)->(II f y)->(II (RPP_mult e2 f) x[*]y))
     ->(II (Rexpr_plus e1 e2) x)
     ->(II f y)
     ->(II (RPP_plus (RPM_mult f e1) (RPP_mult e2 f)) x[*]y).
Cut (i:Z; f:Rexpr; x,y:F)
     (II (Rexpr_int i) x)->(II f y)->(II (RPM_mult f (Rexpr_int i)) x[*]y).
Cut (e,f:Rexpr; x,y:F)(II e x)->(II f y)->(II (Rexpr_mult e f) x[*]y).
Intros H H0 H1 e.
Elim e; Intros; Simpl; Auto.
Intros. Apply Rinterp_mult with x y; Algebra.
Intros. Apply Rinterp_wd with y[*]x; Algebra.
Apply RPM_mult_corr; Auto.
Intros. Inversion H0.
Apply Rinterp_wd with y[*]x0[+]y0[*]y.
Apply RPP_plus_corr; Auto.
Apply RPM_mult_corr; Auto.
Step x0[*]y[+]y0[*]y.
Step_final (x0[+]y0)[*]y.
Qed.
Transparent RPP_plus RPM_mult.

Fixpoint RNorm [e:Rexpr] : Rexpr :=
  Cases e of
    (Rexpr_var n) => (Rexpr_plus (Rexpr_mult e Rexpr_one) Rexpr_zero)
  | (Rexpr_int i) => e
  | (Rexpr_plus e1 e2) => (RPP_plus (RNorm e1) (RNorm e2))
  | (Rexpr_mult e1 e2) => (RPP_mult (RNorm e1) (RNorm e2))
  | (Rexpr_part f e) =>
      (Rexpr_plus (Rexpr_mult (Rexpr_part f (RNorm e)) Rexpr_one) Rexpr_zero)
  end.

Lemma RNorm_corr : (e:Rexpr; x:F)(II e x)->(II (RNorm e) x).
Intro; Elim e; Intros; Simpl.
Apply (Rinterp_plus F val fun (Rexpr_mult (Rexpr_var r) Rexpr_one) Rexpr_zero x
        (Zero::F) x).
Algebra.
Apply (Rinterp_mult F val fun (Rexpr_var r) Rexpr_one x (One::F) x); Algebra.
Apply (Rinterp_int F val fun `1`); Algebra.
Apply (Rinterp_int F val fun `0`); Algebra.
Assumption.
Inversion H1. Apply Rinterp_wd with x0[+]y. Apply RPP_plus_corr; Auto. Auto.
Inversion H1. Apply Rinterp_wd with x0[*]y. Apply RPP_mult_corr; Auto. Auto.
Apply (Rinterp_plus F val fun
        (Rexpr_mult (Rexpr_part r (RNorm r0)) Rexpr_one) Rexpr_zero x (Zero::F) x).
Algebra.
Apply (Rinterp_mult F val fun (Rexpr_part r (RNorm r0)) Rexpr_one x (One::F) x); Algebra.
Inversion H0.
Apply (Rinterp_part F val fun (RNorm r0) r x0 x Hx); Auto.
Apply (Rinterp_int F val fun `1`); Algebra.
Apply (Rinterp_int F val fun `0`); Algebra.
Qed.

Lemma RNorm_wf : (e:Rexpr)(Rwf F val fun e)->(Rwf F val fun (RNorm e)).
Unfold Rwf.
Intros.
Elim H.
Intros.
Exists x.
Apply RNorm_corr.
Assumption.
Qed.

(*
Definition RfNorm : (Rfexpr F val)->(Rfexpr F val) :=
  [e:(Rfexpr F val)]
  let e' = (Rfforget ? ? e) in
    (Rexpr2Rfexpr ? ? (RNorm e') (RNorm_wf e' (Rfexpr2wf ? ? e))).

Lemma RfNorm_compat : (e:(Rfexpr F val))
  (Rfforget ? ? (RfNorm e)) = (RNorm (Rfforget ? ? e)).
Intros.
Unfold RfNorm.
Apply Rexpr2Rfexpr_compat.
Qed.

Lemma RfNorm_corr : (e:(Rfexpr F val))
  (Rfinterp ? ? (RfNorm e)) [=] (Rfinterp ? ? e).
Intros.
Unfold RfNorm.
Apply Rexpr2Rfexpr_corr.
Apply RNorm_corr.
Apply Rfexpr2interp.
Qed.
*)

Definition Rexpr_is_zero [e:Rexpr] : Prop :=
  Cases e of
    (Rexpr_int ZERO) => True
  | _ => False
  end.

Lemma Rexpr_is_zero_corr : (e:Rexpr)(Rwf F val fun e)->(Rexpr_is_zero e)->(II e Zero).
Unfold Rwf.
Intros e H.
Elim H. Intro.
Elim e; Simpl; Try ((* FIXME *) Intros; Tauto).
Intro.
Elim z; Simpl; Try Tauto; Intros.
Apply Rinterp_int.
Algebra.
Qed.

Lemma RTactic_lemma_zero : (x:F)(e:(Rxexpr F val fun x))
  (Rexpr_is_zero (RNorm (Rxforget ? ? ? ? e)))->(x [=] Zero).
Intros.
Apply refl_Rinterp with val fun (RNorm (Rxforget ? ? ? ? e)).
Apply RNorm_corr.
Apply Rxexpr2interp.
Apply Rexpr_is_zero_corr.
Apply RNorm_wf.
Apply Rxexpr2wf.
Assumption.
Qed.

Lemma RTactic_lemma : (x,y:F)(e:(Rxexpr F val fun x))(f:(Rxexpr F val fun y))
  (Rexpr_is_zero (RNorm (Rxforget ? ? ? ? (Rxexpr_minus ? ? ? ? ? e f))))->(x [=] y).
Intros.
Apply cg_inv_unique_2.
Apply RTactic_lemma_zero with (Rxexpr_minus ? ? ? ? ? e f).
Assumption.
Qed.

End RNormCorrect.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import machine_int.
Import MachineInt.
Require Import mips_cmd.
Require Import pick_sign_prg multi_add_s_s_u_prg multi_sub_s_s_u_prg copy_s_s_prg.

Local Open Scope mips_cmd_scope.

(** z <- x - y with z, x, y signed *)
Definition multi_sub_s_s_s rk rz rx ry a0 a1 a2 a3 a4 a5 rX rY rZ :=
  lw rY four16 ry ;
  pick_sign ry a0 a1 ;
  If_bgez a1 Then (* 0 <= y ? *)
    If_beq a1 , r0 Then (* y = 0 ? *)
       copy_s_s rk rz rx a0 a1 a2 a3 a4 ;
       addiu a3 r0 zero16 (* no overflow *)
    Else (* 0 < y *)
       multi_sub_s_s_u rk rz rx rY a0 a1 a2 a3 a4 a5 rX rZ
  Else (* y < 0 *)
    multi_add_s_s_u rk rz rx rY a0 a1 a2 a3 a4 a5 rX rZ.


(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
  Require Coq.funind.Recdef.

Local Open Scope nat_scope.

Record ageable_facts (A:Type) (level: A -> nat) (age1:A -> option A)  :=
{ af_unage : forall x':A, exists x, age1 x = Some x'
; af_level1 : forall x, age1 x = None <-> level x = 0
; af_level2 : forall x y, age1 x = Some y -> level x = S (level y)
}.

Arguments af_unage [A] [level] [age1] _ _.
Arguments af_level1 [A] [level] [age1] _ _.
Arguments af_level2 [A] [level] [age1] _ _ _ _.

Class ageable (A:Type) := mkAgeable
{ level : A -> nat
; age1 : A -> option A
; age_facts : ageable_facts A level age1
}.

Definition age {A} `{ageable A} (x y:A) := age1 x = Some y.

Lemma af_wf {A} `{ageable A} :
 well_founded (fun x y => age y x).
Proof.
  intros.
  intro.
  remember (level a).
  revert a Heqn.
  induction n; intros; constructor; intros.
  apply (af_level2 age_facts) in H0.
  rewrite H0 in Heqn.
  inversion Heqn.
  copy H0.
  apply (af_level2 age_facts) in H0.
  apply IHn.
  lia.
Qed.
Arguments af_wf [A] _ _.

Definition age_induction {A} `{ageable A} :=
  well_founded_induction (af_wf _).

Definition fashionR {A1} `{ageable A1} {A2}`{ageable A2} (x:A1) (y: A2) : Prop :=
  level x = level y.

Lemma fashionR_refl {A} `{ageable A} : reflexive _ fashionR.
Proof.
  repeat intro; hnf; auto.
Qed.

Lemma fashionR_trans {A} `{ageable A} {B} `{ageable B} {C} `{ageable C} :
    forall (x: A) (y: B) (z: C), fashionR x y -> fashionR y z -> fashionR x z.
Proof.
  unfold fashionR; intros; congruence.
Qed.

Lemma fashionR_sym {A} `{ageable A} {B} `{ageable B}:
   forall (x: A) (y: B), fashionR x y -> fashionR y x.
Proof.
  unfold fashionR; intros; auto.
Qed.

Lemma age_level {A} `{ageable A} : forall (x y:A),
  age x y -> level x = S (level y).
Proof.
  intros.
  apply (af_level2 age_facts); auto.
Qed.

Lemma age1_level0 {A} `{ageable A} : forall (x:A),
  age1 x = None <-> level x = 0.
Proof.
  intros; apply (af_level1 age_facts).
Qed.

Section level'.
  Variable A:Type.
  Variable ag:ageable A.

  Function level' (x:A) { wf (fun x y => @age A ag y x)  x } : nat :=
(*  Function level' (x:A) { wf (transp _ (@age A ag)) x } : nat := *)
    match age1 x with
    | None => 0
    | Some x' => S (level' x')
    end.
    intros. hnf. assumption.
    unfold transp. apply (af_wf _).
  Defined.

  Theorem level_level' : forall x:A, level x = level' x.
  Proof.
    intro x; induction x using age_induction; intros.
    rewrite level'_equation.
    case_eq (age1 x); intros.
    rewrite (af_level2 age_facts x a); auto.
    rewrite <- age1_level0; auto.
  Qed.
End level'.

Lemma levelS_age1 {A} `{ageable A} : forall (x:A) n,
  level x = S n ->
  exists y, age1 x = Some y.
Proof.
  intros; rewrite level_level' in H0.
  rewrite level'_equation in H0.
  destruct (age1 x); eauto.
  inv H0.
Qed.

Lemma age1_levelS {A} `{ageable A} : forall (x y:A),
  age1 x = Some y ->
  exists n, level x = S n.
Proof.
  intros; rewrite level_level'.
  rewrite level'_equation.
  destruct (age1 x); eauto.
  inv H0.
Qed.

Lemma age1_level0_absurd {A} `{ageable A} : forall (x y:A),
  age1 x = Some y ->
  level x = 0 ->
  False.
Proof.
  intros.
  rewrite <- age1_level0 in H1.
  rewrite H0 in H1; discriminate.
Qed.

Lemma age1None_levelS_absurd {A} `{ageable A} : forall (x:A) n,
  age1 x = None ->
  level x = S n ->
  False.
Proof.
  intros.
  rewrite age1_level0 in H0.
  rewrite H0 in H1; discriminate.
Qed.

Section RtRft.
  Variable A:Type.
  Variable R:relation A.

  Let Rt := clos_trans A R.
  Let Rft := clos_refl_trans A R.

  Lemma Rt_Rft : forall x y, Rt x y -> Rft x y.
  Proof.
    intros; elim H; intros.
    apply rt_step; auto.
    eapply rt_trans; eauto.
  Qed.

  Lemma Rt_Rft_trans : forall x y z, Rt x y -> Rft y z -> Rt x z.
  Proof.
    intros x y z H H1; revert x H; elim H1; intros; auto.
    eapply t_trans; eauto; apply t_step; auto.
  Qed.

  Lemma Rft_Rt_trans : forall x y z, Rft x y -> Rt y z -> Rt x z.
  Proof.
    intros x y z H; revert z; elim H; intros; auto.
    eapply t_trans; eauto; apply t_step; auto.
  Qed.

  Lemma transpose_clos_trans : forall A R x y,
    clos_trans A (transp A R) x y <-> transp A (clos_trans A R) x y.
  Proof.
    unfold transp; intuition.

    elim H; intros.
    apply t_step; auto.
    apply t_trans with y0; auto.

    elim H; intros.
    apply t_step; auto.
    apply t_trans with y0; auto.
  Qed.
End RtRft.

#[export] Hint Resolve rt_refl : core.

Definition laterR {A} `{ageable A} : relation A := clos_trans A age.
Definition necR   {A} `{ageable A} : relation A := clos_refl_trans A age.

Require Coq.Wellfounded.Wellfounded.
Lemma laterR_wf {A} `{ageable A} :
  well_founded (transp _ laterR).
Proof.
  intros.
  hnf; intro.
  induction a using
    (well_founded_induction (Wellfounded.Transitive_Closure.wf_clos_trans _ (fun x y => age y x) (af_wf _))).
  constructor; intros.
  unfold laterR in H1.
  rewrite <- transpose_clos_trans in H1.
  apply H0; auto.
Qed.

Definition laterR_induction {A} `{ageable A} :=
  @well_founded_induction A (transp A laterR) laterR_wf.

Lemma age_irreflexive {A}  `{ageable A}: forall x, age x x -> False.
Proof.
  intros x.
  induction x using age_induction; intros.
  apply H0 with x; auto.
Qed.

Lemma laterR_irreflexive {A} `{HA: ageable A} : forall x, laterR x x -> False.
Proof.
  intros x.
  induction x using laterR_induction; intros.
  apply H with x; auto.
Qed.

Lemma nec_refl_or_later {A} `{ageable A} : forall x y,
  necR x y -> x = y \/ laterR x y.
Proof.
  intros.
  elim H0; intros; auto.
  right; apply t_step; auto.
  destruct H2; destruct H4; subst; auto.
  right; apply t_trans with y0; auto.
Qed.

Lemma necR_antisym {A} `{ageable A} : forall x y,
  necR x y -> necR y x -> x = y.
Proof.
  intros.
  apply nec_refl_or_later in H0.
  apply nec_refl_or_later in H1.
  intuition.
  elim (laterR_irreflexive x).
  eapply t_trans; eauto.
Qed.

Lemma age_later_nec {A} `{HA: ageable A} : forall x y z,
  age x y ->
  laterR x z ->
  necR y z.
Proof.
  intros x y z H H1; revert y H.
  induction H1; intros.
  replace y0 with y.
  apply rt_refl.
  unfold age in *; congruence.
  apply rt_trans with y; auto.
  apply IHclos_trans1; auto.
  apply Rt_Rft; auto.
Qed.

Lemma necR_level {A} `{X: ageable A} : forall (x y:A),
  necR x y ->
  level x >= level y.
Proof.
  intros x y H; induction H; auto.
  rewrite (age_level x y); auto.
  lia.
Qed.

Lemma laterR_level {A} `{X: ageable A} : forall (x y:A),
  laterR x y ->
  level x > level y.
Proof.
  intros x y H; induction H; auto.
  rewrite (age_level x y); auto.
  lia.
Qed.

Section NAT_AGEABLE.

  Definition natLevel (x:nat) : nat := x.
  Definition natAge1 (x:nat) : option nat :=
    match x with
    | 0 => None
    | S n => Some n
    end.
  Definition natUnage (x:nat) : nat := S x.

  Lemma ag_nat_facts :
    ageable_facts nat natLevel natAge1.
  Proof.
    constructor.
    intros; exists (S x'); compute; auto.
    intro x; destruct x; intuition; inv H.
    firstorder;
      destruct x; inv H; compute; eauto.
  Qed.

  Definition ag_nat : ageable nat :=
    mkAgeable nat natLevel natAge1 ag_nat_facts.

  Lemma nec_nat : forall (n n':nat),
    @necR _ ag_nat n n' <-> n' <= n.
  Proof.
    intros. split; intro.
    induction H.
    destruct x; inv H; auto.
    auto.
    lia.

    induction H.
    apply rt_refl.
    apply rt_trans with m.
    apply rt_step. compute; auto.
    auto.
  Qed.

  Lemma later_nat : forall (n n':nat),
    @laterR _ ag_nat n n' <-> n' < n.
  Proof.
    intros. split; intro.
    induction H.
    destruct x; simpl in H.
    inv H.
    inv H. lia.
    lia.
    hnf in H.
    inv H.
    apply t_step.
    compute; auto.
    apply Rt_Rft_trans with m.
    apply t_step. compute; auto.
    change (@necR _ ag_nat m n').
    rewrite nec_nat.
    lia.
  Qed.

End NAT_AGEABLE.

Lemma laterR_level' {A} `{H : ageable A}: forall {w1 w2: A}, laterR w1 w2 -> @laterR _ ag_nat (level w1) (level w2).
Proof.
induction 1.
constructor 1. apply age_level in H0. rewrite H0; reflexivity.
constructor 2 with (level y); auto.
Qed.

Lemma necR_nat {A} `{H : ageable A}:
    forall {x y: A}, necR x y -> @necR nat ag_nat (level x) (level y).
  Proof.
    intros. apply necR_level in H0.
     induction H0; simpl in *. constructor 2.
     constructor 3 with m. constructor 1. constructor.
     auto.
  Qed.

Section BIJECTION.
  Variable A B : Type.
  Variable ag: ageable A.
  Variable bijAB: bijection A B.

  Let levelB (x:B) : nat :=
    level (bij_g _ _ bijAB x).

  Let age1B  (x: B) : option B :=
     match age1 (bij_g _ _ bijAB x) with
     | Some y => Some (bij_f _ _ bijAB y)
     | None => None
     end.

  Let ageB (x y: B) :=age1B x = Some y.

  Lemma age_bij_unage :
    forall x', exists x, age1B x = Some x'.
  Proof.
    unfold age1B, levelB; simpl; intros.
    destruct bijAB as [f g fg gf]; simpl in *.
    destruct (af_unage age_facts (g x')) as [y ?].
   exists (f y). rewrite gf. rewrite H. f_equal. apply fg.
  Qed.

  Lemma age_bij_level1 :
    forall x, age1B x = None <-> levelB x = 0.
  Proof.
    intros.
    unfold age1B, levelB; simpl.
    destruct bijAB as [f g fg gf]; simpl.
    case_eq (age1 (g x)); intuition; try discriminate.
    rewrite <- age1_level0 in H1.
    rewrite H0 in H1; discriminate.
    rewrite <- age1_level0; auto.
  Qed.

  Lemma age_bij_level2 :
    forall x y, age1B x = Some y -> levelB x = S (levelB y).
  Proof.
    intros.
    unfold age1B, levelB in *; simpl in *.
    destruct bijAB as [f g fg gf]; simpl in *.
    case_eq (age1 (g x)); intros; rewrite H0 in H; inv H.
    rewrite gf.
    apply (af_level2 age_facts); auto.
  Qed.

  Lemma ag_bij_facts : ageable_facts B levelB age1B.
  Proof.
    constructor.
    exact age_bij_unage.
    exact age_bij_level1.
    exact age_bij_level2.
  Qed.

  Definition ag_bij : ageable B :=
    mkAgeable B levelB age1B ag_bij_facts.
End BIJECTION.

Section PROD.
  Variable A B : Type.
  Variable agA: ageable A.

  Let levelAB (x:prod A B) := level (fst x).
  Let age1AB (x:prod A B) :=
    match age1 (fst x) with
    | None => None
    | Some a' => Some (a',snd x)
    end.

  Lemma ag_prod_facts : ageable_facts (prod A B) levelAB age1AB.
  Proof.
    constructor.
    unfold levelAB, age1AB; simpl; intros.
    destruct (af_unage age_facts (fst x')) as [y1 ?].
    exists (y1, snd x'). simpl. rewrite H. f_equal. destruct x'; auto.
    intros [a b]; firstorder.
    unfold age1AB in H; simpl in H.
    case_eq (age1 a); intros; rewrite H0 in H; inv H.
    unfold levelAB; simpl.
    rewrite <- age1_level0; auto.
    unfold levelAB in H.
    simpl in H.
    rewrite <- age1_level0 in H.
    unfold age1AB; simpl.
    rewrite H; auto.
    intros.
    unfold age1AB in H.
    unfold levelAB.
    destruct x; simpl in *.
    case_eq (age1 a); intros; rewrite H0 in H; inv H.
    simpl.
    apply age_level; auto.
  Qed.

  Definition ag_prod :=
    mkAgeable (prod A B) levelAB age1AB ag_prod_facts.

  Lemma prod_nec_split : forall n x n' x',
    @necR (prod A B) ag_prod (n,x) (n',x') <-> necR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (n,x) as w.
    remember (n',x') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H. simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply rt_step. auto.
    inv Heqw'.
    split; auto.
    apply rt_refl.
    specialize (IHclos_refl_trans1 n x0 (fst y) (snd y)).
    spec IHclos_refl_trans1; auto.
    spec IHclos_refl_trans1; destruct y; auto.
    simpl in *.
    specialize (IHclos_refl_trans2 a b n' x').
    spec IHclos_refl_trans2; auto.
    spec IHclos_refl_trans2; auto.
    intuition. eapply rt_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply rt_step. hnf.
    hnf in H. simpl.
    unfold age1AB. simpl. rewrite H. auto.
    apply rt_refl.
    eapply rt_trans; eauto.
  Qed.

  Lemma prod_later_split : forall n x n' x',
    @laterR (prod A B) ag_prod (n,x) (n',x') <-> laterR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (n,x) as w.
    remember (n',x') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H; simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply t_step. compute. auto.
    specialize (IHclos_trans1 n x0 (fst y) (snd y)).
    spec IHclos_trans1; auto.
    spec IHclos_trans1; destruct y; auto.
    simpl in *.
    specialize (IHclos_trans2 a b n' x').
    spec IHclos_trans2; auto.
    spec IHclos_trans2; auto.
    intuition. eapply t_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply t_step.
    hnf; simpl. unfold age1AB. simpl; rewrite H. auto.
    eapply t_trans; eauto.
  Qed.

End PROD.

Section PROD'.
  Variable A B : Type.
  Variable agB: ageable B.

  Let levelAB (x:prod A B) := level (snd x).
  Let age1AB (x:prod A B) :=
    match age1 (snd x) with
    | None => None
    | Some a' => Some (fst x, a')
    end.

  Lemma ag_prod'_facts : ageable_facts (prod A B) levelAB age1AB.
  Proof.
    constructor.
    unfold levelAB, age1AB; simpl; intros.
    destruct (af_unage age_facts (snd x')) as [y2 ?].
    exists (fst x', y2). simpl. rewrite H. f_equal. destruct x'; auto.
    intros [a b]; firstorder.
    unfold age1AB in H; simpl in H.
    case_eq (age1 b); intros; rewrite H0 in H; inv H.
    unfold levelAB; simpl.
    rewrite <- age1_level0; auto.
    unfold levelAB in H.
    simpl in H.
    rewrite <- age1_level0 in H.
    unfold age1AB; simpl.
    rewrite H; auto.
    intros.
    unfold age1AB in H.
    unfold levelAB.
    destruct x; simpl in *.
    case_eq (age1 b); intros; rewrite H0 in H; inv H.
    simpl.
    apply age_level; auto.
  Qed.

  Definition ag_prod' :=
    mkAgeable (prod A B) levelAB age1AB ag_prod'_facts.

  Lemma prod'_nec_split : forall n x n' x',
    @necR (prod A B) ag_prod' (x,n) (x',n') <-> necR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (x,n) as w.
    remember (x',n') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H. simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply rt_step. auto.
    inv Heqw'.
    split; auto.
    apply rt_refl.
    specialize (IHclos_refl_trans1 n x0 (snd y) (fst y)).
    spec IHclos_refl_trans1; auto.
    spec IHclos_refl_trans1; destruct y; auto.
    simpl in *.
    specialize ( IHclos_refl_trans2 b a n' x').
    spec IHclos_refl_trans2; auto.
    spec IHclos_refl_trans2; auto.
    intuition. eapply rt_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply rt_step. hnf.
    hnf in H. simpl.
    unfold age1AB. simpl. rewrite H. auto.
    apply rt_refl.
    eapply rt_trans; eauto.
  Qed.

  Lemma prod'_later_split : forall n x n' x',
    @laterR (prod A B) ag_prod' (x,n) (x',n') <-> laterR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (x,n) as w.
    remember (x',n') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H; simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply t_step. compute. auto.
    specialize (IHclos_trans1 n x0 (snd y) (fst y)).
    spec IHclos_trans1; auto.
    spec IHclos_trans1; destruct y; auto.
    simpl in *.
    specialize ( IHclos_trans2 b a n' x').
    spec IHclos_trans2; auto.
    spec IHclos_trans2; auto.
    intuition. eapply t_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply t_step.
    hnf; simpl. unfold age1AB. simpl; rewrite H. auto.
    eapply t_trans; eauto.
  Qed.

End PROD'.

Fixpoint composeOptN (A: Type) (f: A -> option A)
         (n: nat) (w: A) {struct n} : option A :=
 match n  with
 | S n' => match f w with Some w' => composeOptN A f n' w' | None => None end
 | O => Some w
 end.
Arguments composeOptN [A] _ _ _.

Definition ageN {A} `{ageable A}: nat -> A -> option A := composeOptN age1.

Lemma ageN1  {A} `{ageable A}: ageN 1 = age1.
Proof.
intros.
unfold ageN. simpl.
extensionality phi.
case_eq (age1 phi); intros; try rewrite H; auto.
Qed.

Lemma ageN_compose {A} `{agA : ageable A}:
 forall a b c phi1 phi2 phi3,ageN a phi1 = Some phi2 ->
       ageN b phi2 = Some phi3 ->  (a+b=c)%nat ->  ageN c phi1 = Some phi3.
Proof.
unfold ageN in *.
induction a; simpl; intros.
subst. inversion H; clear H. auto.
subst c.
case_eq (age1 phi1); intros; rewrite H1 in H; try discriminate.
simpl.
rewrite H1.
eapply IHa; eauto.
Qed.

Lemma ageN_compose' {A} `{agA : ageable A}:
  forall a b phi1 phi3,
   ageN (a+b)%nat phi1 = Some phi3 -> exists phi2, ageN a phi1 = Some phi2 /\ ageN b phi2 = Some phi3.
Proof.
intros.
case_eq (ageN a phi1); intros.
rename a0 into phi.
exists phi.
split; auto.
case_eq (ageN b phi); intros.
rename a0 into phi0.
generalize (ageN_compose a b (a+b) phi1 _ _ H0 H1 (refl_equal _)); intro.
rewrite H in H2; auto.
exfalso.
revert phi1 phi H H1 H0; induction a; intros.
simpl in *.
inv H0.
rewrite H in H1; discriminate.
replace (S a + b)%nat with (S (a+b))%nat in H by lia.
unfold ageN in *;
simpl in *.
case_eq (age1 phi1); intros; rewrite H2 in H; try discriminate.
rewrite H2 in H0.
eapply IHa; eauto.
exfalso.
unfold ageN in *.
revert phi1 H H0; induction a; intros.
simpl in *. discriminate.
replace (S a + b)%nat with (S (a+b))%nat in H by lia.
simpl in *.
revert H H0; case_eq (age1 phi1); intros; try discriminate.
eapply IHa; eauto.
Qed.

Lemma necR_evolve {A} `{agA : ageable A}:
    necR = fun (phi phi': A) => exists n, ageN n phi = Some phi'.
Proof.
extensionality w w'.
apply prop_ext; split; intros.
unfold necR in H.
induction H.
exists 1%nat. rewrite ageN1.
simpl.
auto.
exists O; auto.
destruct IHclos_refl_trans1 as [n1 ?].
destruct IHclos_refl_trans2 as [n2 ?].
exists (n1+n2)%nat.
eapply ageN_compose; eauto.
destruct H as [n ?].
revert w w' H; induction n; intros.
inv H.
constructor 2.
unfold ageN in H.
simpl in H.
revert H; case_eq (age1 w); intros; try discriminate.
constructor 3 with a.
constructor 1; auto.
apply IHn; auto.
Qed.

Lemma age_noetherian  {A} `{ageable A}: forall phi, exists n, ageN n phi = None.
Proof.
  intros.
  induction phi using age_induction.
  rename x into phi.
  case_eq (age1 phi); intros.
  generalize H1; intros.
  apply H0 in H1.
  destruct H1 as [n ?].
  exists (S n).
  unfold ageN; simpl.
  rewrite H2; auto.
  exists (S O); simpl.
  unfold ageN; simpl.
  rewrite H1.
  auto.
Qed.

Lemma predicate_max:
  forall (F: nat -> Prop) (Fdec: forall n, {F n}+{~ F n}) n,
  F 0%nat ->
  ~ F n ->
  exists i, F i /\ (i<n)%nat /\ ~ F (S i).
Proof.
intros.
assert (forall m, (m <= n)%nat ->
         (forall k, (k<m)%nat -> F k) \/
         (exists i, F i /\ (i<m)%nat /\ ~ F (S i))).
induction m.
left; intros.
exfalso; lia.
intro.
assert (m<=n)%nat; try lia.
destruct (IHm H2).
assert (m < n \/ m = n)%nat; try lia.
destruct H4.
destruct (Fdec m) as [?H|?H].
left.
intros.
assert (k < m \/ k = m)%nat; try lia.
destruct H7.
auto.
subst k; auto.
right.
exists (Peano.pred m).
destruct m.
contradiction.
replace (Peano.pred (S m)) with m; try lia.
split.
apply H3; try lia.
split; try lia.
auto.
subst m.
right.
destruct n.
contradiction.
exists n; repeat split; auto; try lia.
right.
destruct H3 as [i H4].
destruct H4.
destruct H4.
exists i; repeat split; auto; lia.
assert (n <= n)%nat; try lia.
destruct (H1 _ H2).
destruct n; try contradiction.
exists n; repeat split; auto; try lia.
auto.
Qed.

Lemma age_noetherian'  {A} `{agA : ageable A}:
       forall phi, exists! n, exists phi', ageN n phi = Some phi' /\ age1 phi' = None.
Proof.
intros.
destruct (age_noetherian phi) as [n ?].
assert (Fdec: forall n, {ageN n phi <> None}+{~( ageN n phi <> None)})
  by (intros; destruct (ageN n0 phi); auto; left; intro Hx; inversion Hx).
destruct (predicate_max (fun n => ageN n phi <> None) Fdec n) as [i [? [? ?]]].
intro. inv H0.
intro.
rewrite H in H0.
contradiction H0; auto.
exists i.
split.
revert H0; case_eq (ageN i phi); intros.
exists a; split; auto.
revert H2; case_eq (ageN (S i) phi); intros.
contradiction H4.
intro Hx; inv Hx.
clear - H0 H2.
revert phi a H0 H2; induction i; intros.
inv H0.
rewrite ageN1 in H2; auto.
unfold ageN in *.
simpl in H0.
revert H0; case_eq (age1 phi); intros; try discriminate.
simpl in H2.
rewrite H in H2.
eapply IHi.
eauto.
simpl.
auto.
contradiction H3; auto.
intros.
destruct H3 as [phi' [? ?]].
assert (ageN (S i) phi = None).
clear - H2.
revert H2; case_eq (ageN (S i) phi); intros.
contradict H2. intro Hx; inv Hx.
auto. clear H2.
clear - H0 H5 H3 H4.
revert H0; case_eq (ageN i phi); intros.
2: contradiction H0; auto.
clear H0.
assert (age1 a = None).
clear - H H5.
revert phi H5 H; induction i; intros.
inv H; rewrite ageN1 in H5; auto.
unfold ageN in *.
revert H H5; simpl. case_eq (age1 phi); intros; try discriminate.
eapply IHi; eauto.
clear H5.
assert (forall i d phi a a', ageN i phi = Some a -> ageN (i+d) phi = Some a' -> age1 a' = None -> age1 a = None -> d=0%nat).
clear.
induction i; intros.
inv H.
destruct d; auto.
simpl in H0.
unfold ageN in H0. simpl in H0.
rewrite H2 in H0. inv H0.
unfold ageN in H, H0. simpl in *.
revert H; case_eq (age1 phi); intros; try discriminate.
rewrite H in H0.
eauto.
assert (i<x' \/ i=x' \/ i>x')%nat by lia.
destruct H2 as [?| [?| ?]]; auto.
replace x' with (i+(x'-i))%nat in H3 by lia.
specialize (H1 _ _ _ _ _ H H3 H4 H0).
lia.
replace i with (x'+(i-x'))%nat in H by lia.
specialize (H1 _ _ _ _ _ H3 H H0 H4).
lia.
Qed.

Lemma ageable_ext:
   forall A (B C: ageable A),
      @age1 _ B = @age1 _ C -> @level _ B = @level _ C -> B=C.
Proof.
intros.
destruct B; destruct C.
simpl in *.
subst age3. subst level0.
replace age_facts1 with age_facts0; auto.
apply proof_irr.
Qed.

Lemma necR_linear {A} `{H : ageable A}:
  forall {a b c}, necR a b -> necR a c -> necR b c \/ necR c b.
Proof.
intros.
apply trans_rt1n in H0.
apply trans_rt1n in H1.
revert c H1; induction H0; intros; auto.
left; apply rt1n_trans; auto.
inversion H2; subst.
right.
apply rt_trans with y.
constructor 1; auto.
apply rt1n_trans; auto.
unfold age in H0,H3.
rewrite H0 in H3; inv H3.
destruct (IHclos_refl_trans_1n _ H4); auto.
Qed.

Lemma necR_linear' {A} `{H : ageable A}:
   forall {a b c}, necR a b -> necR a c -> level b = level c -> b=c.
Proof.
intros.
destruct (necR_linear H0 H1).
clear - H2 H3.
apply nec_refl_or_later in H3.
destruct H3; auto.
apply laterR_level in H0; unfold fashionR in H2; exfalso; lia.
apply nec_refl_or_later in H3.
destruct H3; auto.
apply laterR_level in H3; unfold fashionR in H2; exfalso; lia.
Qed.

Lemma laterR_necR {A} `{agA : ageable A}:
  forall {x y}, laterR x y -> necR x y.
Proof.
induction 1; intros.
constructor; auto.
econstructor 3; auto.
apply rt_trans with y; auto.
Qed.

Lemma necR_refl {A} `{H : ageable A}:
  forall phi, necR phi phi.
Proof.
intros; constructor 2.
Qed.

#[export] Hint Resolve necR_refl : core.

Lemma necR_trans  {A} `{H : ageable A}:
  forall phi1 phi2 phi3, necR phi1 phi2 -> necR phi2 phi3 -> necR phi1 phi3.
Proof.
intros.
econstructor 3; eauto.
Qed.

Lemma necR_laterR {A} `{agA : ageable A}:
  forall w1 w2 w3, necR w1 w2 -> laterR w2 w3 -> laterR w1 w3.
Proof.
intros.
revert w3 H0; induction H; intros.
econstructor 2. constructor 1; eauto. apply H0.
auto.
auto.
Qed.


(** This file contains random necessary lemmas for the project,
including the definition of error_sum used in the conclusion of the
main global accuracy theorem **)

From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.

Import List ListNotations.

Set Bullet Behavior "Strict Subproofs".

From mathcomp Require Import matrix bigop all_algebra all_ssreflect.
From mathcomp.analysis Require Import Rstruct.
From Coquelicot Require Import Lub Rbar.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** We will open the real scope and the Ring scope
  separately **)

Open Scope ring_scope.

(** We instantiate the ring scope with real scope using
  Delimit Scope ... **)
Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

(** We next import the ring theory so that we can use
  it for reals **)
Import Order.TTheory GRing.Theory Num.Def Num.Theory.

Lemma sum_1_eq:
  forall k,
  \sum_(j < k.+1) 1 = k.+1%:R :> R.
Proof.
intros. induction k.
+ rewrite !big_ord_recr //= big_ord0 add0r //=.
+ rewrite big_ord_recr //=. rewrite IHk. rewrite -[in RHS]addn1.
  by rewrite natrD.
Qed.

Lemma big_0_ex_abstract I r (P: pred I) (E : I -> R):
  (forall i, P i -> E i = 0) ->
  \big[+%R/0]_(i <-r | P i) E i = 0.
Proof.
move => Eq. apply big_ind.
+ by [].
+ intros. rewrite H H0 addr0 //=.
+ by apply /Eq.
Qed.

Lemma nat_ge_0:
  forall (k:nat),
  (0 <= k.+1%:R)%Re.
Proof.
intros. induction k.
+ apply Rle_0_1.
+ rewrite -addn1. rewrite natrD. rewrite -RplusE.
  apply Rplus_le_le_0_compat.
  - apply IHk.
  - apply Rle_0_1.
Qed.

Lemma m_ge_n (m n :nat) :
  (m <= n)%N -> (m%:R <= n%:R)%Re.
Proof.
intros. induction n.
+ rewrite leqn0 in H. assert ( m = 0%N). { by apply /eqP. }
  rewrite H0. nra.
+ rewrite leq_eqVlt in H.
  assert ( (m == n.+1) \/ (m < n.+1)%N).
  { by apply /orP. } destruct H0.
  - assert ( m = n.+1). { by apply /eqP. }
    rewrite H1. nra.
  - assert ( (m <=n)%N). { by []. }
    specialize (IHn H1).
    rewrite -addn1 natrD. apply Rle_trans with n%:R.
    * apply IHn.
    * rewrite -RplusE.
      assert (n%:R = (n%:R + 0)%Re). { nra. }
      rewrite H2.
      assert ((n%:R + 0 + 1%:R)%Re = (n%:R + 1%:R)%Re).
      { nra. } rewrite H3. apply Rplus_le_compat.
      nra. apply Rlt_le. apply Rlt_0_1.
Qed.

Lemma real_cast (n:nat):
  n%:R = INR n.
Proof.
induction n.
+ by simpl.
+ rewrite -addn1. rewrite natrD. rewrite plus_INR.
  rewrite IHn. reflexivity.
Qed.

Definition row_sum {n:nat} (A: 'M[R]_n) (i: 'I_n) :=
  \big[+%R/0]_(j<n) Rabs (A i j).

Definition theta_x {n:nat} (x1 : 'cV[R]_n) (x2 : nat -> 'cV[R]_n) (m:nat) :=
  Lub_Rbar (fun x =>
    x = bigmaxr 0 [seq (Rabs (x2 m i 0) / Rabs (x1 i 0)) | i <- enum 'I_n]).

Definition error_sum (n:nat) (S:R) :=
  if (n == 0%N) then 0%Re else
    \big[+%R/0]_(l < n) S^+l.

Definition listR_to_vecR {n:nat} (l : list R) := \col_(i < n)
  match (nat_of_ord i) with
    | S n =>  List.nth (S n) l 0
    | _ => List.nth 0 l 0
  end.

Lemma x_minus_x_is_0 {n:nat}:
  forall x: 'cV[R]_n, x - x = 0.
Proof.
intros. apply matrixP. unfold eqrel.
intros. rewrite !mxE //=. apply /eqP.
by rewrite subr_eq0.
Qed.

Lemma nth_seq_0_is_0 {n:nat} (i:nat):
  (i < n)%N ->
  [seq Rabs ((0 : 'cV[R]_n) i0 0) | i0 <- enum 'I_n]`_i = 0%Re.
Proof.
intros.
assert ([seq Rabs ((0 : 'cV[R]_n) i0 0) | i0 <- enum 'I_n] =
          mkseq (fun _ => 0) n).
{ unfold mkseq. rewrite -val_enum_ord.
  rewrite -[in RHS]map_comp.
  apply eq_map. unfold eqfun.
  intros. rewrite mxE Rabs_R0 //=.
} rewrite H0. by rewrite nth_mkseq.
Qed.

Lemma bigmax_le (x0:R) lr (x:R):
 (0 < size lr)%N ->
 (forall i:nat, (i < size lr)%N -> ((nth x0 lr i) <= x)%Re) ->
 ((bigmaxr x0 lr) <= x)%Re.
Proof.
intros.
move /(nthP x0): (bigmaxr_mem x0 H).
move => [i i_size <-].
by apply H0.
Qed.

Lemma enum_list:
  enum 'I_3 = [:: ord0;  1; (@inord 2 2)].
Proof.
apply: (inj_map val_inj); rewrite val_enum_ord.
rewrite /iota //=.
assert ((1 %% 3)%N = 1%N). { by []. } rewrite H //=.
by rewrite inordK.
Qed.

Lemma s_destruct (x0:R) s:
  s != [::] ->
  s = head x0 s :: behead s.
Proof.
induction s.
+ by [].
+ by intros.
Qed.

Lemma bigmax_le_0 (x0:R) s:
  0 <= x0 ->
  (forall i, (i < size s)%N -> 0 <= nth x0 s i) ->
  0 <= bigmaxr x0 s.
Proof.
intros.
rewrite /bigmaxr.
induction s.
+ by rewrite big_nil //=.
+ rewrite big_cons //=.
  assert (s = [::] \/ s != [::]).
  { destruct s.
    + by left.
    + by right.
  } destruct H1.
  - rewrite H1 //=. rewrite H1 //= in H0.
    rewrite big_nil. specialize (H0 0%N).
    assert ((0 < 1)%N). { by []. } specialize (H0 H2).
    simpl in H0. rewrite -RmaxE. rewrite Rmax_left.
    * by [].
    * nra.
  - assert (s = head x0 s :: behead s).
    { by apply s_destruct. }
    rewrite H2. rewrite bigrmax_dflt. rewrite -H2.
    rewrite le_maxr. apply /orP.
    specialize (H0 0%N). simpl in H0.
    left. by apply H0.
Qed.

Lemma big_ge_0_ex_abstract I r (P: pred I) (E : I -> R):
  (forall i, P i -> (0 <= E i)) ->
  (0 <= \big[+%R/0]_(i <-r | P i) E i).
Proof.
move => leE. apply big_ind.
+ apply /RleP. apply Rle_refl.
+ intros. apply /RleP.
  rewrite -RplusE. apply Rplus_le_le_0_compat.
  - by apply /RleP.
  - by apply /RleP.
+ apply leE.
Qed.

Lemma big_sum_ge_ex_abstract I r (P: pred I) (E1 E2: I -> R):
  (forall i, P i -> (E1 i <= E2 i)%Re) ->
  (\big[+%R/0]_(i <-r | P i) E1 i <= \big[+%R/0]_(i <-r | P i) E2 i).
Proof.
move => leE12. apply /RleP. apply big_ind2.
+ nra.
+ intros. rewrite -!RplusE. by apply Rplus_le_compat.
+ apply leE12.
Qed.

Lemma Rabs_ineq {n:nat} (f : 'I_n.+1 -> R):
  Rabs (\sum_j f j) <= \sum_j (Rabs (f j)).
Proof.
induction n.
+ simpl. rewrite !big_ord_recr //= !big_ord0 !add0r //=.
+ simpl. rewrite big_ord_recr //=.
  assert (\sum_(j < n.+2) Rabs (f j) =
            \sum_(j < n.+1) Rabs (f (widen_ord (leqnSn n.+1) j)) + Rabs (f ord_max)).
  { by rewrite !big_ord_recr//=. } rewrite H.
  apply /RleP. rewrite -!RplusE.
  apply Rle_trans with
  (Rabs (\sum_(i < n.+1) f (widen_ord (leqnSn n.+1) i)) +
    Rabs (f ord_max))%Re.
  - apply Rabs_triang.
  - apply Rplus_le_compat_r. apply /RleP. by apply IHn.
Qed.

Lemma seq_equiv {n:nat} (f : 'I_n.+1 -> R) :
  [seq f i | i <- enum 'I_n.+1] =
  mkseq (fun i => f (@inord n i)) n.+1.
Proof.
unfold mkseq. rewrite -val_enum_ord.
rewrite -[in RHS]map_comp.
apply eq_map. unfold eqfun. intros.
by rewrite //= inord_val //=.
Qed.

Lemma bigmax_le_implies (x0:R) lr (x:R):
 (0 < size lr)%N ->
  ((bigmaxr x0 lr) <= x)%Re ->
 (forall i:nat, (i < size lr)%N -> ((nth x0 lr i) <= x)%Re).
Proof.
intros.
apply Rle_trans with (bigmaxr x0 lr).
+ apply /RleP. by apply (@bigmaxr_ler _ x0 lr i).
+ apply H0.
Qed.

Definition error_sum_ind:=
  fun (error : R) (n : nat) =>
  match n with
  | 0%nat => 0
  | S n' => sum_f 0 n' (fun m : nat => error ^ m)
  end.

Lemma error_sum_equiv:
  forall (n:nat) (f: R),
  error_sum n f = error_sum_ind f n.
Proof.
intros.
induction n.
+ rewrite /error_sum /error_sum_ind //=.
+ rewrite /error_sum /error_sum_ind in IHn.
  destruct n.
  - simpl in IHn. rewrite /error_sum /error_sum_ind //=.
    rewrite /sum_f big_ord_recr //= big_ord0 add0r //=.
  - simpl in IHn. rewrite /error_sum /error_sum_ind //=.
    rewrite big_ord_recr //=. rewrite /sum_f //=.
    rewrite /sum_f //= in IHn.
    assert ((n - 0)%coq_nat = n). { lia. } rewrite H in IHn.
    rewrite IHn.
    assert ((n + 0)%coq_nat = n). { lia. } rewrite H0.
    by rewrite !RplusE.
Qed.

Lemma vec_sum_simpl {n:nat}:
  forall (a b c : 'cV[R]_n),
  a - c = a - b + b - c.
Proof.
intros. apply matrixP. unfold eqrel. intros. rewrite !mxE.
rewrite -!RplusE -!RoppE. nra.
Qed.

Ltac rewrite_scope :=
  try apply /RleP;
  try rewrite -!RplusE -!RmultE
.

Lemma Rle_minus_l :
  forall a b c : R, (a - b <= c) -> (a <= c + b).
Proof.
intros. rewrite -RplusE.
rewrite_scope.
rewrite -RminusE in H.
assert (a - b <= c)%Re.
rewrite_scope; auto.
nra.
Qed.

Lemma mulmx_distrr {n:nat}:
  forall (A :'M[R]_n) (f : nat -> 'cV[R]_n) (k:nat),
  \sum_(i < k.+1) (A *m (f i)) = A *m (\sum_(i < k.+1) (f i)).
Proof.
intros. induction k.
+ rewrite !big_ord_recr //= !big_ord0. by rewrite !add0r.
+ rewrite big_ord_recr //=.
  assert (\sum_(i < k.+2) f i = (\sum_(i < k.+1) f i) + f k.+1).
  { by rewrite !big_ord_recr //= !big_ord0. } rewrite H.
  rewrite mulmxDr. by rewrite IHk.
Qed.

Lemma two_not_zero:
  2%Re <> 0%Re.
Proof. nra. Qed.

Lemma f_pow_ge_0:
  forall (i:nat) (f:R),
  0 <= f -> 0 <= f^+i.
Proof.
intros. induction i.
+ rewrite expr0. apply /RleP. apply Rle_0_1.
+ rewrite exprS. apply /RleP. rewrite -RmultE.
  by apply Rmult_le_pos; apply /RleP.
Qed.

Lemma error_sum_ge_0:
  forall (n:nat) (f:R),
  0 <= f ->
  0 <= error_sum n f.
Proof.
intros. rewrite /error_sum.
destruct (n == 0%N).
+ apply /RleP;apply Rle_refl.
+ apply big_ge_0_ex_abstract.
  intros. by apply f_pow_ge_0.
Qed.

Lemma pow_add:
  forall (er : R_ringType) (n:nat),
  (er ^ (n + 1)%N) = (er * er ^ n).
Proof.
intros.
induction n.
+ rewrite add0n //=.
rewrite expr1z expr0z.
rewrite  -!RmultE.
rewrite Rmult_1_r.
auto.
+
rewrite exprzD_nat.
rewrite expr1z.
repeat rewrite -RmultE.
nra.
Qed.

Lemma error_sum_aux2 er n:
  er * error_sum_ind er n + 1  = error_sum_ind er (S n).
Proof.
intros.
induction n.
+ simpl. unfold sum_f. rewrite mulr0 add0r //=.
+ unfold error_sum_ind. rewrite /error_sum_ind in IHn.
  destruct n.
  - rewrite /sum_f. simpl. rewrite /sum_f in IHn. simpl in IHn.
    rewrite mulr0 in IHn. rewrite add0r in IHn. rewrite -IHn.
    rewrite mulr1. rewrite RplusE //=.
    assert (er ^ 1%N = er). { by rewrite //=. } rewrite H.
    by rewrite addrC.
  - rewrite /sum_f. rewrite /sum_f in IHn. simpl.
    assert ( (n + 0)%coq_nat = n). { lia. } rewrite H.
    rewrite !RplusE. simpl in IHn. rewrite H in IHn.
    rewrite mulrDr.
    assert ((n - 0)%coq_nat = n). { lia. } rewrite H0 in IHn.
    rewrite -addrA.
    assert (er * er ^ n.+1 + 1 = 1 + er * er ^ n.+1).
    { by rewrite addrC. } rewrite H1. rewrite addrA.
    rewrite IHn. rewrite RplusE.
    assert (er ^ n.+2 =  er * er ^ n.+1).
    { rewrite -addn1. by rewrite pow_add. } by rewrite H2.
Qed.

Lemma mult_abs_le {n:nat}:
  forall (f g : 'I_n.+1 -> R),
  (\sum_(j < n.+1) Rabs (f j * g j) <=
    (\sum_(j < n.+1) Rabs (f j)) *
    \sum_(j < n.+1) Rabs (g j))%Re.
Proof.
intros. induction n.
+ rewrite !big_ord_recr //= !big_ord0 !add0r.
  rewrite Rabs_mult. nra.
+ rewrite big_ord_recr //=.
  assert (\sum_(j < n.+2) Rabs (f j) =
          \sum_(j < n.+1) Rabs (f (widen_ord (leqnSn n.+1) j)) + Rabs (f ord_max)).
  { by rewrite big_ord_recr //=. } rewrite H.
  assert (\sum_(j < n.+2) Rabs (g j) =
          \sum_(j < n.+1) Rabs (g (widen_ord (leqnSn n.+1) j)) + Rabs (g ord_max)).
  { by rewrite big_ord_recr //=. } rewrite H0.
  rewrite -!RplusE.
  assert (((\sum_(j < n.+1) Rabs (f (widen_ord (leqnSn n.+1) j)) +
            Rabs (f ord_max)) *
           (\sum_(j < n.+1) Rabs (g (widen_ord (leqnSn n.+1) j)) +
            Rabs (g ord_max)) )%Re =
          (((\sum_(j < n.+1) Rabs (f (widen_ord (leqnSn n.+1) j))) *
            \sum_(j < n.+1) Rabs (g (widen_ord (leqnSn n.+1) j))) +
          ((Rabs (f ord_max) * Rabs (g ord_max)) +
            (Rabs (f ord_max) * (\sum_(j < n.+1) Rabs (g (widen_ord (leqnSn n.+1) j))) +
             Rabs (g ord_max) * (\sum_(j < n.+1) Rabs (f (widen_ord (leqnSn n.+1) j))))))%Re).
  { nra. } rewrite H1. apply Rplus_le_compat.
  - apply IHn.
  - assert (Rabs (f ord_max * g ord_max) = (Rabs (f ord_max * g ord_max) + 0)%Re).
    { nra. } rewrite H2. rewrite Rabs_mult. apply Rplus_le_compat_l.
    apply Rplus_le_le_0_compat.
    * apply Rmult_le_pos.
      ++ apply Rabs_pos.
      ++ apply /RleP. apply big_ge_0_ex_abstract. intros.
         apply /RleP. apply Rabs_pos.
    * apply Rmult_le_pos.
      ++ apply Rabs_pos.
      ++ apply /RleP. apply big_ge_0_ex_abstract. intros.
         apply /RleP. apply Rabs_pos.
Qed.

Lemma sum_abs_le {n:nat}:
  forall (f g : 'I_n.+1 -> R),
  (\sum_(j < n.+1) Rabs (f j + g j) <=
    \sum_(j < n.+1) Rabs (f j) +
    \sum_(j < n.+1) Rabs (g j))%Re.
Proof.
intros. induction n.
+ rewrite !big_ord_recr //= !big_ord0 !add0r.
  apply Rabs_triang.
+ rewrite big_ord_recr //=. rewrite -RplusE.
  assert (\sum_(j < n.+2) Rabs (f j) =
          \sum_(j < n.+1) Rabs (f (widen_ord (leqnSn n.+1) j)) + Rabs (f ord_max)).
  { by rewrite big_ord_recr //=. } rewrite H.
  assert (\sum_(j < n.+2) Rabs (g j) =
          \sum_(j < n.+1) Rabs (g (widen_ord (leqnSn n.+1) j)) + Rabs (g ord_max)).
  { by rewrite big_ord_recr //=. } rewrite H0.
  rewrite -!RplusE.
  assert ((\sum_(j < n.+1) Rabs (f (widen_ord (leqnSn n.+1) j)) +
             Rabs (f ord_max) +
             (\sum_(j < n.+1) Rabs (g (widen_ord (leqnSn n.+1) j)) +
              Rabs (g ord_max)))%Re =
           ((\sum_(j < n.+1) Rabs (f (widen_ord (leqnSn n.+1) j)) +
            \sum_(j < n.+1) Rabs (g (widen_ord (leqnSn n.+1) j))) +
            (Rabs (f ord_max) +  Rabs (g ord_max)))%Re).
  { nra. } rewrite H1.
  apply Rplus_le_compat.
  - apply IHn.
  - apply Rabs_triang.
Qed.

Lemma mulmx_distrl {n:nat}:
  forall (A :'cV[R]_n) (f : nat -> 'M[R]_n) (k:nat),
  \sum_(i < k.+1) ((f i) *m A) = (\sum_(i < k.+1) (f i)) *m A.
Proof.
intros. induction k.
+ rewrite !big_ord_recr //= !big_ord0. by rewrite !add0r.
+ rewrite big_ord_recr //=.
  assert (\sum_(i < k.+2) f i = (\sum_(i < k.+1) f i) + f k.+1).
  { by rewrite !big_ord_recr //= !big_ord0. } rewrite H.
  rewrite mulmxDl. by rewrite IHk.
Qed.

Lemma error_sum_le :
  forall k er er',
  0 <= er ->
  er <= er' ->
  error_sum k er <= error_sum k er'.
Proof.
intros.
induction k.
- simpl; auto.
- repeat rewrite error_sum_equiv.
repeat rewrite error_sum_equiv in IHk.
repeat rewrite <- error_sum_aux2.
apply ler_add; auto.
apply ler_pmul; auto.
rewrite <- error_sum_equiv.
apply error_sum_ge_0; auto.
Qed.

Lemma error_sum_1 :
  forall k,
  (error_sum k 1 = INR k).
Proof.
intros.
induction k.
- simpl; auto.
- repeat rewrite error_sum_equiv.
repeat rewrite error_sum_equiv in IHk.
repeat rewrite <- error_sum_aux2.
rewrite_scope.
rewrite Rmult_1_l.
rewrite IHk.
rewrite S_INR; auto.
Qed.