From mathcomp Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import seq eqtype order.
From ipcssr Require Import avlmap forms normal_forms kripke_trees in_ngamma forces_ngamma le_ks.

Section NDecoSound.
Context {disp : unit} {A : orderType disp}.

Definition k_deco_sound (k : kripke_tree A) (i0 i1 : A)
                        (work : seq (normal_form A)) (ds : seq (disj A))
                        (ni : seq (nested_imp A)) (ai : atomic_imps A)
                        (a : atoms A) : Prop :=
  [/\ Is_Monotone_kripke_tree k,
      forces_ngamma work ds ni ai a k &
      ~ forces_t k (Imp (Atom i0) (Atom i1))].

Definition deco_sound (work : seq (normal_form A)) (ds : seq (disj A))
                      (ni : seq (nested_imp A)) (ai : atomic_imps A)
                      (a : atoms A) : Prop :=
  forall k i0 i1 b, Decorated (NImp i0 i1 b) k \in ni ->
  k_deco_sound k i0 i1 work ds ni ai a.

(*****************************************************************)

Lemma deco_sound_cons_work_tail c work ds ni ai a :
  deco_sound (c :: work) ds ni ai a -> deco_sound work ds ni ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 b D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: (forces_ngamma_cons_work_tail c).
Qed.

Lemma deco_sound_cons_ds_tail work i j ds ni ai a :
  deco_sound work ((i, j) :: ds) ni ai a -> deco_sound work ds ni ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 b D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: (forces_ngamma_cons_ds_tail _ i j).
Qed.

Lemma deco_sound_cons_ni_tail work ds x ni ai a :
  deco_sound work ds (x :: ni) ai a -> deco_sound work ds ni ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 b D.
case: (C k i0 i1 b); first by rewrite inE D orbT.
move=>{C D}M F NF; split=>//.
by apply: (forces_ngamma_cons_ni_tail _ _ x).
Qed.

(*****************************************************************)

(* TODO roll into bijections? *)

Lemma deco_sound_shift_ds_work work i j ds ni ai a :
  deco_sound work ((i, j) :: ds) ni ai a ->
  deco_sound (NDisj i j :: work) ds ni ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 b D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_ds_work.
Qed.

Lemma deco_sound_shift_work_ds i j work ds ni ai a :
  deco_sound (NDisj i j :: work) ds ni ai a ->
  deco_sound work ((i, j) :: ds) ni ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 b D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_work_ds.
Qed.

Lemma deco_sound_shift_ni_work x work ds ni ai a :
  deco_sound work ds (x :: ni) ai a ->
  deco_sound (NImp_NF (nested_imp2nimp x) :: work) ds ni ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 b D.
case: (C k i0 i1 b); first by rewrite inE D orbT.
move=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_ni_work.
Qed.

Lemma deco_sound_shift_work_ni0 x work ds ni ai a :
  deco_sound (NImp_NF x :: work) ds ni ai a ->
  deco_sound work ds (Undecorated x :: ni) ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 b; rewrite inE /= => D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_work_ni.
Qed.

(* new + old *)
Lemma deco_sound_shift_ai_work i b work ds ni ai a :
  invariant ai ->
  deco_sound work ds ni (update_aimps b i ai).1 a ->
  deco_sound (AImp i b :: work) ds ni ai a.
Proof.
rewrite /deco_sound=>Ha C k i0 i1 c D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_ai_work.
Qed.

Lemma deco_sound_shift_work_ai i b work ds ni ai a :
  invariant ai ->
  deco_sound (AImp i b :: work) ds ni ai a ->
  deco_sound work ds ni (update_aimps b i ai).1 a.
Proof.
rewrite /deco_sound=>Ha C k i0 i1 c D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_work_ai.
Qed.

Lemma deco_sound_shift_a_work i work ds ni ai a :
  invariant a ->
  deco_sound work ds ni ai (update_atoms i a).1 ->
  deco_sound (NAtom i :: work) ds ni ai a.
Proof.
rewrite /deco_sound=>Ha C k i0 i1 c D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_a_work.
Qed.

Lemma deco_sound_shift_work_a i work ds ni ai a :
  invariant a ->
  deco_sound (NAtom i :: work) ds ni ai a ->
  deco_sound work ds ni ai (update_atoms i a).1.
Proof.
rewrite /deco_sound=>Ha C k i0 i1 c D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_work_a.
Qed.

Lemma deco_sound_shift_ni_x_ni_work x work ds ni1 ni2 ai a :
  deco_sound work ds (ni1 ++ x :: ni2) ai a ->
  deco_sound (NImp_NF (nested_imp2nimp x) :: work) ds (ni1 ++ ni2) ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 c D.
case: (C k i0 i1 c).
- by rewrite mem_cat inE orbCA -mem_cat D orbT.
move=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_ni_x_ni_work.
Qed.

Lemma deco_sound_shift_work_ninni x work ds ni1 ni2 ai a :
  deco_sound (NImp_NF x :: work) ds (ni1 ++ ni2) ai a ->
  deco_sound work ds (ni1 ++ Undecorated x :: ni2) ai a.
Proof.
rewrite /deco_sound=>C k i0 i1 c; rewrite mem_cat inE /= -mem_cat => D.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_work_ni_x_ni.
Qed.

Lemma deco_sound_shift_work_nirni a0 a1 b k1 work ds ni1 ni2 ai a :
  k_deco_sound k1 a0 a1 work ds (ni1 ++ Decorated (NImp a0 a1 b) k1 :: ni2) ai a ->
  deco_sound (NImp_NF (NImp a0 a1 b) :: work) ds (ni1 ++ ni2) ai a ->
  deco_sound work ds (ni1 ++ Decorated (NImp a0 a1 b) k1 :: ni2) ai a.
Proof.
rewrite /deco_sound=>K C k i0 i1 c; rewrite mem_cat inE orbCA -mem_cat.
case/orP=>[/eqP[->-> _ ->]|D] //.
case: (C _ _ _ _ D)=>{C D}M F NF; split=>//.
by apply: forces_ngamma_shift_work_ni_x_ni.
Qed.

(********************************************************************)

Lemma deco_sound_le work ds ni1 ni2 ai a :
  le_ni ni1 ni2 -> deco_sound work ds ni1 ai a ->
  deco_sound work ds ni2 ai a.
Proof.
rewrite /deco_sound=>L C k i0 i1 c D.
case: (C k i0 i1 c); first by apply/in_k_le/D.
move=>{C D}M F NF; split=>//.
apply/forces_ngamma_eqv/F.
by apply: ge_eqv.
Qed.

(*********************************************************************)

Lemma deco_sound_cons_work_weak b c work ds ni ai a :
  (forall k, Is_Monotone_kripke_tree k ->
   forces_t k (nf2form b) -> forces_t k (nf2form c)) ->
  deco_sound (b :: work) ds ni ai a -> deco_sound (c :: work) ds ni ai a.
Proof.
rewrite /deco_sound=>H C k i0 i1 d D.
case: (C _ _ _ _ D)=>{d C D}M F NF; split=>//.
apply: (forces_ngamma_cons_work_weak b)=>//.
by apply: H.
Qed.

Lemma deco_sound_cons_work_weak2 b c d work ds ni ai a :
  (forall k, Is_Monotone_kripke_tree k ->
   forces_t k (nf2form b) -> forces_t k (nf2form c) -> forces_t k (nf2form d)) ->
  deco_sound (b :: c :: work) ds ni ai a ->
  deco_sound (d :: work) ds ni ai a.
Proof.
rewrite /deco_sound=>H C k i0 i1 e D.
case: (C _ _ _ _ D)=>{e C D}M F NF; split=>//.
apply: (forces_ngamma_cons_work_weak2 b c)=>//.
by apply: H.
Qed.

Lemma deco_sound_cons_work_strength b c work ds ni ai a :
  (forall k, Is_Monotone_kripke_tree k ->
   forces_ngamma (b :: work) ds ni ai a k -> forces_t k (nf2form c)) ->
  deco_sound (b :: work) ds ni ai a -> deco_sound (c :: work) ds ni ai a.
Proof.
rewrite /deco_sound=>H C k i0 i1 d D.
case: (C _ _ _ _ D)=>{d C D}M F NF; split=>//.
apply: (forces_ngamma_cons_work_weak b)=>// _.
by apply: H.
Qed.

Lemma deco_sound_shift_work_ai_weak i bs work ds ni ai a :
  invariant ai -> lookup ai i = Some bs ->
  deco_sound (bs ++ work) ds ni (delete i ai).1 a ->
  deco_sound work ds ni ai a.
Proof.
rewrite /deco_sound=>Ha L C k i0 i1 d D.
case: (C _ _ _ _ D)=>{d C D}M F NF; split=>//.
by apply: (forces_ngamma_shift_work_ai_weak i bs).
Qed.

Lemma deco_sound_shift_work_ai_strength i bs work ds ni ai a :
  invariant ai -> invariant a ->
  lookup ai i = Some bs ->
  deco_sound work ds ni ai (update_atoms i a).1 ->
  deco_sound (bs ++ work) ds ni (delete i ai).1 (update_atoms i a).1.
Proof.
rewrite /deco_sound=>Hai Ha L C k i0 i1 d D.
case: (C _ _ _ _ D)=>{d C D}M F NF; split=>//.
by apply: (forces_ngamma_shift_work_ai_strength i).
Qed.

Lemma deco_sound_inf work ds ni ni1 ni2 ai a :
  le_ni ni ni1 -> eqv_ni ni ni2 ->
  (forall x k,
    Decorated x k \in ni -> (Decorated x k \in ni1) || (Decorated x k \in ni2)) ->
  deco_sound work ds ni1 ai a -> deco_sound work ds ni2 ai a ->
  deco_sound work ds ni ai a.
Proof.
rewrite /deco_sound=>L E H C1 C2 k i0 i1 d D.
case/orP: (H _ _ D)=>{}D.
- case: (C1 _ _ _ _ D)=>{D}M F NF; split=>//.
  by apply/forces_ngamma_eqv/F/le_eqv.
case: (C2 _ _ _ _ D)=>{D}M F NF; split=>//.
by apply/forces_ngamma_eqv/F.
Qed.

Lemma deco_sound_filter_deco i work ds ni ai a :
  (forall x k, Decorated x k \in ni -> forces_t k (Atom i)) ->
  deco_sound work ds ni ai a -> deco_sound (NAtom i :: work) ds ni ai a.
Proof.
rewrite /deco_sound=>H C k i0 i1 d D.
case: (C _ _ _ _ D)=>M F NF; split=>//.
apply: forces_ngamma_cons_work=>//.
by apply/H/D.
Qed.

End NDecoSound.


From mathcomp Require Export ssreflect.
From Coq Require Export Morphisms RelationClasses List Bool Utf8 Setoid.
Set Default Proof Using "Type".
Global Set Bullet Behavior "Strict Subproofs".
Global Open Scope general_if_scope.


(* Ugly tacty to resolve sign condition for Z *)

Require Import Reals.
Require Import RPolS.
Require Import PolAux.
Require Import List.

(* Building the tactics *)

Definition Zsign_type := fun (x y:list Z) => Prop.

Definition Zsign_cons : forall x y, (Zsign_type  x y) := fun x y => True.

Ltac Zsign_push term1 term2 := generalize (Zsign_cons term1 term2); intro.

Ltac Zsign_le term :=
  match term with
    (?X1 * ?X2)%Z =>  Zsign_le X1;
                             match goal with
                             H1: (Zsign_type ?s1 ?s2) |- _ =>
                                    Zsign_le X2;
                                   match goal with
                                      H2: (Zsign_type ?s3 ?s4) |- _ => clear H1 H2;
                                              let s5 := eval unfold List.app in (s1++s3) in
                                              let s6 := eval unfold List.app in (s2++s4) in
                                               Zsign_push s5 s6
                                   end
                              end
| _ =>  let H1 := fresh "H" in
    (((assert (H1: (0 <= term)%Z); [auto with zarith; fail | idtac])
      ||
     (assert (H1: (term <= 0)%Z); [auto with zarith; fail | idtac])); clear H1;
         Zsign_push (term::nil) (@nil Z)) || Zsign_push (@nil Z) (term::nil)
end.

Ltac Zsign_lt term :=
  match term with
    (?X1 * ?X2)%Z =>  Zsign_lt X1;
                             match goal with
                             H1: (Zsign_type ?s1 ?s2) |- _ =>
                                    Zsign_lt X2;
                                   match goal with
                                      H2: (Zsign_type ?s3 ?s4) |- _ => clear H1 H2;
                                              let s5 := eval unfold List.app in (s1++s3) in
                                              let s6 := eval unfold List.app in (s2++s4) in
                                               Zsign_push s5 s6
                                   end
                              end
| _ =>  let H1 := fresh "H" in
    (((assert (H1: (0 < term)%Z); [auto with zarith; fail | idtac])
      ||
     (assert (H1: (term < 0)%Z); [auto with zarith; fail | idtac])); clear H1;
         Zsign_push (term::nil) (@nil Z)) || Zsign_push (@nil Z) (term::nil)
end.

Ltac Zsign_top0 :=
  match goal with
  |- (0 <= ?X1)%Z => Zsign_le  X1
| |- (?X1 <= 0)%Z => Zsign_le  X1
| |- (0 < ?X1)%Z => Zsign_lt  X1
| |- (?X1 < 0)%Z => Zsign_le  X1
| |- (0 >= ?X1)%Z => Zsign_le  X1
| |- (?X1 >= 0)%Z => Zsign_le  X1
| |- (0 > ?X1 )%Z => Zsign_lt X1
| |- (?X1 > 0)%Z => Zsign_le  X1
  end.

Ltac Zsign_top :=
  match goal with
| |- (?X1 * _ <= ?X1 * _)%Z => Zsign_le  X1
| |- (?X1 * _ < ?X1 * _)%Z => Zsign_le  X1
| |- (?X1 * _ >= ?X1 * _)%Z => Zsign_le  X1
| |- (?X1 * _ > ?X1 * _)%Z => Zsign_le  X1
  end.

Ltac Zhyp_sign_top0 H:=
  match type of H with
   (0 <= ?X1)%Z => Zsign_lt  X1
|  (?X1 <= 0)%Z => Zsign_lt  X1
|  (0 < ?X1)%Z => Zsign_lt  X1
|  (?X1 < 0)%Z => Zsign_lt X1
|  (0 >= ?X1)%Z => Zsign_lt  X1
|  (?X1 >= 0)%Z => Zsign_lt  X1
|  (0 > ?X1 )%Z => Zsign_lt X1
|  (?X1 > 0)%Z => Zsign_lt  X1
  end.

Ltac Zhyp_sign_top H :=
  match type of H with
|  (?X1 * _ <= ?X1 * _)%Z => Zsign_lt  X1
|  (?X1 * _ < ?X1 * _)%Z => Zsign_lt X1
|  (?X1 * _ >= ?X1 * _)%Z => Zsign_lt  X1
|  (?X1 * _ > ?X1 * _)%Z => Zsign_lt  X1
|  ?X1 => generalize H
  end.

Ltac Zsign_get_term g :=
  match g with
   (0 <= ?X1)%Z =>  X1
