(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

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 3 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
COPYING file for more details.
*)

Require Import Reals Psatz.
Require Import mathcomp.ssreflect.ssreflect Rbar.
Require Import Rcomplements.
Require Import Lim_seq Continuity Derive Series.
Require Import Lub Hierarchy.

(** This file describes sequences of functions and results about
their convergence. *)

Open Scope R_scope.

(** * Sequence of functions *)

(** ** Definitions *)

Definition CVS_dom (fn : nat -> R -> R) (D : R -> Prop) :=
  forall x : R, D x -> ex_finite_lim_seq (fun n => fn n x).

Definition CVU_dom (fn : nat -> R -> R) (D : R -> Prop) :=
  forall eps : posreal, eventually (fun n => forall x : R,
    D x -> Rabs ((fn n x) - real (Lim_seq (fun n => fn n x))) < eps).
Definition CVU_cauchy (fn : nat -> R -> R) (D : R -> Prop) :=
  forall eps : posreal, exists N : nat,
  forall (n m : nat) (x : R), D x -> (N <= n)%nat -> (N <= m)%nat
    -> Rabs (fn n x - fn m x) < eps.

(** Equivalence with standard library *)

Lemma CVU_dom_Reals (fn : nat -> R -> R) (f : R -> R) (x : R) (r : posreal) :
  (forall y, (Boule x r y) -> (Finite (f y)) = Lim_seq (fun n => fn n y)) ->
  (CVU fn f x r <-> CVU_dom fn (Boule x r)).
Proof.
  split ; move => Hcvu.
  have Hf : forall y, Boule x r y -> is_lim_seq (fun n => fn n y) (f y).
    move => y Hy.
    apply is_lim_seq_spec.
    move => [e He] /=.
    case: (Hcvu e He) => {Hcvu} N Hcvu.
    exists N => n Hn.
    rewrite -Ropp_minus_distr' Rabs_Ropp.
    by apply Hcvu.
  move => [e He] /=.
  case: (Hcvu e He) => {Hcvu} N Hcvu.
  exists N => n Hn y Hy.
  rewrite (is_lim_seq_unique (fun n0 : nat => fn n0 y) _ (Hf y Hy)).
  simpl.
  rewrite -/(Rminus (fn n y) (f y)) -Ropp_minus_distr' Rabs_Ropp.
  by apply Hcvu.

  move => e He ; set eps := mkposreal e He.
  case: (Hcvu eps) => {Hcvu} N Hcvu.
  exists N => n y Hn Hy.
  move: (Hcvu n Hn y Hy).
  rewrite -(H y Hy) /=.
  by rewrite -Ropp_minus_distr' Rabs_Ropp.
Qed.

(** Various inclusions and equivalences between definitions *)

Lemma CVU_CVS_dom (fn : nat -> R -> R) (D : R -> Prop) :
  CVU_dom fn D -> CVS_dom fn D.
Proof.
  move => Hcvu x Hx.
  exists (real (Lim_seq (fun n => fn n x))).
  apply is_lim_seq_spec.
  intros eps.
  case: (Hcvu eps) => {Hcvu} N Hcvu.
  exists N => n Hn.
  by apply Hcvu.
Qed.
Lemma CVU_dom_cauchy (fn : nat -> R -> R) (D : R -> Prop) :
  CVU_dom fn D <-> CVU_cauchy fn D.
Proof.
  split => H eps.
(* CVU_dom -> CVU_cauchy *)
  case: (H (pos_div_2 eps)) => {H} N /= H.
  exists N => n m x Hx Hn Hm.
  rewrite (double_var eps).
  replace (fn n x - fn m x)
    with ((fn n x - real (Lim_seq (fun n0 : nat => fn n0 x)))
      - (fn m x - real (Lim_seq (fun n0 : nat => fn n0 x))))
    by ring.
  apply Rle_lt_trans with (1 := Rabs_triang _ _) ; rewrite Rabs_Ropp.
  apply Rplus_lt_compat ; by apply H.
(* CVU_cauchy -> CVU_dom *)
  rewrite /Lim_seq.
  case: (H (pos_div_2 eps)) => {H} N /= H.
  exists N => n Hn x Hx.
  rewrite /LimSup_seq ; case: ex_LimSup_seq ; case => [ls | | ] /= Hls.
  rewrite /LimInf_seq ; case: ex_LimInf_seq ; case => [li | | ] /= Hli.
  replace (fn n x - (ls + li) / 2)
    with (((fn n x - ls) + (fn n x - li))/2)
    by field.
  rewrite Rabs_div ; [ | by apply Rgt_not_eq, Rlt_R0_R2].
  rewrite (Rabs_pos_eq 2) ; [ | by apply Rlt_le, Rlt_R0_R2].
  rewrite Rlt_div_l ; [ | by apply Rlt_R0_R2].
  apply Rle_lt_trans with (1 := Rabs_triang _ _).
  replace (eps * 2) with (eps + eps) by ring.
  apply Rplus_lt_compat ; apply Rabs_lt_between'.
  case: (Hls (pos_div_2 eps)) => {Hls Hli} /= H0 [N0 H1] ; split.
  case: (H0 N) => {H0} m [Hm H0].
  apply Rlt_trans with (fn m x - eps/2).
  replace (ls - eps)
    with ((ls - eps / 2) - eps/2)
    by field.
  by apply Rplus_lt_compat_r.
  replace (fn n x) with (eps/2 + (fn n x - eps/2)) by ring.
  replace (fn m x - eps / 2) with ((fn m x - fn n x) + (fn n x - eps/2)) by ring.
  apply Rplus_lt_compat_r.
  apply Rle_lt_trans with (1 := Rle_abs _) ; by apply H.
  apply Rlt_trans with (fn (n+N0)%nat x + eps/2).
  replace (fn n x) with (fn (n + N0)%nat x + (fn n x - fn (n+N0)%nat x)) by ring.
  apply Rplus_lt_compat_l.
  apply Rle_lt_trans with (1 := Rle_abs _).
  apply H ; by intuition.
  replace (ls + eps) with ((ls + eps/2) + eps/2) by field.
  apply Rplus_lt_compat_r.
  apply H1 ; by intuition.
  case: (Hli (pos_div_2 eps)) => {Hls Hli} /= H0 [N0 H1] ; split.
  apply Rlt_trans with (fn (n+N0)%nat x - eps/2).
  replace (li - eps) with ((li - eps/2) - eps/2) by field.
  apply Rplus_lt_compat_r.
  apply H1 ; by intuition.
  replace (fn n x) with (eps/2 + (fn n x - eps/2)) by ring.
  replace (fn (n + N0)%nat x - eps / 2)
    with ((fn (n + N0)%nat x - fn n x) + (fn n x - eps/2))
    by ring.
  apply Rplus_lt_compat_r.
  apply Rle_lt_trans with (1 := Rle_abs _).
  apply H ; by intuition.
  case: (H0 N) => {H0} m [Hm H0].
  apply Rlt_trans with (fn m x + eps/2).
  replace (fn n x) with (fn m x + (fn n x - fn m x)) by ring.
  apply Rplus_lt_compat_l.
  apply Rle_lt_trans with (1 := Rle_abs _) ; by apply H.
  replace (li + eps)
    with ((li + eps / 2) + eps/2)
    by field.
  by apply Rplus_lt_compat_r.
  case: (Hli (fn n x + eps / 2)) => {Hls Hli} N0 H0.
  move: (H0 _ (le_plus_r N N0)) => {H0} H0 ; contradict H0.
  apply Rle_not_lt, Rlt_le.
  replace (fn (N + N0)%nat x)
    with (fn n x + (fn (N + N0)%nat x - fn n x))
    by ring.
  apply Rplus_lt_compat_l.
  apply Rle_lt_trans with (1 := Rle_abs _).
  apply H ; by intuition.
  case: (Hli (fn n x - eps / 2) N) => {Hls Hli} m [Hm H0].
  contradict H0.
  apply Rle_not_lt, Rlt_le.
  replace (fn m x) with (eps/2 + (fn m x - eps/2)) by ring.
  replace (fn n x - eps / 2)
    with ((fn n x - fn m x) + (fn m x - eps/2)) by ring.
  apply Rplus_lt_compat_r, Rle_lt_trans with (1 := Rle_abs _) ; by apply H.
  case: (Hls (fn n x + eps / 2) N) => {Hls} m [Hm H0].
  contradict H0.
  apply Rle_not_lt, Rlt_le.
  replace (fn m x) with (fn n x + (fn m x - fn n x)) by ring.
  apply Rplus_lt_compat_l, Rle_lt_trans with (1 := Rle_abs _) ; by apply H.
  case: (Hls (fn n x - eps / 2)) => {Hls} N0 H0.
  move: (H0 _ (le_plus_r N N0)) => {H0} H0 ; contradict H0.
  apply Rle_not_lt, Rlt_le.
  replace (fn (N + N0)%nat x)
    with (eps/2 + (fn (N + N0)%nat x - eps/2))
    by ring.
  replace (fn n x - eps / 2)
    with ((fn n x - fn (N+N0)%nat x) + (fn (N+N0)%nat x - eps/2)) by ring.
  apply Rplus_lt_compat_r.
  apply Rle_lt_trans with (1 := Rle_abs _).
  apply H ; by intuition.
Qed.

Lemma CVU_dom_include (fn : nat -> R -> R) (D1 D2 : R -> Prop) :
  (forall y, D2 y -> D1 y) -> CVU_dom fn D1 -> CVU_dom fn D2.
Proof.
  move => H H1 eps.
  case: (H1 eps) => {H1} N H1.
  exists N => n Hn x Hx.
  apply H1.
  exact Hn.
  by apply H.
Qed.

(** ** Limits, integrals and differentiability *)

Definition is_connected (D : R -> Prop) :=
  forall a b x, D a -> D b -> a <= x <= b -> D x.

Lemma CVU_limits_open (fn : nat -> R -> R) (D : R -> Prop) :
  open D
  -> CVU_dom fn D
  -> (forall x n, D x -> ex_finite_lim (fn n) x)
  -> forall x, D x -> ex_finite_lim_seq (fun n => real (Lim (fn n) x))
    /\ ex_finite_lim (fun y => real (Lim_seq (fun n => fn n y))) x
    /\ real (Lim_seq (fun n => real (Lim (fn n) x)))
      = real (Lim (fun y => real (Lim_seq (fun n => fn n y))) x).
