(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library 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 library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Rbase.
Require Import Ranalysis.
Require Import Rfunctions.
Require Import Rseries_def.
Require Import Fourier.
Require Import RiemannInt.
Require Import SeqProp.
Require Import Max.
Require Import MyRIneq.
Require Import Ranalysis_def.
Require Import RIVT.

Local Open Scope R_scope.

(* begin hide *)
Ltac case_le H :=
   let t := type of H in
   let h' := fresh in
      match t with ?x <= ?y => case (total_order_T x y);
         [intros h'; case h'; clear h' |
          intros h'; clear -H h'; elimtype False; fourier ] end.
(* end hide *)

(** The image of an interval by a continuous function is an interval *)

Lemma continuity_interval_image_interval : forall (f:R->R) (lb ub y:R),
       lb <= ub ->
       interval (f lb) (f ub) y ->
       continuity_interval f lb ub ->
       {x | interval lb ub x /\ f x = y}.
Proof.
intros f lb ub y lb_le_ub y_encad f_cont_interv.
 case (Rle_lt_or_eq_dec _ _ lb_le_ub) ; clear lb_le_ub ; intro lb_lt_ub.
 case y_encad ; intro y_encad1.
   case_le y_encad1 ; intros y_encad2 y_encad3 ; case_le y_encad3.
    intro y_encad4.
     clear y_encad y_encad1 y_encad3.
     assert (Cont : forall a : R, lb <= a <= ub -> continuity_pt (fun x => f x - y) a).
      intros a a_encad. unfold continuity_pt, continue_in, limit1_in, limit_in ; simpl ; unfold R_dist.
      intros eps eps_pos. elim (f_cont_interv a a_encad eps eps_pos).
      intros alpha alpha_pos. destruct alpha_pos as (alpha_pos,Temp).
      exists alpha. split.
      assumption. intros x  x_cond.
      replace (f x - y - (f a - y)) with (f x - f a) by field.
      exact (Temp x x_cond).
     assert (H1 : interval (f lb - y) (f ub - y) 0).
      split ; left ; [apply Rlt_minus | apply Rgt_minus] ; assumption.
     destruct (IVT_interv (fun x => f x - y) lb ub Cont lb_lt_ub H1) as (x,Hx).
     exists x.
     destruct Hx as (Hyp,Result).
     split ; [assumption | intuition].
     intro H ; exists ub ; repeat split ; intuition.
     intro H ; exists lb ; repeat split ; intuition.
     intro H ; exists ub ; repeat split ; intuition.
     exists lb ; repeat split ; intuition.
     subst ; apply Rle_antisym ; unfold interval in * ; intuition.
Qed.

(** * Continuity of the reciprocal function *)

Lemma continuity_reciprocal_strictly_increasing_interval : forall (f g:R->R) (lb ub:R),
       lb <= ub ->
       strictly_increasing_interval f lb ub ->
       reciprocal_interval g f lb ub ->
       continuity_interval f lb ub ->
       continuity_open_interval g (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)).