|  (?X1 <= 0)%Z => X1
|  (?X1 * _ <= ?X1 * _)%Z =>  X1
|  (0 < ?X1)%Z =>  X1
|  (?X1 < 0)%Z => X1
|  (?X1 * _ < ?X1 * _)%Z =>  X1
|  (0 >= ?X1)%Z => X1
|  (?X1 >= 0)%Z => X1
|  (?X1 * _ >= ?X1 * _)%Z =>  X1
|  (?X1 * _  >= _)%Z => X1
|  (0 > ?X1)%Z => X1
|  (?X1 > 0)%Z => X1
|  (?X1 * _ > ?X1 * _)%Z =>  X1
  end.

Ltac Zsign_get_left g :=
  match g with
|  (_ * ?X1 <=  _)%Z =>  X1
|  (_ * ?X1 <  _)%Z =>  X1
|  (_ * ?X1 >=  _)%Z =>  X1
|  (_ * ?X1 >  _)%Z =>  X1
end.

Ltac Zsign_get_right g :=
  match g with
|  (_ <= _ * ?X1)%Z =>  X1
|  (_ < _ * ?X1)%Z =>  X1
|  (_ >= _ * ?X1)%Z =>  X1
|  (_ > _ * ?X1)%Z =>  X1
end.

Fixpoint mkZprodt (l: list Z)(t:Z) {struct l}: Z :=
match l with nil => t | e::l1 => (e * mkZprodt l1 t)%Z end.

Fixpoint mkZprod (l: list Z) : Z :=
match l with nil => 1%Z  | e::nil => e | e::l1 => (e * mkZprod l1)%Z end.

(* tatic for 0 ? x * y where ? is < > <= >= *)

Ltac zsign_tac_aux0 :=
match goal with
  |- (0 <= ?X1 * ?X2)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 <= X1)%Z); auto with zarith; apply Zle_sign_pos_pos)
      ||
     (assert (H1: (X1 <= 0)%Z); auto with zarith; apply Zle_sign_neg_neg); try zsign_tac_aux0; clear H1)
| |- (?X1 * ?X2 <= 0)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 <= X1)%Z); auto with zarith; apply Zle_sign_pos_neg)
      ||
     (assert (H1: (X1 <= 0)%Z); auto with zarith; apply Zle_sign_neg_pos); try zsign_tac_aux0; clear H1)
| |- (0 < ?X1 * ?X2)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; apply Zlt_sign_pos_pos)
      ||
     (assert (H1: (X1 < 0)%Z); auto with zarith; apply Zlt_sign_neg_neg); try zsign_tac_aux0; clear H1)
| |- (?X1 * ?X2 < 0)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; apply Zlt_sign_pos_neg)
      ||
     (assert (H1: (X1 < 0)%Z); auto with zarith; apply Zlt_sign_neg_pos); try zsign_tac_aux0; clear H1)
 | |- (?X1 * ?X2 >= 0)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 >= X1)%Z); auto with zarith; apply Zge_sign_neg_neg)
      ||
     (assert (H1:  (X1 >= 0)%Z); auto with zarith; apply Zge_sign_pos_pos); try zsign_tac_aux0; clear H1)
| |- (0 >= ?X1 * ?X2)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (X1 >= 0)%Z); auto with zarith; apply Zge_sign_pos_neg)
      ||
     (assert (H1: (0 >= X1)%Z); auto with zarith; apply Zge_sign_neg_pos); try zsign_tac_aux0; clear H1)
| |- (0 > ?X1 * ?X2)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 > X1)%Z); auto with zarith; apply Zgt_sign_neg_pos)
      ||
     (assert (H1: (X1 > 0)%Z); auto with zarith; apply Zgt_sign_pos_neg); try zsign_tac_aux0; clear H1)
| |- (?X1 * ?X2 > 0)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 > X1)%Z); auto with zarith; apply Zgt_sign_neg_neg)
      ||
     (assert (H1: (X1 > 0)%Z); auto with zarith; apply Zgt_sign_pos_pos); try zsign_tac_aux0; clear H1)
|
 _ => auto with zarith; fail 1 "zsign_tac_aux"
end.

Ltac zsign_tac0 := Zsign_top0;
  match goal with
    H1: (Zsign_type ?s1 ?s2) |- ?g => clear H1;
    let s := eval unfold mkZprod, mkZprodt in
                  (mkZprodt s1 (mkZprod s2)) in
    let t := Zsign_get_term g in
         replace t with s; [try zsign_tac_aux0 | try ring]; auto with zarith
  end.

(* tatic for hyp 0 ? x * y where ? is < > <= >= *)

Ltac hyp_zsign_tac_aux0 H :=
match  type of H  with
   (0 <= ?X1 * ?X2)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; generalize (Zle_sign_pos_pos_rev  _ _ H1 H)
      ||
     (assert (H1: (X1 < 0)%Z); auto with zarith; generalize (Zle_sign_neg_neg_rev  _ _ H1 H)));
     clear H; intros H; try hyp_zsign_tac_aux0 H; clear H1)
|  (?X1 * ?X2 <= 0)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; generalize (Zle_sign_pos_neg_rev  _ _ H1 H))
      ||
     (assert (H1: (X1 <= 0)%Z); auto with zarith; generalize (Zle_sign_neg_pos_rev  _ _ H1 H));
      clear H; intros H; try hyp_zsign_tac_aux0 H; clear H1)
|  (0 < ?X1 * ?X2)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; generalize (Zlt_sign_pos_pos_rev _  _ H1 H))
      ||
     (assert (H1: (X1 < 0)%Z); auto with zarith; generalize (Zlt_sign_neg_neg_rev _ _ H1 H));
      clear H; intros H; try hyp_zsign_tac_aux0 H; clear H1)
|  (?X1 * ?X2 < 0)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; generalize (Zlt_sign_pos_neg_rev _ _ H1 H))
      ||
     (assert (H1: (X1 < 0)%Z); auto with zarith; generalize (Zlt_sign_neg_pos_rev _ _ H1 H));
     clear H; intros H; try hyp_zsign_tac_aux0 H; clear H1)
 |  (?X1 * ?X2 >= 0)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 >X1)%Z); auto with zarith; generalize (Zge_sign_neg_neg_rev _ _ H1 H))
      ||
     (assert (H1:  (X1 > 0)%Z); auto with zarith; generalize (Zge_sign_pos_pos _ _ H1 H));
      clear H; intros H; try hyp_zsign_tac_aux0 H; clear H1)
|  (0 >= ?X1 * ?X2)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (X1 > 0)%Z); auto with zarith; generalize (Zge_sign_pos_neg _ _ H1 H))
      ||
     (assert (H1: (0 > X1)%Z); auto with zarith; generalize (Zge_sign_neg_pos _ _ H1 H));
     clear H; intros H; try hyp_zsign_tac_aux0 H; clear H1)
|  (0 > ?X1 * ?X2)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 > X1)%Z); auto with zarith; generalize (Zgt_sign_neg_pos _ _ H1 H))
      ||
     (assert (H1: (X1 > 0)%Z); auto with zarith; generalize (Zgt_sign_pos_neg _ _ H1 H));
     clear H; intros H; try hyp_zsign_tac_aux0 H; clear H1)
|  (?X1 * ?X2 > 0)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 > X1)%Z); auto with zarith; generalize (Zgt_sign_neg_neg _ _ H1 H))
      ||
     (assert (H1: (X1 > 0)%Z); auto with zarith; generalize (Zgt_sign_pos_pos _ _ H1 H));
     clear H; intros H; try hyp_zsign_tac_aux0 H; clear H1)
|
 _ => auto with zarith; fail 1 "hyp_zsign_tac_aux0"
end.

Ltac hyp_zsign_tac0 H := Zhyp_sign_top0 H;
  match goal with
    H1: (Zsign_type ?s1 ?s2) |- ?g => clear H1;
    let s := eval unfold mkZprod, mkZprodt in
                  (mkZprodt s1 (mkZprod s2)) in
    let t := Zsign_get_term g in
         replace t with s in H; [try hyp_zsign_tac_aux0 H | try ring]; auto with zarith
  end.

(* Tactic for goal x1 * x2 ? x1 * x3 where ? is < > <= >= *)

Ltac zsign_tac_aux :=
match goal with
 | |- (?X1 * ?X2 <= ?X1 * ?X3)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 <= X1)%Z); auto with zarith; apply Zmult_le_compat_l)
      ||
     (assert (H1: (X1 <= 0)%Z); auto with zarith; apply Zmult_le_neg_compat_l); try zsign_tac_aux; clear H1)
| |- (?X1 * ?X2 < ?X1 * ?X3)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 <= X1)%Z); auto with zarith; apply Zmult_lt_compat_l)
      ||
     (assert (H1: (X1 <= 0)%Z); auto with zarith; apply Zmult_lt_neg_compat_l); try zsign_tac_aux; clear H1)
 | |- (?X1 * ?X2 >= ?X1 * ?X3)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (X1 >= 0)%Z); auto with zarith; apply Zmult_ge_compat_l)
      ||
     (assert (H1:  (0 >= X1)%Z); auto with zarith; apply Zmult_ge_neg_compat_l); try zsign_tac_aux; clear H1)
| |- (?X1 * ?X2 > ?X1 * ?X3)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 <= X1)%Z); auto with zarith; apply Zmult_lt_compat_l)
      ||
     (assert (H1: (X1 <= 0)%Z); auto with zarith; apply Zmult_lt_neg_compat_l); try zsign_tac_aux; clear H1)
|
 _ => auto with zarith; fail 1 "Zsign_tac_aux"
end.

Ltac zsign_tac := zsign_tac0 || (Zsign_top;
  match goal with
    H1: (Zsign_type ?s1 ?s2) |- ?g => clear H1;
    let s := eval unfold mkZprod, mkZprodt in
                  (mkZprodt s1 (mkZprod s2)) in
    let t := Zsign_get_term g in
    let l := Zsign_get_left g in
    let r := Zsign_get_right g in
    let sl := eval unfold mkZprod, mkZprodt in
                  (mkZprodt s1 (Zmult (mkZprod s2) l)) in
    let sr := eval unfold mkZprod, mkZprodt in
                  (mkZprodt s1 (Zmult (mkZprod s2) r)) in
         replace2_tac (Zmult t l) (Zmult t r) sl sr; [zsign_tac_aux | ring | ring]
  end).

(* Tactic for hyp x1 * x2 ? x1 * x3 where ? is < > <= >= *)

Ltac hyp_zsign_tac_aux H :=
match type of H with
 | (?X1 * ?X2 <= ?X1 * ?X3)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; generalize (Zmult_le_compat_l_rev _ _ _ H1 H))
      ||
     (assert (H1: (X1 < 0)%Z); auto with zarith; generalize (Zmult_le_neg_compat_l_rev _ _ _ H1 H));
     clear H; intros H; try hyp_zsign_tac_aux H; clear H1)
|  (?X1 * ?X2 < ?X1 * ?X3)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; generalize (Zmult_lt_compat_l_rev _ _ _ H1 H))
      ||
     (assert (H1: (X1 < 0)%Z); auto with zarith; generalize (Zmult_lt_neg_compat_l_rev _ _ _ H1 H));
    clear H; intros H; try hyp_zsign_tac_aux H; clear H1)
 |  (?X1 * ?X2 >= ?X1 * ?X3)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (X1 > 0)%Z); auto with zarith; generalize (Zmult_ge_compat_l_rev _ _ _ H1 H))
      ||
     (assert (H1:  (0 > X1)%Z); auto with zarith; generalize (Zmult_ge_neg_compat_l_rev _ _ _ H1 H));
    clear H; intros H; try hyp_zsign_tac_aux H; clear H1)
| (?X1 * ?X2 > ?X1 * ?X3)%Z =>
  let H1 := fresh "H" in
    ((assert (H1: (0 < X1)%Z); auto with zarith; generalize (Zmult_gt_compat_l_rev _ _ _ H1 H))
      ||
     (assert (H1: (X1 < 0)%Z); auto with zarith; generalize (Zmult_gt_neg_compat_l_rev _ _ _ H1 H));
     clear H; intros H; try hyp_zsign_tac_aux H; clear H1)
|
 _ => auto with zarith; fail 0 "Zhyp_sign_tac_aux"
end.

Ltac hyp_zsign_tac H := hyp_zsign_tac0  H||( Zhyp_sign_top H;
  match goal with
    H1: (Zsign_type ?s1 ?s2) |- _ => clear H1;
    let s := eval unfold mkZprod, mkZprodt in
                  (mkZprodt s1 (mkZprod s2)) in
    let g := type of H in
    let t := Zsign_get_term g in
    let l := Zsign_get_left g in
    let r := Zsign_get_right g in
    let sl := eval unfold mkZprod, mkZprodt in
                  (mkZprodt s1 (Zmult (mkZprod s2) l)) in
    let sr := eval unfold mkZprod, mkZprodt in
                  (mkZprodt s1 (Zmult (mkZprod s2) r)) in
         (generalize H; replace2_tac (Zmult t l) (Zmult t r) sl sr; [clear H; intros H; try hyp_zsign_tac_aux H| ring | ring])
  end).

Section Test.

Let test : forall a b c, (0 < a -> a * b < a * c -> b < c)%Z.
intros a b c H H1.
hyp_zsign_tac H1.
Qed.

Let test1 : forall a b c, (a < 0 -> a * b < a * c -> c < b)%Z.
intros a b c H H1.
hyp_zsign_tac H1.
Qed.

Let test2 : forall a b c, (0 < a -> a * b <= a * c -> b <= c)%Z.
intros a b c H H1.
hyp_zsign_tac H1.
Qed.

Let test3 : forall a b c, (a < - 0 -> a * b >= a * c -> c >= b)%Z.
intros a b c H H1.
hyp_zsign_tac H1.
Qed.

End Test.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                    SF_Tactics.v                                    *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.

Definition termred := SF -> SF -> Prop.

Definition preserve (R : termred) (P : SF -> Prop) :=
  forall x : SF, P x -> forall y : SF, R x y -> P y.

Inductive multi_step : termred -> termred :=
  | zero_red : forall red M, multi_step red M M
  | succ_red : forall (red: SF-> SF -> Prop) M N P,
                   red M N -> multi_step red N P -> multi_step red M P
.

Hint Constructors multi_step.

Definition reflective red := forall (M: SF), red M M.

Lemma refl_multi_step : forall (red: termred), reflective (multi_step red).
Proof. red; split_all. Qed.

Ltac reflect := match goal with
| |- reflective (multi_step _) => eapply2 refl_multi_step
| |- multi_step _ _ _ => try (eapply2 refl_multi_step)
| _ => split_all
end.

Ltac one_step :=
match goal with
| |- multi_step _ _ ?N => apply succ_red with N; auto; try red; try reflect
end.

Definition transitive red := forall (M N P: SF), red M N -> red N P -> red M P.

Lemma transitive_red : forall red, transitive (multi_step red).
Proof. red; induction 1; split_all.
apply succ_red with N; auto.
Qed.

Definition preserves_app (red : termred) :=
forall M M' N N', red M M' -> red N N' -> red (App M N) (App M' N').