Proof.
  move => Ho Hfn Hex x Hx.
  have H : ex_finite_lim_seq (fun n : nat => real (Lim (fn n) x)).
    apply CVU_dom_cauchy in Hfn.
    apply ex_lim_seq_cauchy_corr => eps.
    case: (Hfn (pos_div_2 eps)) => {Hfn} /= N Hfn.
    exists N => n m Hn Hm.
    case: (Hex x n Hx) => ln Hex_n ;
    rewrite (is_lim_unique _ _ _ Hex_n).
    case: (Hex x m Hx) => {Hex} lm Hex_m ;
    rewrite (is_lim_unique _ _ _ Hex_m).
    apply is_lim_spec in Hex_n.
    apply is_lim_spec in Hex_m.
    case: (Hex_n (pos_div_2 (pos_div_2 eps))) => {Hex_n} /= dn Hex_n.
    case: (Hex_m (pos_div_2 (pos_div_2 eps))) => {Hex_m} /= dm Hex_m.
    case: (Ho x Hx) => {Ho} d0 Ho.
    set y := x + Rmin (Rmin dn dm) d0 / 2.
    have Hd : 0 < Rmin (Rmin dn dm) d0 / 2.
      apply Rdiv_lt_0_compat.
      apply Rmin_case ; [ | by apply d0].
      apply Rmin_case ; [ by apply dn | by apply dm].
      exact: Rlt_R0_R2.
    have Hy : Rabs (y - x) < d0.
      rewrite /y ; ring_simplify ((x + Rmin (Rmin dn dm) d0 / 2) - x).
      rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hd)).
      generalize (Rmin_r (Rmin dn dm) d0).
      lra.
    move : (Ho y Hy) => {Ho Hy} Hy.
    replace (ln - lm)
      with (- (fn n y - ln) + (fn m y - lm) + (fn n y - fn m y))
      by ring.
    rewrite (double_var eps) ;
    apply Rle_lt_trans with (1 := Rabs_triang _ _), Rplus_lt_compat.
    rewrite (double_var (eps/2)) ;
    apply Rle_lt_trans with (1 := Rabs_triang _ _), Rplus_lt_compat.
    rewrite Rabs_Ropp ; apply Hex_n.
    rewrite /y /ball /= /AbsRing_ball /= /minus /plus /opp /abs /=.
    ring_simplify ((x + Rmin (Rmin dn dm) d0 / 2) + - x).
    rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hd)).
    generalize (Rmin_l (Rmin dn dm) d0) (Rmin_l dn dm).
    lra.
    apply Rgt_not_eq, Rlt_gt, Rminus_lt_0.
    rewrite /y ; by ring_simplify ((x + Rmin (Rmin dn dm) d0 / 2) - x).
    apply Hex_m.
    rewrite /y /ball /= /AbsRing_ball /= /minus /plus /opp /abs /=.
    ring_simplify ((x + Rmin (Rmin dn dm) d0 / 2) + - x).
    rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hd)).
    generalize (Rmin_l (Rmin dn dm) d0) (Rmin_r dn dm).
    lra.
    apply Rgt_not_eq, Rlt_gt, Rminus_lt_0.
    rewrite /y ; by ring_simplify ((x + Rmin (Rmin dn dm) d0 / 2) - x).
    by apply Hfn.
  split.
  exact: H.
  apply Lim_seq_correct' in H.
  move: (real (Lim_seq (fun n : nat => real (Lim (fn n) x)))) H => l H.
  have H0 : is_lim (fun y : R => real (Lim_seq (fun n : nat => fn n y))) x l.
    apply is_lim_spec.
    move => eps.
    apply is_lim_seq_spec in H.
    case: (Hfn (pos_div_2 (pos_div_2 eps))) => {Hfn} /= n1 Hfn.
    case: (H (pos_div_2 (pos_div_2 eps))) => {H} /= n2 H.
    set n := (n1 + n2)%nat.
    move: (fun y Hy => Hfn n (le_plus_l _ _) y Hy) => {Hfn} Hfn.
    move: (H n (le_plus_r _ _)) => {H} H.
    move: (Hex x n Hx) => {Hex} Hex.
    apply Lim_correct' in Hex.
    apply is_lim_spec in Hex.
    case: (Hex (pos_div_2 eps)) => {Hex} /= d1 Hex.
    case: (Ho x Hx) => {Ho} /= d0 Ho.
    have Hd : 0 < Rmin d0 d1.
      apply Rmin_case ; [by apply d0 | by apply d1].
    exists (mkposreal _ Hd) => /= y Hy Hxy.
    replace (real (Lim_seq (fun n0 : nat => fn n0 y)) - l)
      with ((real (Lim (fn n) x) - l)
            - (fn n y - real (Lim_seq (fun n : nat => fn n y)))
            + (fn n y - real (Lim (fn n) x)))
      by ring.
    rewrite (double_var eps) ;
    apply Rle_lt_trans with (1 := Rabs_triang _ _), Rplus_lt_compat.
    rewrite (double_var (eps/2)) ;
    apply Rle_lt_trans with (1 := Rabs_triang _ _), Rplus_lt_compat.
    exact: H.
    rewrite Rabs_Ropp ; apply Hfn.
    by apply Ho, Rlt_le_trans with (1 := Hy), Rmin_l.
    apply Hex.
    by apply Rlt_le_trans with (1 := Hy), Rmin_r.
    exact: Hxy.
  split.
  by exists l.
  replace l with (real l) by auto.
  by apply sym_eq, (f_equal real), is_lim_unique.
Qed.
Lemma CVU_cont_open (fn : nat -> R -> R) (D : R -> Prop) :
  open D ->
  CVU_dom fn D ->
  (forall n, forall x, D x -> continuity_pt (fn n) x)
    -> forall x, D x -> continuity_pt (fun y => real (Lim_seq (fun n => fn n y))) x.
Proof.
  move => Ho Hfn Hc x Hx.
  case: (fun H => CVU_limits_open fn D Ho Hfn H x Hx)
    => [{x Hx} x n Hx | Hex_s [Hex_f Heq]].
  exists (fn n x).
  apply is_lim_spec.
  intros eps.
  case: (Hc n x Hx eps (cond_pos eps)) => {Hc} d [Hd Hc].
  exists (mkposreal d Hd) => /= y Hy Hxy.
  apply (Hc y).
  split.
  split.
  exact: I.
  by apply sym_not_eq, Hxy.
  exact: Hy.
  apply Lim_correct' in Hex_f.
  rewrite -Heq in Hex_f => {Heq}.
  replace (Lim_seq (fun n : nat => real (Lim (fn n) x)))
    with (Lim_seq (fun n : nat => (fn n) x)) in Hex_f.
  move => e He.
  apply is_lim_spec in Hex_f.
  case: (Hex_f (mkposreal e He)) => {Hex_f} /= delta Hex_f.
  exists delta ; split => [ | y [[_ Hxy] Hy]].
  by apply delta.
  apply Hex_f.
  exact: Hy.
  by apply sym_not_eq.
  apply Lim_seq_ext => n.
  replace (fn n x) with (real (fn n x)) by auto.
  apply sym_eq, f_equal, is_lim_unique.
  apply is_lim_spec.
  move => eps.
  case: (Hc n x Hx eps (cond_pos eps)) => {Hc} d [Hd Hc].
  exists (mkposreal d Hd) => /= y Hy Hxy.
  apply (Hc y).
  split.
  split.
  exact: I.
  by apply sym_not_eq, Hxy.
  exact: Hy.
Qed.

Lemma CVU_Derive (fn : nat -> R -> R) (D : R -> Prop) :
  open D -> is_connected D
  -> CVU_dom fn D
  -> (forall n x, D x -> ex_derive (fn n) x)
  -> (forall n x, D x -> continuity_pt (Derive (fn n)) x)
  -> CVU_dom (fun n x => Derive (fn n) x) D
  -> (forall x , D x ->
       (is_derive (fun y => real (Lim_seq (fun n => fn n y))) x
         (real (Lim_seq (fun n => Derive (fn n) x))))).