Proof.
intros f g lb ub lb_le_ub f_incr f_eq_g f_cont_interv b b_encad.
  assert (f_incr2 := strictly_increasing_increasing_interval _ _ _ f_incr).
  intros eps eps_pos ; simpl ; unfold R_dist.
   assert (b_encad2 : open_interval (f lb) (f ub) b).
    apply strictly_increasing_open_interval_image ; assumption.
   assert (b_encad3 := open_interval_interval _ _ _ b_encad2).
   elim (continuity_interval_image_interval f lb ub b lb_le_ub b_encad3 f_cont_interv) ;
   intros x [x_encad f_x_b].
   assert (x_encad2 : open_interval lb ub x).
    split.
    assert (Temp : x <> lb).
     intro Hfalse ; rewrite Hfalse in f_x_b.
     assert (Temp' : b <> f lb).
      apply Rgt_not_eq ; exact (proj1 b_encad2).
     apply Temp' ; symmetry ; assumption.
    apply Rle_neq_lt ; split ; unfold interval in * ; intuition.
    assert (Temp : x <> ub).
    intro Hfalse ; rewrite Hfalse in f_x_b.
    assert (Temp' : b <> f ub).
     apply Rlt_not_eq ; exact (proj2 b_encad2).
    apply Temp' ; symmetry ; assumption.
    apply Rle_neq_lt ; split ; unfold interval in * ; intuition.
   pose (x1 := Rmax (x - eps) lb).
   pose (x2 := Rmin (x + eps) ub).
   assert (x1_encad : interval lb ub x1).
    split. apply RmaxLess2.
    apply Rlt_le. unfold x1 ; rewrite Rmax_lt_lt_lt ;
    split ; apply Rlt_trans with (r2:=x).
    fourier.
    apply (proj2 x_encad2).
    apply (proj1 x_encad2).
    apply (proj2 x_encad2).
  assert (x2_encad : interval lb ub x2).
   split. apply Rlt_le ; unfold x2 ; apply Rgt_lt ; rewrite Rmin_gt_gt_gt ;
   split ; apply Rgt_trans with (r2:=x).
   fourier.
   apply (proj1 x_encad2).
   apply (proj2 x_encad2).
   apply (proj1 x_encad2).
   apply Rmin_r.
 assert (x_lt_x2 : x < x2).
  unfold x2 ; apply Rgt_lt ; rewrite Rmin_gt_gt_gt ;
  split ; unfold open_interval in * ; intuition ; fourier.
 assert (x1_lt_x : x1 < x).
  unfold x1 ; rewrite Rmax_lt_lt_lt ; split ; unfold open_interval in * ; intuition ; fourier.
 exists (Rmin (f x - f x1) (f x2 - f x)).
 split. apply Rmin_pos ; apply Rgt_minus. apply f_incr ; assumption.
 apply f_incr ; assumption.
 intros y [_ y_cond].
  rewrite <- f_x_b in y_cond.
  assert (Temp : forall x y d1 d2, d1 > 0 -> d2 > 0 -> Rabs (y - x) < Rmin d1 d2 -> x - d1 <= y <= x + d2).
   intros.
    split. assert (H10 : forall x y z, x - y <= z -> x - z <= y). intuition. fourier.
    apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)).
    replace (Rabs (y0 - x0)) with (Rabs (x0 - y0)). apply RRle_abs.
    rewrite <- Rabs_Ropp. unfold Rminus ; rewrite Ropp_plus_distr. rewrite Ropp_involutive.
    intuition.
    apply Rle_trans with (r2:= Rmin d1 d2). apply Rlt_le ; assumption.
    apply Rmin_l.
    assert (H10 : forall x y z, x - y <= z -> x <= y + z). intuition. fourier.
    apply H10. apply Rle_trans with (r2:=Rabs (y0 - x0)). apply RRle_abs.
    apply Rle_trans with (r2:= Rmin d1 d2). apply Rlt_le ; assumption.
    apply Rmin_r.
  assert (Temp' := Temp (f x) y (f x - f x1) (f x2 - f x)).
  replace (f x - (f x - f x1)) with (f x1) in Temp' by field.
  replace (f x + (f x2 - f x)) with (f x2) in Temp' by field.
  assert (T : f x - f x1 > 0).
   apply Rgt_minus. apply f_incr ; assumption.
  assert (T' : f x2 - f x > 0).
   apply Rgt_minus. apply f_incr ; assumption.
  assert (Main := Temp' T T' y_cond).
  clear Temp Temp' T T'.
  assert (x1_lt_x2 : x1 < x2).
   apply Rlt_trans with (r2:=x) ; assumption.
   assert (f_cont_myinterv : forall a : R, x1 <= a <= x2 -> continuity_pt f a).
    intros ; apply f_cont_interv ; split ; unfold interval in *.
    apply Rle_trans with (r2 := x1) ; intuition.
    apply Rle_trans with (r2 := x2) ; intuition.
    assert (x1_le_x2 : x1 <= x2) by intuition.
    assert (f_cont_interv2 : continuity_interval f x1 x2).
     intros a a_in_I ; apply f_cont_interv.
     split ; unfold interval in *.
     apply Rle_trans with (r2 := x1) ; intuition.
     apply Rle_trans with (r2 := x2) ; intuition.
   destruct (continuity_interval_image_interval f x1 x2 y x1_le_x2 Main f_cont_interv2) as
   [x' [x'_encad f_x'_y]].
   rewrite <- f_x_b ; rewrite <- f_x'_y.
   unfold reciprocal_interval, comp in f_eq_g.
   repeat rewrite f_eq_g.
   unfold id.
   assert (x'_encad2 : interval (x - eps) (x + eps) x').
    split ; unfold interval in *.
    apply Rle_trans with (r2:=x1) ; [ apply RmaxLess1|] ; intuition.
    apply Rle_trans with (r2:=x2) ; [ | apply Rmin_l] ; intuition.
   assert (x1_neq_x' : x1 <> x').
    intro Hfalse. rewrite Hfalse, f_x'_y in y_cond.
    assert (Hf : Rabs (y - f x) < f x - y).
     apply Rlt_le_trans with (r2:=Rmin (f x - y) (f x2 - f x)). fourier.
     apply Rmin_l.
     assert(Hfin : f x - y < f x - y).
      apply Rle_lt_trans with (r2:=Rabs (y - f x)).
      rewrite Rabs_minus_sym ; apply RRle_abs.
      assumption.
      elim (Rlt_irrefl _ Hfin).
           assert (x'_lb : x - eps < x').
    apply Rle_neq_lt.
      split ; unfold interval in *. intuition. apply Rlt_not_eq.
      apply Rle_lt_trans with (r2:=x1) ; [ apply RmaxLess1|].
      apply Rle_neq_lt ; split ; intuition.
      assert (x2_neq_x' : x2 <> x').
      intro Hfalse ; assert (Hf : Rabs (y - f x) < y - f x).
      rewrite Hfalse, f_x'_y in y_cond.
      apply Rlt_le_trans with (r2:=Rmin (f x - f x1) (y - f x)). fourier.
       apply Rmin_r.
      assert(Hfin : y - f x < y - f x).
       apply Rle_lt_trans with (r2:=Rabs (y - f x)). apply RRle_abs. fourier.
      elim (Rlt_irrefl _ Hfin).
     assert (x'_ub : x' < x + eps).
   apply Rle_neq_lt.
      split ; unfold interval in *. intuition. apply Rlt_not_eq.
      apply Rlt_le_trans with (r2:=x2).
      apply Rle_neq_lt ; split ; intuition.
      apply Rmin_l.
    apply Rabs_def1 ; fourier.
    assumption.
    split ; [apply Rle_trans with x1 | apply Rle_trans with x2] ; unfold interval in * ;
    intuition.
Qed.

Lemma continuity_reciprocal_strictly_decreasing_interval : forall (f g:R->R) (lb ub:R),
       lb <= ub ->
       strictly_decreasing_interval f lb ub ->
       reciprocal_interval g f lb ub ->
       continuity_interval f lb ub ->
       continuity_open_interval g (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)).
Proof.
intros f g lb ub lb_le_ub f_decr f_eq_g f_cont_interv.
 assert (f_incr := strictly_decreasing_strictly_increasing_interval2 _ _ _ f_decr).
 assert (ub_le_lb : - ub <= - lb) by fourier.
 assert ( T : reciprocal_interval (- g)%F (fun x : R => f (- x)) (- ub) (- lb)).
  intros x x_in_I ; unfold comp ; simpl.
  replace ((- g)%F (f (- x))) with (- (comp g f) (-x)).
  rewrite f_eq_g.
  unfold id ; simpl ; ring.
  unfold interval in * ; split ; destruct x_in_I ;
  fourier.
  reflexivity.

 assert (T2 : continuity_interval (fun x : R => f (- x)) (- ub) (- lb)).
  intros x x_in_I eps eps_pos.
  assert (x_interv : interval lb ub (-x)).
   unfold interval in * ; split ; intuition ; fourier.
  destruct (f_cont_interv (-x) x_interv eps eps_pos) as [alpha [alpha_pos Halpha]] ;
  exists alpha.
  split.
  assumption.
  intros a Ha.
  case (Req_dec x a) ; intro Hxa.
  subst ; simpl ; unfold R_dist ; unfold Rminus ; rewrite Rplus_opp_r, Rabs_R0 ;
  assumption.
  apply Halpha ; split.
  unfold D_x, no_cond ; split.
  intuition.
  intro Hf ; apply Hxa.
  replace x with (- -x) by (apply Ropp_involutive).
  replace a with (- - a) by (apply Ropp_involutive).
  apply Ropp_eq_compat ; assumption.
  simpl ; unfold R_dist, Rminus ; rewrite <- Ropp_plus_distr, Rabs_Ropp ;
  apply (proj2 Ha).

 assert (H := continuity_reciprocal_strictly_increasing_interval
  (fun x => f(-x)) (-g)%F (-ub) (-lb) ub_le_lb f_incr T T2).
 simpl in H ; repeat rewrite Ropp_involutive in H.

apply continuity_open_interval_opp_rev ; rewrite Rmin_comm, Rmax_comm ;
assumption.
Qed.

Lemma continuity_reciprocal_strictly_monotonous_interval : forall (f g:R->R) (lb ub:R),
       lb <= ub ->
       strictly_monotonous_interval f lb ub ->
       reciprocal_interval g f lb ub ->
       continuity_interval f lb ub ->
       continuity_open_interval g (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)).
Proof.
intros f g lb ub lb_le_ub f_mono f_eq_g f_cont_interv.
 destruct f_mono as [f_incr | f_decr] ;
 [apply continuity_reciprocal_strictly_increasing_interval |
 apply continuity_reciprocal_strictly_decreasing_interval] ; assumption.
Qed.

(** * Derivability of the reciprocal function *)

Lemma derivable_pt_lim_reciprocal_interval : forall (f g:R->R) (lb ub:R)
       (f_deriv : derivable_interval f (g lb) (g ub)),
       reciprocal_interval f g lb ub ->
       forall x (g_incr : interval (g lb) (g ub) (g x)),
       continuity_pt g x ->
       open_interval lb ub x ->
       derive_pt f (g x) (f_deriv (g x) g_incr) <> 0 ->
       derivable_pt_lim g x (1 / derive_pt f (g x) (f_deriv (g x) g_incr)).
Proof.
intros f g lb ub f_deriv f_recip_g x g_incr g_cont x_in_I df_neq ; pose (y := g x) ;
 assert (x_encad2 := open_interval_interval _ _ _ x_in_I) ;
 elim (f_deriv (g x)); simpl; intros l Hl ; assert (l_neq : l <> 0) by (intro l_null ;
 rewrite l_null in Hl ; apply df_neq ; rewrite derive_pt_eq ; assumption) ;
 intros eps eps_pos ; fold y.
 assert (Hlinv := limit_inv).
 destruct (Hl eps eps_pos) as [delta Hdelta] ; simpl in Hlinv ; unfold R_dist in Hlinv.
 assert (Hlinv' := Hlinv (fun h => (f (y+h) - f y)/h) (fun h => h <>0) l 0).
 unfold limit1_in, limit_in in Hlinv' ; simpl in Hlinv' ; unfold R_dist in Hlinv'.
 assert (Premisse : (forall eps:R, eps > 0 -> exists alp : R,
     alp > 0 /\ (forall x : R, (fun h => h <>0) x /\ Rabs (x - 0) < alp ->
     Rabs ((f (y + x) - f y) / x - l) < eps))).
  intros eps0 eps0_pos ; elim (Hl eps0 eps0_pos) ; intros delta2 Hdelta2 ;
  exists delta2 ; split ; [apply delta2.(cond_pos) |].
 intros h [h_neq h_bd] ; rewrite Rminus_0_r in h_bd ; apply Hdelta2 ; assumption.
  destruct (Hlinv' Premisse l_neq eps eps_pos) as [alpha [alpha_neq Halpha]] ;
  clear Premisse Hlinv Hlinv' Hl.
  pose (mydelta := Rmin delta alpha) ; assert (mydelta_pos : 0 < mydelta).
   unfold mydelta ; apply Rmin_pos ; [apply delta.(cond_pos) | assumption].
   destruct (g_cont mydelta mydelta_pos) as [delta' [delta'_pos Hdelta']].
  pose (mydelta'' := Rmin delta' (Rmin (x - lb) (ub - x))) ; assert(mydelta''_pos : mydelta'' > 0).
   unfold mydelta'' ; repeat apply Rmin_pos ; [assumption | |] ; unfold open_interval in * ;
   intuition ; fourier.
  pose (delta'' := mkposreal mydelta'' mydelta''_pos) ; exists delta'' ; intros h h_neq h_bd.
  assert (Sublemma2 : forall x y, Rabs x < Rabs y -> y > 0 -> x < y).
   intros m n Hyp_abs y_pos ; apply Rlt_le_trans with (r2:=Rabs n).
   apply Rle_lt_trans with (r2:=Rabs m) ; [ | assumption] ; apply RRle_abs.
   apply Req_le ; apply Rabs_right ; apply Rgt_ge ; assumption.
  assert (xh_encad : interval lb  ub (x +h)).
   split.
   assert (Sublemma : forall x y z, -z <= y - x -> x <= y + z) by (intros ; fourier) ;
   apply Sublemma ; apply Rlt_le ; apply Sublemma2.
   rewrite Rabs_Ropp.
   apply Rlt_le_trans with (r2:=x-lb) ; [| apply RRle_abs] ;
   apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_l] ;
   apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))).
   assumption.
   apply Rmin_r.
   unfold open_interval in * ; intuition ; fourier.
   assert (Sublemma : forall x y z, y <= z - x -> x + y <= z) by (intros ; fourier) ;
   apply Sublemma ; apply Rlt_le ; apply Sublemma2.
   apply Rlt_le_trans with (r2:=ub-x) ; [| apply RRle_abs] ;
   apply Rlt_le_trans with (r2:=Rmin (x - lb) (ub - x)) ; [| apply Rmin_r] ;
   apply Rlt_le_trans with (r2:=Rmin delta' (Rmin (x - lb) (ub - x))) ; [| apply Rmin_r] ; assumption.
   unfold open_interval in * ; intuition ; fourier.
  assert (g(x+h) - y <> 0).
   intro Hf ; apply Rminus_diag_uniq in Hf.
   assert (Hfalse : (comp f g) (x+h) = (comp f g) x).
    intros ; unfold comp ; rewrite Hf ; trivial.
   do 2 rewrite f_recip_g in Hfalse ; unfold id in Hfalse.
   apply Rplus_0_r_uniq in Hfalse ; apply h_neq ; assumption.
   assumption. assumption. assumption.
  replace ((g (x + h) - y) / h) with (1/ (h / (g (x + h) - y))).
  assert (Hrew : h = (comp f g ) (x+h) - (comp f g) x).
  repeat rewrite f_recip_g ; unfold id ; [ring | |] ; assumption.
  rewrite Hrew at 1 ; unfold comp ; replace (g(x+h)) with (y + (g (x+h) - y)) by ring ;
  pose (h':=g (x+h) - y) ; fold y h' ; replace (y + h' - y) with h' by ring.
  apply Rle_lt_trans with (Rabs (/ ((f (y + h') - f y) / h') - / l)) ;
  [right ; apply Rabs_eq_compat ; field |] ; repeat split.
  assumption. assumption.
  unfold h' ; intro Hf ; replace (y + (g (x+h) -y)) with (g (x+h)) in Hf.
  unfold reciprocal_interval, comp in f_recip_g ; unfold y in Hf ;
  do 2 rewrite f_recip_g in Hf ; unfold id in Hf.
  apply h_neq ; ring_simplify in Hf ; assumption.
  assumption. assumption. assumption.
  unfold y ; ring.
  apply Halpha ; split.
  assumption.
  apply Rlt_le_trans with mydelta ; [| apply Rmin_r].
  rewrite Rminus_0_r ; simpl in Hdelta' ; unfold R_dist, y in * ; apply Hdelta' ;
  split.
  unfold D_x, no_cond ; split ; [trivial |].
  intro Hf ; apply h_neq ; apply Rplus_eq_reg_l with x ; rewrite Rplus_0_r ;
  symmetry ; assumption.
  replace (x + h - x) with h by ring ; apply Rlt_le_trans with mydelta''.
  assumption.
  apply Rmin_l.
  field ; split ; assumption.
Qed.

Lemma derivable_pt_reciprocal_interval : forall (f g:R->R) (lb ub:R)
       (f_deriv : derivable_interval f (g lb) (g ub)),
       reciprocal_interval f g lb ub ->
       forall x (g_incr : interval (g lb) (g ub) (g x)),
       continuity_pt g x ->
       open_interval lb ub x ->
       derive_pt f (g x) (f_deriv (g x) g_incr) <> 0 ->
       derivable_pt g x.
Proof.
intros ; exists (1 / derive_pt f (g x) (f_deriv (g x) g_incr)) ;
 apply derivable_pt_lim_reciprocal_interval ;
 assumption.
Qed.

Lemma derivable_pt_reciprocal_interval_rev :forall (f g:R->R) (lb ub x : R),
         lb < ub ->
         open_interval (f lb) (f ub) x ->
         reciprocal_interval f g (f lb) (f ub) ->
         (forall x : R, interval (f lb) (f ub) x -> interval lb ub (g x)) ->
         strictly_increasing_interval f lb ub ->
         derivable_interval f lb ub ->
         derivable_pt f (g x).
Proof.
intros f g lb ub x lb_lt_ub x_encad f_eq_g g_ok f_incr f_derivable.
 apply f_derivable.
 assert (Left_inv :=  strictly_increasing_reciprocal_interval_comm f g lb ub f_incr) ;
 assert (f_incr' : f lb < f ub) by (apply Rlt_trans with x ; unfold open_interval in x_encad ;
 intuition).
 assert (Hrew_min : Rmin (f lb) (f ub) = f lb).
  unfold Rmin ; destruct (Rle_dec (f lb) (f ub)) ; [reflexivity | elim (n (Rlt_le _ _ f_incr'))].
 assert (Hrew_max : Rmax (f lb) (f ub) = f ub).
  unfold Rmax ; destruct (Rle_dec (f lb) (f ub)) ; [reflexivity | elim (n (Rlt_le _ _ f_incr'))].
 replace lb with ((comp g f) lb).
 replace ub with ((comp g f) ub).
 unfold comp.
 assert (Temp:= strictly_increasing_reciprocal_interval_compat  f g lb ub f_incr f_eq_g g_ok).
 split ; apply Rlt_le ; apply Temp ; unfold interval, open_interval in * ; intuition ;
 apply Rle_trans with x ; left ; assumption.
 apply Left_inv ; try rewrite Hrew_min, Hrew_max ; intuition ; apply interval_r ; intuition.
 apply Left_inv ; try rewrite Hrew_min, Hrew_max ; intuition ; apply interval_l ; intuition.
Qed.

Lemma derivable_pt_recip_interv : forall (f g:R->R) (lb ub x : R)
         (lb_lt_ub : lb < ub) (x_encad : open_interval (f lb) (f ub) x)
         (f_eq_g : reciprocal_interval f g (f lb) (f ub))
         (g_wf : forall x : R, interval (f lb) (f ub) x -> interval lb ub (g x))
        (f_incr : strictly_increasing_interval f lb ub)
         (f_derivable : derivable_interval f lb ub),
         derive_pt f (g x)
              (derivable_pt_reciprocal_interval_rev f g lb ub x lb_lt_ub x_encad
              f_eq_g g_wf f_incr f_derivable)  <> 0 ->
         derivable_pt g x.
Proof.
intros f g lb ub x lb_lt_ub x_encad f_eq_g g_wf f_incr f_derivable Df_neq.
 assert(g_incr : g (f lb) < g x < g (f ub)).
  assert (Temp:= strictly_increasing_reciprocal_interval_compat f g lb ub f_incr f_eq_g g_wf).
   assert (x_encad2 := x_encad) ; destruct x_encad2 ; split ; apply Temp ;
   try ((apply interval_l || apply interval_r) ; apply Rle_trans with x ; left ; assumption) ;
   try (apply open_interval_interval) ; try assumption.
 assert (g_eq_f := strictly_increasing_reciprocal_interval_comm2  f g lb ub
                  lb_lt_ub f_incr f_eq_g g_wf).
 assert (f_derivable2 : derivable_interval f (g (f lb)) (g (f ub))).
  intros a a_encad ; apply f_derivable.
  unfold reciprocal_interval, comp, id in g_eq_f ; rewrite g_eq_f in a_encad ;
  rewrite g_eq_f in a_encad ; try apply interval_l ; try apply interval_r ; intuition.
  assert (H := derivable_pt_reciprocal_interval f g (f lb) (f ub)).
  unfold reciprocal_interval, comp, id in g_eq_f.
  rewrite (g_eq_f lb), (g_eq_f ub) in H.
  assert (H' := H f_derivable f_eq_g x (g_wf _ (open_interval_interval _ _ _ x_encad))) ;
  apply H' ; clear H H'.
  assert (H := continuity_reciprocal_strictly_increasing_interval _ _ _ _ (Rlt_le _ _ lb_lt_ub)
                    f_incr g_eq_f (derivable_continuous_interval _ _ _ f_derivable)).
  rewrite strictly_increasing_Rmin_simpl, strictly_increasing_Rmax_simpl in H ;
  intuition.
  assumption.
  intro Hf ; apply Df_neq.
  rewrite <- Hf.
  apply pr_nu_var2_interv with lb ub.
  do 2 rewrite g_eq_f in g_incr ; try apply interval_l ; try apply interval_r ; try (left ; assumption).
  apply g_incr.
  trivial.
  apply interval_r ; left ; assumption.
  apply interval_l ; left ; assumption.
Qed.

Lemma derivable_pt_reciprocal_interval2 : forall (f g:R->R) (lb ub x : R)
         (x_in_I : open_interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) x)
         (f_recip_g : reciprocal_interval f g (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)))
         (g_ok : forall x, interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) x -> interval lb ub (g x))
         (f_deriv : derivable_interval f lb ub), lb < ub ->
         strictly_monotonous_interval f lb ub ->
         derive_pt f (g x) (f_deriv (g x) (g_ok x (open_interval_interval _ _ _ x_in_I)))
         <> 0 ->
         derivable_pt g x.
Proof.
assert (Main : forall (f g:R->R) (lb ub x : R)
         (x_in_I : open_interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) x)
         (f_recip_g : reciprocal_interval f g (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)))
         (g_ok : forall x, interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) x -> interval lb ub (g x))
         (f_deriv : derivable_interval f lb ub), lb < ub ->
         strictly_increasing_interval f lb ub ->
         derive_pt f (g x) (f_deriv (g x) (g_ok x (open_interval_interval _ _ _ x_in_I)))
         <> 0 ->
         derivable_pt g x).
intros f g lb ub x x_in_I f_recip_g g_ok f_deriv lb_lt_ub f_incr Df_neq.
 assert (f lb < f ub).
  apply f_incr ; [apply interval_l | apply interval_r |] ; intuition.
 assert (x_in_I' := x_in_I) ; rewrite Rmin_eq_l, Rmax_eq_r in x_in_I' ;
 assert (x_in_I'' := x_in_I') ; unfold open_interval in x_in_I' ; [| intuition | intuition].
 assert(g_incr : open_interval (g (f lb)) (g (f ub)) (g x)).
  assert (g_ok' := g_ok) ; rewrite Rmin_eq_l, Rmax_eq_r in f_recip_g, g_ok' ;
  try (left ; assumption).
  assert (Temp:= strictly_increasing_reciprocal_interval_compat
             f g lb ub f_incr f_recip_g g_ok').
  split ; apply Temp ; try apply interval_l ; try apply interval_r ; intuition ;
  apply open_interval_interval ; assumption.
  assert(g_incr2 : interval (g (f lb)) (g (f ub)) (g x)) by (apply open_interval_interval ;
  assumption).
 assert (g_eq_f := strictly_increasing_reciprocal_interval_comm f g lb ub f_incr f_recip_g g_ok).
 unfold reciprocal_interval, comp, id in g_eq_f.
 assert (f_derivable2 : forall a : R, interval (g (f lb)) (g (f ub)) a -> derivable_pt f a).
  intros a a_encad ; apply f_deriv.
  rewrite g_eq_f in a_encad ; rewrite g_eq_f in a_encad ; intuition ;
  try apply interval_l || apply interval_r ; intuition.
 apply derivable_pt_reciprocal_interval with (f:=f) (lb:=f lb) (ub:=f ub)
     (f_deriv:=f_derivable2) (g_incr:=g_incr2) ; try assumption.
rewrite Rmin_eq_l, Rmax_eq_r in f_recip_g ; intuition.
assert (T := continuity_reciprocal_strictly_increasing_interval f g lb ub
      (Rlt_le _ _ lb_lt_ub) f_incr g_eq_f (derivable_continuous_interval _ _ _ f_deriv)) ;
apply T ; assumption.
rewrite pr_nu_var2 with (g:=f) (pr2:=f_deriv (g x)
              (g_ok x (open_interval_interval (Rmin (f lb) (f ub))
              (Rmax (f lb) (f ub)) x x_in_I))) ; intuition.

intros f g lb ub x x_in_I f_recip_g g_ok f_deriv lb_lt_ub [f_incr | f_decr] Df_neq.
 eapply Main ; eassumption.
 assert (f ub < f lb).
  apply f_decr ; [apply interval_l | apply interval_r |] ; intuition.
 assert (x_in_I' := x_in_I) ; rewrite Rmin_eq_r, Rmax_eq_l in x_in_I' ; intuition.
 assert (x_in_I'' : open_interval (Rmin ((- f)%F lb) ((- f)%F ub))
                 (Rmax ((- f)%F lb) ((- f)%F ub)) (- x)).
  rewrite Rmin_eq_l, Rmax_eq_r ; intuition ; try (unfold opp_fct ; intuition).
  clear - x_in_I' ; unfold open_interval in * ; intuition ; fourier.
 assert (f_recip_g' : reciprocal_interval (- f)%F (fun x : R => g (- x))
      (Rmin ((- f)%F lb) ((- f)%F ub)) (Rmax ((- f)%F lb) ((- f)%F ub))).
  unfold opp_fct ; rewrite Rmin_opp_opp_Rmax, Rmax_opp_opp_Rmin ;
  apply reciprocal_opp_compat_interval2 ; assumption.
 assert (g_ok' : forall x : R,
              interval (Rmin ((- f)%F lb) ((- f)%F ub))
              (Rmax ((- f)%F lb) ((- f)%F ub)) x ->
              interval lb ub ((fun x0 : R => g (- x0)) x)).
  clear -g_ok ; intros x x_in_I ; apply g_ok.
  unfold opp_fct, interval in x_in_I ; rewrite Rmin_opp_opp_Rmax, Rmax_opp_opp_Rmin in x_in_I.
  split ; intuition ; fourier.
 assert (f_deriv' : derivable_interval (- f)%F lb ub).
  intros a Ha ; reg ; apply f_deriv ; assumption.
 assert (f_incr : strictly_increasing_interval (- f)%F lb ub) by
  (apply strictly_decreasing_strictly_increasing_interval ; assumption).

assert (Df_neq' : derive_pt (- f) ((fun x : R => g (- x)) (- x))
       (f_deriv' ((fun x : R => g (- x)) (- x))
          (g_ok' (- x)
             (open_interval_interval (Rmin ((- f)%F lb) ((- f)%F ub))
                (Rmax ((- f)%F lb) ((- f)%F ub)) (- x) x_in_I''))) = 0 ->
     False).
intro Hf.
apply Df_neq.
destruct (f_deriv' (g (- - x))
          (g_ok' (- x)
          (open_interval_interval (Rmin ((- f)%F lb) ((- f)%F ub))
          (Rmax ((- f)%F lb) ((- f)%F ub)) (- x) x_in_I''))) as (l1, Hl1).
destruct (f_deriv (g x)
          (g_ok x
          (open_interval_interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) x
          x_in_I))) as (l2, Hl2).
assert (Hl1' := Hl1) ; rewrite Ropp_involutive in Hl1'.
assert (Hl1'' := derivable_pt_lim_opp _ _ _ Hl2).
assert (l1 = -l2) by (eapply uniqueness_limite ; eassumption).
assert (l1 = 0).
 rewrite derive_pt_eq in Hf.
 eapply uniqueness_limite ; [apply Hl1 | apply Hf].
rewrite H1 in H0.
assert (l2 = 0) by (clear -H0 ; symmetry ; rewrite <- Ropp_involutive, <- H0 ; intuition).
subst ; simpl ; reflexivity.

assert (L := Main (-f)%F (fun x => g(-x)) lb ub (-x) x_in_I''
           f_recip_g' g_ok' f_deriv' lb_lt_ub f_incr Df_neq').
clear - L ; destruct L as (l, Hl) ; exists (-l) ; intros eps eps_pos ;
 destruct (Hl eps eps_pos) as (delta, Hdelta) ; exists delta ;
 intros h h_neq h_bd.
 assert (R := Hdelta (-h)).
 rewrite Ropp_plus_distr, Ropp_involutive in R.
 apply Rle_lt_trans with (Rabs ((g (x + - - h) - g x) / - h - l)).
 right ; rewrite <- Rabs_Ropp ; apply Rabs_eq_compat.
 unfold Rminus, Rdiv ; rewrite Ropp_plus_distr ;
 repeat rewrite Ropp_involutive ; field ; assumption.
 apply R.
 intro Hf ; apply h_neq.
 symmetry ; rewrite <- Ropp_involutive ; intuition.
 rewrite Rabs_Ropp ; assumption.

Qed.

(****************************************************)
(** *   Value of the derivative of the reciprocal function        *)
(****************************************************)

Lemma derive_pt_recip_interv_prelim0 : forall (f g:R->R) (lb ub x:R)
       (Prf:derivable_pt f (g x)) (Prg:derivable_pt g x),
       lb < x < ub ->
       reciprocal_open_interval f g lb ub ->
       derive_pt f (g x) Prf <> 0 ->
       derive_pt g x Prg = 1 / (derive_pt f (g x) Prf).
Proof.
intros f g lb ub x Df Dg x_in_I local_recip Df_neq.
 replace (derive_pt g x Dg) with
  ((derive_pt g x Dg) * (derive_pt f (g x) Df) * / (derive_pt f (g x) Df))
  by (field ; assumption).
 unfold Rdiv ; apply Rmult_eq_compat_r.
 rewrite Rmult_comm, <- derive_pt_comp.
 assert (x_encad2 : lb <= x <= ub) by intuition.
 rewrite pr_nu_var2_interv with (g:=id)
  (pr2:= derivable_pt_id x) (lb:=lb) (ub:=ub).
  reg.
  assumption.
 assumption.
Qed.

Lemma derive_pt_recip_interv_prelim1_0 : forall (f g:R->R) (lb ub x:R),
       lb <= ub -> open_interval (f lb) (f ub) x ->
       strictly_increasing_interval f lb ub ->
       (forall x : R, interval (f lb) (f ub) x -> interval lb ub (g x)) ->
       reciprocal_interval f g (f lb) (f ub) ->
       open_interval lb ub (g x).
Proof.
intros f g lb ub x lb_lt_ub x_in_I f_incr g_ok f_recip_g ;
 assert (f_incr2 := strictly_increasing_increasing_interval _ _ _ f_incr) ;
 assert (H : f lb <= f ub).
  apply f_incr2 ; [apply interval_l | apply interval_r |] ; assumption.
 assert (f_recip_g2 : reciprocal_interval f g (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub))).
  rewrite Rmin_eq_l, Rmax_eq_r ; assumption.
 assert (g_ok2 : forall x : R,
        interval (Rmin (f lb) (f ub)) (Rmax (f lb) (f ub)) x ->
        interval lb ub (g x)).
  rewrite Rmin_eq_l, Rmax_eq_r ; assumption.
 assert (Hrew := strictly_increasing_reciprocal_interval_comm
            f g lb ub f_incr f_recip_g2 g_ok2).
 assert (g_incr := strictly_increasing_reciprocal_interval_compat
            _ _ _ _ f_incr f_recip_g g_ok).
 split ; unfold reciprocal_interval, comp, id in Hrew ;
  [rewrite <- Hrew with (x := lb) | rewrite <- Hrew].
 apply g_incr ; [apply interval_l | apply open_interval_interval |
 apply (proj1 x_in_I)] ; assumption.
 apply interval_l ; assumption.
 apply g_incr ; [apply open_interval_interval | apply interval_r |
 apply (proj2 x_in_I)] ; assumption.
 apply interval_r ; assumption.
Qed.

Lemma derive_pt_recip_interv_prelim1_1 : forall (f g:R->R) (lb ub x:R),
       lb <= ub ->
       open_interval (f lb) (f ub) x ->
       strictly_increasing_interval f lb ub ->
       (forall x : R, interval (f lb) (f ub) x  -> interval lb ub (g x)) ->
       reciprocal_interval f g (f lb) (f ub) ->
       interval lb ub (g x).
Proof.
intros f g lb ub x lb_le_ub x_encad f_incr g_wf f_eq_g.
 assert (Temp := derive_pt_recip_interv_prelim1_0 f g lb ub x lb_le_ub x_encad
 f_incr g_wf f_eq_g).
 split ; apply Rlt_le ; unfold interval, open_interval in * ; intuition.
Qed.

Lemma ub_lt_2_pos : forall x ub lb, lb < x -> x < ub -> 0 < (ub-lb)/2.
Proof.
intros x ub lb lb_lt_x x_lt_ub.
 assert (T : 0 < ub - lb).
  fourier.
 unfold Rdiv ; apply Rlt_mult_inv_pos ; intuition.
Qed.

Definition mkposreal_lb_ub (x lb ub:R) (x_in_I : open_interval lb ub x) : posreal.
intros x lb ub x_in_I.
 apply (mkposreal ((ub-lb)/2) (ub_lt_2_pos x ub lb (proj1 x_in_I) (proj2 x_in_I))).
Defined.

Require Import Rsequence.

Lemma Dfn_CVU_implies_Df_exists : forall (fn fn':nat -> R -> R) (f g:R->R)
      (x lb ub:R) (x_in_I : open_interval lb ub x),
      (forall (x:R) (n:nat), open_interval lb ub x -> derivable_pt_lim (fn n) x (fn' n x)) ->
      (forall (x:R), open_interval lb ub x -> Rseq_cv (fun n => fn n x) (f x)) ->
      (CVU fn' g ((lb + ub)/2) (mkposreal_lb_ub x lb ub x_in_I)) ->
      (forall (x:R), open_interval lb ub x -> continuity_pt g x) ->
      derivable_pt_lim f x (g x).
Proof.
intros fn fn' f g x lb ub x_in_I Dfn_eq_fn' fn_CV_f fn'_CVU_g g_cont eps eps_pos.
 assert (eps_8_pos : 0 < eps / 8) by fourier.
 elim (g_cont x x_in_I (eps/8) eps_8_pos) ; clear g_cont ; intros delta1 Hdelta1 ;
 destruct Hdelta1 as (delta1_pos, g_cont).
 assert (delta_pos : 0 < Rmin (Rmin ((x-lb)/2) ((ub-x)/2)) delta1).
  apply Rmin_pos ; [apply Rmin_pos | intuition] ; unfold Rdiv ;
  apply Rlt_mult_inv_pos ; intuition ; apply Rlt_Rminus ;
  [apply (proj1 x_in_I) | apply (proj2 x_in_I)].
 pose (delta := mkposreal (Rmin (Rmin ((x-lb)/2) ((ub-x)/2)) delta1) (delta_pos)).
 exists delta ; intros h h_neq h_ub.
 assert (eps'_pos : 0 < (Rabs h) * eps / 4).
  unfold Rdiv ; rewrite Rmult_assoc ; apply Rmult_lt_0_compat.
  apply Rabs_pos_lt ; assumption.
  fourier.
 elim (fn_CV_f x x_in_I ((Rabs h) * eps / 4) eps'_pos) ; intros N2 fnx_CV_fx.
 assert(lb_lt_xh : lb < x + h).
  apply Rlt_trans with (x - delta).
  unfold delta.
  assert (Temp : forall a b c, a + c < b -> a < b - c).
   intros ; fourier.
  apply Temp ; clear Temp ; apply Rle_lt_trans with (lb + Rmin ((x - lb) / 2) ((ub - x) / 2)).
  apply Rplus_le_compat_l ; apply Rmin_l.
  apply Rle_lt_trans with (lb + (x - lb) / 2).
  apply Rplus_le_compat_l ; apply Rmin_l.
  replace (lb + (x - lb) / 2) with ((lb + x)/2) by field.
  assert (Temp : forall a b, a < b -> (a+b)/2 < b).
   clear ; intros a b a_lt_b.
   unfold Rdiv ; rewrite Rmult_plus_distr_r.
   fourier.
  apply Temp ; apply (proj1 x_in_I).
  apply Rplus_lt_compat_l.
  exact (proj2 (Rabs_def2 h delta h_ub)).
 assert(xh_lt_ub : x + h < ub).
  apply Rlt_trans with (x + delta).
  apply Rplus_lt_compat_l.
  exact (proj1 (Rabs_def2 h delta h_ub)).
  unfold delta.
  apply Rle_lt_trans with (x + Rmin ((x - lb) / 2) ((ub - x) / 2)).
  apply Rplus_le_compat_l ; apply Rmin_l.
  apply Rle_lt_trans with (x + (ub - x) / 2).
  apply Rplus_le_compat_l ; apply Rmin_r.
  replace (x + (ub - x) / 2) with ((ub + x)/2) by field.
  assert (Temp : forall a b, a < b -> (b+a)/2 < b).
   clear ; intros a b a_lt_b.
   unfold Rdiv ; rewrite Rmult_plus_distr_r.
   fourier.
  apply Temp ; apply (proj2 x_in_I).
  assert (xh_in_I : open_interval lb ub (x+h)) by (split ; assumption).
 elim (fn_CV_f (x+h) xh_in_I ((Rabs h) * eps / 4) eps'_pos) ;
 clear fn_CV_f ; intros N1 fnxh_CV_fxh.
 elim (fn'_CVU_g (eps/8) eps_8_pos) ; intros N3 fn'c_CVU_gc.
 pose (N := max (max N1 N2) N3).
 assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn N x - h * (g x))) < (Rabs h)*eps).
 apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h) - (f x - fn N x)) +  Rabs ((fn N (x + h) - fn N x - h * g x))).
 apply Rabs_triang.
 apply Rle_lt_trans with (Rabs (f (x + h) - fn N (x + h)) + Rabs (- (f x - fn N x)) + Rabs (fn N (x + h) - fn N x - h * g x)).
 apply Rplus_le_compat_r ; apply Rabs_triang.
 rewrite Rabs_Ropp.
 case (Rlt_le_dec h 0) ; intro sgn_h.
 assert (pr1 : forall c : R, x + h < c < x -> derivable_pt (fn N) c).
  intros c c_encad ; unfold derivable_pt.
  assert (lb_lt_c : lb < c).
   apply Rlt_trans with (x+h) ; intuition.
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with x ; intuition ; apply (proj2 x_in_I).
 exists (fn' N c) ; apply Dfn_eq_fn' ; split ; assumption.
 assert (pr2 : forall c : R, x + h < c < x -> derivable_pt id c).
  intros c c_encad ; apply derivable_id.
 assert (xh_x : x+h < x).
  fourier.
 assert (pr3 : forall c : R, x + h <= c <= x -> continuity_pt (fn N) c).
  intros c c_encad ; apply derivable_continuous_pt.
  exists (fn' N c) ; apply Dfn_eq_fn' ; split.
  apply Rlt_le_trans with (x+h) ; intuition.
  apply Rle_lt_trans with x ; intuition ; apply (proj2 x_in_I).
 assert (pr4 : forall c : R, x + h <= c <= x -> continuity_pt id c).
  intros c c_encad ; apply derivable_continuous ; apply derivable_id.
 elim (MVT (fn N) id (x+h) x pr1 pr2 xh_x pr3 pr4) ; intros c Hc ; elim Hc ; clear Hc ; intros P Hc.
 assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)).
  apply Rmult_eq_reg_l with (-1).
  replace (-1 * (h * derive_pt (fn N) c (pr1 c P))) with (-h * derive_pt (fn N) c (pr1 c P)) by field.
  replace (-1 * (fn N (x + h) - fn N x)) with (- (fn N (x + h) - fn N x)) by field.
  replace (-h) with (id x - id (x + h)).
  rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
  replace (- (fn N (x + h) - fn N x)) with (fn N x - fn N (x + h)) by field.
  assumption.
  unfold id ; field.
  apply Rlt_not_eq ; intuition.
 clear Hc.
 rewrite <- Hc'.
 replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
 replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
 rewrite Rabs_mult.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
 rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
 unfold N ; apply le_trans with (max N1 N2) ; apply le_max_l.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
 unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
 unfold N ; apply le_trans with (max N1 N2) ; [apply le_max_r | apply le_max_l].
 replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
 apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; rewrite <- Rmult_plus_distr_l ;
 apply Rmult_le_compat_l. apply Rabs_pos.
 apply Rabs_triang.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
          Rabs h * Rabs (g c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 rewrite Rabs_minus_sym ; apply fn'c_CVU_gc.
 unfold N ; apply le_max_r.
 unfold Boule.
 assert (Rabs (c - (lb + ub) / 2) < (ub - lb) / 2).
  apply Rabs_def1.
  assert (Temp : forall a b c, a < b + c -> a - b < c). intros ; fourier.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 + (ub - lb) / 2) with ub by field.
  apply Rlt_trans with x ; [exact (proj2 P) | intuition ; apply (proj2 x_in_I)].
  assert (Temp : forall a b c, a - b < c -> - b < c - a) by (intros ; fourier).
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 - ((ub - lb) / 2)) with lb by field.
  apply Rlt_trans with (x+h) ; [intuition | exact (proj1 P)].
  assumption.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
         Rabs h * (eps / 8)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_lt_compat_l ; apply Rplus_lt_compat_l ; rewrite <- Rmult_plus_distr_l ;
 rewrite <- Rmult_plus_distr_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 apply Rplus_lt_compat_l ; simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
 unfold no_cond ; intuition. apply Rgt_not_eq ; exact (proj2 P).
 unfold R_dist. apply Rlt_trans with (Rabs h).
 apply Rabs_def1. apply Rlt_trans with 0.
 assert (Temp : forall a b, a < b -> a - b < 0).
  intros ; fourier.
 apply Temp ; exact (proj2 P).
 apply Rabs_pos_lt ; assumption.
 apply Rle_lt_trans with h.
 rewrite Rabs_left1.
 apply Req_le ; field.
 apply Rlt_le ; assumption.
 assert (Temp : forall a b c, a + b < c -> b < c - a). intros ; fourier.
 apply Temp ; clear Temp ; exact (proj1 P).
 apply Rlt_le_trans with delta ; [intuition | unfold delta ; apply Rmin_r].
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
 replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
 apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 fourier.
 assert (lb_lt_c : lb < c).
   apply Rlt_trans with (x+h) ; intuition ; exact (proj1 P).
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with x ; intuition ; [exact (proj2 P) | exact (proj2 x_in_I)].
 assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
 assert (Temp : l = fn' N c).
  assert (c_in_I : open_interval lb ub c) by (split ; assumption).
  assert (Hl' := Dfn_eq_fn' c N c_in_I).
  unfold derivable_pt_abs in Hl.
  clear -Hl Hl'.
  apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
  rewrite <- Temp.
  assert (Hl' : derivable_pt (fn N) c).
   exists l ; apply Hl.
  rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
  elim Hl' ; clear Hl' ; intros l' Hl'.
  assert (Main : l = l').
 apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
 rewrite Main ; reflexivity.
 reflexivity.
 assert (h_pos : h > 0).
  case sgn_h ; intro Hyp.
  assumption.
  apply False_ind ; apply h_neq ; symmetry ; assumption.
 clear sgn_h.
 assert (pr1 : forall c : R, x < c < x + h -> derivable_pt (fn N) c).
  intros c c_encad ; unfold derivable_pt.
  assert (lb_lt_c : lb < c).
   apply Rlt_trans with x ; intuition ; apply (proj1 x_in_I).
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with (x+h) ; intuition.
  exists (fn' N c) ; apply Dfn_eq_fn' ; split ; assumption.
 assert (pr2 : forall c : R, x < c < x + h -> derivable_pt id c).
  intros c c_encad ; apply derivable_id.
 assert (xh_x : x < x + h).
  fourier.
 assert (pr3 : forall c : R, x <= c <= x + h -> continuity_pt (fn N) c).
  intros c c_encad ; apply derivable_continuous_pt.
  exists (fn' N c) ; apply Dfn_eq_fn' ; intuition.
  split.
  apply Rlt_le_trans with x ; [exact (proj1 x_in_I) | assumption].
  apply Rle_lt_trans with (x+h) ; intuition.
 assert (pr4 : forall c : R, x <= c <= x + h -> continuity_pt id c).
  intros c c_encad ; apply derivable_continuous ; apply derivable_id.
 elim (MVT (fn N) id x (x+h) pr1 pr2 xh_x pr3 pr4) ; intros c Hc ; elim Hc ; clear Hc ; intros P Hc.
 assert (Hc' : h * derive_pt (fn N) c (pr1 c P) = (fn N (x+h) - fn N x)).
  replace (h * derive_pt (fn N) c (pr1 c P)) with ((id (x+h) - id x)* derive_pt (fn N) c (pr1 c P)).
  rewrite <- Rmult_1_r ; replace 1 with (derive_pt id c (pr2 c P)) by reg.
  assumption.
  unfold id ; field.
 clear Hc.
 rewrite <- Hc'.
 replace (derive_pt (fn N) c (pr1 c P)) with (fn' N c).
 replace (h * fn' N c - h * g x) with (h * (fn' N c - g x)) by field.
 rewrite Rabs_mult.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ;
 rewrite Rabs_minus_sym ; apply fnxh_CV_fxh.
 unfold N ; apply le_trans with (max N1 N2) ; apply le_max_l.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l.
 unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx.
 unfold N ; apply le_trans with (max N1 N2) ; [apply le_max_r | apply le_max_l].
 replace (fn' N c - g x)  with ((fn' N c - g c) +  (g c - g x)) by field.
 apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 +
          Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)).
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite Rplus_assoc ;
 apply Rplus_le_compat_l ; apply Rplus_le_compat_l ; rewrite <- Rmult_plus_distr_l ;
 apply Rmult_le_compat_l. apply Rabs_pos.
 apply Rabs_triang.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
          Rabs h * Rabs (g c - g x)).
 apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l ; apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 rewrite Rabs_minus_sym ; apply fn'c_CVU_gc.
 unfold N ; apply le_max_r.
 unfold Boule.
 assert (Rabs (c - (lb + ub) / 2) < (ub - lb) / 2).
  apply Rabs_def1.
  assert (Temp : forall a b c, a < b + c -> a - b < c). intros ; fourier.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 + (ub - lb) / 2) with ub by field.
  apply Rlt_trans with (x+h) ; [exact (proj2 P) | intuition].
  assert (Temp : forall a b c, a - b < c -> - b < c - a). intros ; fourier.
  apply Temp ; clear Temp ; replace ((lb + ub) / 2 - ((ub - lb) / 2)) with lb by field.
  apply Rlt_trans with x ; [intuition | exact (proj1 P)].
  exact (proj1 x_in_I).
  apply H.
 apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * (eps / 8) +
         Rabs h * (eps / 8)).
 repeat rewrite Rplus_assoc ; repeat apply Rplus_lt_compat_l ;
 repeat rewrite <- Rmult_plus_distr_l.
 apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 simpl in g_cont ; apply g_cont ; split ; [unfold D_x ; split |].
 unfold no_cond ; intuition. apply Rlt_not_eq ; exact (proj1 P).
 unfold R_dist. apply Rlt_trans with (Rabs h).
 apply Rabs_def1.
 assert (Temp : forall a b c, c < a + b -> c - a < b). intros ; fourier.
 apply Temp ; clear Temp ; rewrite Rabs_right. exact (proj2 P).
 apply Rgt_ge ; assumption.
 assert (Temp : forall a b, a - b < c -> - b < c - a). intros ; fourier.
 apply Temp ; apply Rlt_trans with x ; [| exact (proj1 P)].
 rewrite <- Rplus_0_r.
 apply Rplus_lt_compat_l.
 apply Ropp_lt_gt_0_contravar ; apply Rabs_pos_lt ; apply Rgt_not_eq ; assumption.
 apply Rle_lt_trans with h.
 rewrite Rabs_right. apply Req_le ; reflexivity.
 fourier.
 apply Rlt_le_trans with delta ; [intuition | unfold delta ; apply Rmin_r].
 rewrite Rabs_right in h_ub ; intuition.
 rewrite Rplus_assoc ; rewrite Rplus_assoc ; rewrite <- Rmult_plus_distr_l.
 replace (Rabs h * eps / 4 + (Rabs h * eps / 4 + Rabs h * (eps / 8 + eps / 8))) with
      (Rabs h * (eps / 4 + eps / 4 + eps / 8 + eps / 8)) by field.
 apply Rmult_lt_compat_l.
 apply Rabs_pos_lt ; assumption.
 fourier.
 assert (lb_lt_c : lb < c).
   apply Rlt_trans with x ; intuition ; [exact (proj1 x_in_I) | exact (proj1 P)].
  assert (c_lt_ub : c < ub).
   apply Rlt_trans with (x+h) ; intuition ; exact (proj2 P).
 assert (H := pr1 c P) ; elim H ; clear H ; intros l Hl.
 assert (Temp : l = fn' N c).
  assert (c_in_I : open_interval lb ub c) by (split ; assumption) ;
   assert (Hl' := Dfn_eq_fn' c N c_in_I).
  unfold derivable_pt_abs in Hl.
  clear -Hl Hl'.
  apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
  rewrite <- Temp.
  assert (Hl' : derivable_pt (fn N) c).
   exists l ; apply Hl.
  rewrite pr_nu_var with (g:= fn N) (pr2:=Hl').
  elim Hl' ; clear Hl' ; intros l' Hl'.
  assert (Main : l = l').
 apply uniqueness_limite with (f:= fn N) (x:=c) ; assumption.
 rewrite Main ; reflexivity.
 reflexivity.
 replace ((f (x + h) - f x) / h - g x) with ((/h) * ((f (x + h) - f x) - h * g x)).
 rewrite Rabs_mult ; rewrite Rabs_Rinv.
 replace eps with (/ Rabs h * (Rabs h * eps)).
 apply Rmult_lt_compat_l.
 apply Rinv_0_lt_compat ; apply Rabs_pos_lt ; assumption.
 replace (f (x + h) - f x - h * g x) with (f (x + h) - fn N (x + h) - (f x - fn N x) +
          (fn N (x + h) - fn N x - h * g x)) by field.
 assumption.
 field ; apply Rgt_not_eq ; apply Rabs_pos_lt ; assumption.
 assumption.
 field. assumption.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  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 file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Definitions and theorems about semi-open integer intervals *)

Require Import Coqlib.
Require Import Zwf.
Require Coq.Program.Wf.
Require Recdef.

Definition interv : Type := (Z * Z)%type.

(** * Membership *)

Definition In (x: Z) (i: interv) : Prop := fst i <= x < snd i.

Lemma In_dec:
  forall x i, {In x i} + {~In x i}.
Proof.
  unfold In; intros.
  case (zle (fst i) x); intros.
  case (zlt x (snd i)); intros.
  left; auto.
  right; intuition.
  right; intuition.
Defined.

Lemma notin_range:
  forall x i,
  x < fst i \/ x >= snd i -> ~In x i.
Proof.
  unfold In; intros; omega.
Qed.

Lemma range_notin:
  forall x i,
  ~In x i -> fst i < snd i -> x < fst i \/ x >= snd i.
Proof.
  unfold In; intros; omega.
Qed.

(** * Emptyness *)

Definition empty (i: interv) : Prop := fst i >= snd i.

Lemma empty_dec:
  forall i, {empty i} + {~empty i}.
Proof.
  unfold empty; intros.
  case (zle (snd i) (fst i)); intros.
  left; omega.
  right; omega.
Defined.

Lemma is_notempty:
  forall i, fst i < snd i -> ~empty i.
Proof.
  unfold empty; intros; omega.
Qed.

Lemma empty_notin:
  forall x i, empty i -> ~In x i.
Proof.
  unfold empty, In; intros. omega.
Qed.

Lemma in_notempty:
  forall x i, In x i -> ~empty i.
Proof.
  unfold empty, In; intros. omega.
Qed.

(** * Disjointness *)

Definition disjoint (i j: interv) : Prop :=
  forall x, In x i -> ~In x j.

Lemma disjoint_sym:
  forall i j, disjoint i j -> disjoint j i.
Proof.
  unfold disjoint; intros; red; intros. elim (H x); auto.
Qed.

Lemma empty_disjoint_r:
  forall i j, empty j -> disjoint i j.
Proof.
  unfold disjoint; intros. apply empty_notin; auto.
Qed.

Lemma empty_disjoint_l:
  forall i j, empty i -> disjoint i j.
Proof.
  intros. apply disjoint_sym. apply empty_disjoint_r; auto.
Qed.

Lemma disjoint_range:
  forall i j,
  snd i <= fst j \/ snd j <= fst i -> disjoint i j.
Proof.
  unfold disjoint, In; intros. omega.
Qed.

Lemma range_disjoint:
  forall i j,
  disjoint i j ->
  empty i \/ empty j \/ snd i <= fst j \/ snd j <= fst i.
Proof.
  unfold disjoint, empty; intros.
  destruct (zlt (fst i) (snd i)); auto.
  destruct (zlt (fst j) (snd j)); auto.
  right; right.
  destruct (zlt (fst i) (fst j)).
(* Case 1: i starts to the left of j. *)
  destruct (zle (snd i) (fst j)).
(* Case 1.1: i ends to the left of j, OK *)
  auto.
(* Case 1.2: i ends to the right of j's start, not disjoint. *)
  elim (H (fst j)). red; omega. red; omega.
(* Case 2: j starts to the left of i *)
  destruct (zle (snd j) (fst i)).
(* Case 2.1: j ends to the left of i, OK *)
  auto.
(* Case 2.2: j ends to the right of i's start, not disjoint. *)
  elim (H (fst i)). red; omega. red; omega.
Qed.

Lemma range_disjoint':
  forall i j,
  disjoint i j -> fst i < snd i -> fst j < snd j ->
  snd i <= fst j \/ snd j <= fst i.
Proof.
  intros. exploit range_disjoint; eauto. unfold empty; intuition omega.
Qed.

Lemma disjoint_dec:
  forall i j, {disjoint i j} + {~disjoint i j}.
Proof.
  intros.
  destruct (empty_dec i). left; apply empty_disjoint_l; auto.
  destruct (empty_dec j). left; apply empty_disjoint_r; auto.
  destruct (zle (snd i) (fst j)). left; apply disjoint_range; auto.
  destruct (zle (snd j) (fst i)). left; apply disjoint_range; auto.
  right; red; intro. exploit range_disjoint; eauto. intuition.
Defined.

(** * Shifting an interval by some amount *)

Definition shift (i: interv) (delta: Z) : interv := (fst i + delta, snd i + delta).

Lemma in_shift:
  forall x i delta,
  In x i -> In (x + delta) (shift i delta).
Proof.
  unfold shift, In; intros. simpl. omega.
Qed.

Lemma in_shift_inv:
  forall x i delta,
  In x (shift i delta) -> In (x - delta) i.
Proof.
  unfold shift, In; simpl; intros. omega.
Qed.

(** * Enumerating the elements of an interval *)

Section ELEMENTS.

Variable lo: Z.

Function elements_rec (hi: Z) {wf (Zwf lo) hi} : list Z :=
  if zlt lo hi then (hi-1) :: elements_rec (hi-1) else nil.
Proof.
  intros. red. omega.
  apply Zwf_well_founded.
Qed.

Lemma In_elements_rec:
  forall hi x,
  List.In x (elements_rec hi) <-> lo <= x < hi.
Proof.
  intros. functional induction (elements_rec hi).
  simpl; split; intros.
  destruct H. clear IHl. omega. rewrite IHl in H. clear IHl. omega.
  destruct (zeq (hi - 1) x); auto. right. rewrite IHl. clear IHl. omega.
  simpl; intuition.
Qed.

End ELEMENTS.

Definition elements (i: interv) : list Z :=
  elements_rec (fst i) (snd i).

Lemma in_elements:
  forall x i,
  In x i -> List.In x (elements i).
Proof.
  intros. unfold elements. rewrite In_elements_rec. auto.
Qed.

Lemma elements_in:
  forall x i,
  List.In x (elements i) -> In x i.
Proof.
  unfold elements; intros.
  rewrite In_elements_rec in H. auto.
Qed.

(** * Checking properties on all elements of an interval *)

Section FORALL.

Variables P Q: Z -> Prop.
Variable f: forall (x: Z), {P x} + {Q x}.
Variable lo: Z.

Program Fixpoint forall_rec (hi: Z) {wf (Zwf lo) hi}:
                 {forall x, lo <= x < hi -> P x}
                 + {exists x, lo <= x < hi /\ Q x} :=
  if zlt lo hi then
    match f (hi - 1) with
    | left _ =>
        match forall_rec (hi - 1) with
        | left _ => left _ _
        | right _ => right _ _
        end
    | right _ => right _ _
    end
  else
    left _ _
.
Next Obligation.
  red. omega.
Qed.
Next Obligation.
  assert (x = hi - 1 \/ x < hi - 1) by omega.
  destruct H2. congruence. auto.
Qed.
Next Obligation.
  exists wildcard'0; split; auto. omega.
Qed.
Next Obligation.
  exists (hi - 1); split; auto. omega.
Qed.
Next Obligation.
  omegaContradiction.
Defined.

End FORALL.

Definition forall_dec
       (P Q: Z -> Prop) (f: forall (x: Z), {P x} + {Q x}) (i: interv) :
       {forall x, In x i -> P x} + {exists x, In x i /\ Q x} :=
 forall_rec P Q f (fst i) (snd i).

(** * Folding a function over all elements of an interval *)

Section FOLD.

Variable A: Type.
Variable f: Z -> A -> A.
Variable lo: Z.
Variable a: A.

Function fold_rec (hi: Z) {wf (Zwf lo) hi} : A :=
  if zlt lo hi then f (hi - 1) (fold_rec (hi - 1)) else a.
Proof.
  intros. red. omega.
  apply Zwf_well_founded.
Qed.

Lemma fold_rec_elements:
  forall hi, fold_rec hi = List.fold_right f a (elements_rec lo hi).
Proof.
  intros. functional induction (fold_rec hi).
  rewrite elements_rec_equation. rewrite zlt_true; auto.
  simpl. congruence.
  rewrite elements_rec_equation. rewrite zlt_false; auto.
Qed.

End FOLD.

Definition fold {A: Type} (f: Z -> A -> A) (a: A) (i: interv) : A :=
  fold_rec A f (fst i) a (snd i).

Lemma fold_elements:
  forall (A: Type) (f: Z -> A -> A) a i,
  fold f a i = List.fold_right f a (elements i).
Proof.
  intros. unfold fold, elements. apply fold_rec_elements.
Qed.

(** Hints *)

Hint Resolve
  notin_range range_notin
  is_notempty empty_notin in_notempty
  disjoint_sym empty_disjoint_r empty_disjoint_l
  disjoint_range
  in_shift in_shift_inv
  in_elements elements_in : intv.


Require Import Coq.PArith.BinPos.
Require Import ExtLib.Core.RelDec.

Set Implicit Arguments.
Set Strict Implicit.

(* Decidable Instances *)
Global Instance RelDec_peq : RelDec (@eq positive) :=
{ rel_dec := Pos.eqb }.

Global Instance RelDec_plt : RelDec (Pos.lt) :=
{ rel_dec := Pos.ltb }.

Global Instance RelDec_ple : RelDec (Pos.le) :=
{ rel_dec := Pos.leb }.

Global Instance RelDec_pgt : RelDec (Pos.gt) :=
{ rel_dec := fun x y => negb (Pos.leb x y) }.

Global Instance RelDec_pge : RelDec (Pos.ge) :=
{ rel_dec := fun x y => negb (Pos.ltb x y) }.

Global Instance RelDec_Correct_peq : RelDec_Correct RelDec_peq.
Proof.
  constructor; simpl. intros.
  apply Pos.eqb_eq.
Qed.

Global Instance RelDec_Correct_plt : RelDec_Correct RelDec_plt.
Proof.
  constructor; simpl; intros.
  apply Pos.ltb_lt.
Qed.

Global Instance RelDec_Correct_ple : RelDec_Correct RelDec_ple.
Proof.
  constructor; simpl; intros.
  apply Pos.leb_le.
Qed.

Global Instance RelDec_Correct_pgt : RelDec_Correct RelDec_pgt.
Proof.
  constructor; simpl; intros.
  unfold rel_dec; simpl.
  rewrite <- Pos.ltb_antisym. rewrite Pos.ltb_lt.
  intuition; [ apply Pos.lt_gt | apply Pos.gt_lt ]; auto.
Qed.

Global Instance RelDec_Correct_pge : RelDec_Correct RelDec_pge.
Proof.
  constructor; simpl. intros.
  unfold rel_dec; simpl.
  rewrite <- Pos.leb_antisym. rewrite Pos.leb_le.
  intuition; [ apply Pos.le_ge | apply Pos.ge_le ]; auto.
Qed.

Export Coq.PArith.BinPos.


Require Import clight_expr_eq.
Require Import Clight.
Require Import ExtLib.Data.List.
Require Import ExtLib.Core.RelDec.
Require Import Coq.Bool.Bool.
Require Import ExtLib.Tactics.

Hint Resolve expr_beq_sound : expr_beq.

Instance RelDec_expr_beq : RelDec (@eq expr) :=
{ rel_dec := expr_beq }.

Instance RelDec_Correct_expr_beq : RelDec_Correct RelDec_expr_beq.
Proof.
  constructor.
  unfold rel_dec; simpl.
  exact expr_beq_spec.
Qed.

Fixpoint statement_beq s1 s2 :=
  match s1, s2 with
  | Sskip, Sskip
  | Sbreak, Sbreak
  | Scontinue, Scontinue => true
  | Sset id1 e1, Sset id2 e2 => andb (BinPos.Pos.eqb id1 id2) (expr_beq e1 e2)
  | Sassign e11 e21, Sassign e12 e22 =>  andb (expr_beq e11 e12) (expr_beq e21 e22)
  | Scall id1 e1 l1, Scall id2 e2 l2 => andb (andb (expr.eqb_option BinPos.Pos.eqb id1 id2) (expr_beq e1 e2)) (List.list_eqb _ l1 l2)
  | Sbuiltin _ _ _ _, Sbuiltin _ _ _ _ => false (*TODO*)
  | Ssequence st1 st2, Ssequence st3 st4
  | Sloop st1 st2, Sloop st3 st4 => andb (statement_beq st1 st3) (statement_beq st2 st4)
  | Sifthenelse e1 st1 st2, Sifthenelse e2 st3 st4 => andb (andb (statement_beq st1 st3) (statement_beq st2 st4)) (expr_beq e1 e2)
  | Sreturn e1, Sreturn e2 => expr.eqb_option expr_beq e1 e2
  | Slabel l1 s1, Slabel l2 s2 => andb (BinPos.Pos.eqb l1 l2) (statement_beq s1 s2)
  | Sgoto l1, Sgoto l2 => BinPos.Pos.eqb l1 l2
  | Sswitch e1 l1, Sswitch e2 l2 => andb (expr_beq e1 e2) (labeled_statements_beq l1 l2)
  | _ , _ => false
end
with labeled_statements_beq a b :=
match a, b with
| LSnil, LSnil => true
| LScons z1 s1 t1, LScons z2 s2 t2 => andb (andb (expr.eqb_option Zbool.Zeq_bool z1 z2) (statement_beq s1 s2)) (labeled_statements_beq t1 t2)
| _, _ => false
end.

Ltac destruct_ands :=
repeat rewrite andb_true_iff in *;
repeat
match goal with
| [ H: _ /\ _ |- _] => destruct H
end.

Lemma eqb_option_sound : forall T f a b,  (forall (x y : T), f x y = true -> x = y) -> expr.eqb_option f a b = true -> a = b.
Proof.
intros.
destruct a, b; auto; inversion H0.
Qed.

Hint Resolve eqb_option_sound : expr_beq.

Lemma statement_beq_sound : forall s1 s2, statement_beq s1 s2 = true -> s1 = s2
with labeled_statements_beq_sound : forall ls1 ls2, labeled_statements_beq ls1 ls2 = true -> ls1 = ls2.
Proof.
+ intro. destruct s1; intros; match goal with [ |- _ = ?s2] => destruct s2 end; try solve [repeat
  try reflexivity; try solve [inversion H]; try (simpl in H; try rewrite andb_true_iff in H; destruct_ands); f_equal; try apply eqb_option_sound in H; auto with expr_beq].
  - simpl in H. destruct_ands. apply eqb_option_sound in H; auto with expr_beq. f_equal;
                                                                                auto with expr_beq.
    consider (list_eqb RelDec_expr_beq l l0); auto.
+ intros. destruct ls1, ls2; try reflexivity; try solve [inversion H].
  simpl in H; destruct_ands; f_equal; auto with expr_beq.
  apply eqb_option_sound in H; auto with expr_beq.
  apply Zbool.Zeq_bool_eq.
Qed.


Require Import BaseTypes List ListUtils FunctionalExtensionality Lia PeanoNat.

Set Implicit Arguments.

Definition total_mem {A : Type} {AEQ : EqDec A} {V : Type} := A -> V.

Section GenTotal_Mem.
  Variable A : Type.
  Variable V : Type.
  Variable AEQ : EqDec A.

  (** Operations **)

  Definition upd (m : @total_mem A AEQ V) (a : A) (v : V) : @total_mem A AEQ V :=
    fun a' => if AEQ a' a then v else m a'.

  Definition upd_set (m : @total_mem A AEQ (V * list V)) (a : A) (v : V) : @total_mem A AEQ (V * list V) :=
    fun a' =>
      if AEQ a' a then
         (v, fst (m a) :: snd (m a))
      else
        m a'.

  Definition total_mem_map {V'} (f: V -> V') (m : @total_mem A AEQ V) : @total_mem A AEQ V' :=
    fun a => f (m a).

  Definition merge_set (m1: @total_mem A AEQ V)
             (m2: @total_mem A AEQ (V * list V)) : @total_mem A AEQ (V * list V) :=
  fun a =>((m1 a), fst (m2 a)::snd (m2 a)).

  Definition sync (m: @total_mem A AEQ (V * list V)) :=
    fun a => (fst (m a), nil: list V).

  Definition shift (shift_a: A -> A) (m:@total_mem A AEQ V) :=
    fun a => m (shift_a a).

  Fixpoint upd_batch m al vl :=
    match al, vl with
    | a::al', v::vl' => upd_batch (upd m a v) al' vl'
    | _, _ => m
    end.

  Fixpoint upd_batch_set m al vl :=
    match al, vl with
    | a::al', v::vl' => upd_batch_set (upd_set m a v) al' vl'
    | _, _ => m
    end.

  Fixpoint list_upd_batch (m: @total_mem A AEQ V) l_l_a l_l_v :=
  match l_l_a, l_l_v with
  | l_a :: lla, l_v :: llv =>
    list_upd_batch (upd_batch m l_a l_v) lla llv
  | _, _ => m
  end.

  Fixpoint list_upd_batch_set (m: @total_mem A AEQ (V * list V)) l_l_a l_l_v :=
  match l_l_a, l_l_v with
  | l_a :: lla, l_v :: llv =>
    list_upd_batch_set (upd_batch_set m l_a l_v) lla llv
  | _, _ => m
  end.

  Definition get_all_existing (m: @total_mem A AEQ V) al :=
    map m al.

  Definition select_for_addr {A AEQ V} (selection: @total_mem A AEQ nat) (a: A) (vs: V * list V) : V :=
    seln (fst vs :: snd vs) (selection a) (fst vs).

  Definition select_total_mem {A AEQ V} (selection: @total_mem A AEQ nat) (m: @total_mem A AEQ (V * list V)) : @total_mem A AEQ (V * list V) :=
    fun a => (select_for_addr selection a (m a), nil).

   Definition select_list_shifted {V} n (selection: @total_mem addr addr_dec nat) (l: list (V * list V)) : list V :=
   indexed_map_shifted n (select_for_addr selection) l.

  (** Properties **)

  (** Facts **)
  Theorem upd_eq : forall m (a : A) (v : V) a',
    a' = a -> upd m a v a' = v.
  Proof.
    intros; subst; unfold upd.
    destruct (AEQ a a); tauto.
  Qed.

  Theorem upd_ne : forall m (a : A) (v : V) a',
    a' <> a -> upd m a v a' = m a'.
  Proof.
    intros; subst; unfold upd.
    destruct (AEQ a' a); tauto.
  Qed.

  Theorem upd_repeat: forall m (a : A) (v v':V),
    upd (upd m a v') a v = upd m a v.
  Proof.
    intros; apply functional_extensionality; unfold upd; intros.
    destruct (AEQ a a); try congruence.
    destruct (AEQ x a); auto.
  Qed.

  Theorem upd_nop: forall m (a : A) (v : V),
    m a = v ->
    upd m a v = m.
  Proof.
    intros; apply functional_extensionality; intros.
    case_eq (AEQ a x); intros; subst.
    repeat erewrite upd_eq; eauto.
    repeat rewrite upd_ne; auto.
  Qed.

  Theorem upd_comm: forall m (a0 : A) (v0 : V) a1 v1, a0 <> a1
    -> upd (upd m a0 v0) a1 v1 = upd (upd m a1 v1) a0 v0.
  Proof.
    intros; apply functional_extensionality; unfold upd; intros.
    destruct (AEQ a1 a0); destruct (AEQ a0 a1); try congruence.
    case_eq (AEQ x a1); case_eq (AEQ x a0); intros; subst; try congruence.
  Qed.

End GenTotal_Mem.

  Lemma sync_upd_set_comm:
    forall A AEQ V (m: @total_mem A AEQ (V * list V)) a v,
      sync (upd_set m a v) = upd (sync m) a (v, nil).
  Proof.
    intros.
    extensionality x; simpl.
    unfold sync, upd_set; simpl.
    destruct (AEQ x a); subst; eauto.
    destruct (m a); try congruence.
    rewrite upd_eq; eauto.
    rewrite upd_ne; eauto.
  Qed.

  Lemma sync_upd_batch_set_comm:
    forall A AEQ V l_a l_v (m: @total_mem A AEQ (V * list V)),
      sync (upd_batch_set m l_a l_v) = upd_batch (sync m) l_a (map (fun v => (v, nil)) l_v).
  Proof.
    induction l_a; simpl; intros; eauto.
    destruct l_v; simpl; eauto.
    rewrite IHl_a.
    rewrite sync_upd_set_comm; eauto.
  Qed.

  Lemma sync_idempotent:
    forall A AEQ V (m: @total_mem A AEQ (V * list V)),
      sync (sync m) = sync m.
  Proof.
    intros; extensionality x.
    unfold sync; simpl.
    destruct (m x); simpl; eauto.
  Qed.

  Lemma upd_batch_upd:
    forall A AEQ V l_a l_v a v (m: @total_mem A AEQ V),
      ~In a l_a ->
      upd_batch (upd m a v) l_a l_v = upd (upd_batch m l_a l_v) a v.
  Proof.
    induction l_a; simpl; intros;
    eauto.
    destruct l_v; simpl; eauto.
    destruct (AEQ a0 a); subst.
    exfalso; eauto.
    rewrite upd_comm; eauto.
  Qed.

  Lemma sync_upd_comm:
  forall A AEQ V (m: @total_mem A AEQ (V * list V)) a vs,
    sync (upd m a vs) = upd (sync m) a (fst vs, nil).
Proof.
  unfold sync; intros; extensionality x; simpl.
  destruct (AEQ a x); subst; eauto.
  repeat rewrite upd_eq; simpl; eauto.
  repeat rewrite upd_ne; eauto.
Qed.

Lemma upd_set_ne:
  forall A AEQ V (m: @total_mem A AEQ (V * list V)) a a' v,
    a <> a' ->
    upd_set m a v a' = m a'.
Proof.
  unfold upd_set; intros.
  destruct (AEQ a' a); intuition eauto.
  congruence.
Qed.

Lemma upd_batch_set_ne:
  forall A AEQ V l_a l_v (m: @total_mem A AEQ (V * list V)) a,
    ~In a l_a ->
    upd_batch_set m l_a l_v a = m a.
Proof.
  induction l_a; simpl; intros; eauto.
  destruct l_v; eauto.
  rewrite IHl_a; eauto.
  rewrite upd_set_ne; eauto.
Qed.

Lemma upd_batch_app:
  forall A AEQ V l1 l2 l3 l4 (m: @total_mem A AEQ V),
    length l1 = length l3 ->
    upd_batch m (l1++l2) (l3++l4) = upd_batch (upd_batch m l1 l3) l2 l4.
Proof.
  induction l1; simpl; intros; eauto;
  destruct l3; simpl in *; try lia; eauto.
Qed.

Lemma upd_batch_ne:
  forall A AEQ V l_a l_v (m: @total_mem A AEQ V) a,
    ~In a l_a ->
    upd_batch m l_a l_v a = m a.
Proof.
  induction l_a; simpl; intros; eauto.
  destruct l_v; eauto.
  rewrite IHl_a; eauto.
  apply upd_ne; eauto.
Qed.

Lemma upd_set_upd_some:
  forall A AEQ V (m: @total_mem A AEQ (V * list V)) a v vs,
    m a = vs ->
    upd_set m a v = upd m a (v, fst vs :: snd vs).
Proof.
  intros.
  unfold upd_set; rewrite H; eauto.
Qed.

Lemma list_upd_batch_set_not_in:
  forall A AEQ V l_l_a l_l_v (m: @total_mem A AEQ (V * list V)) a,
    (forall l_a, In l_a l_l_a -> ~In a l_a) ->
    list_upd_batch_set m l_l_a l_l_v a = m a.
Proof.
  induction l_l_a; simpl; intros; eauto.
  destruct l_l_v; eauto.
  rewrite IHl_l_a; eauto.
  rewrite upd_batch_set_ne; eauto.
Qed.

Lemma sync_list_upd_batch_set:
  forall A AEQ V l_l_a l_l_v (m: @total_mem A AEQ (V * list V)),
    sync (list_upd_batch_set m l_l_a l_l_v) =
    list_upd_batch (sync m) l_l_a (map (map (fun v => (v, nil))) l_l_v).
Proof.
  induction l_l_a; simpl; intros; eauto.
  destruct l_l_v; simpl; eauto.
  rewrite IHl_l_a; eauto.
  rewrite sync_upd_batch_set_comm; eauto.
Qed.

Lemma list_upd_batch_not_in:
  forall A AEQ V l_l_a l_l_v (m: @total_mem A AEQ V) a,
    (forall l_a, In l_a l_l_a -> ~In a l_a) ->
    list_upd_batch m l_l_a l_l_v a = m a.
Proof.
  induction l_l_a; simpl; intros; eauto.
  destruct l_l_v; eauto.
  rewrite IHl_l_a; eauto.
  eapply upd_batch_ne; eauto.
Qed.

Lemma select_list_shifted_length:
  forall V (l: list (V * list V)) n selection,
    length(select_list_shifted n selection l) = length l.
Proof.
  induction l; simpl; eauto.
Qed.

Lemma select_list_shifted_seln:
  forall V (l: list (V * list V)) i n selection def1 def2,
    i < length l ->
    seln (select_list_shifted n selection l) i def1 =
    select_for_addr selection (n + i) (seln l i def2).
Proof.
  induction l; simpl; intros; eauto.
  lia.
  destruct i; simpl; eauto.
  rewrite Nat.add_0_r; eauto.
  unfold select_list_shifted in *; erewrite IHl.
  replace (S n + i) with (n + S i) by lia; eauto.
  lia.
Qed.

Lemma select_for_addr_synced:
  forall A AEQ V (selection: @total_mem A AEQ nat) (a: A) (vs: V * list V),
    snd vs = nil ->
    select_for_addr selection a vs = fst vs.
Proof.
  unfold select_for_addr; simpl; intros.
  destruct (selection a); simpl; eauto.
  destruct n; eauto.
  rewrite H; simpl; eauto.
  rewrite H; simpl; eauto.
Qed.

Lemma select_list_shifted_synced:
  forall V (l: list (V * list V)) selection n,
    (forall vs, In vs l -> snd vs = nil) ->
    select_list_shifted n selection l = map fst l.
Proof.
  induction l; simpl; eauto; intros.
  unfold select_list_shifted in *; simpl.
  rewrite IHl; eauto.
  rewrite select_for_addr_synced; eauto.
Qed.

  Lemma total_mem_map_upd_comm:
    forall A AEQ V1 V2 (m: @total_mem A AEQ V1) a v (f: V1 -> V2),
      total_mem_map f (upd m a v) = upd (total_mem_map f m) a (f v).
  Proof.
    intros. unfold total_mem_map.
    extensionality x.
    destruct (AEQ a x); subst;
    [ repeat rewrite upd_eq; eauto
    | repeat rewrite upd_ne; eauto].
  Qed.

  Definition sumbool_agree {A B C D} (eq1: {A}+{B})(eq2: {C}+{D}):=
    if eq1 then
      if eq2 then
        True
      else
        False
    else
      if eq2 then
        False
      else
        True.

  Lemma upd_shift_comm:
    forall A AEQ V (m: @total_mem A AEQ V) (f: A -> A) a v,
      (forall x y, sumbool_agree (AEQ x y) (AEQ (f x) (f y))) ->
      upd (shift f m) a v = shift f (upd m (f a) v).
  Proof.
    unfold sumbool_agree; intros; simpl.
    extensionality x; simpl.
    specialize (H a x).
    unfold shift.
    destruct (AEQ a x);
    destruct (AEQ (f a) (f x)); subst; intuition;
    [ repeat rewrite upd_eq
    | repeat rewrite upd_ne]; eauto.
  Qed.

  Lemma upd_merge_set_cons_comm:
    forall A AEQ V (m1: @total_mem A AEQ V) m2 a v0 v1 vl,
      upd (merge_set m1 m2) a (v0, v1::vl) = merge_set (upd m1 a v0) (upd m2 a (v1, vl)).
  Proof.
    unfold merge_set; intros.
    extensionality x; simpl.
    destruct (AEQ a x); subst; intuition;
    [ repeat rewrite upd_eq
    | repeat rewrite upd_ne]; eauto.
  Qed.

  Lemma total_mem_map_fst_some_elim:
      forall A AEQ V1 V2 (m: @total_mem A AEQ (V1 * V2)) a v vs,
        m a = (v, vs) ->
        total_mem_map fst m a = v.
  Proof.
    intros.
    unfold total_mem_map; simpl; rewrite H; eauto.
  Qed.

  Lemma total_mem_map_fst_some_exists:
      forall A AEQ V1 V2 (m: @total_mem A AEQ (V1 * V2)) a v,
        total_mem_map fst m a = v ->
        exists vs, m a = (v, vs).
  Proof.
    intros.
    unfold total_mem_map in *; simpl.
    destruct (m a).
    simpl in *; subst; eauto.
  Qed.

  Definition synced_from {V} a (m: @total_mem nat Nat.eq_dec (V * list V)):=
    forall a', a' >= a -> (sync m) a' = m a'.

  (*
  Lemma upd_batch_eq:
  forall A AEQ V l1 l2 (m: @total_mem A AEQ V) a i,
    nth_error l1 i = Some a ->
    ~In a (skipn (S i) l1) ->
    length l1 = length l2 ->
    upd_batch m l1 l2 a = nth_error l2 i.
Proof.
  induction l1; simpl in *; intros; eauto.
  congruence.

  destruct l2; simpl in *; try lia.
  destruct i; subst; simpl in *.
  -
    rewrite upd_batch_ne; eauto.
    apply upd_eq; eauto.
    congruence.

  - erewrite IHl1; eauto.
Qed.
*)

Lemma upd_batch_set_app:
  forall A AEQ V l1 l2 l3 l4 (m: @total_mem A AEQ (V * list V)),
    length l1 = length l3 ->
    upd_batch_set m (l1++l2) (l3++l4) = upd_batch_set (upd_batch_set m l1 l3) l2 l4.
Proof.
  induction l1; simpl; intros; eauto.
  destruct l3; simpl in *; eauto; lia.
  destruct l3; simpl in *; try lia.
  rewrite IHl1; eauto.
Qed.

Lemma upd_batch_set_seq_in:
  forall V n start l i j (m: @total_mem addr addr_dec (V * list V)) vs def,
    m j = vs ->
    j = start + i ->
    i < n ->
    length l = n ->
    upd_batch_set m (seq start n) l j = (seln l i def, fst vs :: snd vs).
Proof.
  induction n; simpl; intros; eauto; try lia.
  destruct l; simpl in *; subst; try lia.
  destruct i; simpl in *; eauto.
  rewrite Nat.add_0_r in *.
  rewrite upd_batch_set_ne; eauto.
  unfold upd_set; subst; eauto.
  destruct (addr_dec start start); subst;
  intuition eauto; try lia.
  intros Hx; apply in_seq in Hx; lia.
  specialize IHn with (i:= i) (start:= S start); simpl in *.
  erewrite <- IHn.
  replace (S (start + i)) with (start + S i) by lia; eauto.
  rewrite upd_set_ne; eauto.
  all: lia.
Qed.

Lemma select_list_shifted_select_0:
  forall V (l: list (V * list V)) n selector,
    (forall i, i < length l -> selector (n + i) = 0) ->
    select_list_shifted n selector l = map fst l.
Proof.
  unfold select_list_shifted; induction l;
  simpl; intros; eauto.
  erewrite IHl; eauto.
  unfold select_for_addr.
  setoid_rewrite <- Nat.add_0_r at 2.
  rewrite H; eauto.
  lia.
  intros.
  rewrite Nat.add_succ_comm.
  eapply H; lia.
Qed.

Lemma select_list_shifted_app:
  forall V (l' l: list (V * list V)) n selector,
    select_list_shifted n selector (l++l') =
    select_list_shifted n selector l ++
                        select_list_shifted (n + length l) selector l'.
Proof.
  induction l; simpl; intros; eauto.
  unfold select_list_shifted; simpl.
  rewrite Nat.add_0_r; eauto.
  unfold select_list_shifted in *; simpl.
  rewrite IHl.
  replace (n + S (length l)) with (S n + length l) by lia; eauto.
Qed.

Lemma select_for_addr_not_1_latest :
  forall A AEQ V (selector: @total_mem A AEQ nat) (n: A) (v1 v2: V),
    selector n <> 1 ->
    select_for_addr selector n (v1, v2::nil) = v1.
Proof.
  unfold select_for_addr; intros; simpl.
  destruct (selector n); simpl; eauto.
  destruct n0; simpl; eauto.
  congruence.
Qed.

Lemma map_noop:
  forall A l (f: A -> A),
    (forall a, In a l -> f a = a) ->
    map f l = l.
Proof.
  induction l; simpl; intuition eauto.
  rewrite IHl; eauto.
  rewrite H; eauto.
Qed.

Lemma shift_select_total_mem_comm:
  forall A AEQ V (m: @total_mem A AEQ (V * list V)) f (selector: @total_mem A AEQ nat),
    select_total_mem (shift f selector) (shift f m) = shift f (select_total_mem selector m).
Proof.
  intros; unfold select_total_mem, select_for_addr, shift; eauto.
Qed.

Lemma sync_shift_comm:
  forall A AEQ V (m: @total_mem A AEQ (V * list V)) f,
    sync (shift f m) = shift f (sync m).
Proof.
  unfold shift, sync; intros; simpl; eauto.
Qed.

Lemma select_total_mem_upd_comm:
  forall A AEQ V (a: A) (vs: V * list V) (selector: @total_mem A AEQ nat) (m: @total_mem A AEQ _),
    snd vs = nil ->
    select_total_mem selector (upd m a vs) =
    upd (select_total_mem selector m) a vs.
Proof.
  intros; unfold select_total_mem, select_for_addr, upd; simpl; intros.
  destruct vs; simpl in *; subst.
  extensionality x.

  destruct (AEQ x a); subst; eauto.
  destruct (selector a); simpl; eauto.
Qed.

Lemma select_total_mem_upd_batch_comm:
  forall A AEQ V (l_a: list A) (l_vs: list (V * list V)) (selector: @total_mem A AEQ nat) (m: @total_mem A AEQ _),
    Forall (fun vs => snd vs = nil) l_vs ->

    select_total_mem selector (upd_batch m l_a l_vs) =
    upd_batch (select_total_mem selector m) l_a l_vs.
Proof.
  induction l_a; simpl; intros; eauto.
  destruct l_vs; simpl in *; eauto.
  rewrite IHl_a; eauto.
  rewrite select_total_mem_upd_comm; eauto.
  all: inversion H; intuition eauto.
Qed.

Lemma select_total_mem_list_upd_batch_comm:
  forall A AEQ V (l_l_a: list (list A)) (l_l_vs: list (list (V * list V)))
  (selector: @total_mem A AEQ nat) (m: @total_mem A AEQ _),
    Forall (fun l_vs => Forall (fun vs => snd vs = nil) l_vs) l_l_vs ->
    select_total_mem selector (list_upd_batch m l_l_a l_l_vs) =
    list_upd_batch (select_total_mem selector m) l_l_a l_l_vs.
Proof.
  induction l_l_a; simpl in *; intros; eauto.
  destruct l_l_vs; eauto.
  erewrite IHl_l_a.
  rewrite select_total_mem_upd_batch_comm; eauto.
  all: inversion H; intuition eauto.
Qed.

Lemma sync_select_total_mem_noop:
  forall A AEQ V (selector: @total_mem A AEQ nat) (m: @total_mem A AEQ (V * list V)),
    sync (select_total_mem selector m) = select_total_mem selector m.
Proof.
  unfold sync, select_total_mem; intros; simpl; eauto.
Qed.

Lemma list_upd_batch_app:
      forall A AEQ V l1 l2 l3 l4 (m: @total_mem A AEQ V),
        length l1 = length l3 ->
        list_upd_batch m (l1++l2) (l3++l4) = list_upd_batch (list_upd_batch m l1 l3) l2 l4.
Proof.
  induction l1; destruct l3; simpl; intros; eauto; lia.
Qed.

Lemma list_upd_batch_set_app:
  forall A AEQ V l1 l2 l3 l4 (m: @total_mem A AEQ (V * list V)),
    length l1 = length l3 ->
    list_upd_batch_set m (l1++l2) (l3++l4) = list_upd_batch_set (list_upd_batch_set m l1 l3) l2 l4.
Proof.
  induction l1; destruct l3; simpl; intros; eauto; lia.
Qed.

Lemma shift_upd_batch_comm:
  forall A AEQ V f l1 l2 (m: @total_mem A AEQ V),
    (forall x y : A, sumbool_agree (AEQ x y) (AEQ (f x) (f y))) ->
    upd_batch (shift f m) l1 l2 = shift f (upd_batch m (map f l1) l2).
Proof.
  induction l1; destruct l2; simpl; intros; eauto.
  rewrite upd_shift_comm; eauto.
Qed.

Lemma shift_eq_after:
  forall V (m1 m2: @total_mem addr addr_dec V) f,
    (forall a, f a >= f 0)  ->
    (forall a, a >= f 0 -> m1 a = m2 a) ->
    shift f m1 = shift f m2.
Proof.
  unfold shift; intros; extensionality x; eauto.
Qed.

Lemma shift_upd_set_comm:
  forall A AEQ V f a v (m: @total_mem A AEQ (V * list V)),
    (forall x y : A, sumbool_agree (AEQ x y) (AEQ (f x) (f y))) ->
    shift f (upd_set m (f a) v) =
    upd_set (shift f m) a v.
Proof.
  unfold sumbool_agree, upd_set, shift; simpl; intros; eauto.
  extensionality x; simpl.
  specialize (H x a).
  destruct (AEQ x a); subst.
  destruct (AEQ (f a) (f a)); subst; intuition eauto.
  destruct (AEQ (f x) (f a)); intuition eauto.
Qed.

Lemma shift_upd_batch_set_comm:
  forall A AEQ V f l1 l2 (m: @total_mem A AEQ (V * list V)),

    (forall x y : A, sumbool_agree (AEQ x y) (AEQ (f x) (f y))) ->
    shift f (upd_batch_set m (map f l1) l2) =
    upd_batch_set (shift f m) l1 l2.
Proof.
  induction l1; destruct l2; simpl; intros; eauto.
  rewrite IHl1; eauto.
  rewrite shift_upd_set_comm; eauto.
Qed.

Lemma shift_list_upd_batch_set_comm:
  forall A AEQ V f l1 l2 (m: @total_mem A AEQ (V * list V)),
    (forall x y : A, sumbool_agree (AEQ x y) (AEQ (f x) (f y))) ->
    shift f (list_upd_batch_set m (map (map f) l1) l2) =
    list_upd_batch_set (shift f m) l1 l2.
Proof.
  induction l1; destruct l2; simpl; intros; eauto.
  rewrite IHl1; eauto.
  rewrite shift_upd_batch_set_comm; eauto.
Qed.

Lemma shift_upd_noop:
  forall A AEQ V f (m: @total_mem A AEQ V) a v,
    (forall a', f a' <> a) ->
    shift f (upd m a v) = shift f m.
Proof.
  unfold shift, upd; intros.
  extensionality x.
  destruct (AEQ (f x) a); eauto; congruence.
Qed.

Lemma shift_upd_set_noop:
  forall A AEQ V f (m: @total_mem A AEQ (V * list V)) a v,
    (forall a', f a' <> a) ->
    shift f (upd_set m a v) = shift f m.
Proof.
  unfold shift, upd_set; intros.
  extensionality x.
  destruct (AEQ (f x) a); eauto; congruence.
Qed.

Lemma total_mem_map_shift_comm:
  forall A AEQ V1 V2 (f: V1 -> V2) s (m: @total_mem A AEQ V1),
    total_mem_map f (shift s m) = shift s (total_mem_map f m).
Proof.
  unfold total_mem_map, shift; intros; extensionality a.
  eauto.
Qed.

Lemma total_mem_map_fst_upd_set:
  forall A AEQ V a v (m: @total_mem A AEQ (V * list V)),
    total_mem_map fst (upd_set m a v) = upd (total_mem_map fst m) a v.
Proof.
  unfold upd_set, upd, total_mem_map; intros; simpl.
  extensionality x.
  destruct (AEQ x a); subst; eauto.
Qed.

Lemma total_mem_map_fst_upd_batch_set:
  forall A AEQ V l_a l_v (m: @total_mem A AEQ (V * list V)),
    total_mem_map fst (upd_batch_set m l_a l_v) = upd_batch (total_mem_map fst m) l_a l_v.
Proof.
  induction l_a; intros; simpl; eauto.
  destruct l_v; eauto.
  rewrite IHl_a.
  rewrite total_mem_map_fst_upd_set; eauto.
Qed.

Lemma total_mem_map_fst_list_upd_batch_set:
  forall A AEQ V l_a l_v (m: @total_mem A AEQ (V * list V)),
    total_mem_map fst (list_upd_batch_set m l_a l_v) = list_upd_batch (total_mem_map fst m) l_a l_v.
Proof.
  induction l_a; intros; simpl; eauto.
  destruct l_v; eauto.
  rewrite IHl_a.
  rewrite total_mem_map_fst_upd_batch_set; eauto.
Qed.

Lemma total_mem_map_fst_sync_noop:
  forall A AEQ V (m: @total_mem A AEQ (V * list V)),
    total_mem_map fst (sync m) = total_mem_map fst m.
Proof.
  unfold total_mem_map, sync; simpl; intros; eauto.
Qed.

Lemma upd_batch_list_upd_batch_app_rev:
  forall A AEQ V (m: @total_mem A AEQ V) l_l_a l_l_v l_a l_v,
    length l_l_a = length l_l_v ->
    upd_batch (list_upd_batch m l_l_a l_l_v) l_a l_v =
    list_upd_batch m (l_l_a ++ (l_a::nil)) (l_l_v ++ (l_v::nil)).
Proof.
  intros; rewrite list_upd_batch_app ; simpl; eauto.
Qed.

Lemma rev_cons_app:
  forall A (l l': list A) a,
    rev l = a::l' ->
    l = rev l' ++ (a::nil).
Proof.
  induction l; simpl;
  intros; try congruence.

  destruct (rev l') eqn:D.
  {
    rewrite <- rev_involutive with (l:= l') in H.
    rewrite D in H.
    simpl in *.
    destruct l; simpl in *; eauto.
    assert (AX: length ((rev l ++ (a1::nil)) ++ (a::nil)) = length (a0::nil)). {
      rewrite H; eauto.
    }
    repeat rewrite app_length in *; simpl in *; lia.
  }
  {
    rewrite <- rev_involutive with (l:= l') in H.
    rewrite D in H.
    simpl in *.
    rewrite app_comm_cons in H.
    apply app_inj_tail in H; intuition subst.
    erewrite IHl.
    rewrite rev_involutive; eauto.
    eauto.
  }
Qed.

Lemma upd_batch_upd_in_noop:
  forall A AEQ V l_a l_v (m: @total_mem A AEQ V) a v,
    In a l_a ->
    length l_a = length l_v ->
    upd_batch (upd m a v) l_a l_v =
    upd_batch m l_a l_v.
Proof.
  intros.
  apply in_split_first in H; eauto; subst.
  do 2 destruct H.
  intuition; subst.
  rewrite app_length in *; simpl in *.
  rewrite <- firstn_skipn with (l:= l_v) (n:= length x).
  repeat rewrite upd_batch_app.
  destruct (skipn (length x) l_v) eqn:D.
  { (** Impossible **)
    apply length_zero_iff_nil in D.
    rewrite skipn_length in D; lia.
  }
  {
    simpl.
    setoid_rewrite upd_batch_upd at 2; eauto.
    rewrite upd_repeat; eauto.
  }
  all: rewrite firstn_length_l; lia.
Qed.

Lemma upd_batch_in_cons_noop:
  forall A AEQ V l_a l_v a v (m: @total_mem A AEQ V),
    In a l_a ->
    length l_a = length l_v ->
    upd_batch m (a::l_a) (v::l_v) =
    upd_batch m l_a l_v.
Proof.
  induction l_a; simpl; intuition eauto.
  {
    subst; destruct l_v; simpl in *; try lia.
    rewrite upd_repeat; eauto.
  }
  {
    subst; destruct l_v; simpl in *; try lia.
    destruct (AEQ a a0); subst.
    rewrite upd_repeat; eauto.
    rewrite upd_comm; eauto.
  }
Qed.

Lemma upd_batch_upd_batch_noop:
  forall A AEQ V l_a l_v1 l_v2 (m: @total_mem A AEQ V),
    length l_a = length l_v1 ->
    length l_a = length l_v2 ->
    upd_batch (upd_batch m l_a l_v1) l_a l_v2 =
    upd_batch m l_a l_v2.
Proof.
  induction l_a; intros; eauto.
  destruct l_v1, l_v2; try lia; eauto.
  simpl in *; lia.

  destruct (in_dec AEQ a l_a).
  repeat rewrite upd_batch_in_cons_noop; eauto.
  simpl.
  rewrite <- upd_batch_upd; eauto.
  rewrite IHl_a; eauto.
  rewrite upd_repeat; eauto.
Qed.

Lemma upd_upd_batch_app_rev:
  forall A AEQ V (m: @total_mem A AEQ V) a v l_a l_v,
    length l_a = length l_v ->
    upd (upd_batch m l_a l_v) a v =
    upd_batch m (l_a ++ (a::nil)) (l_v ++ (v::nil)).
Proof.
  intros; rewrite upd_batch_app ; simpl; eauto.
Qed.

Lemma upd_batch_firstn_noop:
  forall A AEQ V l_a l_v (s: @total_mem A AEQ V) n,
    length l_a = length l_v ->
    upd_batch (upd_batch s (firstn n l_a) (firstn n l_v)) l_a l_v =
    upd_batch s l_a l_v.
Proof.
  intros A AEQ V l_a.
  eapply rev_ind with
      (P:= fun l_a =>
             forall (l_v : list V) (s : total_mem) (n : nat),
               length l_a = length l_v ->
               upd_batch (upd_batch s (firstn n l_a) (firstn n l_v))
                         l_a l_v = upd_batch s l_a l_v).

  simpl; intros.
  repeat rewrite firstn_nil; simpl; eauto.

  simpl; intros.
  destruct (rev l_v) eqn:D; simpl; eauto.
  {
    destruct l_v; simpl in *; try congruence.
    repeat rewrite firstn_nil; simpl; eauto.
    destruct (l ++ (x::nil)); simpl.
    destruct (firstn n nil); simpl; eauto.
    destruct (firstn n (a :: l0)); simpl; eauto.
    apply app_eq_nil in D; intuition; congruence.
  }
  {
    apply rev_cons_app in D.
    subst.
    repeat rewrite app_length in *; simpl in *.
    repeat rewrite upd_batch_app by lia; simpl.
    destruct (Compare_dec.le_dec n (length l)).
    repeat rewrite firstn_app_l by lia.
    rewrite H by lia; eauto.
    repeat rewrite firstn_oob by (rewrite app_length; simpl; lia).
    repeat rewrite upd_upd_batch_app_rev by lia.
    rewrite upd_batch_upd_batch_noop; eauto.
    repeat rewrite app_length; simpl; eauto.
    repeat rewrite app_length; simpl; eauto.
  }
Qed.

Lemma upd_to_upd_batch_singleton:
  forall A AEQ V (m: @total_mem A AEQ V) a v,
    upd m a v = upd_batch m (a::nil) (v::nil).
Proof.
  eauto.
Qed.

Lemma upd_batch_to_list_upd_batch_singleton:
  forall A AEQ V (m: @total_mem A AEQ V) l_a l_v,
    upd_batch m l_a l_v = list_upd_batch m (l_a::nil) (l_v::nil).
Proof.
  eauto.
Qed.

Lemma upd_list_upd_batch_upd_noop:
  forall A AEQ V  l_l_a l_l_v a v1 v2 (s: @total_mem A AEQ V),
    Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v ->
    upd (list_upd_batch (upd s a v1) l_l_a l_l_v) a v2 =
    upd (list_upd_batch s l_l_a l_l_v) a v2.
Proof.
  induction l_l_a; intros; eauto.
  apply upd_repeat; eauto.
  eapply forall2_length in H as Hx.
  destruct l_l_v;
  try solve [simpl in *; lia].
  simpl.
  destruct (in_dec AEQ a0 a).
  rewrite upd_batch_upd_in_noop; eauto.
  inversion H; lia.
  rewrite upd_batch_upd; eauto.
  rewrite IHl_l_a; eauto.
  inversion H; eauto.
Qed.

Lemma upd_batch_list_upd_batch_upd_batch_noop:
  forall A AEQ V l_a l_v1 l_v2 l_l_a l_l_v (s: @total_mem A AEQ V),
    Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v ->
    length l_a = length l_v1 ->
    length l_a = length l_v2 ->
    upd_batch (list_upd_batch (upd_batch s l_a l_v1) l_l_a l_l_v) l_a l_v2 =
    upd_batch (list_upd_batch s l_l_a l_l_v) l_a l_v2.
Proof.
  induction l_a; intros; eauto.
  destruct l_v1, l_v2;
  try solve [simpl in *; lia].
  destruct (in_dec AEQ a l_a).
  repeat rewrite upd_batch_in_cons_noop; eauto.

  simpl.
  repeat rewrite upd_batch_upd; eauto.
  setoid_rewrite upd_to_upd_batch_singleton at 2.
  setoid_rewrite upd_batch_to_list_upd_batch_singleton at 2.
  rewrite <- list_upd_batch_app.
  rewrite IHl_a; eauto.
  simpl.
  rewrite <- upd_batch_upd; eauto.
  rewrite upd_list_upd_batch_upd_noop; eauto.
  rewrite upd_batch_upd; eauto.
  apply Forall2_app; simpl; eauto.
  simpl; eauto.
Qed.

Lemma upd_batch_list_upd_batch_upd_batch_firstn_noop:
  forall A AEQ V l_a l_v1 l_v2 l_l_a l_l_v (s: @total_mem A AEQ V) n,
    Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v ->
    length l_a = length l_v1 ->
    length l_a = length l_v2 ->
    upd_batch (list_upd_batch (upd_batch s (firstn n l_a) (firstn n l_v1)) l_l_a l_l_v) l_a l_v2 =
    upd_batch (list_upd_batch s l_l_a l_l_v) l_a l_v2.
Proof.
  induction l_a; intros; eauto.
  destruct l_v1, l_v2;
  try solve [simpl in *; lia].
  repeat rewrite firstn_nil; simpl; eauto.

  destruct l_v1, l_v2;
  try solve [simpl in *; lia].
  destruct n.
  simpl; eauto.
  destruct (in_dec AEQ a (firstn n l_a)).

  {
    simpl firstn.
    repeat rewrite upd_batch_in_cons_noop; eauto.
    eapply in_firstn_in; eauto.
    repeat rewrite firstn_length; simpl in *; lia.
    eapply in_firstn_in; eauto.
  }
  {
    simpl firstn.
    simpl upd_batch at 2.
    rewrite upd_batch_upd; eauto.
    simpl.
    rewrite upd_list_upd_batch_upd_noop; eauto.

    destruct (in_dec AEQ a l_a).
    repeat rewrite upd_batch_upd_in_noop; eauto.
    repeat rewrite upd_batch_upd; eauto.
    rewrite IHl_a; eauto.
  }
Qed.

Lemma list_upd_batch_noop:
  forall A AEQ V l_l_a l_l_v1 l_l_v2 (s: @total_mem A AEQ V),
    Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v1 ->
    Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v2 ->
    list_upd_batch (list_upd_batch s l_l_a l_l_v1) l_l_a l_l_v2 =
    list_upd_batch s l_l_a l_l_v2.
Proof.
  intros A AEQ V l_l_a.
  eapply rev_ind with
      (P:= fun l_l_a =>
             forall (l_l_v1 l_l_v2 : list (list V)) (s : total_mem),
               Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v1 ->
               Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v2 ->
               list_upd_batch (list_upd_batch s l_l_a l_l_v1) l_l_a l_l_v2 =
               list_upd_batch s l_l_a l_l_v2).
  {
    simpl; intros; eauto.
  }
  {
    intros.
    eapply forall2_length in H0 as Hx;
    eapply forall2_length in H1 as Hx0.
    repeat rewrite app_length in *.
    destruct (nil_or_app l_l_v1);
    subst; try solve [simpl in *; lia].
    destruct (nil_or_app l_l_v2);
    subst; try solve [simpl in *; lia].
    do 2 destruct H2.
    do 2 destruct H3.
    subst.

    repeat rewrite app_length in *.
    repeat rewrite list_upd_batch_app.
    simpl.
    rewrite upd_batch_list_upd_batch_upd_batch_noop; eauto.
    rewrite H; eauto.

    apply Forall2_app_split in H0; intuition eauto.
    simpl in *; lia.
    apply Forall2_app_split in H1;
    intuition eauto.
    simpl in *; lia.
    apply Forall2_app_split in H1; intuition eauto.
    simpl in *; lia.
    apply Forall2_app_split in H0; intuition eauto.
    inversion H3; eauto.
    simpl in *; lia.
    apply Forall2_app_split in H1; intuition eauto.
    inversion H3; eauto.
    all: simpl in *; lia.
  }
Qed.

Lemma list_upd_batch_firstn_noop:
  forall A AEQ V l_l_a l_l_v (s: @total_mem A AEQ V) n m,
    Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v ->
    list_upd_batch (list_upd_batch s (firstn n l_l_a ++ (firstn m (seln l_l_a n nil)::nil)) (firstn n l_l_v ++ (firstn m (seln l_l_v n nil)::nil))) l_l_a l_l_v =
    list_upd_batch s l_l_a l_l_v.
Proof.

  intros A AEQ V l_l_a.
  eapply rev_ind with
      (P:= fun l_l_a =>
             forall (l_l_v : list (list V)) (s : total_mem) (n m : nat),
               Forall2 (fun (l_a : list A) (l_v : list V) => length l_a = length l_v) l_l_a l_l_v ->
               list_upd_batch (list_upd_batch s (firstn n l_l_a ++ (firstn m (seln l_l_a n nil)::nil)) (firstn n l_l_v ++ (firstn m (seln l_l_v n nil)::nil))) l_l_a l_l_v =
    list_upd_batch s l_l_a l_l_v).
  {
    simpl; intros; eauto.
    repeat rewrite firstn_nil; simpl; eauto.
    destruct (firstn n l_l_v ++ (firstn m (seln l_l_v n nil)::nil));
    eauto.
  }
  {
    intros.
    eapply forall2_length in H0 as Hx.
    rewrite app_length in *.
    destruct (nil_or_app l_l_v); subst;
    try solve [simpl in *; lia].
    do 2 destruct H1; subst.
    rewrite app_length in *.
    {
      repeat rewrite list_upd_batch_app by (simpl in *; lia); simpl.
      destruct (Compare_dec.le_dec n (length l)).
      {
        repeat rewrite firstn_app_l by (simpl in *; lia).
        simpl in *.
        apply Forall2_app_split in H0; intuition subst.
        inversion H2; subst.
        inversion l0; subst.
        {
          rewrite firstn_oob.
          repeat rewrite seln_last by (simpl in *; lia).
          setoid_rewrite firstn_oob at 2.
          repeat rewrite list_upd_batch_app by lia; eauto; simpl.
          rewrite upd_batch_list_upd_batch_upd_batch_firstn_noop; eauto.
          rewrite list_upd_batch_noop; eauto.
          lia.
          eauto.
        }
        {
          repeat rewrite seln_app by lia.
          rewrite H; eauto.
          rewrite list_upd_batch_app; eauto.
          lia.
        }
        lia.
      }
      {
        repeat rewrite seln_oob.
        repeat rewrite firstn_nil.
        repeat rewrite firstn_oob.
        rewrite list_upd_batch_app; simpl; eauto.
        rewrite upd_batch_to_list_upd_batch_singleton.
        rewrite <- list_upd_batch_app; eauto.
        rewrite list_upd_batch_noop; eauto.
        all: try repeat rewrite app_length; simpl in *; try lia.
      }
    }
  }
Qed.

Lemma upd_batch_in:
forall A AEQ V l_a l_v (s1 s2: @total_mem A AEQ V) a,
In a l_a ->
length l_a = length l_v ->
upd_batch s1 l_a l_v a = upd_batch s2 l_a l_v a.
Proof.
  induction l_a; simpl; intros; eauto.
  intuition.
  destruct l_v; simpl in *; try lia.
  destruct H; subst; eauto.
  destruct (in_dec AEQ a0 l_a); eauto.
  repeat rewrite upd_batch_ne; eauto.
  repeat rewrite upd_eq; eauto.
Qed.

Lemma list_upd_batch_in:
forall A AEQ V l_l_a l_l_v (s1 s2: @total_mem A AEQ V) a,
(exists l_a, In l_a l_l_a /\ In a l_a) ->
Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v ->
list_upd_batch s1 l_l_a l_l_v a = list_upd_batch s2 l_l_a l_l_v a.
Proof.
  induction l_l_a; simpl; intros; eauto.
  destruct H; intuition.
  apply forall2_length in H0 as Hx.
  destruct l_l_v; simpl in *; try lia.
  destruct H; intuition; subst; eauto.
  {
    destruct (list_list_in_EXM AEQ l_l_a a0).
    destruct H; intuition.
    eapply IHl_l_a; eauto.
    eexists; intuition eauto.
    apply in_seln; eauto.
    inversion H0; eauto.
    repeat rewrite list_upd_batch_not_in; eauto.
    apply  upd_batch_in; eauto.
    inversion H0; eauto.
  }
  {
    eapply IHl_l_a; eauto.
    inversion H0; eauto.
  }
Qed.

Lemma list_upd_batch_upd_batch_in_noop:
  forall A AEQ V l_l_a l_l_v l_a l_v (s: @total_mem A AEQ V),
    Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v ->
    In l_a l_l_a ->
    length l_a = length l_v  ->
    list_upd_batch (upd_batch s l_a l_v) l_l_a l_l_v =
    list_upd_batch s l_l_a l_l_v.
Proof.
  induction l_l_a; simpl; intros; eauto.
  intuition.
  eapply forall2_length in H as Hx.
  destruct l_l_v; simpl in *; try lia.
  intuition subst.
  rewrite upd_batch_upd_batch_noop; eauto.
  inversion H; eauto.
  extensionality x.
  destruct (list_list_in_EXM AEQ l_l_a x).
  destruct H0; intuition.
  eapply list_upd_batch_in; eauto.
  eexists; split; [|eauto].
  apply in_seln; eauto.
  inversion H; eauto.

  repeat rewrite list_upd_batch_not_in; eauto.
  destruct (in_dec AEQ x a); subst.
  apply upd_batch_in; eauto.
  inversion H; eauto.
  repeat rewrite upd_batch_ne; eauto.
Qed.

Lemma shift_some :
  forall A AEQ V f (m: @total_mem A AEQ V) a,
    shift f m a = m (f a).
Proof.
  unfold shift; eauto.
Qed.

Lemma list_upd_batch_some:
  forall A AEQ V l_l_a l_l_v (m1 m2: @total_mem A AEQ V) a v,
    list_upd_batch m1 l_l_a l_l_v a = v ->
    length l_l_a = length l_l_v ->
    Forall2 (fun l_a l_v => length l_a = length l_v) l_l_a l_l_v ->
    m1 a = v \/ list_upd_batch m2 l_l_a l_l_v a = v.
Proof.
  intros.
  destruct (list_list_in_EXM AEQ l_l_a a).
  {
    destruct H2; intuition eauto.
    rewrite <- firstn_skipn with (n:= S x)(l:= l_l_a) in H.
    rewrite <- firstn_skipn with (n:= S x)(l:= l_l_v) in H.
    rewrite list_upd_batch_app in H.
    rewrite list_upd_batch_not_in in H; eauto.
    setoid_rewrite firstn_S_seln in H; eauto.
    rewrite list_upd_batch_app in H.
    simpl in *.

    rewrite <- firstn_skipn with (n:= S x)(l:= l_l_a).
    rewrite <- firstn_skipn with (n:= S x)(l:= l_l_v).
    rewrite list_upd_batch_app.
    rewrite list_upd_batch_not_in; eauto.
    setoid_rewrite firstn_S_seln; eauto.
    rewrite list_upd_batch_app.
    simpl in *.

    apply in_split_last in H2.
    do 2 destruct H2; intuition; subst.
    rewrite H4 in *.
    instantiate (1:= nil) in H.
    instantiate (1:= nil).
    rewrite <- firstn_skipn with (n:= length x0)(l:= (seln l_l_v x nil)) in *.
    rewrite upd_batch_app in *; eauto.
    simpl in *.
    destruct (skipn (length x0) (seln l_l_v x nil)) eqn:D.
    eapply (f_equal (@length A)) in H4.
    eapply (f_equal (@length V)) in D.
    rewrite skipn_length in D; simpl in *.
    rewrite app_length in *; simpl in *.
    eapply forall2_seln in H1.
    rewrite <- H1, H4 in D; lia.
    lia.

    rewrite upd_batch_ne in *; eauto.
    rewrite upd_eq in *; eauto.

    all: try solve [
               try repeat rewrite firstn_length_l; eauto; try lia].
    all: try solve [eapply forall2_seln in H1;
                    [>  try repeat rewrite firstn_length_l; eauto;
                     try rewrite <- H1, H4, app_length; simpl; lia | lia] ].
  }
  {
    rewrite list_upd_batch_not_in in *; eauto.
  }
Qed.

Lemma upd_batch_eq:
  forall A AEQ V l1 l2 (m: @total_mem A AEQ V) a i def1 def2,
    seln l1 i def1 = a ->
    ~In a (skipn (S i) l1) ->
    length l1 = length l2 ->
    i < length l1 ->
    upd_batch m l1 l2 a = seln l2 i def2.
Proof.
  induction l1; simpl in *; intros; eauto.
  lia.

  destruct l2; simpl in *; try lia.
  destruct i; subst; simpl in *.
  -
    rewrite upd_batch_ne; eauto.
    apply upd_eq; eauto.

  - erewrite IHl1; eauto.
    lia.
Qed.

Lemma shift_select_total_mem_synced:
  forall A AEQ V (tm: @total_mem A AEQ (V * list V)) (selector: @total_mem A AEQ nat) f,
    (forall a, snd (tm (f a)) = nil) ->
    shift f (select_total_mem selector tm) = shift f tm.
Proof.
  intros.
  extensionality a; simpl.
  unfold shift, select_total_mem; simpl.
  rewrite select_for_addr_synced; eauto.
  erewrite <- (H a).
  destruct (tm (f a)) eqn:D; eauto.
Qed.

Lemma select_total_mem_synced:
    forall A AEQ V (m: @total_mem A AEQ (V * list V)) (selector: @total_mem A AEQ nat) (a: A) vs,
      select_total_mem selector m a = vs ->
      snd vs = nil.
  Proof.
    unfold select_total_mem; intros.
    destruct (m a); try congruence.
    inversion H; simpl; eauto.
  Qed.

  Lemma select_total_mem_synced_noop:
    forall A AEQ V (m: @total_mem A AEQ (V * list V)) (selector: @total_mem A AEQ nat),
      (forall a vs, m a = vs -> snd vs = nil) ->
      select_total_mem selector m = m.
  Proof.
    intros; extensionality a.
    unfold select_total_mem; simpl.
    destruct (m a) eqn:D; eauto.
    apply H in D; subst; eauto.
    simpl in *; subst; eauto.
    rewrite select_for_addr_synced; simpl; eauto.
  Qed.

  Lemma list_upd_batch_upd_comm:
  forall A AEQ V l_l_a l_l_v a v (m: @total_mem A AEQ V),
  (forall l_a, In l_a l_l_a -> ~ In a l_a) ->
  upd (list_upd_batch m l_l_a l_l_v) a v =
  list_upd_batch (upd m a v) l_l_a l_l_v.
Proof.
  induction l_l_a; simpl; intros; eauto.
  destruct l_l_v; eauto.
  rewrite upd_batch_upd; eauto.
Qed.

Hint Rewrite upd_eq using (solve [ auto ]) : upd.
Hint Rewrite upd_ne using (solve [ auto ]) : upd.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj22synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (mult lv0 lv1) lv2)) (plus (Succ lv2) (mult lv1 lv0))).
Admitted.
QuickChick conj22synthconj2.