Lemma preserves_app_multi_step : forall (red: termred), reflective red -> preserves_app red -> preserves_app (multi_step red).
Proof.
red. induction 3; split_all. generalize H0; induction 1.
reflect.
apply succ_red with (App M N); auto.
assert( transitive (multi_step red)) by eapply2 transitive_red.
apply X0 with (App N0 N); auto.
one_step.
Qed.

Hint Resolve preserves_app_multi_step.

Ltac inv1 prop :=
match goal with
| H: prop _ |- _ => inversion H; clear H; inv1 prop
| H: prop (App  _ _) |- _ => inversion H; clear H; inv1 prop
| H: prop Op _ |- _ => inversion H; clear H; inv1 prop
| _ => split_all
 end.

Definition implies_red (red1 red2: termred) := forall M N, red1 M N -> red2 M N.

Lemma implies_red_multi_step: forall red1 red2, implies_red red1  (multi_step red2) ->
                                                implies_red (multi_step red1) (multi_step red2).
Proof. red.
intros red1 red2 IR M N R; induction R; split_all.
apply transitive_red with N; auto.
Qed.

Ltac inv red :=
match goal with
| H: multi_step red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red (Op _) _ |- _ => inversion H; clear H; inv red
| H: red (Ref _) _ |- _ => inversion H; clear H; inv red
| H: red (App _ _) _ |- _ => inversion H; clear H; inv red
| H: red (Op _) _ |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: multi_step red _ (Op _) |- _ => inversion H; clear H; inv red
| H: red _ (Ref _) |- _ => inversion H; clear H; inv red
| H: red _ (App _ _) |- _ => inversion H; clear H; inv red
| H: red _ (Op _) |- _ => inversion H; clear H; inv red
| _ => subst; split_all
 end.

Definition diamond (red1 red2 : termred) :=
forall M N, red1 M N -> forall P, red2 M P -> exists Q, red2 N Q /\ red1 P Q.

Lemma diamond_flip: forall red1 red2, diamond red1 red2 -> diamond red2 red1.
Proof.
unfold diamond; split_all. elim (H M P H1 N H0); split_all. inversion H2.
 exist x.
Qed.

Lemma diamond_strip :
forall red1 red2, diamond red1 red2 -> diamond red1 (multi_step red2).
Proof. intros.
eapply2 diamond_flip.
red; induction 1; split_all.
exist P.
elim (H M P0 H2 N); split_all. inversion H3.
elim(IHmulti_step H x); split_all. inversion H6.
exist x0. split. auto.
apply succ_red with x; auto.
Qed.

Definition diamond_star (red1 red2: termred) := forall  M N, red1 M N -> forall P, red2 M P ->
  exists Q, red1 P Q /\ multi_step red2 N Q.

Lemma diamond_star_strip: forall red1 red2, diamond_star red1 red2 -> diamond (multi_step red2) red1 .
Proof.
red. induction 2; split_all.
exist P.
elim(H M P0 H2 N H0); split_all. inversion H3.
elim(IHmulti_step H x); split_all. inversion H6.
exist x0. split. auto.
apply transitive_red with x; auto.
Qed.

Lemma diamond_tiling :
forall red1 red2, diamond red1 red2 -> diamond (multi_step red1) (multi_step red2).
Proof.
red.  induction 2; split_all.
exist P.
elim(diamond_strip red red2 H M N H0 P0); split_all.
inversion H3.
elim(IHmulti_step H x H4); split_all. inversion H6.
exist x0. split. auto.
apply succ_red with x; auto.
Qed.

Hint Resolve diamond_tiling.

Fixpoint rank (M: SF) :=
match M with
| Ref _ => 1
| Op _ => 1
| App M1 M2 => S((rank M1) + (rank M2))
end.

Lemma rank_positive: forall M, rank M > 0.
Proof.
induction M; split_all; try omega.
Qed.

Ltac rank_tac := match goal with
| |- forall M, ?P  =>
  cut (forall p M, p >= rank M -> P )
; [ intros H M;  eapply2 H | ]
end .


Require Import VST.floyd.proofauto.
Require Import triang.
Require Import simple_spec_stdlib.
Require Import PileModel.
Instance TriangCompSpecs : compspecs. make_compspecs prog. Defined.

(*APD is empty, but the ASI still depend n the MallocFree-APD*)

Definition Triang_nth_spec :=
 DECLARE _Triang_nth
 WITH n:Z, gv: globals
 PRE [ tint ]
    PROP( 0 <= n < 1000)
    PARAMS (Vint (Int.repr n)) GLOBALS (gv)
    SEP(mem_mgr gv)
 POST[ tint ]
    PROP()
    LOCAL(temp ret_temp (Vint (Int.repr (triang (Z.to_nat n)))))
    SEP(mem_mgr gv).

Definition TriangASI:funspecs := [Triang_nth_spec].


Require Import NoQ.Monad.
Require Import NoQ.Function.

Class MonadState (S:Type) (m:Type -> Type) `{! Monad m } :=
  { mget : m S
  ; mput : S -> m unit
  }.

Section MonadState.
  Context {S m} `{! Monad m ,! MonadState S m }.

  Definition mmodify (f:S -> S) : m unit :=
    s <- mget ;;
    mput $ f s.
End MonadState.


Require Import Sail.Values Sail.Values_lemmas Sail.Operators_mwords Sail.State_monad bbv.Word.
Require Import aarch64_types aarch64 Address_Translation_Orig AArch64_Aux.

Import Word.Notations.
Import ListNotations.
Local Open Scope word_scope.
Local Open Scope bool.
Local Open Scope Z.

(*
(*<*)
(* Author: Thomas Bauereiss *)
theory Address_Translation_Pure
  imports AArch64_Aux Address_Translation_Orig
begin
(*>*)

section \<open>Pure characterisation\<close>

subsection \<open>Types\<close>

text \<open>Translation tables are represented as a list of entries, each of which might recursively
contain another table.\<close>
*)

Inductive TableEntry : Type :=
  Invalid
  | Descriptor : word 64 -> TableEntry (* 64-bit block or page descriptor *)
  | Table : word 52 -> bool -> bool -> bool -> bool -> bool -> list TableEntry -> TableEntry. (* base address, table attributes, entries *)

(*text \<open>A record for the main parameters of the translation, e.g. address size or page size.\<close>*)

Record Parameters := {
  inputsize : Z;
  outputsize : Z;
  grainsize : Z;
  firstblocklevel : Z;
  updateAF : bool;
  SH : word 2;
  ORGN : word 2;
  IRGN : word 2
}.

(* TODO: move *)
Notation "v !! n" := (getBit v n) (at level 20).
(*
Lemma cast_to_mword
  @cast_to_mword m n w E =
*)

(*
Notation "'word_slice' i v n" :=
 (@Word_slice (ltac:(
   let ty := type of v in
   match ty with
   | word ?len => constr:((len - i - n)%nat)
   | mword ?len => constr:((Z.to_nat len - i - n)%nat)
   end)) n i v) (at level 10, i, v at level 9).

Notation "'word_slice' i v n" :=
 (ltac:(
   let ty := type of v in
   let m := match ty with
   | word ?len => constr:((len - i - n)%nat)
(*   | mword ?len => constr:((Z.to_nat len - i - n)%nat)*)
   end in constr:(@Word_slice m n i v))) (at level 10, i, v at level 9).
*)
Definition word_size {n} (_ : word n) := n.

Import ConversionNotations.

(*subsection \<open>Auxiliary functions for our pure characterisation, e.g. for reading the translation
parameters from the control registers or decoding descriptor attributes.\<close>*)

Definition read_params (high : bool) (s : sequential_state regstate) : Parameters :=
  let largegrain := if high then weqb (slice (TCR_EL1 (ss_regstate s)) 30 2) $3
                    else weqb (slice (TCR_EL1 (ss_regstate s)) 14 2) ($1 : word 2) in
  let midgrain := if high then weqb (slice (TCR_EL1 (ss_regstate s)) 30 2) ($1 : word 2)
                  else weqb (slice (TCR_EL1 (ss_regstate s)) 14 2) ($2 : word 2) in
  let grainsize := if largegrain then 16 else if midgrain then 14 else 12 in
  let outputsize := calc_outputsize (slice (TCR_EL1 (ss_regstate s)) 32 3) largegrain in
  let inputsize_max := if largegrain then 52 else 48 in
  let inputsize := 64 - (projT1 (uint (slice (TCR_EL1 (ss_regstate s)) (if high then 16 else 0) 6))) in
    {| inputsize := Z.min (Z.max inputsize 25) inputsize_max;
       outputsize := outputsize;
       grainsize := grainsize;
       firstblocklevel := (if andb (negb largegrain) midgrain then 2 else 1);
       updateAF := TCR_EL1 (ss_regstate s) !! 39;
       SH := slice (TCR_EL1 (ss_regstate s)) (if high then 28 else 12) 2;
       ORGN := slice (TCR_EL1 (ss_regstate s)) (if high then 26 else 10) 2;
       IRGN := slice (TCR_EL1 (ss_regstate s)) (if high then 24 else 8) 2 |}.

Lemma inputsize_range high s :
  0 <= inputsize (read_params high s) <= 52.
unfold read_params, inputsize.
(*match goal with |- context[projT1 ?x] =>
let v := fresh "v" in
let H := fresh "H" in
destruct x as [v H];
change (projT1 (existT _ v H)) with v
end.*)
repeat match goal with |- context[if ?b then _ else _] => destruct b end;
omega with Z.
Qed.

Lemma grainsize_range high s :
  12 <= grainsize (read_params high s) <= 16.
unfold read_params, grainsize.
repeat match goal with |- context[if ?b then _ else _] => destruct b end;
omega with Z.
Qed.

Lemma grainsize_split high s :
  grainsize (read_params high s) = 12 \/
  grainsize (read_params high s) = 14 \/
  grainsize (read_params high s) = 16.
unfold read_params, grainsize.
repeat match goal with |- context[if ?b then _ else _] => destruct b end; auto.
Qed.

Definition largegrain p := Z.eqb (grainsize p) 16.
Definition midgrain p := Z.eqb (grainsize p) 14.

Definition startlevel (p : Parameters) : Z :=
  calc_startlevel (inputsize p) (grainsize p) (grainsize p - 3).

Lemma startlevel_bounds high s :
  0 <= startlevel (read_params high s) < 4.
unfold startlevel, read_params, calc_startlevel, inputsize, grainsize.
rewrite Sail.Real.round_up_div.

split.
apply Zle_minus_le_0.

repeat match goal with |- context[if ?b then _ else _] => destruct b end;
try match goal with |- context[uint ?v] => destruct (uint v) as [i [H]]; simpl (projT1 _) end;
match goal with |- _ / ?denom <= _ => change 4 with ((4*denom + denom - 1)/denom); apply Z.div_le_mono end;
try simpl in H;
try omega with Z.

apply Z.lt_sub_pos.
apply Z.div_str_pos.
repeat match goal with |- context[if ?b then _ else _] => destruct b end;
try match goal with |- context[uint ?v] => destruct (uint v) as [i [H]]; simpl (projT1 _) end;
try simpl in H;
try omega with Z.

repeat match goal with |- context[if ?b then _ else _] => destruct b end;
try match goal with |- context[uint ?v] => destruct (uint v) as [i [H]]; simpl (projT1 _) end;
try simpl in H;
try omega with Z.

repeat match goal with |- context[if ?b then _ else _] => destruct b end;
try match goal with |- context[uint ?v] => destruct (uint v) as [i [H]]; simpl (projT1 _) end;
try simpl in H;
try omega with Z.
Qed.

Lemma startlevel_largegrain_bounds high s p :
  p = read_params high s ->
  grainsize p = 16 ->
  1 <= startlevel p.
intros -> GRAINSIZE.
unfold startlevel, read_params, calc_startlevel, inputsize, grainsize in *.
rewrite Sail.Real.round_up_div.
2,3: repeat match goal with |- context[if ?b then _ else _] => destruct b end;
try match goal with |- context[uint ?v] => destruct (uint v) as [i [H]]; simpl (projT1 _) end;
try simpl in H;
omega with Z.

apply Zle_0_minus_le.
rewrite <- Z.sub_add_distr.
rewrite Z.add_comm.
rewrite Z.sub_add_distr.
simpl (4 - 1).
apply Zle_minus_le_0.

repeat match goal with |- context[if ?b then _ else _] => destruct b end;
  try match goal with |- context[uint ?v] => destruct (uint v) as [i [H]]; simpl (projT1 _) end;
  match goal with |- ?nom / ?denom <= ?rhs => change (nom / denom <= rhs) with (nom / denom <= ((rhs*denom + denom - 1)/denom)); apply Z.div_le_mono end;
  try simpl in H;
  omega with Z.
Qed.

Definition baselowerbound (p : Parameters) : Z :=
  3 + (inputsize p) - ((3 - startlevel p) * (grainsize p - 3) + (grainsize p)).

Lemma mul_div_pos_range a b :
  0 <= a ->
  0 < b ->
  a - b < b * (a / b) <= a.
intro H.
split; auto using Z.mul_div_le.
specialize (Z.div_mod a b ltac:(omega)).
specialize (Z.mod_bound_pos a b).
generalize (a mod b).
generalize (b * (a / b)).
intros.
subst.
omega with Z.
Qed.

Lemma baselowerbound_bounds high s :
  3 <= baselowerbound (read_params high s) < 48.
unfold baselowerbound, read_params, startlevel, calc_startlevel, grainsize, inputsize.
match goal with |- context[uint ?v] => destruct (uint v) as [i [H1]]; simpl (projT1 _) end;
simpl in H1.
rewrite Sail.Real.round_up_div.

split;

repeat match goal with |- context[if ?b then _ else _] => destruct b end;
zify;
rewrite !Z.mul_sub_distr_r;
match goal with |- context[(Z.div ?nom ?denom) * ?denom] => specialize (mul_div_pos_range nom denom); generalize (Z.div nom denom) end;
intros;
omega.

repeat match goal with |- context[if ?b then _ else _] => destruct b end;
omega with Z.

repeat match goal with |- context[if ?b then _ else _] => destruct b end;
omega with Z.
Qed.

Lemma baselowerbound_bounds_af high s :
  ArithFact (0 <? baselowerbound (read_params high s) <? 48).
constructor.
unbool_comparisons_goal.
specialize (baselowerbound_bounds high s).
omega.
Qed.
Hint Resolve baselowerbound_bounds_af : sail.

Lemma baselowerbound_bounds' high s p :
  p = read_params high s ->
  0 < baselowerbound p < 48.
intros ->.
specialize (baselowerbound_bounds high s).
omega.
Qed.

Definition contiguousbitcheck p level :=
  calc_contiguousbitcheck (inputsize p) (largegrain p) (midgrain p) level.