Proof.
  move => Ho Hc Hfn Edn Cdn Hdn.

  set rn := fun x n h => match (Req_EM_T h 0) with
    | left _ => Derive (fn n) x
    | right _ => (fn n (x+h) - fn n x)/h
  end.

  assert (Ho' : forall x : R, open (fun h : R => D (x + h))).
    intros x.
    apply open_comp with (2 := Ho).
    intros t _.
    eapply (filterlim_comp_2 (F := locally t)).
    apply filterlim_const.
    apply filterlim_id.
    apply: filterlim_plus.

  have Crn : forall x, D x -> forall n h, D (x+h) -> is_lim (rn x n) h (rn x n h).
    move => x Hx n h Hh.
    rewrite {2}/rn ; case: (Req_EM_T h 0) => [-> | Hh0].
    apply is_lim_spec.
    move => eps.
    cut (locally 0 (fun y : R => y <> 0 ->
      Rabs ((fn n (x + y) - fn n x) / y - Derive (fn n) x) < eps)).
    case => d H.
    exists d => y Hy Hxy.
    rewrite /rn ; case: Req_EM_T => // _ ; by apply H.
    move: (Edn n x Hx) => {Edn} Edn.
    apply Derive_correct in Edn.
    apply is_derive_Reals in Edn.
    case: (Edn eps (cond_pos eps)) => {Edn} delta Edn.
    exists delta => y Hy Hxy.
    rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /= in Hy.
    rewrite -/(Rminus _ _) Rminus_0_r in Hy.
    by apply Edn.

    have H : continuity_pt (fun h => ((fn n (x + h) - fn n x) / h)) h.
      apply derivable_continuous_pt.
      apply derivable_pt_div.
      apply derivable_pt_minus.
      apply derivable_pt_comp.
      apply (derivable_pt_plus (fun _ => x) (fun h => h) h).
      exact: derivable_pt_const.
      exact: derivable_pt_id.
      exists (Derive (fn n) (x + h)) ; by apply is_derive_Reals, Derive_correct, Edn.
      exact: derivable_pt_const.
      exact: derivable_pt_id.
      exact: Hh0.

    apply is_lim_spec.
    move => eps.
    case: (H eps (cond_pos eps)) => {H} d [Hd H].
    have Hd0 : 0 < Rmin d (Rabs h).
      apply Rmin_case.
      exact: Hd.
      by apply Rabs_pos_lt.
    exists (mkposreal _ Hd0) => /= y Hy Hhy.
    rewrite /rn ; case: Req_EM_T => /= Hy'.
    contradict Hy.
    apply Rle_not_lt.
    rewrite /abs /minus /plus /opp /=.
    rewrite Hy' -/(Rminus _ _) Rminus_0_l Rabs_Ropp ; by apply Rmin_r.
    apply (H y) ; split.
    split.
    exact: I.
    by apply sym_not_eq.
    by apply Rlt_le_trans with (1 := Hy), Rmin_l.

  have Hrn : forall x, D x -> CVU_dom (rn x) (fun h : R => D (x + h)).
    move => x Hx.
    apply CVU_dom_cauchy => eps.
    apply CVU_dom_cauchy in Hdn.
    case: (Hdn eps) => {Hdn} /= N Hdn.
    exists N => n m h Hh Hn Hm.
    rewrite /rn ; case: Req_EM_T => Hh0.
    exact: (Hdn n m x Hx Hn Hm).
    replace ((fn n (x + h) - fn n x) / h - (fn m (x + h) - fn m x) / h)
      with (((fn n (x + h) - fn m (x + h)) - (fn n x - fn m x))/h)
      by (field ; auto).
    case: (MVT_gen (fun x => (fn n x - fn m x)) x (x+h) (Derive (fun x => fn n x - fn m x))) => [y Hy | y Hy | z [Hz ->]].
    apply Derive_correct.
    apply: ex_derive_minus ; apply Edn, (Hc (Rmin x (x + h)) (Rmax x (x + h))).
    apply Rmin_case ; [by apply Hx | by apply Hh].
    apply Rmax_case ; [by apply Hx | by apply Hh].
    split ; apply Rlt_le ; by apply Hy.
    apply Rmin_case ; [by apply Hx | by apply Hh].
    apply Rmax_case ; [by apply Hx | by apply Hh].
    split ; apply Rlt_le ; by apply Hy.
    apply derivable_continuous_pt, derivable_pt_minus.
    exists (Derive (fn n) y) ; apply is_derive_Reals, Derive_correct, Edn, (Hc (Rmin x (x + h)) (Rmax x (x + h))).
    apply Rmin_case ; [by apply Hx | by apply Hh].
    apply Rmax_case ; [by apply Hx | by apply Hh].
    by apply Hy.
    exists (Derive (fn m) y) ; apply is_derive_Reals, Derive_correct, Edn, (Hc (Rmin x (x + h)) (Rmax x (x + h))).
    apply Rmin_case ; [by apply Hx | by apply Hh].
    apply Rmax_case ; [by apply Hx | by apply Hh].
    by apply Hy.
    replace (Derive (fun x1 : R => fn n x1 - fn m x1) z * (x + h - x) / h)
      with (Derive (fun x1 : R => fn n x1 - fn m x1) z)
      by (field ; auto).
    rewrite Derive_minus.
    apply (Hdn n m z).
    apply (Hc (Rmin x (x + h)) (Rmax x (x + h))).
    apply Rmin_case ; [by apply Hx | by apply Hh].
    apply Rmax_case ; [by apply Hx | by apply Hh].
    by apply Hz.
    exact: Hn.
    exact: Hm.
    apply Edn, (Hc (Rmin x (x + h)) (Rmax x (x + h))).
    apply Rmin_case ; [by apply Hx | by apply Hh].
    apply Rmax_case ; [by apply Hx | by apply Hh].
    by apply Hz.
    apply Edn, (Hc (Rmin x (x + h)) (Rmax x (x + h))).
    apply Rmin_case ; [by apply Hx | by apply Hh].
    apply Rmax_case ; [by apply Hx | by apply Hh].
    by apply Hz.

  have Lrn : forall x, D x -> (forall (y : R) (n : nat),
    (fun h : R => D (x + h)) y -> ex_finite_lim (rn x n) y).
    intros ; exists (rn x n y) ; by intuition.

  move => x Hx.

  case: (CVU_limits_open (rn x) _ (Ho' x) (Hrn x Hx) (Lrn x Hx) 0) => [ | H [H0 H1]].
  by rewrite Rplus_0_r.

  have : ex_derive (fun y : R => real (Lim_seq (fun n : nat => fn n y))) x
    /\ Derive (fun y : R => real (Lim_seq (fun n : nat => fn n y))) x
      = real (Lim_seq (fun n : nat => Derive (fn n) x)).

  split.
  case: H0 => df H0.
  exists df.
  apply is_derive_Reals => e He.
  apply is_lim_spec in H0.
  case: (H0 (mkposreal e He)) => {H0} /= delta H0.
  destruct (Ho x Hx) as [dx Hd].
  have H2 : 0 < Rmin delta dx.
    apply Rmin_case ; [by apply delta | by apply dx].
  exists (mkposreal _ H2) => /= h Hh0 Hh.
  replace (real (Lim_seq (fun n : nat => fn n (x + h))) -
    real (Lim_seq (fun n : nat => fn n x))) with
    (real (Rbar_minus (Lim_seq (fun n : nat => fn n (x + h))) (Lim_seq (fun n : nat => fn n x)))).
  rewrite -Lim_seq_minus.
  replace (real (Lim_seq (fun n : nat => fn n (x + h) - fn n x)) / h)
  with (real (Rbar_mult (/h) (Lim_seq (fun n : nat => fn n (x + h) - fn n x)))).
  rewrite -Lim_seq_scal_l.
  replace (Lim_seq (fun n : nat => / h * (fn n (x + h) - fn n x)))
    with (Lim_seq (fun n : nat => rn x n h)).
  apply H0.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /=.
  rewrite -/(Rminus _ _) Rminus_0_r ; apply Rlt_le_trans with (1 := Hh), Rmin_l.
  exact: Hh0.
  apply Lim_seq_ext => n.
  rewrite /rn /Rdiv ; case: Req_EM_T => // _ ; exact: Rmult_comm.
  case: (Lim_seq (fun n : nat => fn n (x + h) - fn n x))
    => [l | | ] //=.
    by field.
    rewrite /Rdiv Rmult_0_l.
    case: Rle_dec => // Hh1.
    case: Rle_lt_or_eq_dec => //.
    rewrite /Rdiv Rmult_0_l.
    case: Rle_dec => // Hh1.
    case: Rle_lt_or_eq_dec => //.

  apply ex_finite_lim_seq_correct, CVU_CVS_dom with D.
  exact: Hfn.
  apply Hd.
  simpl.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /=.
  ring_simplify (x + h + - x) ; apply Rlt_le_trans with (1 := Hh), Rmin_r.
  apply ex_finite_lim_seq_correct, CVU_CVS_dom with D.
  exact: Hfn.
  apply Hd.
  apply ball_center.
  apply (CVU_CVS_dom fn D) in Hfn ; rewrite /CVS_dom in Hfn.
  move: (fun H => Lim_seq_correct' _ (Hfn (x+h) (Hd _ H))) => F.
  move: (fun H => Lim_seq_correct' _ (Hfn (x) (Hd _ H))) => F0.
  rewrite (is_lim_seq_unique _ (real (Lim_seq (fun n : nat => fn n (x + h))))).
  rewrite (is_lim_seq_unique  (fun n : nat => fn n (x)) (real (Lim_seq (fun n : nat => fn n (x))))).
  easy.
  apply F0.
  apply ball_center.
  apply F.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /=.
  ring_simplify (x + h + - x).
  apply Rlt_le_trans with (1 := Hh), Rmin_r.
  apply (CVU_CVS_dom fn D) in Hfn ; rewrite /CVS_dom in Hfn.
  move: (fun H => Lim_seq_correct' _ (Hfn (x+h) (Hd _ H))) => F.
  move: (fun H => Lim_seq_correct' _ (Hfn (x) (Hd _ H))) => F0.
  rewrite (is_lim_seq_unique _ (real (Lim_seq (fun n : nat => fn n (x + h))))).
  rewrite (is_lim_seq_unique  (fun n : nat => fn n (x)) (real (Lim_seq (fun n : nat => fn n (x))))).
  by [].
  apply F0.
  apply ball_center.
  apply F.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /=.
  ring_simplify (x + h + - x).
  apply Rlt_le_trans with (1 := Hh), Rmin_r.

  rewrite /Derive.
  replace (Lim_seq (fun n : nat => real (Lim (fun h : R => (fn n (x + h) - fn n x) / h) 0)))
    with (Lim_seq (fun n : nat => real (Lim (rn x n) 0))).
  rewrite H1.
  case: H0 => drn H0.
  rewrite (is_lim_unique _ _ _ H0).
  apply f_equal, is_lim_unique.
  apply is_lim_spec.
  intros eps.
  apply is_lim_spec in H0.
  case: (H0 eps) => {H0} delta H0.
  destruct (Ho x Hx) as [dx Hd].
  have H2 : 0 < Rmin delta dx.
    apply Rmin_case ; [by apply delta | by apply dx].
  exists (mkposreal _ H2) => /= h Hh0 Hh.
  replace (real (Lim_seq (fun n : nat => fn n (x + h))) -
    real (Lim_seq (fun n : nat => fn n x))) with
    (real (Rbar_minus (Lim_seq (fun n : nat => fn n (x + h))) (Lim_seq (fun n : nat => fn n x)))).
  rewrite -Lim_seq_minus.
  replace (real (Lim_seq (fun n : nat => fn n (x + h) - fn n x)) / h)
  with (real (Rbar_mult (/h) (Lim_seq (fun n : nat => fn n (x + h) - fn n x)))).
  rewrite -Lim_seq_scal_l.
  replace (Lim_seq (fun n : nat => / h * (fn n (x + h) - fn n x)))
    with (Lim_seq (fun n : nat => rn x n h)).
  apply H0.
  apply Rlt_le_trans with (1 := Hh0), Rmin_l.
  exact: Hh.
  apply Lim_seq_ext => n.
  rewrite /rn /Rdiv ; case: Req_EM_T => // _ ; exact: Rmult_comm.
  case: (Lim_seq (fun n : nat => fn n (x + h) - fn n x))
    => [l | | ] //=.
    by field.
    rewrite /Rdiv Rmult_0_l.
    case: Rle_dec => // Hh1.
    case: Rle_lt_or_eq_dec => //.
    rewrite /Rdiv Rmult_0_l.
    case: Rle_dec => // Hh1.
    case: Rle_lt_or_eq_dec => //.

  apply ex_finite_lim_seq_correct, CVU_CVS_dom with D.
  exact: Hfn.
  apply Hd.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /=.
  ring_simplify (x + h + - x) ; rewrite -(Rminus_0_r h) ;
  apply Rlt_le_trans with (1 := Hh0), Rmin_r.
  apply ex_finite_lim_seq_correct, CVU_CVS_dom with D.
  exact: Hfn.
  apply Hd.
  apply ball_center.
  apply (CVU_CVS_dom fn D) in Hfn ; rewrite /CVS_dom in Hfn.
  move: (fun H => Lim_seq_correct' _ (Hfn (x+h) (Hd _ H))) => F.
  move: (fun H => Lim_seq_correct' _ (Hfn (x) (Hd _ H))) => F0.
  rewrite (is_lim_seq_unique _ (real (Lim_seq (fun n : nat => fn n (x + h))))).
  rewrite (is_lim_seq_unique  (fun n : nat => fn n (x)) (real (Lim_seq (fun n : nat => fn n (x))))).
  easy.
  apply F0.
  apply ball_center.
  apply F.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /=.
  ring_simplify (x + h + - x).
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /= in Hh0.
  rewrite -/(Rminus _ _) Rminus_0_r in Hh0.
  apply Rlt_le_trans with (1 := Hh0), Rmin_r.
  apply (CVU_CVS_dom fn D) in Hfn ; rewrite /CVS_dom in Hfn.
  move: (fun H => Lim_seq_correct' _ (Hfn (x+h) (Hd _ H))) => F.
  move: (fun H => Lim_seq_correct' _ (Hfn (x) (Hd _ H))) => F0.
  rewrite (is_lim_seq_unique _ (real (Lim_seq (fun n : nat => fn n (x + h))))).
  rewrite (is_lim_seq_unique  (fun n : nat => fn n (x)) (real (Lim_seq (fun n : nat => fn n (x))))).
  by [].
  apply F0.
  apply ball_center.
  apply F.
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /=.
  ring_simplify (x + h + - x).
  rewrite /ball /= /AbsRing_ball /= /minus /plus /opp /= in Hh0.
  rewrite -/(Rminus _ _) Rminus_0_r in Hh0.
  apply Rlt_le_trans with (1 := Hh0), Rmin_r.

  apply Lim_seq_ext => n.
  apply sym_eq, f_equal, is_lim_unique.
  have Hx' : D (x + 0).
    by rewrite Rplus_0_r.
  rewrite (is_lim_unique _ _ _ (Crn x Hx n 0 Hx')).
  apply is_lim_spec.
  move: (Crn x Hx n 0 Hx') => H2 eps.
  apply is_lim_spec in H2.
  case: (H2 eps) => {H2} delta H2.
  exists delta => y Hy Hy0.
  move: (H2 y Hy Hy0).
  rewrite {1}/rn ; by case: Req_EM_T.

  case => H2 H3.
  rewrite -H3.
  by apply Derive_correct.
Qed.

(** ** Dini's theorem *)

Lemma Dini (fn : nat -> R -> R) (a b : R) :
  a  CVS_dom fn (fun x => a <= x <= b)
  -> (forall (n : nat) (x : R), a <= x <= b -> continuity_pt (fn n) x)
  -> (forall (x : R), a <= x <= b -> continuity_pt (fun y => Lim_seq (fun n => fn n y)) x)
  -> (forall (n : nat) (x y : R), a <= x -> x <= y -> y <= b -> fn n x <= fn n y)
  -> CVU_dom fn (fun x => a <= x <= b).
Proof.
  set AB := fun x => a <= x <= b.
  set f : R -> R := (fun y : R => Lim_seq (fun n : nat => fn n y)).
  move => Hab Hcvs Cfn Cf Hfn.

  have CUf : uniform_continuity f AB.
    apply Heine.
    by apply compact_P3.
    by apply Cf.
  suff H : forall eps : posreal, exists N : nat,
    forall n : nat, (N <= n)%nat -> forall x : R, AB x ->
    Rabs (fn n x - Lim_seq (fun n0 : nat => fn n0 x)) < 5 * eps.
    move => eps.
    replace (pos eps) with (5 * (eps / 5)) by field.
    suff He : 0 < eps / 5.
    by apply (H (mkposreal _ He)).
    apply Rdiv_lt_0_compat.
    by apply eps.
    repeat (apply Rplus_lt_0_compat || apply Rmult_lt_0_compat) ; apply Rlt_0_1.

  move => eps.
  case: (CUf eps) => {CUf} eta CUf.
  move: (interval_finite_subdiv_between  a b (pos_div_2 eta) (Rlt_le _ _ Hab)).
  case: (interval_finite_subdiv a b (pos_div_2 eta) (Rlt_le _ _ Hab)) =>
    a_ Ha_ /= Ha_0.
  have : exists N, forall n i, (N <= n)%nat -> (i < seq.size a_)%nat
    -> Rabs (fn n (seq.nth 0 a_ i) - f (seq.nth 0 a_ i)) < eps.
    case: a_ Ha_ Ha_0 => [ | a0 a_] Ha_ /= Ha_0.
    contradict Hab.
    rewrite -(proj1 Ha_) -(proj1 (proj2 Ha_)).
    by apply Rlt_irrefl.
    elim: (a_) (a0) Ha_0 => /= [ | x1 l IH] x0 Hl.
    move: (Hcvs x0 (Hl O (lt_n_Sn _))) ;
    move/Lim_seq_correct' => {Hcvs} Hcvs.
    apply is_lim_seq_spec in Hcvs.
    case: (Hcvs eps) => {Hcvs} N Hcvs.
    exists N => n i Hn Hi.
    case: i Hi => /= [ | i] Hi.
    by apply Hcvs.
    by apply lt_S_n, lt_n_O in Hi.
    case: (IH x1).
    move => i Hi.
    by apply (Hl (S i)), lt_n_S.
    move => N0 HN0.
    move: (Hcvs x0 (Hl O (lt_O_Sn _))) ;
    move/Lim_seq_correct' => {Hcvs} Hcvs.
    apply is_lim_seq_spec in Hcvs.
    case: (Hcvs eps) => {Hcvs} N Hcvs.
    exists (N + N0)%nat => n i Hn Hi.
    case: i Hi => /= [ | i ] Hi.
    apply Hcvs ; by intuition.
    apply HN0 ; by intuition.
  case => N HN.
  exists N => n Hn x Hx.
  have : exists i, (S i < seq.size a_)%nat /\ seq.nth 0 a_ i <= x <= seq.nth 0 a_ (S i).
    case: a_ Ha_ Ha_0 {HN} => [ | a0 a_] Ha_ /= Ha_0.
    contradict Hab.
    rewrite -(proj1 Ha_) -(proj1 (proj2 Ha_)).
    by apply Rlt_irrefl.
    case: a_ Ha_ Ha_0 => [ | a1 a_] Ha_ /= Ha_0.
    contradict Hab.
    rewrite -(proj1 Ha_) -(proj1 (proj2 Ha_)).
    by apply Rlt_irrefl.
    rewrite -(proj1 Ha_) in AB Hcvs CUf Hx Hab Cfn Cf Hfn Ha_0 |- * ; case: Ha_ => {a} _ Ha_.
    rewrite -(proj1 Ha_) in AB Hcvs CUf Hx Hab Cfn Cf Hfn Ha_0 |- * ; case: Ha_ => {b} _ Ha_.
    clear Hcvs CUf ;
    revert AB Hx ;
    elim: (a_) (a0) (a1) => /= [ | x2 l IH] x0 x1 Hx.
    exists O ; split => /=.
    by apply lt_n_Sn.
    by apply Hx.
    case: (Rlt_le_dec x x1) => Hx'.
    exists O ; split => /=.
    by apply lt_n_S, lt_O_Sn.
    split ; intuition.
    case: (IH x1 x2).
    by intuition.
    move => i [Hi Hx0].
    exists (S i) ; by intuition.
  case => i [Hi Hx'].
  replace (fn n x - Lim_seq (fun n0 : nat => fn n0 x))
    with ((f (seq.nth 0 a_ i) - f x) + (fn n x - f (seq.nth 0 a_ i)))
    by (rewrite /f ; ring).
  replace (5 * eps) with (eps + 4 * eps) by ring.
  apply Rle_lt_trans with (1 := Rabs_triang _ _).
  apply Rplus_lt_compat.
  apply CUf.
  apply Ha_0 ; by intuition.
  by apply Hx.
  rewrite -Rabs_Ropp Ropp_minus_distr' Rabs_pos_eq.
  apply Rle_lt_trans with (seq.nth 0 a_ (S i) - seq.nth 0 a_ i).
  apply Rplus_le_compat_r.
  by apply Hx'.
  apply Rle_lt_trans with (eta/2).
  apply Rle_minus_l.
  rewrite Rplus_comm.
  by apply Ha_.
  apply Rminus_lt_0 ; field_simplify ; rewrite Rdiv_1.
  by apply is_pos_div_2.
  apply Rle_minus_r ; rewrite Rplus_0_l.
  by apply Hx'.
  replace (fn n x - f (seq.nth 0 a_ i))
    with ((fn n (seq.nth 0 a_ i) - f (seq.nth 0 a_ i)) + (fn n x - fn n (seq.nth 0 a_ i)))
    by ring.
  replace (4 * eps) with (eps + 3 * eps) by ring.
  apply Rle_lt_trans with (1 := Rabs_triang _ _).
  apply Rplus_lt_compat.
  apply HN ; by intuition.
  rewrite Rabs_pos_eq.
  apply Rle_lt_trans with (fn n (seq.nth 0 a_ (S i)) - fn n (seq.nth 0 a_ i)).
  apply Rplus_le_compat_r.
  apply Hfn.
  by apply Hx.
  by apply Hx'.
  by apply Ha_0.
  replace (fn n (seq.nth 0 a_ (S i)) - fn n (seq.nth 0 a_ i))
    with ((fn n (seq.nth 0 a_ (S i)) - f (seq.nth 0 a_ (S i)))
      - (fn n (seq.nth 0 a_ i) - f (seq.nth 0 a_ i))
      + (f (seq.nth 0 a_ (S i)) - f (seq.nth 0 a_ i)))
    by ring.
  replace (3 * eps) with ((eps + eps) + eps) by ring.
  apply Rle_lt_trans with (1 := Rle_abs _).
  apply Rle_lt_trans with (1 := Rabs_triang _ _).
  apply Rplus_lt_compat.
  apply Rle_lt_trans with (1 := Rabs_triang _ _).
  apply Rplus_lt_compat.
  apply HN ; by intuition.
  rewrite Rabs_Ropp.
  apply HN ; by intuition.
  apply CUf.
  apply Ha_0 ; by intuition.
  apply Ha_0 ; by intuition.
  rewrite Rabs_pos_eq.
  apply Rle_lt_trans with (eta/2).
  apply Rle_minus_l.
  rewrite Rplus_comm.
  by apply Ha_.
  apply Rminus_lt_0 ; field_simplify ; rewrite Rdiv_1.
  by apply is_pos_div_2.
  apply Rle_minus_r ; rewrite Rplus_0_l.
  apply Rle_trans with x ; apply Hx'.
  apply Rle_minus_r ; rewrite Rplus_0_l.
  apply Hfn.
  apply Ha_0 ; by intuition.
  by apply Hx'.
  by apply Hx.
Qed.

(** ** Series of functions *)

Lemma CVN_CVU_r (fn : nat -> R -> R) (r : posreal) :
  CVN_r fn r -> forall x, (Rabs x < r) -> exists e : posreal,
    CVU (fun n => SP fn n) (fun x => Series (fun n => fn n x)) x e.
Proof.
  case => An [l [H H0]] x Hx.
  assert (H1 : ex_series An).
    apply ex_series_Reals_1.
    exists l => e He.
    case: (H e He) => {H} N H.
    exists N => n Hn.
    replace (sum_f_R0 An n) with (sum_f_R0 (fun k : nat => Rabs (An k)) n).
    by apply H.
    elim: n {Hn} => /= [ | n IH].
    apply Rabs_pos_eq.
    apply Rle_trans with (Rabs (fn O 0)).
    by apply Rabs_pos.
    apply H0 ; rewrite /Boule Rminus_0_r Rabs_R0 ; by apply r.
    rewrite IH Rabs_pos_eq.
    by [].
    apply Rle_trans with (Rabs (fn (S n) 0)).
    by apply Rabs_pos.
    apply H0 ; rewrite /Boule Rminus_0_r Rabs_R0 ; by apply r.

  have H2 : is_lim_seq (fun n => Series (fun k => An (n + k)%nat)) 0.
    apply is_lim_seq_incr_1.
    apply is_lim_seq_ext with (fun n => Series An - sum_f_R0 An n).
    move => n ; rewrite (Series_incr_n An (S n)) /=.
    ring.
    by apply lt_O_Sn.
    by apply H1.
    replace (Finite 0) with (Rbar_plus (Series An) (- Series An))
      by (simpl ; apply Rbar_finite_eq ; ring).
    apply (is_lim_seq_plus _ _ (Series An) (-Series An)).
    by apply is_lim_seq_const.
    replace (Finite (-Series An)) with (Rbar_opp (Series An))
      by (simpl ; apply Rbar_finite_eq ; ring).
    apply -> is_lim_seq_opp.
    rewrite /Series ;
    apply (is_lim_seq_ext (sum_n (fun k => An k))).
    elim => /= [ | n IH].
    by rewrite sum_O.
    by rewrite sum_Sn IH.
    apply is_lim_seq_ext with (sum_n An).
    move => n ; by rewrite sum_n_Reals.
    apply Lim_seq_correct', H1.
    easy.

  assert (H3 : forall y, Boule 0 r y -> ex_series (fun n => Rabs (fn n y))).
  move => y Hy.
  move: H1 ; apply @ex_series_le.
  move => n.
  rewrite /norm /= /abs /= Rabs_Rabsolu.
  by apply H0.

  apply Rminus_lt_0 in Hx.
  set r0 := mkposreal _ Hx.
  exists r0 => e He ; set eps := mkposreal e He.
  apply is_lim_seq_spec in H2.
  case: (H2 eps) => {H2} N H2.
  exists N => n y Hn Hy.

  have H4 : Boule 0 r y.
  rewrite /Boule /= in Hy |- *.
  apply Rle_lt_trans with (1 := Rabs_triang_inv _ _) in Hy.
  rewrite /Rminus ?(Rplus_comm _ (-Rabs x)) in Hy.
  apply Rplus_lt_reg_l in Hy.
  by rewrite Rminus_0_r.

  apply Rle_lt_trans with (2 := H2 (S n) (le_trans _ _ _ (le_n_Sn _) (le_n_S _ _ Hn))).
  rewrite Rminus_0_r /SP.
  rewrite (Series_incr_n (fun k : nat => fn k y) (S n)) /=.
  ring_simplify (sum_f_R0 (fun k : nat => fn k y) n +
    Series (fun k : nat => fn (S (n + k)) y) -
    sum_f_R0 (fun k : nat => fn k y) n).

  apply Rle_trans with (2 := Rle_abs _).
  apply Rle_trans with (Series (fun k : nat => Rabs (fn (S (n + k)) y))).
  apply Series_Rabs.
  apply ex_series_ext with (fun n0 : nat => Rabs (fn (S (n) + n0)%nat y)).
    move => n0 ; by rewrite plus_Sn_m.
  apply (ex_series_incr_n (fun n => Rabs (fn n y))).
  by apply H3.
  apply Series_le.
  move => k ; split.
  by apply Rabs_pos.
  by apply H0.
  apply ex_series_ext with (fun k : nat => An (S n + k)%nat).
  move => k ; by rewrite plus_Sn_m.
  by apply ex_series_incr_n.
  by apply lt_O_Sn.
  apply ex_series_Rabs.
  by apply H3.
Qed.


Require Import Rewriter.Util.FixCoqMistakes.
Require Import Coq.Classes.Morphisms Coq.Relations.Relation_Definitions.
Require Import Rewriter.Util.Tactics.GetGoal.
Require Import Rewriter.Util.Notations.

Definition Let_In {A P} (x : A) (f : forall a : A, P a) : P x := let y := x in f y.
Definition Let_In_pf {A P} (x : A) (f : forall a : A, a = x -> P a) : P x := let y := x in f y eq_refl.
Notation "'dlet_nd' x .. y := v 'in' f" := (Let_In (P:=fun _ => _) v (fun x => .. (fun y => f) .. )) (only parsing).
Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )).
Notation "'pflet' x , pf := y 'in' f" := (Let_In_pf y (fun x pf => f)).

Strategy 100 [Let_In Let_In_pf].

Module Bug5107WorkAround.
  Notation "'dlet' x .. y := v 'in' f" := (Let_In (P:=fun _ => _) v (fun x => .. (fun y => f) .. )).
End Bug5107WorkAround.

Global Instance Proper_Let_In_nd_changebody {A P R} {Reflexive_R:@Reflexive P R}
  : Proper (eq ==> pointwise_relation _ R ==> R) (@Let_In A (fun _ => P)).
Proof. lazy; intros; subst; auto; congruence. Qed.

Global Instance Proper_Let_In_nd_changevalue {A B} (RA:relation A) {RB:relation B}
  : Proper (RA ==> (RA ==> RB) ==> RB) (Let_In (P:=fun _=>B)).
Proof. cbv; intuition. Qed.

Lemma Proper_Let_In_nd_changebody_eq {A P R} {Reflexive_R:@Reflexive P R} {x}
  : Proper ((fun f g => forall a, x = a -> R (f a) (g a)) ==> R) (@Let_In A (fun _ => P) x).
Proof. lazy; intros; subst; auto; congruence. Qed.

Global Instance Proper_Let_In_nd_changevalue_forall {A B} {RB:relation B}
  : Proper (eq ==> (forall_relation (fun _ => RB)) ==> RB) (Let_In (P:=fun _:A=>B)).
Proof. cbv; intuition (subst; eauto). Qed.

(* Strangely needed in some cases where we have [(fun _ => foo) ...] messing up dependency calculation *)
#[global] Hint Extern 1 (Proper _ (@Let_In _ _)) => progress cbv beta : typeclass_instances.

Definition app_Let_In_nd {A B T} (f:B->T) (e:A) (C:A->B)
  : f (Let_In e C) = Let_In e (fun v => f (C v)) := eq_refl.

Definition Let_app_In_nd {A B T} (f:A->B) (e:A) (C:B->T)
  : Let_In (f e) C = Let_In e (fun v => C (f v)) := eq_refl.

Lemma unfold_Let_In {A B} v f : @Let_In A B v f = f v.
Proof. reflexivity. Qed.

Class _call_let_in_to_Let_In {T} (e:T) := _let_in_to_Let_In_return : T.
(* : forall T, gallina T -> gallina T, structurally recursive in the argument *)
Ltac let_in_to_Let_In e :=
  lazymatch e with
  | let x := ?ex in @?eC x =>
    let ex := let_in_to_Let_In ex in
    let eC := let_in_to_Let_In eC in
    constr:(Let_In ex eC)
  | ?f ?x =>
    let f := let_in_to_Let_In f in
    let x := let_in_to_Let_In x in
    constr:(f x)
  | (fun x : ?T => ?C) =>
    lazymatch constr:(fun (x : T) => (_ : _call_let_in_to_Let_In C))
                       (* [C] here above is an open term that references "x" by name *)
    with fun x => @?C x => C end (* match drops the type cast *)
  | ?x => x
  end.
#[global] Hint Extern 0 (_call_let_in_to_Let_In ?e) => (
  let e := let_in_to_Let_In e in eexact e
) : typeclass_instances.
Ltac change_let_in_with_Let_In :=
  let g := get_goal in
  let g' := let_in_to_Let_In g in
  change g'.


(* Optimisation on syntax *)
From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq Require Import Ast utils Typing.
From Translation
Require Import util Sorts SAst SLiftSubst Equality SCommon XTyping Conversion
ITyping ITypingInversions ITypingLemmata ITypingAdmissible DecideConversion.
Import ListNotations.

Section Optim.

Context `{Sort_notion : Sorts.notion}.

(* For optimisation, we remark that we can decide whenever an heterogenous
   equality is reflexivity.
 *)
Inductive isHeqRefl : sterm -> Type :=
| is_HeqRefl A u : isHeqRefl (sHeqRefl A u).

Definition decHeqRefl t : dec (isHeqRefl t).
  refine (
    match t with
    | sHeqRefl A u => inleft (is_HeqRefl A u)
    | _ => inright (fun e => _)
    end
  ). all: inversion e.
Defined.

Definition optHeqSym p :=
  match p with
  | sHeqRefl A u => sHeqRefl A u
  | _ => sHeqSym p
  end.

Lemma opt_HeqSym :
  forall {Σ Γ A a B b p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sHeq A a B b ->
    Σ ;;; Γ |-i optHeqSym p : sHeq B b A a.
Proof.
  intros Σ Γ A a B b p hg h.
  case (decHeqRefl p).
  - intros i. destruct i as [C c].
    simpl.
    ttinv h. destruct (heq_conv_inv h3) as [eA [eu [eA' ev]]].
    destruct (istype_type hg h) as [z heq]. ttinv heq.
    eapply type_conv.
    + eapply type_HeqRefl' ; eassumption.
    + eapply type_Heq ; eassumption.
    + apply cong_Heq ; assumption.
  - intros e. destruct p.
    16: exfalso ; apply e ; constructor.
    all: simpl ; apply type_HeqSym' ; assumption.
Defined.

Definition optHeqTrans p q :=
  match p,q with
  | sHeqRefl A u,  sHeqRefl _ _ => sHeqRefl A u
  | sHeqRefl A u, _ => q
  | _, sHeqRefl A u => p
  | _,_ => sHeqTrans p q
  end.

Lemma opt_HeqTrans :
  forall {Σ Γ A a B b C c p q},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sHeq A a B b ->
    Σ ;;; Γ |-i q : sHeq B b C c ->
    Σ ;;; Γ |-i optHeqTrans p q : sHeq A a C c.
Proof.
  intros Σ Γ A a B b C c p q hg hp hq.
  assert (hT : isType Σ Γ (sHeq A a C c)).
  { eapply istype_type ; try assumption.
    eapply type_HeqTrans' ; eassumption.
  }
  destruct hT.
  case (decHeqRefl p) ; case (decHeqRefl q).
  - intros iq ip. destruct ip as [D d], iq as [E e].
    simpl.
    ttinv hp. destruct (heq_conv_inv h2) as [DA [da [DB db]]].
    ttinv hq. destruct (heq_conv_inv h5) as [EB [eb [EC ec]]].
    eapply type_conv.
    + eapply type_HeqRefl' ; eassumption.
    + eassumption.
    + conv rewrite <- EC, ec.
      conv rewrite EB, eb.
      conv rewrite <- DA, da.
      apply cong_Heq ; try apply conv_refl ; assumption.
  - intros bot ip. destruct ip as [D d].
    replace (optHeqTrans (sHeqRefl D d) q) with q.
    + ttinv hp. destruct (heq_conv_inv h2) as [DA [da [DB db]]].
      eapply type_conv ; try eassumption.
      conv rewrite <- DA, da. apply conv_sym.
      apply cong_Heq ; try apply conv_refl ; assumption.
    + destruct q. all: try reflexivity.
      exfalso. apply bot. constructor.
  - intros iq bot. destruct iq as [E e].
    replace (optHeqTrans p (sHeqRefl E e)) with p.
    + ttinv hq. destruct (heq_conv_inv h2) as [EB [eb [EC ec]]].
      eapply type_conv ; try eassumption.
      conv rewrite <- EB, eb.
      apply cong_Heq ; try apply conv_refl ; assumption.
    + destruct p. all: reflexivity.
  - intros bq bp.
    destruct p ; try (exfalso ; apply bp ; constructor).
    all: destruct q ; try (exfalso ; apply bq ; constructor).
    all: try (simpl ; eapply type_HeqTrans' ; eassumption).
Defined.

Definition optTransport A B p t :=
  (* if Equality.eq_term A B then t else sTransport A B p t. *)
  if isconv (2^18) A B then t else sTransport A B p t.

Lemma opt_Transport :
  forall {Σ Γ s A B p t},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sEq (sSort s) A B ->
    Σ ;;; Γ |-i t : A ->
    Σ ;;; Γ |-i optTransport A B p t : B.
Proof.
  intros Σ Γ s A B p t hg hp ht.
  unfold optTransport.
  case_eq (isconv (2 ^ 18) A B).
  - intro h.
    destruct (istype_type hg hp) as [z hT].
    ttinv hT.
    eapply type_conv ; try eassumption.
    eapply isconv_sound. eassumption.
  - intros _. eapply type_Transport' ; eassumption.
Defined.

Definition optHeqToEq p :=
  match p with
  | sHeqRefl A a => sRefl A a
  | sEqToHeq e => e
  | _ => sHeqToEq p
  end.

Lemma opt_HeqToEq :
  forall {Σ Γ A u v p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sHeq A u A v ->
    Σ ;;; Γ |-i optHeqToEq p : sEq A u v.
Proof.
  intros Σ Γ A u v p hg h.
  assert (hT : isType Σ Γ (sEq A u v)).
  { eapply istype_type ; try assumption.
    eapply type_HeqToEq' ; eassumption.
  }
  destruct hT.
  destruct p.
  all: try (simpl ; eapply type_HeqToEq' ; eassumption).
  - simpl. rename p1 into B, p2 into b.
    ttinv h. destruct (heq_conv_inv h3) as [BA [bu [_ bv]]].
    eapply type_conv ; try eassumption.
    + eapply type_Refl' ; eassumption.
    + apply cong_Eq ; assumption.
  - simpl. ttinv h. rename A0 into B, u0 into a, v0 into b.
    destruct (heq_conv_inv h5) as [BA [au [_ bv]]].
    eapply type_conv ; try eassumption.
    apply cong_Eq ; assumption.
Defined.

Fact opt_sort_heq :
  forall {Σ Γ s1 s2 A B e},
    type_glob Σ ->
    Σ ;;; Γ |-i e : sHeq (sSort s1) A (sSort s2) B ->
    Σ ;;; Γ |-i optHeqToEq e : sEq (sSort s1) A B.
Proof.
  intros Σ Γ s1 s2 A B e hg h.
  destruct (istype_type hg h) as [? hty].
  ttinv hty.
  eapply opt_HeqToEq ; try assumption.
  eapply heq_sort ; eassumption.
Defined.

Corollary opt_sort_heq_ex :
  forall {Σ Γ s1 s2 A B e},
    type_glob Σ ->
    Σ ;;; Γ |-i e : sHeq (sSort s1) A (sSort s2) B ->
    ∑ p, Σ ;;; Γ |-i p : sEq (sSort s1) A B.
Proof.
  intros Σ Γ s A B e hg h.
  eexists. now eapply opt_sort_heq.
Defined.

Definition optHeqTransport p t :=
  match p with
  | sRefl s A => sHeqRefl A t
  | _ => sHeqTransport p t
  end.

Lemma opt_HeqTransport :
  forall {Σ Γ s A B p t},
    type_glob Σ ->
    Σ ;;; Γ |-i t : A ->
    Σ ;;; Γ |-i p : sEq (sSort s) A B ->
    Σ ;;; Γ |-i optHeqTransport p t : sHeq A t B (sTransport A B p t).
Proof.
  intros Σ Γ s A B p t hg ht hp.
  destruct p.
  all: try (simpl ; eapply type_HeqTransport' ; eassumption).
  simpl.
  ttinv hp. destruct (eq_conv_inv h2) as [? [eA eB]].
  destruct (istype_type hg hp) as [? hT].
  ttinv hT.
  eapply type_conv.
  - econstructor.
    + econstructor ; eassumption.
    + apply conv_sym in eA.
      econstructor ; try eassumption.
      econstructor ; eassumption.
  - econstructor ; try eassumption.
    econstructor ; eassumption.
  - apply cong_Heq ; try assumption ; try apply conv_refl.
    eapply conv_red_r ; econstructor. reflexivity.
Defined.

Definition optEqToHeq p :=
  match p with
  | sRefl A x => sHeqRefl A x
  | _ => sEqToHeq p
  end.

Lemma opt_EqToHeq :
  forall {Σ Γ A u v p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sEq A u v ->
    Σ ;;; Γ |-i optEqToHeq p : sHeq A u A v.
Proof.
  intros Σ Γ A u v p hg h.
  destruct p.
  all: try (simpl ; eapply type_EqToHeq' ; eassumption).
  simpl.
  ttinv h. destruct (eq_conv_inv h3) as [eA [eu ev]].
  destruct (istype_type hg h) as [? hT].
  ttinv hT.
  econstructor.
  - econstructor ; eassumption.
  - econstructor ; eassumption.
  - apply cong_Heq ; assumption.
Defined.

(* Tests if t does not depend on variable i *)
Fixpoint notdepi (t : sterm) (i : nat) {struct t} : bool :=
  match t with
  | sRel j => negb (i =? j)
  | sSort _ => true
  | sProd _ A B => notdepi A i && notdepi B (S i)
  | sLambda _ A B t => notdepi A i && notdepi B (S i) && notdepi t (S i)
  | sApp u A B v => notdepi A i && notdepi B (S i) && notdepi u i && notdepi v i
  | sSum _ A B => notdepi A i && notdepi B (S i)
  | sPair A B u v => notdepi A i && notdepi B (S i) && notdepi u i && notdepi v i
  | sPi1 A B p => notdepi A i && notdepi B (S i) && notdepi p i
  | sPi2 A B p => notdepi A i && notdepi B (S i) && notdepi p i
  | sEq A u v => notdepi A i && notdepi u i && notdepi v i
  | sRefl A u => notdepi A i && notdepi u i
  (* | sJ *)
  | sTransport A B p t =>
    notdepi A i && notdepi B i && notdepi p i && notdepi t i
  | sHeq A a B b => notdepi A i && notdepi a i && notdepi B i && notdepi b i
  | sHeqToEq p => notdepi p i
  | sHeqRefl A u => notdepi A i && notdepi u i
  | sHeqSym p => notdepi p i
  | sHeqTrans p q => notdepi p i && notdepi q i
  | sHeqTransport p t => notdepi p i && notdepi t i
  | sCongProd B1 B2 pA pB =>
    notdepi B1 (S i) && notdepi B2 (S i) && notdepi pA i && notdepi pB (S i)
  | sCongLambda B1 B2 t1 t2 pA pB pt =>
    notdepi B1 (S i) && notdepi B2 (S i) &&
    notdepi t1 (S i) && notdepi t2 (S i) &&
    notdepi pA i && notdepi pB (S i) && notdepi pt (S i)
  | sCongApp B1 B2 pu pA pB pv =>
    notdepi B1 (S i) && notdepi B2 (S i) &&
    notdepi pA i && notdepi pB (S i) &&
    notdepi pu i && notdepi pv i
  | sCongSum B1 B2 pA pB =>
    notdepi B1 (S i) && notdepi B2 (S i) && notdepi pA i && notdepi pB (S i)
  (* | sCongPair TODO *)
  (* | sCongPi1 TODO *)
  (* | sCongPi2 TODO *)
  | sCongEq pA pu pv => notdepi pA i && notdepi pu i && notdepi pv i
  | sCongRefl pA pu => notdepi pA i && notdepi pu i
  | sEqToHeq p => notdepi p i
  | sHeqTypeEq A B p => notdepi A i && notdepi B i && notdepi p i
  | sPack A B => notdepi A i && notdepi B i
  | sProjT1 p => notdepi p i
  | sProjT2 p => notdepi p i
  | sProjTe p => notdepi p i
  | sAx _ => true
  | _ => false
  end.

Definition notdep t := notdepi t 0.

Lemma notdepi_lift :
  forall {t i},
    notdepi t i = true ->
    lift 1 (S i) t = lift 1 i t.
Proof.
  intro t. induction t ; intros i h.
  all: try (cbn in h ; discriminate h).
  all: try (cbn in h ; repeat destruct_andb ;
            cbn ; f_equal ;
            rewrite_assumption ; (reflexivity || assumption)).
  revert h. cbn - [Nat.leb]. ncase (i =? n).
  - cbn. discriminate.
  - intros _. nat_case.
    + nat_case. reflexivity.
    + nat_case. reflexivity.
Defined.

Corollary notdep_lift :
  forall {t},
    notdep t = true ->
    lift 1 1 t = lift0 1 t.
Proof.
  intros t h.
  apply notdepi_lift. assumption.
Defined.

Definition optCongProd B1 B2 pA pB :=
  match pA, pB with
  | sHeqRefl (sSort s) A, sHeqRefl (sSort z) B =>
    if notdep B1 && notdep B2 then
      sHeqRefl (sSort (prod_sort s z)) (sProd nAnon A B1)
    else sCongProd B1 B2 pA pB
  | _,_ => sCongProd B1 B2 pA pB
  end.

Lemma opt_CongProd :
  forall {Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 pA pB},
    type_glob Σ ->
    Σ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ;;; Γ,, sPack A1 A2 |-i
    pB : sHeq (sSort z1)
              ((lift 1 1 B1) {0 := sProjT1 (sRel 0)})
              (sSort z2)
              ((lift 1 1 B2) {0 := sProjT2 (sRel 0)}) ->
    Σ;;; Γ,, A1 |-i B1 : sSort z1 ->
    Σ;;; Γ,, A2 |-i B2 : sSort z2 ->
    Σ;;; Γ |-i optCongProd B1 B2 pA pB
    : sHeq (sSort (prod_sort s1 z1)) (sProd nx A1 B1)
           (sSort (prod_sort s2 z2)) (sProd ny A2 B2).
Proof.
  intros Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 pA pB hg hpA hpB hB1 hB2.
  destruct pA.
  all: try (simpl ; eapply type_CongProd' ; eassumption).
  destruct pA1.
  all: try (simpl ; eapply type_CongProd' ; eassumption).
  destruct pB.
  all: try (simpl ; eapply type_CongProd' ; eassumption).
  destruct pB1.
  all: try (simpl ; eapply type_CongProd' ; eassumption).
  simpl.
  case_eq (notdep B1) ; try (intro ; simpl ; eapply type_CongProd' ; eassumption).
  case_eq (notdep B2) ; try (intros ; simpl ; eapply type_CongProd' ; eassumption).
  intros nd2 nd1. simpl.
  ttinv hpA. ttinv hpB.
  destruct (istype_type hg hpA) as [? hTA]. ttinv hTA.
  destruct (istype_type hg hpB) as [? hTB]. ttinv hTB.
  destruct (heq_conv_inv h2) as [es1 [? [es2 ?]]].
  destruct (heq_conv_inv h5) as [es3 [eB1 [es4 eB2]]].
  pose proof (sort_conv_inv h10).
  pose proof (sort_conv_inv h15).
  pose proof (sort_conv_inv es1).
  pose proof (sort_conv_inv es2).
  pose proof (sort_conv_inv es3).
  pose proof (sort_conv_inv es4).
  subst.
  econstructor.
  - econstructor ; try eassumption.
    + econstructor ; try eassumption. eapply typing_wf. eassumption.
    + econstructor ; try eassumption.
      eapply ContextConversion.type_ctxconv ; try eassumption.
      * econstructor ; try eassumption.
        eapply typing_wf. eassumption.
      * constructor.
        -- apply ContextConversion.ctxconv_refl.
        -- apply conv_sym. assumption.
  - econstructor.
    + econstructor ; try eassumption.
      eapply typing_wf. eassumption.
    + econstructor ; try eassumption.
      eapply typing_wf. eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
  - apply cong_Heq ; try apply conv_refl.
    + apply cong_Prod ; try apply conv_refl. assumption.
    + apply cong_Prod ; try assumption.
      rewrite notdep_lift, lift_subst in eB1 by assumption.
      rewrite notdep_lift, lift_subst in eB2 by assumption.
      eapply conv_trans ; try eassumption.
      apply conv_sym. assumption.
Defined.

Definition optCongLambda B1 B2 t1 t2 pA pB pt :=
  match pA, pB, pt with
  | sHeqRefl _ A, sHeqRefl _ _, sHeqRefl _ _ =>
    if notdep B1 && notdep B2 && notdep t1 && notdep t2 then
      sHeqRefl (sProd nAnon A B1) (sLambda nAnon A B1 t1)
    else sCongLambda B1 B2 t1 t2 pA pB pt
  | _,_,_ => sCongLambda B1 B2 t1 t2 pA pB pt
  end.

Lemma opt_CongLambda :
  forall {Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 t1 t2 pA pB pt},
    type_glob Σ ->
    Σ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ;;; Γ,, sPack A1 A2 |-i pB
    : sHeq (sSort z1) ((lift 1 1 B1) {0 := sProjT1 (sRel 0)})
           (sSort z2) ((lift 1 1 B2) {0 := sProjT2 (sRel 0)}) ->
    Σ;;; Γ,, sPack A1 A2 |-i pt
    : sHeq ((lift 1 1 B1) {0 := sProjT1 (sRel 0)})
           ((lift 1 1 t1) {0 := sProjT1 (sRel 0)})
           ((lift 1 1 B2) {0 := sProjT2 (sRel 0)})
           ((lift 1 1 t2) {0 := sProjT2 (sRel 0)}) ->
    Σ;;; Γ,, A1 |-i B1 : sSort z1 ->
    Σ;;; Γ,, A2 |-i B2 : sSort z2 ->
    Σ;;; Γ,, A1 |-i t1 : B1 ->
    Σ;;; Γ,, A2 |-i t2 : B2 ->
    Σ;;; Γ |-i optCongLambda B1 B2 t1 t2 pA pB pt
    : sHeq (sProd nx A1 B1) (sLambda nx A1 B1 t1)
           (sProd ny A2 B2) (sLambda ny A2 B2 t2).
Proof.
  intros Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 t1 t2 pA pB pt
         hg hpA hpB hpt hB1 hB2 ht1 ht2.
  destruct pA.
  all: try (simpl ; eapply type_CongLambda' ; eassumption).
  destruct pB.
  all: try (simpl ; eapply type_CongLambda' ; eassumption).
  destruct pt.
  all: try (simpl ; eapply type_CongLambda' ; eassumption).
  simpl.
  case_eq (notdep B1) ; try (intro ; simpl ; eapply type_CongLambda' ; eassumption).
  case_eq (notdep B2) ; try (intros ; simpl ; eapply type_CongLambda' ; eassumption).
  case_eq (notdep t1) ; try (intros ; simpl ; eapply type_CongLambda' ; eassumption).
  case_eq (notdep t2) ; try (intros ; simpl ; eapply type_CongLambda' ; eassumption).
  intros ndt2 ndt1 ndB2 ndB1. simpl.
  ttinv hpA. ttinv hpB. ttinv hpt.
  destruct (istype_type hg hpA) as [? hTA]. ttinv hTA.
  destruct (istype_type hg hpB) as [? hTB]. ttinv hTB.
  destruct (istype_type hg hpt) as [? hTt]. ttinv hTt.
  destruct (heq_conv_inv h2) as [es1 [? [es2 ?]]].
  destruct (heq_conv_inv h5) as [es3 [eB1 [es4 eB2]]].
  destruct (heq_conv_inv h8) as [_ [et1 [_ et2]]].
  assert (sSort s1 ≡ sSort s2).
  { eapply conv_trans ; try eassumption.
    apply conv_sym. assumption.
  }
  assert (sSort z1 ≡ sSort z2).
  { eapply conv_trans ; try eassumption.
    apply conv_sym. assumption.
  }
  repeat match goal with
  | h : sSort _ ≡ sSort _ |- _ =>
    pose proof (sort_conv_inv h) ; clear h
  end.
  subst.
  assert (Σ;;; Γ |-i pA2 : sSort s2).
  { econstructor ; eassumption. }
  assert (wf Σ Γ).
  { eapply typing_wf. eassumption. }
  econstructor.
  - eapply type_HeqRefl' ; try eassumption.
    eapply type_Lambda ; try eassumption.
    + eapply ContextConversion.type_ctxconv ; try eassumption.
      * econstructor ; eassumption.
      * econstructor ; try apply ContextConversion.ctxconv_refl.
        apply conv_sym. assumption.
    + eapply ContextConversion.type_ctxconv ; try eassumption.
      * econstructor ; eassumption.
      * econstructor ; try apply ContextConversion.ctxconv_refl.
        apply conv_sym. assumption.
  - econstructor.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
  - apply cong_Heq.
    + apply cong_Prod ; try apply conv_refl. assumption.
    + apply cong_Lambda ; try apply conv_refl. assumption.
    + apply cong_Prod ; try apply conv_refl. assumption.
      rewrite notdep_lift, lift_subst in eB1 by assumption.
      rewrite notdep_lift, lift_subst in eB2 by assumption.
      eapply conv_trans ; try eassumption.
      apply conv_sym. assumption.
    + apply cong_Lambda ; try apply conv_refl. assumption.
      * rewrite notdep_lift, lift_subst in eB1 by assumption.
        rewrite notdep_lift, lift_subst in eB2 by assumption.
        eapply conv_trans ; try eassumption.
        apply conv_sym. assumption.
      * rewrite notdep_lift, lift_subst in et1 by assumption.
        rewrite notdep_lift, lift_subst in et2 by assumption.
        eapply conv_trans ; try eassumption.
        apply conv_sym. assumption.
Defined.

Definition optCongApp B1 B2 pu pA pB pv :=
  match pA, pB, pu, pv with
  | sHeqRefl _ A, sHeqRefl _ _, sHeqRefl _ u, sHeqRefl _ v =>
    if notdep B1 && notdep B2 then
      sHeqRefl (B1{ 0 := v }) (sApp u A B1 v)
    else sCongApp B1 B2 pu pA pB pv
  | _,_,_,_ => sCongApp B1 B2 pu pA pB pv
  end.

Lemma opt_CongApp :
  forall {Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv},
    type_glob Σ ->
    Σ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ;;; Γ,, sPack A1 A2 |-i pB
    : sHeq (sSort z1) ((lift 1 1 B1) {0 := sProjT1 (sRel 0)})
           (sSort z2) ((lift 1 1 B2) {0 := sProjT2 (sRel 0)}) ->
    Σ;;; Γ |-i pu : sHeq (sProd nx A1 B1) u1 (sProd ny A2 B2) u2 ->
    Σ;;; Γ |-i pv : sHeq A1 v1 A2 v2 ->
    Σ;;; Γ,, A1 |-i B1 : sSort z1 ->
    Σ;;; Γ,, A2 |-i B2 : sSort z2 ->
    Σ;;; Γ |-i optCongApp B1 B2 pu pA pB pv
    : sHeq (B1 {0 := v1}) (sApp u1 A1 B1 v1) (B2 {0 := v2}) (sApp u2 A2 B2 v2).
Proof.
  intros Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv
         hg hpA hpB hpu hpv hB1 hB2.
  destruct pA.
  all: try (simpl ; eapply type_CongApp' ; eassumption).
  destruct pB.
  all: try (simpl ; eapply type_CongApp' ; eassumption).
  destruct pu.
  all: try (simpl ; eapply type_CongApp' ; eassumption).
  destruct pv.
  all: try (simpl ; eapply type_CongApp' ; eassumption).
  simpl.
  case_eq (notdep B1) ; try (intro ; simpl ; eapply type_CongApp' ; eassumption).
  case_eq (notdep B2) ; try (intros ; simpl ; eapply type_CongApp' ; eassumption).
  intros ndB2 ndB1. simpl.
  ttinv hpA. ttinv hpB. ttinv hpu. ttinv hpv.
  destruct (istype_type hg hpA) as [? hTA]. ttinv hTA.
  destruct (istype_type hg hpB) as [? hTB]. ttinv hTB.
  destruct (istype_type hg hpu) as [? hTu]. ttinv hTu.
  destruct (istype_type hg hpv) as [? hTv]. ttinv hTv.
  destruct (heq_conv_inv h2) as [es1 [? [es2 ?]]].
  destruct (heq_conv_inv h5) as [es3 [eB1 [es4 eB2]]].
  destruct (heq_conv_inv h8) as [? [eu1 [? eu2]]].
  destruct (heq_conv_inv h11) as [? [ev1 [? ev2]]].
  assert (sSort s1 ≡ sSort s2).
  { eapply conv_trans ; try eassumption.
    apply conv_sym. assumption.
  }
  assert (sSort z1 ≡ sSort z2).
  { eapply conv_trans ; try eassumption.
    apply conv_sym. assumption.
  }
  repeat match goal with
  | h : sSort _ ≡ sSort _ |- _ =>
    pose proof (sort_conv_inv h) ; clear h
  end.
  subst.
  assert (Σ;;; Γ |-i pA2 : sSort s2).
  { econstructor ; eassumption. }
  assert (wf Σ Γ).
  { eapply typing_wf. eassumption. }
  assert (Σ;;; Γ,, pA2 |-i B1 : sSort z2).
  { eapply ContextConversion.type_ctxconv ; try eassumption.
    - econstructor ; eassumption.
    - econstructor ; try apply ContextConversion.ctxconv_refl.
      apply conv_sym. assumption.
  }
  assert (B1 ≡ B2).
  { rewrite notdep_lift, lift_subst in eB1 by assumption.
    rewrite notdep_lift, lift_subst in eB2 by assumption.
    eapply conv_trans ; try eassumption.
    apply conv_sym. assumption.
  }
  assert (pv1 ≡ pA2).
  { eapply conv_trans ; try eassumption.
    apply conv_sym. assumption.
  }
  assert (A1 ≡ pA2).
  { eapply conv_trans ; try eassumption.
    apply conv_sym. assumption.
  }
  econstructor.
  - econstructor.
    + ContextConversion.lift_sort. eapply typing_subst ; try eassumption.
      econstructor ; eassumption.
    + econstructor ; try eassumption.
      * econstructor ; try eassumption.
        -- econstructor ; eassumption.
        -- eapply conv_trans ; try eassumption.
           apply conv_sym. apply cong_Prod ; assumption.
      * econstructor ; eassumption.
  - econstructor.
    + ContextConversion.lift_sort. eapply typing_subst ; try eassumption.
      econstructor ; eassumption.
    + ContextConversion.lift_sort. eapply typing_subst ; eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
  - apply cong_Heq.
    + apply substs_conv. assumption.
    + apply cong_App ; try apply conv_refl ; assumption.
    + apply cong_subst ; assumption.
    + apply cong_App ; try apply conv_refl ; assumption.
  Unshelve. exact nAnon.
Defined.

(* TODO congSum, congPair, congPi1, congPi2 *)

Definition optCongEq pA pu pv :=
  match pA, pu, pv with
  | sHeqRefl (sSort s) A, sHeqRefl _ u, sHeqRefl _ v =>
    sHeqRefl (sSort (eq_sort s)) (sEq A u v)
  | _,_,_ => sCongEq pA pu pv
  end.

Lemma opt_CongEq :
  forall {Σ Γ s1 s2 A1 A2 u1 u2 v1 v2 pA pu pv},
    type_glob Σ ->
    Σ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ;;; Γ |-i pu : sHeq A1 u1 A2 u2 ->
    Σ;;; Γ |-i pv : sHeq A1 v1 A2 v2 ->
    Σ;;; Γ |-i optCongEq pA pu pv :
              sHeq (sSort (eq_sort s1)) (sEq A1 u1 v1)
                   (sSort (eq_sort s2)) (sEq A2 u2 v2).
Proof.
  intros Σ Γ s1 s2 A1 A2 u1 u2 v1 v2 pA pu pv hg hpA hpu hpv.
  destruct pA.
  all: try (simpl ; eapply type_CongEq' ; eassumption).
  destruct pA1.
  all: try (simpl ; eapply type_CongEq' ; eassumption).
  destruct pu.
  all: try (simpl ; eapply type_CongEq' ; eassumption).
  destruct pv.
  all: try (simpl ; eapply type_CongEq' ; eassumption).
  simpl.
  ttinv hpA. ttinv hpu. ttinv hpv.
  destruct (istype_type hg hpA) as [? hTA]. ttinv hTA.
  destruct (istype_type hg hpu) as [? hTu]. ttinv hTu.
  destruct (istype_type hg hpv) as [? hTv]. ttinv hTv.
  destruct (heq_conv_inv h2) as [es1 [? [es2 ?]]].
  destruct (heq_conv_inv h5) as [es3 [? [es4 ?]]].
  destruct (heq_conv_inv h8) as [es5 [? [es6 ?]]].
  repeat match goal with
  | h : sSort _ ≡ sSort _ |- _ =>
    pose proof (sort_conv_inv h) ; clear h
  end.
  subst.
  econstructor.
  - econstructor ; try eassumption.
    + econstructor. eapply typing_wf. eassumption.
    + econstructor ; try eassumption.
      * econstructor ; try eassumption.
        eapply conv_trans ; try eassumption.
        apply conv_sym. assumption.
      * econstructor ; try eassumption.
        eapply conv_trans ; try eassumption.
        apply conv_sym. assumption.
  - econstructor.
    + econstructor. eapply typing_wf. eassumption.
    + econstructor. eapply typing_wf. eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
  - apply cong_Heq ; try apply conv_refl.
    + apply cong_Eq ; assumption.
    + apply cong_Eq ; assumption.
Defined.

Definition optCongRefl pA pu :=
  match pA, pu with
  | sHeqRefl _ A, sHeqRefl _ u =>
    sHeqRefl (sEq A u u) (sRefl A u)
  | _,_ => sCongRefl pA pu
  end.

Lemma opt_CongRefl :
  forall {Σ Γ s1 s2 A1 A2 u1 u2 pA pu},
    type_glob Σ ->
    Σ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ;;; Γ |-i pu : sHeq A1 u1 A2 u2 ->
    Σ;;; Γ |-i optCongRefl pA pu : sHeq (sEq A1 u1 u1) (sRefl A1 u1)
                                       (sEq A2 u2 u2) (sRefl A2 u2).
Proof.
  intros Σ Γ s1 s2 A1 A2 u1 u2 pA pu hg hpA hpu.
  destruct pA.
  all: try (simpl ; eapply type_CongRefl' ; eassumption).
  destruct pu.
  all: try (simpl ; eapply type_CongRefl' ; eassumption).
  simpl.
  ttinv hpA. ttinv hpu.
  destruct (istype_type hg hpA) as [? hTA]. ttinv hTA.
  destruct (istype_type hg hpu) as [? hTu]. ttinv hTu.
  destruct (heq_conv_inv h2) as [es1 [? [es2 ?]]].
  destruct (heq_conv_inv h5) as [es3 [? [es4 ?]]].
  repeat match goal with
  | h : sSort _ ≡ sSort _ |- _ =>
    pose proof (sort_conv_inv h) ; clear h
  end.
  subst.
  assert (Σ ;;; Γ |-i pA2 : sSort s1).
  { econstructor ; eassumption. }
  econstructor.
  - econstructor.
    + econstructor ; try eassumption.
      * econstructor ; try eassumption.
        eapply conv_trans ; try eassumption.
        apply conv_sym. assumption.
      * econstructor ; try eassumption.
        eapply conv_trans ; try eassumption.
        apply conv_sym. assumption.
    + econstructor ; try eassumption.
      econstructor ; try eassumption.
      eapply conv_trans ; try eassumption.
      apply conv_sym. assumption.
  - econstructor.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
    + econstructor ; eassumption.
  - apply cong_Heq.
    + apply cong_Eq ; assumption.
    + apply cong_Refl ; assumption.
    + apply cong_Eq ; assumption.
    + apply cong_Refl ; assumption.
Defined.

End Optim.


Require Export Primitives.
Require Import String.

(**

* Overview

In this module we define syntax elements of CoqDVM

* Definitions

*)

(**

** Location and Name Definitions

*)

Definition Location := nat.

Definition Name := string.

Definition Register := Location.

Definition ProgramCounter := Location.

Definition ClassLocation := Location.
Definition FieldLocation := Location.
Definition MethodLocation := Location.
Definition ObjectLocation := Location.
Definition Cursor := Location.

Definition ClassName := Name.
Definition FieldName := Name.
Definition MethodName := Name.

(**

** Constant Definition

*)

Inductive Constant : Type :=
  | cnat : nat -> Constant
(*  | cstr : Name -> Constant
    for later purpose*)
  | ctrue : Constant
  | cfalse : Constant
  | cnull : Constant.

(**

** "type" definition

*)

Inductive type : Type :=
  | p : PrimType -> type
  | r : RefType -> type
  | v : type
with RefType : Type :=
  | c : ClassLocation -> RefType
  | a : type -> RefType
  | sizeda : type -> nat -> RefType.

(**

** lhs and rhs for simple expression

*)

Inductive lhs : Type :=
  | reg : Register -> lhs
  | acc : Register -> Register -> lhs
  | ifield : Register -> FieldLocation -> lhs
  | sfield : FieldLocation -> lhs
with rhs : Type :=
  | l : lhs -> rhs
  | cs : Constant -> rhs.

(**

** Instruction Definition

*)

Inductive Instruction : Type :=
  | nop : Instruction
  | ret : Instruction
  | retTo : Register -> Instruction
  | invokes : list rhs -> MethodLocation -> Instruction
  | invokei : Register -> list rhs -> MethodLocation -> Instruction
  | goto : ProgramCounter -> Instruction
  | branch : rhs -> BinaryCompOperator -> rhs -> ProgramCounter -> Instruction
  | move : Register -> rhs -> Instruction
  | update : rhs -> rhs -> Instruction
  | unary : Register -> UnaryOperator -> rhs -> Instruction
  | binaryArith : Register -> rhs -> BinaryArithOperator -> rhs -> Instruction
  | new : Register -> ClassLocation -> Instruction
  | newarr : Register -> type -> rhs -> Instruction
  | cast : Register -> type -> rhs -> Instruction
  | read : Register -> Instruction
  | print : rhs -> Instruction
  | hlt : Instruction.

(**

** Class related final definitions

*)

Inductive MethodSig : Type := ms (am:nat) (mn:MethodName) (ret:type) (regs:nat) (args:list (type*Name)).
Inductive MethodBody : Type := mb (insts:list (ProgramCounter*Instruction)).

Inductive Method : Type := mtd (ml:MethodLocation) (mb:MethodBody).

Inductive Field : Type := fld (am:nat) (fn:FieldName) (ft:type).

Inductive Class : Type :=
  | top : Class
  | class : nat -> ClassLocation -> list FieldLocation -> list MethodLocation -> Class.

(** Accessmodifier then superclass then fields then methods *)

(**

** Val (Values in CoqDVM) Definition

*)

Inductive Ref : Type :=
  | lRef : Location -> Ref
  | null : Ref.

Inductive Val : Type :=
  | prim : Prim -> Val
  | ref : Ref -> Val.

(**

** Object & Array Definitions

An Object either is instance of Top class, or it made of current Class Location (Used in Casting),
Original Class Location, Field Value Pairs, or it is deletedObject which comes into play during Garbage Collection.

*)

Inductive Object : Type :=
  | topObj : Object
  | obj : ClassLocation -> ClassLocation -> list (FieldLocation * Val) -> Object
  | dobj : Object.

Inductive Array : Type :=
  | arr : nat -> list Val -> Array.

Inductive arrOrObj : Type :=
  | ar : Array -> arrOrObj
  | dob : Object -> arrOrObj.

Inductive ValOrRef : Type :=
  | vl : Val -> ValOrRef
  | rf : arrOrObj -> ValOrRef.

(**

** Program : Where all definitions meet

*)

Inductive Program : Type := prog (cnl:list ClassName) (mnl:list MethodSig) (cl:list Class) (fl:list Field) (ml:list Method).


From Undecidability.L Require Export Util.L_facts.
From Undecidability.L.Tactics Require Import Lproc Lbeta Lrewrite Reflection mixedTactics.
Require Import ListTactics.
Import L_Notations.

Local Ltac wLsimpl' _n := intros;try reflexivity';try standardizeGoal _n ; try reflexivity'.
Local Ltac wLsimpl := wLsimpl' 100.

(* Lsimpl' uses correctnes lemmas and wLsimpl*)
Ltac Lsimpl' :=
  match goal with
  | |- eval ?s _ => assert (lambda s) by Lproc;split;[ (exact (starR _ _);fail 1)|Lproc]
  | |- eval ?s _ => (progress (eapply eval_helper;[Lsimpl';reflexivity|]))

  | _ => try Lrewrite;try wLsimpl' 100
  end.

Ltac Lreduce :=
  repeat progress (try Lrewrite;try Lbeta).

(*Lsimpl that uses correctnes lemmas*)
Ltac Lsimpl :=intros(*;repeat foldLocalInts*);
  once lazymatch goal with
  | |- _ >(<= _ ) _ => Lreduce;try Lreflexivity
  | |- _ ⇓(_ ) _ => repeat progress Lbeta;try Lreflexivity
  | |- _ ⇓(<= _ ) _ => Lreduce;try Lreflexivity
  | |- _ >(_) _ => repeat progress Lbeta;try Lreflexivity
  | |- _ >* _ => Lreduce;try Lreflexivity (* test *)
  | |- eval _ _ => Lreduce;try Lreflexivity (* test *)
  (*| |- _ >* _  => repeat Lsimpl';try reflexivity'
  | |- eval _ _  => repeat Lsimpl';try reflexivity'*)
  | |- _ == _  => repeat Lsimpl';try reflexivity'
  end.

Ltac LsimplHypo := standardizeHypo 100.

Tactic Notation "closedRewrite" :=
  match goal with
    | [ |- context[subst ?s _ _] ] =>
      let cl := fresh "cl" in assert (cl:closed s);[Lproc|rewrite !cl;clear cl]

  end.

Tactic Notation "closedRewrite" "in" hyp(h):=
  match type of h with
    | context[subst ?s _ _] =>
      let cl := fresh "cl" in assert (cl:closed s);[Lproc|rewrite !cl in h;clear cl]
  end.

Tactic Notation "redStep" "at" integer(pos) := rewrite step_Lproc at pos;[simpl;try closedRewrite|Lproc].

Tactic Notation "redStep" "in" hyp(h) "at" integer(pos) := rewrite step_Lproc in h at pos;[simpl in h;try closedRewrite in h|Lproc].
(*
Tactic Notation "redStep" := redStep at 1.
*)
Tactic Notation "redStep" "in" hyp(h) := redStep in h at 1.

(* register needed lemmas:*)

Lemma rho_correct s t : proc s -> lambda t -> rho s t >* s (rho s) t.
Proof.
  intros. unfold rho,r. redStep at 1. apply star_trans_l. Lsimpl.
Qed.

Lemma rho_correctPow s t : proc s -> lambda t -> rho s t >(3) s (rho s) t.
Proof.
  intros. unfold rho,r. change 3 with (1+2). apply pow_add.
  eexists;split. apply (rcomp_1 step). now inv H0.
  cbn. closedRewrite. apply pow_step_congL;[|reflexivity]. now Lbeta.
Qed.

Hint Resolve rho_correct : Lrewrite.

Lemma rho_inj s t: rho s = rho t -> s = t.
Proof.
  unfold rho,r. congruence.
Qed.

Hint Resolve rho_lambda rho_cls : LProc.

Tactic Notation "recStep" constr(P) "at" integer(i):=
  match eval lazy [P] in P with
      | rho ?rP => unfold P;rewrite rho_correct at i;[|Lproc..];fold P;try unfold rP
  end.

Tactic Notation "recStep" constr(P) :=
  intros;recStep P at 1.

(*
Lemma rClosed_closed s: recProc s -> proc s.
  intros [? [? ?]]. subst. split; auto with LProc.
Qed.

Hint Resolve rClosed_closed : LProc cbv.
 *)

Lemma I_proc : proc I.
  fLproc.
Qed.

Lemma K_proc : proc K.
  fLproc.
Qed.

Lemma omega_proc : proc omega.
  fLproc.
Qed.

Lemma Omega_closed : closed Omega.
  fLproc.
Qed.

Hint Resolve I_proc K_proc omega_proc Omega_closed: LProc.

Hint Extern 0 (I >(_) _)=> unfold I;reflexivity : Lrewrite.
Hint Extern 0 (K >(_) _)=> unfold K;reflexivity : Lrewrite.

Lemma Omega_diverge t: ~ eval Omega t.
Proof.
  intros (?&?). remember Omega as s eqn:HO. induction H;subst.
  -inv H0. easy.
  -unfold Omega in H. inv H. cbn in *. eauto. all:easy.
Qed.