Definition baseaddress (baseregister : mword 64) (baselowerbound_arg : Z) `{ArithFact (0 <? baselowerbound_arg <? 48)} (outputsize_arg : Z) : mword 52 :=
  if Z.eqb outputsize_arg 52 then
    let z := Z.max baselowerbound_arg 6 in
                 autocast (concat_vec
                             (concat_vec (slice baseregister 2 4)
                                (slice baseregister z (Z.add (Z.opp z) 48))) (zeros z))
  else
autocast (concat_vec (zeros 4) (concat_vec (slice baseregister baselowerbound_arg (48 - baselowerbound_arg)) (zeros baselowerbound_arg))).

Lemma addrtop_inputsize_pos addrtop high s :
  55 <= addrtop ->
  let p := read_params high s in
  0 <= addrtop - inputsize p + 1.
intros.
specialize (inputsize_range high s) as H1.
unfold p.
omega.
Qed.
Hint Resolve addrtop_inputsize_pos : sail.

Lemma inputsize_range' high s p :
  p = read_params high s ->
  0 <= inputsize p <= 52.
intro; subst.
apply inputsize_range.
Qed.

Definition valid_vaddr (addr : mword 64) (addrtop : Z) `{ArithFact (55 <=? addrtop)} (s : sequential_state regstate) : bool :=
  let high := addr !! Z.to_nat addrtop in
  let p := read_params high s in
  let _ := inputsize_range' high s p eq_refl in
  if high
  then IsOnes (slice addr (inputsize p) (addrtop - inputsize p + 1))
  else IsZero (slice addr (inputsize p) (addrtop - inputsize p + 1)).

Definition IsBlockDescriptor (desc : mword 64) : bool :=
  weqb (slice desc 0 2) $1.

Definition ValidDescriptor (level : Z) (grainsize_arg : Z) (outputsize_arg : Z) (desc : mword 64) : bool :=
  desc !! 0 &&
  negb (IsBlockDescriptor desc && Z.eqb level 3) &&
  implb (negb (IsBlockDescriptor desc) && Z.ltb level 3)
     ((implb (Z.ltb outputsize_arg 52 && Z.eqb grainsize_arg 16) (weqb (slice desc 12 4) $0)) &&
      (if sumbool_of_bool (Z.ltb outputsize_arg 48) then IsZero (slice desc outputsize_arg (48 - outputsize_arg)) else true)).

Definition read_WalkAttrDecode (SH_arg : mword 2) (ORGN_arg : mword 2) (IRGN_arg : mword 2) (secondstage : bool) (s : sequential_state regstate) : MemoryAttributes :=
     {| MemoryAttributes_typ := MemType_Normal;
        MemoryAttributes_device := DeviceType_GRE;
        MemoryAttributes_inner :=
          {| MemAttrHints_attrs :=
               if negb secondstage && implb (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2) (eq_vec IRGN_arg $0) ||
                     secondstage && (HCR_EL2 (ss_regstate s) !! 32 || eq_vec IRGN_arg $0)
                  then $0 else if eq_vec IRGN_arg $1 || negb (eq_vec IRGN_arg $2) then $3 else $2;
             MemAttrHints_hints :=
               if negb secondstage && implb (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2) (eq_vec IRGN_arg $0) ||
                       secondstage && (HCR_EL2 (ss_regstate s) !! 32 || eq_vec IRGN_arg $0)
                    then MemHint_No else if eq_vec IRGN_arg $1 then MemHint_RWA else MemHint_RA;
             MemAttrHints_transient := false |};
        MemoryAttributes_outer :=
          {| MemAttrHints_attrs :=
               if negb secondstage && implb (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2) (eq_vec ORGN_arg $0) ||
                     secondstage && (HCR_EL2 (ss_regstate s) !! 32 || eq_vec ORGN_arg $0)
               then $0 else if eq_vec ORGN_arg $1 || negb (eq_vec ORGN_arg $2) then $3 else $2;
             MemAttrHints_hints :=
               if negb secondstage && implb (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2) (eq_vec ORGN_arg $0) ||
                       secondstage && (HCR_EL2 (ss_regstate s) !! 32 || eq_vec ORGN_arg $0)
                    then MemHint_No else if eq_vec ORGN_arg $1 then MemHint_RWA else MemHint_RA;
             MemAttrHints_transient := false |};
        MemoryAttributes_shareable :=
               if negb secondstage then implb (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2) (eq_vec IRGN_arg $0) && eq_vec ORGN_arg $0 || eq_vec SH_arg $1
               else (HCR_EL2 (ss_regstate s) !! 32 || eq_vec IRGN_arg $0) && (HCR_EL2 (ss_regstate s) !! 32 || eq_vec ORGN_arg $0) || SH_arg !! 1;
        MemoryAttributes_outershareable :=
               if negb secondstage then implb (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2) (eq_vec IRGN_arg $0) && eq_vec ORGN_arg $0 || eq_vec SH_arg $2
               else (HCR_EL2 (ss_regstate s) !! 32 || eq_vec IRGN_arg $0) && (HCR_EL2 (ss_regstate s) !! 32 || eq_vec ORGN_arg $0) || eq_vec SH_arg $2;
        MemoryAttributes_tagged := false
|}.

Definition read_S1CacheDisabled (acctype : AccType) (s : sequential_state regstate) : bool :=
  let sctlr := read_SCTLR (read_S1TranslationRegime (read_EL s) s) s in
  if generic_eq acctype AccType_IFETCH then negb(sctlr !! 12) else negb (sctlr !! 2).

Definition read_LongConvertAttrsHints (attrfield : mword 4) (acctype : AccType) (s : sequential_state regstate) : MemAttrHints :=
  {| MemAttrHints_attrs :=
        if read_S1CacheDisabled acctype s || eq_vec attrfield $4 then MemAttr_NC else
        if weqb (slice attrfield 2 2) ($0 : word 2) then MemAttr_WT else
        if weqb (slice attrfield 2 2) ($1 : word 2) then slice attrfield 0 _ else
        slice attrfield 2 2;
     MemAttrHints_hints :=
        if read_S1CacheDisabled acctype s || eq_vec attrfield $4 then MemHint_No else
        if weqb (slice attrfield 2 2) ($0 : word 2) then slice attrfield 0 _ else
        if weqb (slice attrfield 2 2) ($1 : word 2) then MemAttr_WB else (* Is this intentional? *)
        slice attrfield 0 _;
     MemAttrHints_transient :=
        if read_S1CacheDisabled acctype s then false else
        neq_vec attrfield $4 && negb(attrfield !! 3) |}.

Definition read_S1AttrDecode (SH_arg : mword 2) (attr : mword 2) (acctype : AccType) (s : sequential_state regstate) : MemoryAttributes :=
  let mair := read_MAIR (read_S1TranslationRegime (read_EL s) s) s in
  let attrslo := slice mair (8 * wordToZ attr) 4 in
  let attrshi := slice mair (4 + (8 * wordToZ attr)) 4 in
  let ihints := read_LongConvertAttrsHints attrslo acctype s in
  let ohints := read_LongConvertAttrsHints attrshi acctype s in
  {| MemoryAttributes_typ := if eq_vec attrslo $0 || eq_vec attrshi $0 then MemType_Device else MemType_Normal;
   MemoryAttributes_device :=
     if eq_vec attrslo $0 || eq_vec attrshi $0 then
       (if eq_vec attrslo $0 then DeviceType_nGnRnE
        else if eq_vec attrslo $4 then DeviceType_nGnRE
        else if eq_vec attrslo $8 then DeviceType_nGRE
        else if eq_vec attrslo $12 then DeviceType_GRE
        else DeviceType_nGnRnE)
     else DeviceType_GRE;
   MemoryAttributes_inner :=
     if neq_vec attrslo $0 && neq_vec attrshi $0 then ihints
     else {| MemAttrHints_attrs := $0; MemAttrHints_hints := $0; MemAttrHints_transient := false |};
   MemoryAttributes_outer :=
     if neq_vec attrslo $0 && neq_vec attrshi $0 then ohints
     else {| MemAttrHints_attrs := $0; MemAttrHints_hints := $0; MemAttrHints_transient := false |};
   MemoryAttributes_shareable :=
     eq_vec attrslo $0 || eq_vec attrshi $0 ||
     eq_vec (MemAttrHints_attrs ihints) $0 && eq_vec (MemAttrHints_attrs ohints) $0 ||
     SH_arg !! 1;
   MemoryAttributes_outershareable :=
     eq_vec attrslo $0 || eq_vec attrshi $0 ||
     eq_vec (MemAttrHints_attrs ihints) $0 && eq_vec (MemAttrHints_attrs ohints) $0 ||
     eq_vec SH_arg $2;
   MemoryAttributes_tagged :=
     if eq_vec attrslo $0 || eq_vec attrshi $0 then false else true
 |}.

Definition read_TTBR0 s :=
  let el := read_S1TranslationRegime (read_EL s) s in
  if eq_vec el $3 then TTBR0_EL3 (ss_regstate s) else
  if eq_vec el $2 then TTBR0_EL2 (ss_regstate s) else TTBR0_EL1 (ss_regstate s).

Definition read_TTBR1 s :=
  let el := read_S1TranslationRegime (read_EL s) s in
  if eq_vec el $3 then TTBR0_EL3 (ss_regstate s) else
  if eq_vec el $2 then TTBR1_EL2 (ss_regstate s) else TTBR1_EL1 (ss_regstate s).

Definition read_TTBR (high : bool) (s : sequential_state regstate) : mword 64 :=
  if high then read_TTBR1 s else read_TTBR0 s.

Definition TTBR_valid_for_vaddr (addr : mword 64) (addrtop : Z) (s : sequential_state regstate) : bool :=
  let high := addr !! Z.to_nat addrtop in
  let p := read_params high s in
  if sumbool_of_bool (outputsize p <? 48) then IsZero (slice (read_TTBR high s) (outputsize p) (48 - outputsize p)) else true.

Definition addrselecttop (level : Z) (p : Parameters) : Z :=
  Z.min (inputsize p) ((4 - level) * (grainsize p - 3) + grainsize p) - 1.

Definition addrselectbottom (level : Z) (p : Parameters) : Z :=
  (3 - level) * (grainsize p - 3) + grainsize p.

Lemma addrselectbottom_bounds level high s p :
  p = read_params high s ->
  0 <= level < 4 ->
  (grainsize p = 16 -> 1 <= level) ->
  0 <= addrselectbottom level p <= 48.
intros -> LEVEL LEVEL1.
unfold addrselectbottom.
destruct (grainsize_split high s) as [->| [-> | EQ]]; try omega.
rewrite EQ in *.
omega.
Qed.

Definition stride (level : Z) (p : Parameters) : Z :=
  addrselecttop level p - addrselectbottom level p + 1.

Fixpoint read_table_aux (level : Z) (high : bool) (baseaddr : mword 52) (s : sequential_state regstate) (acc : Acc (Zwf.Zwf_up 4) level) : list TableEntry. refine (
  let p := read_params high s in
  let stride := stride level p in
  let descaddrs := List.map (fun idx => wor baseaddr (shiftl (mword_of_int idx : mword 52) 3)) (index_list 0 (Z.shiftl 1 (stride - 1)) 1) in
  let read_desc :=
      fun addr : mword 52 =>
        match read_mem_word addr 8 s with
        | None => Invalid
        | Some desc =>
          let desc := if read_bigendian s then reverse_endianness desc else desc in
          if ValidDescriptor level (grainsize p) (outputsize p) desc && Z.geb level 0 && Z.ltb level 4 then
            if sumbool_of_bool (IsBlockDescriptor desc || Z.geb level 3)
            then Descriptor desc
            else
              let lbaseaddr := (shiftl (slice desc (grainsize p) _) (grainsize p)) : mword 48 in
              let ubaseaddr := (if Z.eqb (outputsize p) 52 then slice desc 12 _ else $0) : mword 4 in
              let baseaddr := concat_vec ubaseaddr lbaseaddr : mword 52 in
              let ns := desc !! 63 in let ap1 := desc !! 62 in let ap0 := desc !! 61 in let xn := desc !! 60 in let pxn := desc !! 59 in
                                                                                Table baseaddr ns ap1 ap0 xn pxn (read_table_aux (level + 1) high baseaddr s _)
          else Invalid
        end in
  map read_desc descaddrs).
refine (Acc_inv acc _).
unfold Zwf.Zwf_up.
unbool_comparisons.
omega.
Defined.

Definition read_table (level : Z) (high : bool) (baseaddr : mword 52) (s : sequential_state regstate) : list TableEntry :=
  read_table_aux level high baseaddr s (Zwf.Zwf_up_well_founded _ _).

Fixpoint walk_table_aux (inputaddr : mword 64) (level : Z) (p : Parameters) (baseaddr : mword 52) (table : list TableEntry) (acc : Acc (Zwf.Zwf_up 4) level) : option (mword 64 * mword 52 * mword 52 * Z * bool * bool * bool * bool * bool). refine (
  if sumbool_of_bool (level >=? 4) then None else
  let index := projT1 (uint (slice inputaddr (addrselectbottom level p) (Z.max 0 (stride level p)))) in
  let descaddr := wor baseaddr (shiftl (mword_of_int index : mword 52) 3) in
  match List.nth (Z.to_nat index) table Invalid with
    Invalid => None
  | Descriptor desc => Some (desc, descaddr, baseaddr, level, false, false, false, false, false)
  | Table baseaddr ns ap1 ap0 xn pxn table =>
    match walk_table_aux inputaddr (level + 1) p baseaddr table _ with
      None => None
    | Some (desc, descaddr, baseaddr, level, ns', ap1', ap0', xn', pxn') =>
      Some (desc, descaddr, baseaddr, level, ns || ns', ap1 || ap1', ap0 || ap0', xn || xn', pxn || pxn')
    end
  end).
refine (Acc_inv acc _).
unfold Zwf.Zwf_up.
clearbody index.
abstract (unbool_comparisons; omega).
Defined.

Definition walk_table (inputaddr : mword 64) (level : Z) (p : Parameters) (baseaddr : mword 52) (table : list TableEntry) : option (mword 64 * mword 52 * mword 52 * Z * bool * bool * bool * bool * bool) := walk_table_aux inputaddr level p baseaddr table (Zwf.Zwf_up_well_founded _ _).

Lemma walk_table_level {inputaddr level p baseaddr table x1 x2 x3 level' x4 x5 x6 x7 x8} :
  walk_table inputaddr level p baseaddr table = Some (x1, x2, x3, level', x4, x5, x6, x7, x8) ->
  level <= level' < 4.
unfold walk_table.
generalize (Zwf.Zwf_up_well_founded 4 level).
destruct (Z_le_dec 0 (4 - level)) as [LE|GT].
* assert (level = 4 - (4 - level)) by omega. revert H.
  set (fmlevel := 4-level) in *. clearbody fmlevel.
  intros EQ acc.
  revert level baseaddr table EQ acc x4 x5 x6 x7 x8.
  apply Wf_Z.natlike_ind with (x := fmlevel).
  + intros level baseaddr table -> [acc].
    discriminate.
  + intros foursublevel pos IH level baseaddr table LEVEL [acc] ?*.
    cbn -[Z.add].
    destruct (sumbool_of_bool (level >=? 4)); [ discriminate | ].
    match goal with |- context [nth ?i ?l ?def] => destruct (nth i l def) end;
    [ discriminate | | auto ].
    - match goal with |- context [wor ?l ?r] => generalize (wor l r) end.
      intros ? [=]. subst level'.
      unbool_comparisons.
      omega.
    - match goal with
        |- context [walk_table_aux ?i ?lev ?p ?w ?l ?acc] =>
        specialize (IH lev w l ltac:(omega) acc);
          destruct (walk_table_aux i lev p w l acc) as [[[[[[[[[desc descaddr] baseaddr0] level0] ns'] ap1'] ap0'] xn'] pxn'] | ]; [ | discriminate ]
      end.
      intros [=]; subst x1 x2 x3 level' x4 x5 x6 x7 x8.
      specialize (IH _ _ _ _ _ eq_refl).
      omega.
  + assumption.
* intros [acc].
  cbn.
  destruct (sumbool_of_bool (level >=? 4)) as [GE | LT]; [ discriminate | ].
  exfalso.
  unbool_comparisons.
  omega.
Qed.

(*declare walk_table.simps[simp del]*)

Definition default_FaultRecord :=
  {| FaultRecord_typ := Fault_None;
     FaultRecord_acctype := AccType_NORMAL;
     FaultRecord_ipaddress := {| FullAddress_address := $0; FullAddress_NS := $1 (* TODO? *) |};
     FaultRecord_s2fs1walk := false;
     FaultRecord_write := false;
     FaultRecord_level := 0;
     FaultRecord_extflag := $0;
     FaultRecord_secondstage := false;
     FaultRecord_domain := $0;
     FaultRecord_errortype := $0;
     FaultRecord_debugmoe := $0
  |}.

Definition valid_perms (perms : Permissions) (acctype : AccType) (iswrite : bool) (s : sequential_state regstate) : bool :=
  let wxn := SCTLR_EL1 (ss_regstate s) !! 19 in
  let r := Permissions_ap perms !! 1 in
  let w := weqb (slice (Permissions_ap perms) 1 2) ($1 : mword 2) in
  let xn := weqb (Permissions_xn perms) $1 || (w && wxn) in
  if generic_eq acctype AccType_IFETCH then negb xn
  else if generic_eq acctype AccType_ATOMICRW || generic_eq acctype AccType_ORDEREDRW then r && w
  else if iswrite then w
  else r.

Lemma read_AddrTop_EL0_bounds' addr acc s top :
  top = read_AddrTop_EL0 addr acc s ->
  55 <= top < 64.
intros ->.
apply read_AddrTop_EL0_bounds.
Qed.

Instance bits_Bitvector {a : Z} `{ArithFact (a >=? 0)} : Bitvector (bits a) := mword_Bitvector.
Instance bits1_Bitvector : Bitvector (bits 1) := mword_Bitvector.

Definition lookup_TLBRecord (vaddress : mword 64) (acctype : AccType) (s : sequential_state regstate) : option TLBRecord. refine (
  let top := read_AddrTop_EL0 vaddress (generic_eq acctype AccType_IFETCH) s in
  let _ := read_AddrTop_EL0_bounds' _ _ _ top eq_refl in
  let high := vaddress !! Z.to_nat top in
  let p := read_params high s in
  let blb_bound := baselowerbound_bounds' _ _ p eq_refl in (* not sure why this has to be explicit - wasn't appearing in the context otherwise *)
  let baseaddress := @baseaddress (read_TTBR high s) (baselowerbound p) _ (outputsize p) in
  let hierattrs := negb (if high then TCR_EL1 (ss_regstate s) !! 42 else TCR_EL1 (ss_regstate s) !! 41) in
  let secure := negb (SCR_EL3 (ss_regstate s) !! 0) in
  match walk_table vaddress (startlevel p) p baseaddress
          (read_table (startlevel p) high baseaddress s) as x return _ = x -> _ with
    None => fun _ => None
  | Some (desc, descaddr, baseaddr, level, ns, ap1, ap0, xn, pxn) => fun LEVEL =>
      let _ := walk_table_level LEVEL in
      let addrselectbottom := addrselectbottom level p in
      let asb_bounds := addrselectbottom_bounds level _ _ p eq_refl _ _ in
      let walkattrs := read_WalkAttrDecode (SH p) (ORGN p) (IRGN p) false s in
      let memattrs := read_S1AttrDecode (slice desc 8 _) (slice desc 2 _) acctype s in
      let perms := {|
             Permissions_ap := of_bools [negb (desc !! 51) && desc !! 7 || hierattrs && ap1; desc !! 6 && negb(hierattrs && ap0); true];
             Permissions_xn := of_bools [desc !! 54 || hierattrs && xn];
             Permissions_xxn := $0;
             Permissions_pxn := of_bools [desc !! 53 || hierattrs && pxn] |} in
      if Z.geb level (firstblocklevel p) &&
         valid_vaddr vaddress top s &&
         TTBR_valid_for_vaddr vaddress top s &&
         (if sumbool_of_bool (outputsize p <? 48) then
            eq_vec (slice desc (outputsize p) (48 - outputsize p)) (mword_of_int 0) else true) &&
         (implb ((outputsize p <? 52) && largegrain p) (weqb (slice desc 12 4) ($0 : mword 4))) &&
         (implb (contiguousbitcheck p level) (negb (desc !! 52)))
      then
        let outputaddr : mword 52 :=
          if outputsize p =? 52
          then autocast (concat_vec (slice desc 12 4)
                 (concat_vec (slice desc addrselectbottom (48 - addrselectbottom))
                             (slice vaddress 0 addrselectbottom)))
          else zero_extend (concat_vec (slice desc addrselectbottom (48 - addrselectbottom)) (slice vaddress 0 addrselectbottom)) 52 in
        Some {|
            TLBRecord_perms := perms;
            TLBRecord_nG := of_bools [desc !! 11 || (secure && ns)];
            TLBRecord_domain := $0;
            TLBRecord_GP := of_bools [desc !! 50];
            TLBRecord_contiguous := desc !! 52;
            TLBRecord_level := level;
            TLBRecord_blocksize := 2 ^ addrselectbottom;
            TLBRecord_descupdate := {|
              DescriptorUpdate_AF := negb (desc !! 10);
              DescriptorUpdate_AP := desc !! 51 && desc !! 7;
              DescriptorUpdate_descaddr := {|
                AddressDescriptor_fault := default_FaultRecord;
                AddressDescriptor_memattrs := walkattrs;
                AddressDescriptor_paddress := {|
                  FullAddress_address := descaddr;
                  FullAddress_NS := of_bools [ns || negb secure]
                |};
                AddressDescriptor_vaddress := vaddress
              |}
            |};
            TLBRecord_CnP := of_bools [read_TTBR high s !! 0];
            TLBRecord_addrdesc := {|
              AddressDescriptor_fault := default_FaultRecord;
              AddressDescriptor_memattrs := memattrs;
              AddressDescriptor_paddress := {|
                FullAddress_address := outputaddr;
                FullAddress_NS := of_bools [desc !! 5 || ns || negb secure]
              |};
              AddressDescriptor_vaddress := vaddress
            |}
          |}
      else None
  end eq_refl).
specialize (startlevel_bounds high s).
change (read_params high s) with p.
clearbody a0. omega.

intro LARGE.
specialize (startlevel_largegrain_bounds high s p eq_refl LARGE).
clearbody a0.
omega.
Defined.

Require HexString.

Definition translate_address (vaddress : mword 64) (acctype : AccType) (iswrite : bool) (wasaligned : bool) (s : sequential_state regstate) : option TLBRecord :=
  match lookup_TLBRecord vaddress acctype s with
    None => None
  | Some r =>
      let top := read_AddrTop_EL0 vaddress (generic_eq acctype AccType_IFETCH) s in
      if valid_perms (TLBRecord_perms r) acctype iswrite s &&
         neq_vec (AddressDescriptor_physicaladdress (DescriptorUpdate_descaddr (TLBRecord_descupdate r))) (mword_of_int (HexString.to_Z "0x13000000")) && (* debug console hard-coded in this ASL model *)
         (implb (generic_eq (MemoryAttributes_typ (AddressDescriptor_memattrs (TLBRecord_addrdesc r))) MemType_Device)
          (wasaligned && (generic_eq acctype AccType_IFETCH || generic_eq acctype AccType_DCZVA)))
      then Some r else None
  end.

Definition read_descriptor (addr : mword 52) (s: sequential_state regstate) : option (mword 64) :=
  match read_mem_word addr 8 s with
    None => None
  | Some desc => Some (if read_bigendian s then reverse_endianness desc else desc)
  end.

Definition write_descriptor (addr : mword 52) (desc : mword 64) (s : sequential_state regstate) : sequential_state regstate :=
  let desc := if read_bigendian s then reverse_endianness desc else desc in
  write_mem_bytes (Z.to_nat (projT1 (uint addr))) 8 (mem_bytes_of_word desc) s.

Definition update_descriptor (descupd : DescriptorUpdate) (acctype : AccType) (iswrite : bool) (s : sequential_state regstate) : sequential_state regstate :=
  match read_descriptor (AddressDescriptor_physicaladdress (DescriptorUpdate_descaddr descupd)) s with
    None => s
  | Some desc =>
      let ap := DescriptorUpdate_AP descupd &&
                (iswrite || generic_eq acctype AccType_ATOMICRW || generic_eq acctype AccType_ORDEREDRW) &&
                generic_neq acctype AccType_AT && generic_neq acctype AccType_DC in
      let af := DescriptorUpdate_AF descupd in
      let desc := if af then setBit desc 10 true else desc in
      let desc := if ap then setBit desc 7 false else desc in
      let addr := AddressDescriptor_physicaladdress (DescriptorUpdate_descaddr descupd) in
      if af || ap
      then write_descriptor addr desc s
      else s
  end.


Require Import List.
Import ListNotations.
Require Import StructTact.StructTactics.
Require Import StructTact.Update.

Require Import Chord.Chord.

Require Import Chord.HandlerLemmas.
Require Import Chord.SystemLemmas.
Require Import Chord.SystemReachable.
Require Import Chord.SystemPointers.

Set Bullet Behavior "Strict Subproofs".

Theorem valid_ptrs_global_inductive :
  forall gst,
    reachable_st gst ->
    valid_ptrs_global gst.
Proof using.
Admitted.

Lemma cur_request_valid :
  forall gst,
    reachable_st gst ->
    forall h st dst q m,
      sigma gst h = Some st ->
      cur_request st = Some (dst, q, m) ->
      valid_ptr gst dst.
Proof.
  intros.
  find_apply_lem_hyp valid_ptrs_global_inductive.
  unfold valid_ptrs_global in *.
  assert (lift_pred_opt (valid_ptrs_state gst) (Some st)).
  {
    repeat find_reverse_rewrite.
    firstorder.
  }
  invcs_prop valid_ptrs_state.
  unfold valid_ptrs_state, valid_ptrs_cur_request, valid_ptrs_some_cur_request in *.
  break_and.
  repeat find_rewrite.
  inv_prop valid_ptr; tauto.
Qed.


(** Bag with contributions specification *)
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import gmultiset frac_auth.
From iris_examples.hocap Require Import abstract_bag.
Set Default Proof Using "Type".

Section proof.
  Context `{heapG Σ}.
  Variable b : bag Σ.
  Variable N : namespace.
  Definition NB := N.@"bag".
  Definition NI := N.@"inv".

  Context `{inG Σ (frac_authR (gmultisetUR val))}.

  Definition bagM_inv (γb : name Σ b) (γ : gname) : iProp Σ :=
    inv NI (∃ X, bag_contents b γb X ∗ own γ (●F X))%I.
  Definition bagM (γb : name Σ b) (γ : gname) (x : val) : iProp Σ :=
    (is_bag b NB γb x ∗ bagM_inv γb γ)%I.
  Definition bagPart (γ : gname) (q : Qp) (X : gmultiset val) : iProp Σ :=
    (own γ (◯F{q} X))%I.

  Lemma bagPart_compose (γ: gname) (q1 q2: Qp) (X Y : gmultiset val) :
    bagPart γ q1 X -∗ bagPart γ q2 Y -∗ bagPart γ (q1+q2) (X ⊎ Y).
  Proof.
    iIntros "Hp1 Hp2".
    rewrite /bagPart -gmultiset_op_disj_union -frac_op'.
    rewrite frac_auth_frag_op own_op. iFrame.
  Qed.
  Lemma bagPart_decompose (γ: gname) (q: Qp) (X Y : gmultiset val) :
    bagPart γ q (X ⊎ Y) -∗ bagPart γ (q/2) X ∗ bagPart γ (q/2) Y.
  Proof.
    iIntros "Hp".
    assert (q = (q/2)+(q/2))%Qp as Hq by (by rewrite Qp_div_2).
    rewrite /bagPart {1}Hq.
    rewrite -gmultiset_op_disj_union -frac_op'.
    rewrite frac_auth_frag_op own_op. iFrame.
  Qed.

  Global Instance bagM_persistent γb γ x : Persistent (bagM γb γ x).
  Proof. apply _. Qed.

  Lemma newBag_spec :
    {{{ True }}}
      newBag b #()
    {{{ x, RET x; ∃ γb γ, bagM γb γ x ∗ bagPart γ 1 ∅ }}}.
  Proof.
    iIntros (Φ) "_ HΦ". iApply wp_fupd.
    iApply (newBag_spec b NB); eauto.
    iNext. iIntros (v γb) "[#Hbag Hcntn]".
    iMod (own_alloc (●F ∅ ⋅ ◯F ∅)) as (γ) "[Hown Hpart]"; first by apply auth_both_valid.
    iMod (inv_alloc NI _ (∃ X, bag_contents b γb X ∗ own γ (●F X))%I with "[Hcntn Hown]") as "#Hinv".
    { iNext. iExists _. iFrame. }
    iApply "HΦ". iModIntro. iExists _,_. iFrame "Hinv Hbag Hpart".
  Qed.

  Lemma pushBag_spec γb γ x v q Y :
    {{{ bagM γb γ x ∗ bagPart γ q Y }}}
       pushBag b x (of_val v)
    {{{ RET #(); bagPart γ q ({[v]} ⊎ Y) }}}.
  Proof.
    iIntros (Φ) "[#[Hbag Hinv] HP] HΦ". rewrite /bagM_inv.
    iApply (pushBag_spec b NB (bagPart γ q Y)%I (bagPart γ q ({[v]} ⊎ Y))%I with "[] [Hbag HP]"); eauto.
    iAlways. iIntros (X) "[Hb1 HP]".
    iInv NI as (X') "[>Hb2 >Hown]" "Hcl".
    iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
    iMod (bag_contents_update b ({[v]} ⊎ X) with "[$Hb1 $Hb2]") as "[Hb1 Hb2]".
    rewrite /bagPart.
    iMod (own_update_2 with "Hown HP") as "[Hown HP]".
    { apply (frac_auth_update _ _ _ ({[v]} ⊎ X) ({[v]} ⊎ Y)).
      do 2 rewrite (comm _ {[v]}).
      apply gmultiset_local_update_alloc. }
    iFrame. iApply "Hcl".
    iNext. iExists _; iFrame.
  Qed.

  Local Ltac multiset_solver :=
    intro;
    repeat (rewrite multiplicity_difference || rewrite multiplicity_disj_union);
    (lia || naive_solver).

  Lemma popBag_spec γb γ x X :
    {{{ bagM γb γ x ∗ bagPart γ 1 X }}}
       popBag b x
    {{{ v, RET v;
        (⌜v = NONEV⌝ ∧ ⌜X = ∅⌝ ∗ bagPart γ 1 X)
       ∨ (∃ y, ⌜v = SOMEV y⌝ ∧ ⌜y ∈ X⌝ ∗ bagPart γ 1 (X ∖ {[y]})) }}}.
  Proof.
    iIntros (Φ) "[[#Hbag #Hinv] Hpart] HΦ".
    iApply (popBag_spec b NB (bagPart γ 1 X)%I
             (fun v => (⌜v = NONEV⌝ ∧ ⌜X = ∅⌝ ∗ bagPart γ 1 X)
                     ∨ (∃ y, ⌜v = SOMEV y⌝ ∧ ⌜y ∈ X⌝ ∗ bagPart γ 1 (X ∖ {[y]})))%I with "[] [] [Hpart]"); eauto.
    { iAlways. iIntros (Y y) "[Hb1 Hpart]".
      iInv NI as (X') "[>Hb2 >HPs]" "Hcl".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iMod (bag_contents_update b Y with "[$Hb1 $Hb2]") as "[Hb1 Hb2]".
      rewrite /bagPart.
      iAssert (⌜X = ({[y]} ⊎ Y)⌝)%I with "[Hpart HPs]" as %->.
      { iDestruct (own_valid_2 with "HPs Hpart") as %Hfoo.
        apply frac_auth_agree in Hfoo. by unfold_leibniz. }
      iMod (own_update_2 with "HPs Hpart") as "Hown".
      { apply (frac_auth_update _ _ _ (({[y]} ⊎ Y) ∖ {[y]}) (({[y]} ⊎ Y) ∖ {[y]})).
        apply gmultiset_local_update_dealloc; multiset_solver. }
      iDestruct "Hown" as "[HPs Hpart]".
      iMod ("Hcl" with "[-Hpart Hb1]") as "_".
      { iNext. iExists _; iFrame.
        assert (Y = (({[y]} ⊎ Y) ∖ {[y]})) as <-
          by (unfold_leibniz; multiset_solver).
        iFrame. }
      iModIntro. iNext. iFrame. iRight. iExists y; repeat iSplit; eauto.
      iPureIntro. apply gmultiset_elem_of_disj_union. left. by apply elem_of_singleton. }
    { iAlways. iIntros "[Hb1 Hpart]".
      iInv NI as (X') "[>Hb2 >HPs]" "Hcl".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iAssert (⌜X = ∅⌝)%I with "[Hpart HPs]" as %->.
      { rewrite /bagPart.
        iDestruct (own_valid_2 with "HPs Hpart") as %Hfoo.
        apply frac_auth_agree in Hfoo. by unfold_leibniz. }
      iMod ("Hcl" with "[Hb2 HPs]") as "_".
      { iNext. iExists _; iFrame. }
      iModIntro. iNext. iFrame. iLeft; eauto. }
  Qed.

End proof.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.ftc.FunctSeries.
Require Export CoRN.ftc.MoreFunctions.

(** printing FSeries_Sum %\ensuremath{\sum_{\infty}}% #∑'<sub>∞</sub># *)

Section Definitions.

(**
* More on Sequences and Series

We will now extend our convergence definitions and results for
sequences and series of functions defined in compact intervals to
arbitrary intervals.

%\begin{convention}% Throughout this file, [J] will be an interval,
[f, g] will be sequences of continuous (in [J]) functions and [F,G]
will be continuous (in [J]) functions.
%\end{convention}%

** Sequences

First we will consider the case of sequences.

*** Definitions

Some of the definitions do not make sense in this more general setting
(for instance, because the norm of a function is no longer defined),
but the ones which do we simply adapt in the usual way.
*)

Variable J : interval.
Variable f : nat -> PartIR.
Variable F : PartIR.

Hypothesis contf : forall n : nat, Continuous J (f n).
Hypothesis contF : Continuous J F.

Definition Cauchy_fun_seq_IR :=  forall a b Hab (Hinc : included (compact a b Hab) J),
  Cauchy_fun_seq _ _ _ f (fun n => included_imp_Continuous _ _ (contf n) _ _ _ Hinc).

Definition conv_fun_seq_IR := forall a b Hab (Hinc : included (Compact Hab) J),
  conv_fun_seq a b Hab f (fun n => included_imp_Continuous _ _ (contf n) _ _ _ Hinc).

Definition conv_fun_seq'_IR := forall a b Hab (Hinc : included (Compact Hab) J),
  conv_fun_seq' a b Hab f F
    (fun n => included_imp_Continuous _ _ (contf n) _ _ _ Hinc)
    (included_imp_Continuous _ _ contF _ _ _ Hinc).

Definition Cauchy_fun_seq2_IR := forall a b Hab (Hinc : included (compact a b Hab) J),
  Cauchy_fun_seq2 _ _ _ f (fun n => included_imp_Continuous _ _ (contf n) _ _ _ Hinc).

(**
The equivalences between these definitions still hold.
*)

Lemma conv_Cauchy_fun_seq'_IR : conv_fun_seq'_IR -> Cauchy_fun_seq_IR.
Proof.
 intro H.
 red in |- *; red in H.
 intros.
 apply conv_Cauchy_fun_seq' with F (included_imp_Continuous _ _ contF _ _ _ Hinc); auto.
Qed.

Lemma Cauchy_fun_seq_seq2_IR : Cauchy_fun_seq_IR -> Cauchy_fun_seq2_IR.
Proof.
 intro H.
 red in |- *; red in H.
 intros.
 apply Cauchy_fun_seq_seq2; auto.
Qed.

Lemma Cauchy_fun_seq2_seq_IR : Cauchy_fun_seq2_IR -> Cauchy_fun_seq_IR.
Proof.
 intro H.
 red in |- *; red in H.
 intros.
 apply Cauchy_fun_seq2_seq; auto.
Qed.

Lemma Cauchy_fun_real_IR : Cauchy_fun_seq_IR -> forall x Hx,
 Cauchy_prop (fun n => Part _ _ (Continuous_imp_inc _ _ (contf n) x Hx)).
Proof.
 intros H x Hx.
 red in H.
 cut (included (compact_single x) J). intro H0.
  set (contf' := fun i : nat => included_imp_Continuous J (f i) (contf i) _ _ (leEq_reflexive _ x) H0)
    in *.
  apply Cauchy_prop_wd with (fun n : nat => Part (f n) x ((fun i : nat =>
    contin_imp_inc _ _ (leEq_reflexive _ x) (f i) (contf' i)) n x (compact_single_prop x))).
   apply Cauchy_fun_real.
   unfold contf' in |- *; simpl in |- *; apply H.
  intro; simpl in |- *; algebra.
 apply compact_single_iprop; auto.
Qed.

End Definitions.

Section More_Definitions.

(**
Limit is defined and works in the same way as before.
*)

Variable J : interval.
Variable f : nat -> PartIR.

Hypothesis contf : forall n : nat, Continuous J (f n).
(* begin show *)
Hypothesis conv : Cauchy_fun_seq_IR J f contf.
(* end show *)

Definition Cauchy_fun_seq_Lim_IR : PartIR.
Proof.
 apply Build_PartFunct with (pfpfun := fun (x : IR) (Hx : J x) =>
   Lim (Build_CauchySeq _ _ (Cauchy_fun_real_IR _ _ _ conv x Hx))).
  apply iprop_wd.
 intros x y Hx Hy H.
 elim (Lim_strext _ _ H).
 intros n Hn.
 simpl in Hn.
 exact (pfstrx _ _ _ _ _ _ Hn).
Defined.

Lemma Cauchy_fun_seq_Lim_char : forall a b Hab (Hinc : included (Compact Hab) J),
 Feq (Compact Hab) Cauchy_fun_seq_Lim_IR
  (Cauchy_fun_seq_Lim _ _ _ _ _ (conv a b Hab Hinc)).
Proof.
 intros.
 FEQ.
 simpl in |- *.
 apply Lim_wd'; intros; simpl in |- *; algebra.
Qed.

End More_Definitions.

Section Irrelevance_of_Proofs.

(**
*** Basic Properties

Proofs are irrelevant as before---they just have to be present.
*)

Variable J : interval.
Variable f : nat -> PartIR.
(* begin show *)
Hypotheses contf contf0 : forall n : nat, Continuous J (f n).
(* end show *)

Variable F : PartIR.
(* begin show *)
Hypotheses contF contF0 : Continuous J F.
(* end show *)

Lemma conv_fun_seq'_wd_IR : conv_fun_seq'_IR _ _ _ contf contF ->
 conv_fun_seq'_IR _ _ _ contf0 contF0.
 intro H.
 red in |- *; intros.
 eapply conv_fun_seq'_wd.
 apply (H a b Hab Hinc).
Qed.

Lemma Cauchy_fun_seq2_wd_IR : Cauchy_fun_seq2_IR _ _ contf ->
 Cauchy_fun_seq2_IR _ _ contf0.
Proof.
 intro H.
 red in |- *; intros.
 eapply Cauchy_fun_seq2_wd.
 apply (H a b Hab Hinc).
Qed.

Lemma conv_fun_seq_wd_IR : conv_fun_seq_IR _ _ contf ->
 conv_fun_seq_IR _ _ contf0.
Proof.
 intro H.
 red in |- *; intros.
 eapply conv_fun_seq_wd.
 apply (H a b Hab Hinc).
Qed.

End Irrelevance_of_Proofs.

Opaque Cauchy_fun_seq_Lim_IR.

Section More_Properties.

Variable J : interval.
Variables f g : nat -> PartIR.

(* begin show *)
Hypotheses contf contf0 : forall n : nat, Continuous J (f n).
Hypotheses contg contg0 : forall n : nat, Continuous J (g n).
(* end show *)

Lemma Cauchy_conv_fun_seq'_IR : forall H contf',
 conv_fun_seq'_IR _ _ (Cauchy_fun_seq_Lim_IR _ _ contf H) contf contf'.
Proof.
 intros.
 red in |- *; intros.
 eapply conv_fun_seq'_wdr.
  apply Feq_symmetric.
  apply (Cauchy_fun_seq_Lim_char J f contf H a b Hab Hinc).
 apply Cauchy_conv_fun_seq' with (H := H a b Hab Hinc)
   (contf' := Cauchy_cont_Lim _ _ _ _ _ (H a b Hab Hinc)).
Qed.

Variables F G : PartIR.
(* begin show *)
Hypotheses contF contF0 : Continuous J F.
Hypotheses contG contG0 : Continuous J G.
(* end show *)

Lemma conv_fun_seq'_wdl_IR : (forall n, Feq J (f n) (g n)) ->
 conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contg contF0.
Proof.
 intros H H0 a b Hab Hinc.
 eapply conv_fun_seq'_wdl with (f := f).
  2: apply (H0 a b Hab Hinc).
 intro; elim (H n); intros.
 inversion_clear b0.
 apply eq_imp_Feq; Included.
Qed.

Lemma conv_fun_seq'_wdr_IR : Feq J F G ->
 conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contf0 contG.
Proof.
 intros H H0 a b Hab Hinc.
 eapply conv_fun_seq'_wdr with (F := F).
  2: apply (H0 a b Hab Hinc).
 apply included_Feq with J; auto.
Qed.

Lemma conv_fun_seq'_wdl'_IR : (forall n, Feq J (f n) (g n)) ->
 conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contg contF.
Proof.
 intros H H0 a b Hab Hinc.
 eapply conv_fun_seq'_wdl' with (f := f); auto.
 intro; elim (H n); intros.
 inversion_clear b0.
 apply eq_imp_Feq; Included.
Qed.

Lemma conv_fun_seq'_wdr'_IR : Feq J F G ->
 conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contf contG.
Proof.
 intros H H0 a b Hab Hinc.
 eapply conv_fun_seq'_wdr' with (F := F).
  2: apply (H0 a b Hab Hinc).
 apply included_Feq with J; auto.
Qed.

Lemma Cauchy_cont_Lim_IR : forall H, Continuous J (Cauchy_fun_seq_Lim_IR _ _ contf H).
Proof.
 intros.
 split; Included.
 intros a b Hab H0; eapply Continuous_I_wd.
  apply Feq_symmetric.
  apply (Cauchy_fun_seq_Lim_char J f contf H a b Hab H0).
 Contin.
Qed.

Lemma Cauchy_conv_fun_seq_IR : Cauchy_fun_seq_IR _ _ contf ->
 conv_fun_seq_IR _ _ contf.
Proof.
 intros H a b Hab Hinc.
 eapply Cauchy_conv_fun_seq.
 apply (H a b Hab Hinc).
Qed.

Lemma conv_Cauchy_fun_seq_IR : conv_fun_seq_IR _ _ contf ->
 Cauchy_fun_seq_IR _ _ contf.
Proof.
 intros H a b Hab Hinc.
 eapply conv_Cauchy_fun_seq.
 apply (H a b Hab Hinc).
Qed.

End More_Properties.

#[global]
Hint Resolve Cauchy_cont_Lim_IR: continuous.

Section Algebraic_Properties.

(**
*** Algebraic Properties

Algebraic operations still work well.
*)

Variable J : interval.
Variables f g : nat -> PartIR.

Hypothesis contf : forall n : nat, Continuous J (f n).
Hypothesis contg : forall n : nat, Continuous J (g n).

Lemma FLim_unique_IR : forall F G HF HG,
 conv_fun_seq'_IR J f F contf HF -> conv_fun_seq'_IR J f G contf HG -> Feq J F G.
Proof.
 intros F G HF HG H H0.
 apply included_Feq'.
 intros a b Hab H1.
 apply FLim_unique with f (fun n : nat => included_imp_Continuous _ _ (contf n) _ _ _ H1)
   (included_imp_Continuous _ _ HF _ _ _ H1) (included_imp_Continuous _ _ HG _ _ _ H1); auto.
Qed.

Lemma Cauchy_fun_seq_wd_IR : (forall n, Feq J (f n) (g n)) ->
 Cauchy_fun_seq_IR _ _ contf -> Cauchy_fun_seq_IR _ _ contg.
Proof.
 intros H H0 a b Hab Hinc.
 eapply Cauchy_fun_seq_wd with (f := f).
  2: apply (H0 a b Hab Hinc).
 intro; apply included_Feq with J; auto.
Qed.

Lemma fun_Lim_seq_const_IR : forall H contH contH',
 conv_fun_seq'_IR J (fun n => H) H contH contH'.
Proof.
 exists 0; intros.
 eapply leEq_wdl.
  2: eapply eq_transitive_unfolded.
   2: apply eq_symmetric_unfolded; apply AbsIRz_isz.
  apply less_leEq; assumption.
 apply AbsIR_wd; rational.
Qed.

Lemma fun_Cauchy_prop_const_IR : forall H (contH:Continuous J H), Cauchy_fun_seq_IR J (fun n => H) (fun n => contH).
Proof.
 intros.
 apply conv_Cauchy_fun_seq'_IR with H (contH).
 apply fun_Lim_seq_const_IR.
Qed.

Variables F G : PartIR.
Hypothesis contF : Continuous J F.
Hypothesis contG : Continuous J G.

(* begin show *)
Hypothesis convF : conv_fun_seq'_IR _ _ _ contf contF.
Hypothesis convG : conv_fun_seq'_IR _ _ _ contg contG.
(* end show *)

Lemma fun_Lim_seq_plus'_IR : forall H H',
 conv_fun_seq'_IR J (fun n => f n{+}g n) (F{+}G) H H'.
Proof.
 intros.
 red in |- *; intros.
 eapply fun_Lim_seq_plus'.
  apply (convF a b Hab Hinc).
 apply (convG a b Hab Hinc).
Qed.

Lemma fun_Lim_seq_minus'_IR : forall H H',
 conv_fun_seq'_IR J (fun n => f n{-}g n) (F{-}G) H H'.
Proof.
 intros.
 red in |- *; intros.
 eapply fun_Lim_seq_minus'.
  apply (convF a b Hab Hinc).
 apply (convG a b Hab Hinc).
Qed.

Lemma fun_Lim_seq_mult'_IR : forall H H',
 conv_fun_seq'_IR J (fun n => f n{*}g n) (F{*}G) H H'.
Proof.
 intros.
 red in |- *; intros.
 eapply fun_Lim_seq_mult'.
  apply (convF a b Hab Hinc).
 apply (convG a b Hab Hinc).
Qed.

End Algebraic_Properties.

Section More_Algebraic_Properties.

(**
If we work with the limit function things fit in just as well.
*)

Variable J : interval.
Variables f g : nat -> PartIR.

Hypothesis contf : forall n : nat, Continuous J (f n).
Hypothesis contg : forall n : nat, Continuous J (g n).

(* begin show *)
Hypothesis Hf : Cauchy_fun_seq_IR _ _ contf.
Hypothesis Hg : Cauchy_fun_seq_IR _ _ contg.
(* end show *)

Lemma fun_Lim_seq_plus_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{+}g n)
 (Cauchy_fun_seq_Lim_IR _ _ _ Hf{+}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H H'.
Proof.
 intros.
 red in |- *; intros.
 cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hf a b Hab Hinc))); [ intro H0 | Contin ].
 cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hg a b Hab Hinc))); [ intro H1 | Contin ].
 eapply conv_fun_seq'_wdr with (contF := Continuous_I_plus _ _ _ _ _ H0 H1).
  apply Feq_symmetric; apply Feq_plus; apply Cauchy_fun_seq_Lim_char.
 apply fun_Lim_seq_plus with (Hf := Hf a b Hab Hinc) (Hg := Hg a b Hab Hinc)
   (H := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc).
Qed.

Lemma fun_Cauchy_prop_plus : forall H, Cauchy_fun_seq_IR J (fun n => f n{+}g n) H.
Proof.
 intro.
 cut (Continuous J (Cauchy_fun_seq_Lim_IR _ _ _ Hf{+}Cauchy_fun_seq_Lim_IR _ _ _ Hg));
   [ intro H0 | Contin ].
 apply conv_Cauchy_fun_seq'_IR
   with (Cauchy_fun_seq_Lim_IR _ _ _ Hf{+}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H0.
 apply fun_Lim_seq_plus_IR.
Qed.

Lemma fun_Lim_seq_inv_IR : forall H H',
 conv_fun_seq'_IR J (fun n => {--} (f n)) {--} (Cauchy_fun_seq_Lim_IR _ _ _ Hf) H H'.
Proof.
 intros.
 red in |- *; intros.
 cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hf a b Hab Hinc))); [ intro H0 | Contin ].
 intros.
 eapply conv_fun_seq'_wdr with (contF := Continuous_I_inv _ _ _ _ H0).
  apply Feq_symmetric; apply Feq_inv; apply Cauchy_fun_seq_Lim_char.
 apply fun_Lim_seq_inv with (Hf := Hf a b Hab Hinc)
   (H := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc).
Qed.

Lemma fun_Cauchy_prop_inv : forall H, Cauchy_fun_seq_IR J (fun n => {--} (f n)) H.
Proof.
 intro.
 cut (Continuous J {--} (Cauchy_fun_seq_Lim_IR _ _ _ Hf)); [ intro H0 | Contin ].
 apply conv_Cauchy_fun_seq'_IR with ( {--} (Cauchy_fun_seq_Lim_IR _ _ _ Hf)) H0.
 apply fun_Lim_seq_inv_IR.
Qed.

Lemma fun_Lim_seq_minus_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{-}g n)
 (Cauchy_fun_seq_Lim_IR _ _ _ Hf{-}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H H'.
Proof.
 intros.
 red in |- *; intros.
 cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hf a b Hab Hinc))); [ intro H0 | Contin ].
 cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hg a b Hab Hinc))); [ intro H1 | Contin ].
 intros.
 eapply conv_fun_seq'_wdr with (contF := Continuous_I_minus _ _ _ _ _ H0 H1).
  apply Feq_symmetric; apply Feq_minus; apply Cauchy_fun_seq_Lim_char.
 apply fun_Lim_seq_minus with (Hf := Hf a b Hab Hinc) (Hg := Hg a b Hab Hinc)
   (H := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc).
Qed.

Lemma fun_Cauchy_prop_minus : forall H, Cauchy_fun_seq_IR J (fun n => f n{-}g n) H.
Proof.
 intro.
 cut (Continuous J (Cauchy_fun_seq_Lim_IR _ _ _ Hf{-}Cauchy_fun_seq_Lim_IR _ _ _ Hg));
   [ intro H0 | Contin ].
 apply conv_Cauchy_fun_seq'_IR
   with (Cauchy_fun_seq_Lim_IR _ _ _ Hf{-}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H0.
 apply fun_Lim_seq_minus_IR.
Qed.

Lemma fun_Lim_seq_mult_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{*}g n)
 (Cauchy_fun_seq_Lim_IR _ _ _ Hf{*}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H H'.
Proof.
 intros.
 red in |- *; intros.
 cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hf a b Hab Hinc))); [ intro H0 | Contin ].
 cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hg a b Hab Hinc))); [ intro H1 | Contin ].
 intros.
 eapply conv_fun_seq'_wdr with (contF := Continuous_I_mult _ _ _ _ _ H0 H1).
  apply Feq_symmetric; apply Feq_mult; apply Cauchy_fun_seq_Lim_char.
 apply fun_Lim_seq_mult with (Hf := Hf a b Hab Hinc) (Hg := Hg a b Hab Hinc)
   (H := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc).
Qed.

Lemma fun_Cauchy_prop_mult : forall H, Cauchy_fun_seq_IR J (fun n => f n{*}g n) H.
Proof.
 intro.
 cut (Continuous J (Cauchy_fun_seq_Lim_IR _ _ _ Hf{*}Cauchy_fun_seq_Lim_IR _ _ _ Hg));
   [ intro H0 | Contin ].
 apply conv_Cauchy_fun_seq'_IR
   with (Cauchy_fun_seq_Lim_IR _ _ _ Hf{*}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H0.
 apply fun_Lim_seq_mult_IR.
Qed.

End More_Algebraic_Properties.

Section Other.

(**
*** Miscellaneous

Finally, we define a mapping between sequences of real numbers and sequences of (constant) functions and prove that convergence is preserved.
*)

Definition seq_to_funseq (x : nat -> IR) n : PartIR := [-C-] (x n).

Lemma funseq_conv : forall J x y, nonvoid J -> conv_fun_seq'_IR J
 (seq_to_funseq x) [-C-]y (fun n => Continuous_const _ _) (Continuous_const _ _) ->
 Cauchy_Lim_prop2 x y.
Proof.
 intros J x y H H0 eps H1.
 elim (nonvoid_point J H); intros x0 Hx0.
 cut (included (compact_single x0) J).
  2: apply compact_single_iprop; auto.
 intro H2.
 elim (H0 _ _ (leEq_reflexive _ _) H2 eps).
  intros N HN.
  exists N; intros.
  simpl in HN.
  apply AbsIR_imp_AbsSmall.
  apply HN with x0.
   auto.
  fold (compact_single x0) in |- *.
  apply compact_single_prop.
 auto.
Qed.

(**
Another interesting fact: if a sequence of constant functions converges then it must converge to a constant function.
*)

Lemma fun_const_Lim : forall J f F contf contF, proper J ->
 conv_fun_seq'_IR J f F contf contF -> (forall n, {c : IR | Feq J (f n) [-C-]c}) ->
 {c : IR | Feq J F [-C-]c}.
Proof.
 intros J f F contf contF pJ H H0.
 set (incF := Continuous_imp_inc _ _ contF) in *.
 set (incf := fun n : nat => Continuous_imp_inc _ _ (contf n)) in *.
 elim (nonvoid_point _ (proper_nonvoid _ pJ)); intros x0 Hx0.
 exists (Part F x0 (incF x0 Hx0)).
 FEQ. rename X into H1.
 simpl in |- *.
 apply cg_inv_unique_2; apply AbsIR_approach_zero.
 intros e H2.
 cut (included (Compact (Min_leEq_Max x x0)) J).
  2: apply included_interval; auto.
 intro Hinc.
 elim (H _ _ _ Hinc _ (pos_div_two _ _ H2)); intros N HN.
 set (Fx := Part _ _ Hx) in *.
 set (Fa := Part _ _ (incF x0 Hx0)) in *.
 set (fx := Part _ _ (incf N x H1)) in *.
 set (fa := Part _ _ (incf N x0 Hx0)) in *.
 apply leEq_wdl with (AbsIR (Fx[-]fx[+] (fx[-]fa) [+] (fa[-]Fa))).
  2: apply AbsIR_wd; rational.
 rstepr (e [/]TwoNZ[+][0][+]e [/]TwoNZ).
 eapply leEq_transitive.
  apply triangle_IR.
 apply plus_resp_leEq_both.
  eapply leEq_transitive.
   apply triangle_IR.
  apply plus_resp_leEq_both.
   eapply leEq_wdl.
    2: apply AbsIR_minus.
   eapply leEq_wdl.
    apply (HN N (le_n N) x (compact_Min_lft _ _ _)).
   unfold Fx, fx in |- *; apply AbsIR_wd; rational.
  elim (H0 N); intros c Hc.
  apply eq_imp_leEq.
  eapply eq_transitive_unfolded.
   2: apply AbsIRz_isz.
  elim Hc; clear Hc; intros H5 H3.
  elim H3; clear H3; intros H6 H4.
  apply AbsIR_wd; unfold fx, fa in |- *; astepr (c[-]c).
  apply cg_minus_wd; simpl in H4; apply H4; auto.
 eapply leEq_wdl.
  apply (HN N (le_n N) x0 (compact_Min_rht _ _ _)).
 unfold Fa, fa in |- *; apply AbsIR_wd; rational.
Qed.

End Other.

Section Series_Definitions.

(**
** Series

We now consider series of functions defined in arbitrary intervals.

Convergence is defined as expected---through convergence in every compact interval.
*)

Variable J : interval.
Variable f : nat -> PartIR.

Definition fun_series_convergent_IR := forall a b Hab (Hinc : included (Compact Hab) J),
  fun_series_convergent a b Hab f.

Lemma fun_series_conv_imp_conv_IR : fun_series_convergent_IR ->
 forall x, J x -> forall Hx, convergent (fun n : nat => f n x (Hx n)).
Proof.
 intros H x H0 Hx.
 apply fun_series_conv_imp_conv with (Hab := leEq_reflexive _ x).
  apply H.
  fold (compact_single x) in |- *; apply compact_single_iprop; auto.
 apply compact_single_prop.
Qed.

(* begin show *)
Hypothesis H : fun_series_convergent_IR.
(* end show *)

Lemma fun_series_inc_IR : forall x, J x -> forall n, Dom (f n) x.
Proof.
 intros x H0 n.
 elim (H _ _ (leEq_reflexive _ x) (compact_single_iprop J x H0)).
 intros contF CauchyF.
 apply (contin_imp_inc _ _ _ _ (contF n)).
 apply compact_single_prop.
Qed.

(** Assume [h(x)] is the pointwise series of [f(x)] *)

(* begin hide *)
Let h (x : IR) (Hx : J x) := series_sum _
    (fun_series_conv_imp_conv _ _ _ _
       (H _ _ (leEq_reflexive _ x) (compact_single_iprop J x Hx)) x
       (compact_single_prop x) (fun_series_inc_IR x Hx)).
(* end hide *)

Lemma FSeries_Sum_strext_IR : forall x y Hx Hy, h x Hx [#] h y Hy -> x [#] y.
Proof.
 unfold h in |- *; clear h; intros x y Hx Hy H0.
 unfold series_sum in H0.
 elim (Lim_strext _ _ H0); intros N HN.
 simpl in HN; unfold seq_part_sum in HN.
 elim (Sum0_strext _ _ _ _ HN); intros.
 exact (pfstrx _ _ _ _ _ _ q).
Qed.

Definition FSeries_Sum : PartIR.
Proof.
 apply Build_PartFunct with (pfpfun := h).
  apply iprop_wd.
 exact FSeries_Sum_strext_IR.
Defined.

Lemma FSeries_Sum_char : forall a b Hab (Hinc : included (Compact Hab) J),
 Feq (Compact Hab) FSeries_Sum (Fun_Series_Sum (H a b Hab Hinc)).
Proof.
 intros; FEQ.
 simpl in |- *; Included.
 simpl in |- *; unfold h in |- *.
 apply series_sum_wd; intros; algebra.
Qed.

End Series_Definitions.

Arguments FSeries_Sum [J f].

Section More_Series_Definitions.

Variable J : interval.
Variable f : nat -> PartIR.

(**
Absolute convergence still exists.
*)

Definition fun_series_abs_convergent_IR :=
 fun_series_convergent_IR J (fun n => FAbs (f n)).

End More_Series_Definitions.

Section Convergence_Results.

(**
As before, any series converges to its sum.
*)

Variable J : interval.
Variable f : nat -> PartIR.

Lemma FSeries_conv : forall (convF : fun_series_convergent_IR J f) H H',
 conv_fun_seq'_IR J (fun n => FSum0 n f) (FSeries_Sum convF) H H'.
Proof.
 intros.
 red in |- *; intros.
 elim (convF _ _ _ Hinc); intros Hcont Hconv.
 apply conv_fun_seq'_wdr with (f := fun n : nat => FSum0 n f)
   (contf := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc)
     (contF := Fun_Series_Sum_cont _ _ _ _ (convF _ _ _ Hinc)).
  apply Feq_symmetric; apply FSeries_Sum_char.
 apply conv_fun_seq'_wdl with (f := fun_seq_part_sum f)
   (contf := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc)
     (contF := Fun_Series_Sum_cont _ _ _ _ (convF _ _ _ Hinc)).
  intro; apply Feq_reflexive.
  red in |- *; intros.
  simpl in |- *; intros.
  apply (contin_imp_inc _ _ _ _ (Hcont n0)); auto.
 apply fun_series_conv.
Qed.

Lemma convergent_imp_inc : fun_series_convergent_IR J f -> forall n, included J (Dom (f n)).
Proof.
 intros H n.
 apply included_imp_inc.
 intros a b Hab H0.
 red in H.
 elim (H _ _ _ H0); intros.
 apply contin_imp_inc; auto.
Qed.

Lemma convergent_imp_Continuous : fun_series_convergent_IR J f -> forall n,
 Continuous J (f n).
Proof.
 intros H n.
 split.
  exact (convergent_imp_inc H n).
 intros a b Hab H0; auto.
 elim (H a b Hab H0); auto.
Qed.

Lemma Continuous_FSeries_Sum : forall H, Continuous J (FSeries_Sum (J:=J) (f:=f) H).
Proof.
 intros.
 split; Included.
 intros a b Hab H0.
 eapply Continuous_I_wd.
  apply Feq_symmetric; apply (FSeries_Sum_char _ _ H _ _ _ H0).
 eapply Continuous_I_wd.
  apply Fun_Series_Sum_char.
 apply Cauchy_cont_Lim.
Qed.

End Convergence_Results.

#[global]
Hint Resolve convergent_imp_inc: included.
#[global]
Hint Resolve convergent_imp_Continuous Continuous_FSeries_Sum: continuous.

Section Operations.

(**
** Algebraic Operations

Convergence is well defined and preserved by operations.
*)

Variable J : interval.

Lemma conv_fun_const_series_IR : forall x : nat -> IR, convergent x ->
 fun_series_convergent_IR J (fun n => [-C-] (x n)).
Proof.
 intros.
 red in |- *; intros.
 apply conv_fun_const_series; auto.
Qed.

Lemma fun_const_series_Sum_IR : forall y H
 (H' : fun_series_convergent_IR J (fun n => [-C-] (y n))) x Hx, FSeries_Sum H' x Hx [=] series_sum y H.
Proof.
 intros.
 simpl in |- *.
 apply series_sum_wd.
 algebra.
Qed.

Lemma conv_zero_fun_series_IR : fun_series_convergent_IR J (fun n => [-C-][0]).
Proof.
 apply conv_fun_const_series_IR with (x := fun n : nat => ZeroR).
 apply conv_zero_series.
Qed.

Lemma FSeries_Sum_zero_IR : forall (H : fun_series_convergent_IR J (fun n => [-C-][0]))
   x Hx, FSeries_Sum H x Hx [=] [0].
Proof.
 intros.
 simpl in |- *.
 apply series_sum_zero.
Qed.

Variables f g : nat -> PartIR.

Lemma fun_series_convergent_wd_IR : (forall n, Feq J (f n) (g n)) ->
 fun_series_convergent_IR J f -> fun_series_convergent_IR J g.
Proof.
 intros.
 red in |- *; intros.
 apply fun_series_convergent_wd with f.
  intros; apply included_Feq with J; auto.
 auto.
Qed.

(* begin show *)
Hypothesis convF : fun_series_convergent_IR J f.
Hypothesis convG : fun_series_convergent_IR J g.
(* end show *)

Lemma FSeries_Sum_wd' : (forall n, Feq J (f n) (g n)) -> Feq J (FSeries_Sum convF) (FSeries_Sum convG).
Proof.
 intros H.
 apply included_Feq'; intros a b Hab H0.
 eapply Feq_transitive.
  apply (FSeries_Sum_char _ _ convF a b Hab H0).
 eapply Feq_transitive.
  2: apply Feq_symmetric; apply (FSeries_Sum_char _ _ convG a b Hab H0).
 apply Fun_Series_Sum_wd'.
 intro; apply included_Feq with J; auto.
Qed.

Lemma FSeries_Sum_plus_conv : fun_series_convergent_IR J (fun n => f n{+}g n).
Proof.
 red in |- *; intros.
 apply conv_fun_series_plus; auto.
Qed.

Lemma FSeries_Sum_plus : forall H : fun_series_convergent_IR J (fun n => f n{+}g n),
 Feq J (FSeries_Sum H) (FSeries_Sum convF{+}FSeries_Sum convG).
Proof.
 intros.
 apply included_Feq'; intros a b Hab H0.
 eapply Feq_transitive.
  apply (FSeries_Sum_char _ _ H a b Hab H0).
 eapply Feq_transitive.
  apply Fun_Series_Sum_plus with (convF := convF a b Hab H0) (convG := convG a b Hab H0).
 apply Feq_symmetric; apply Feq_plus; apply FSeries_Sum_char.
Qed.

Lemma FSeries_Sum_inv_conv : fun_series_convergent_IR J (fun n => {--} (f n)).
Proof.
 red in |- *; intros.
 apply conv_fun_series_inv; auto.
Qed.

Lemma FSeries_Sum_inv : forall H : fun_series_convergent_IR J (fun n => {--} (f n)),
 Feq J (FSeries_Sum H) {--} (FSeries_Sum convF).
Proof.
 intros.
 apply included_Feq'; intros a b Hab H0.
 eapply Feq_transitive.
  apply (FSeries_Sum_char _ _ H a b Hab H0).
 eapply Feq_transitive.
  apply Fun_Series_Sum_inv with (convF := convF a b Hab H0).
 apply Feq_symmetric; apply Feq_inv; apply FSeries_Sum_char.
Qed.

Lemma FSeries_Sum_minus_conv : fun_series_convergent_IR J (fun n => f n{-}g n).
Proof.
 red in |- *; intros.
 apply conv_fun_series_minus; auto.
Qed.

Lemma FSeries_Sum_minus : forall H : fun_series_convergent_IR J (fun n => f n{-}g n),
 Feq J (FSeries_Sum H) (FSeries_Sum convF{-}FSeries_Sum convG).
Proof.
 intros.
 apply included_Feq'; intros a b Hab H0.
 eapply Feq_transitive.
  apply (FSeries_Sum_char _ _ H a b Hab H0).
 eapply Feq_transitive.
  apply Fun_Series_Sum_min with (convF := convF a b Hab H0) (convG := convG a b Hab H0).
 apply Feq_symmetric; apply Feq_minus; apply FSeries_Sum_char.
Qed.

(**
%\begin{convention}% Let [c:IR] and [H:PartIR] be continuous in [J].
%\end{convention}%
*)

Variable c : IR.
Variable H : PartIR.
Hypothesis contH : Continuous J H.

Lemma FSeries_Sum_scal_conv : fun_series_convergent_IR J (fun n => H{*}f n).
Proof.
 red in |- *; intros.
 apply conv_fun_series_scal; auto.
 eapply included_imp_Continuous.
  apply contH.
 auto.
Qed.

Lemma FSeries_Sum_scal : forall H' : fun_series_convergent_IR J (fun n => H{*}f n),
 Feq J (FSeries_Sum H') (H{*}FSeries_Sum convF).
Proof.
 intros.
 apply included_Feq'; intros a b Hab H0.
 cut (Continuous_I Hab H). intro H1.
  eapply Feq_transitive.
   apply (FSeries_Sum_char _ _ H' a b Hab H0).
  eapply Feq_transitive.
   apply Fun_Series_Sum_scal with (convF := convF a b Hab H0).
   auto.
  apply Feq_symmetric; apply Feq_mult.
   apply Feq_reflexive; Included.
  apply FSeries_Sum_char.
 eapply included_imp_Continuous.
  apply contH.
 auto.
Qed.

End Operations.

Section Convergence_Criteria.

(**
*** Convergence Criteria

The most important tests for convergence of series still apply: the
comparison test (in both versions) and the ratio test.
*)

Variable J : interval.
Variable f : nat -> PartIR.
Hypothesis contF : forall n, Continuous J (f n).

Lemma fun_str_comparison_IR : forall g : nat -> PartIR, fun_series_convergent_IR J g ->
 {k : nat | forall n, k <= n -> forall x, J x -> forall Hx Hx', AbsIR (f n x Hx) [<=] g n x Hx'} ->
 fun_series_convergent_IR J f.
Proof.
 intros g H H0 a b Hab H1.
 apply fun_str_comparison with g.
   intro; apply included_imp_Continuous with J; auto.
  auto.
 elim H0; clear H0; intros k Hk.
 exists k; intros.
 apply Hk; auto.
Qed.

Lemma fun_comparison_IR : forall g : nat -> PartIR, fun_series_convergent_IR J g ->
 (forall n x, J x -> forall Hx Hx', AbsIR (f n x Hx) [<=] g n x Hx') ->
 fun_series_convergent_IR J f.
Proof.
 intros g H H0.
 apply fun_str_comparison_IR with g; auto.
 exists 0; intros; apply H0; auto.
Qed.

Lemma abs_imp_conv_IR : fun_series_abs_convergent_IR J f ->
 fun_series_convergent_IR J f.
Proof.
 intro H.
 apply fun_comparison_IR with (fun n => FAbs (f n)).
  apply H.
 intros; apply eq_imp_leEq; apply eq_symmetric_unfolded; apply FAbs_char.
Qed.

Lemma fun_ratio_test_conv_IR : {N : nat | {c : IR | c [<] [1] | [0] [<=] c /\ (forall x,
  J x -> forall n, N <= n -> forall Hx Hx', AbsIR (f (S n) x Hx') [<=] c[*]AbsIR (f n x Hx))}} ->
 fun_series_convergent_IR J f.
Proof.
 intro H.
 red in |- *; intros.
 apply fun_ratio_test_conv.
  intro; apply included_imp_Continuous with J; auto.
 elim H; intros N HN.
 elim HN; clear H HN; intros c Hc H.
 inversion_clear H.
 exists N; exists c; repeat split; auto.
Qed.

End Convergence_Criteria.

Section Power_Series.

(** ***Power Series

The geometric series converges on the open interval (-1, 1)
*)

Lemma fun_power_series_conv_IR : fun_series_convergent_IR (olor ([--][1]) [1]) (fun (i:nat) => Fid IR{^}i).
Proof.
 intros a b Hab H.
 apply fun_ratio_test_conv.
  intros n.
  Contin.
 exists 0%nat.
 exists (Max (AbsIR a) (AbsIR b)).
  destruct (H a) as [Ha0 Ha1].
   split; assumption || apply leEq_reflexive.
  destruct (H b) as [Hb0 Hb1].
   split; assumption || apply leEq_reflexive.
  apply Max_less; apply AbsIR_less; assumption.
 split.
  eapply leEq_transitive.
   apply AbsIR_nonneg.
  apply lft_leEq_Max.
 simpl.
 intros x Hx n Hn _ _.
 rstepr (ABSIR (nexp IR n x)[*]MAX (ABSIR a) (ABSIR b)).
 change (AbsIR (nexp IR n x[*]x)[<=]AbsIR (nexp IR n x)[*]Max (AbsIR a) (AbsIR b)).
 stepl (AbsIR (nexp IR n x)[*]AbsIR x); [| apply eq_symmetric; apply AbsIR_resp_mult].
 apply mult_resp_leEq_lft;[|apply AbsIR_nonneg].
 apply AbsSmall_imp_AbsIR.
 destruct Hx.
 split.
  apply leEq_transitive with a;[|assumption].
  rstepr ([--][--]a).
  apply inv_resp_leEq.
  apply leEq_transitive with (AbsIR a).
   apply inv_leEq_AbsIR.
  apply lft_leEq_Max.
 apply leEq_transitive with b;[assumption|].
 apply leEq_transitive with (AbsIR b).
  apply leEq_AbsIR.
 apply rht_leEq_Max.
Qed.

End Power_Series.

Section Insert_Series.

(**
*** Translation

When working in particular with power series and Taylor series, it is
sometimes useful to ``shift'' all the terms in the series one position
forward, that is, replacing each $f_{i+1}$#f<sub>i+1</sub># with
$f_i$#f<sub>i</sub># and inserting the null function in the first
position.  This does not affect convergence or the sum of the series.
*)

Variable J : interval.
Variable f : nat -> PartIR.
Hypothesis convF : fun_series_convergent_IR J f.

Definition insert_series n : PartIR :=
  match n with
  | O => [-C-][0]
  | S p => f p
  end.

Lemma insert_series_cont : forall n, Continuous J (insert_series n).
Proof.
 intro; elim n; intros.
  simpl in |- *; apply Continuous_const.
 simpl in |- *; apply convergent_imp_Continuous; auto.
Qed.

Lemma insert_series_sum_char : forall n x Hx Hx',
 fun_seq_part_sum f n x Hx [=] fun_seq_part_sum insert_series (S n) x Hx'.
Proof.
 intro; induction  n as [| n Hrecn].
  intros; simpl in |- *; algebra.
 intros; simpl in |- *; simpl in Hrecn; algebra.
Qed.

Lemma insert_series_conv : fun_series_convergent_IR J insert_series.
Proof.
 intros a b Hab Hinc.
 elim (convF _ _ _ Hinc); intros Hcont HCauchy.
 exists (fun n => included_imp_Continuous _ _ (insert_series_cont n) _ _ _ Hinc).
 intros e H.
 elim (HCauchy e H); intros N HN.
 exists (S N); do 4 intro.
 cut (m = S (pred m)); [ intro | apply S_pred with 0; apply lt_le_trans with (S N); auto with arith ].
 cut (n = S (pred n)); [ intro | apply S_pred with 0; apply lt_le_trans with (S N); auto with arith ].
 generalize H0 H1; clear H1 H0.
 rewrite H2; rewrite H3; clear H2 H3.
 intros.
 cut (N <= pred m); [ intro | auto with arith ].
 cut (N <= pred n); [ intro | auto with arith ].
 eapply leEq_wdl.
  apply (HN _ _ H2 H3 x Hx).
 apply AbsIR_wd.
 apply cg_minus_wd; apply insert_series_sum_char.
Qed.

Lemma insert_series_sum : Feq J (FSeries_Sum convF) (FSeries_Sum insert_series_conv).
Proof.
 set (contF := convergent_imp_Continuous _ _ convF) in *.
 apply FLim_unique_IR with (fun n => FSum0 n f) (fun n => Continuous_Sum0 _ _ contF n)
   (Continuous_FSeries_Sum _ _ convF) (Continuous_FSeries_Sum _ _ insert_series_conv).
  apply FSeries_conv.
 red in |- *; intros.
 assert (convS := FSeries_conv _ _ insert_series_conv (Continuous_Sum0 _ _ insert_series_cont)
   (Continuous_FSeries_Sum _ _ insert_series_conv) _ _ _ Hinc).
 intros e H.
 elim (convS e H); intros N HN.
 clear convS; exists N; intros.
 eapply leEq_wdl.
  apply (HN (S n) (le_S _ _ H0) _ Hx).
 apply AbsIR_wd; apply cg_minus_wd.
  2: algebra.
 apply eq_symmetric_unfolded.
 eapply eq_transitive_unfolded.
  eapply eq_transitive_unfolded.
   2: apply (insert_series_sum_char n x (contin_imp_inc _ _ _ _
     (included_imp_Continuous _ _ (Continuous_Sum0 _ _ contF n) _ _ _ Hinc) _ Hx)
       (contin_imp_inc _ _ _ _ (included_imp_Continuous _ _
         (Continuous_Sum0 _ _ insert_series_cont (S n)) _ _ _ Hinc) _ Hx)).
  unfold fun_seq_part_sum in |- *; algebra.
 unfold fun_seq_part_sum in |- *; algebra.
Qed.

End Insert_Series.