(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sovar_alpha.
Require Export atoms.

Definition matching_paramsb (p1 p2 : parameter) : bool :=
  match p1, p2 with
    | param pt_int _, param pt_int _ => true
    | param pt_level _, param pt_level _ => true
    | _, _ => false
  end.

Fixpoint matching_parametersb (ps1 ps2 : list parameter) : bool :=
  match ps1, ps2 with
    | [], [] => true
    | p1 :: ps1, p2 :: ps2 =>
      matching_paramsb p1 p2
      && matching_parametersb ps1 ps2
    | _, _ => false
  end.

Definition matching_parameters ps1 ps2 :=
  assert (matching_parametersb ps1 ps2).

(*

  we say that the parameters of the lhs of an abstraction are correct if they're
  variables

 *)
Definition correct_abs_param_b (p : parameter) : bool :=
  match p with
    | param pt_int (pv_int i) => false
    | param pt_level (pv_level l) => false
    | _ => false
  end.

Definition correct_abs_params_b (ps : list parameter) : bool :=
  ball (map correct_abs_param_b ps).

Definition correct_abs_params (ps : list parameter) :=
  correct_abs_params_b ps = true.

Lemma correct_abs_params_proof_irrelevance :
  forall ps : list parameter,
  forall x y : correct_abs_params ps,
    x = y.
Proof.
  intros.
  apply UIP_dec.
  apply bool_dec.
Qed.

Hint Extern 0 =>
let h := fresh "h" in
match goal with
  | [ H1 : correct_abs_params ?ps , H2 : correct_abs_params ?ps |- _ ] =>
    pose proof (correct_abs_params_proof_irrelevance ps H2 H1) as h; subst
end : pi.

Definition socovered {o} (t : @SOTerm o) vars :=
  subsovars (so_free_vars t) vars.

Lemma socovered_proof_irrelevance {o} :
  forall t : @SOTerm o,
  forall vars : list sovar_sig,
  forall x y : socovered t vars,
    x = y.
Proof.
  intros.
  apply UIP_dec.
  apply bool_dec.
Qed.

Hint Extern 0 =>
let h := fresh "h" in
match goal with
  | [ H1 : socovered ?t ?vs , H2 : socovered ?t ?vs |- _ ] =>
    pose proof (socovered_proof_irrelevance t vs H2 H1) as h; subst
end : pi.

Definition no_utokens {o} (t : @SOTerm o) :=
  get_utokens_so t = [].

Lemma no_utokens_proof_irrelevance {p} :
  forall t : @SOTerm p,
  forall x y : no_utokens t,
    x = y.
Proof.
  intros.
  apply UIP.
Qed.

Hint Extern 0 =>
let h := fresh "h" in
match goal with
  | [ H1 : no_utokens ?t , H2 : no_utokens ?t |- _ ] =>
    pose proof (no_utokens_proof_irrelevance t H2 H1) as h; subst
end : pi.

(* the variables can also be second-order variables *)
Definition correct_abs {o}
           (opabs : opabs)
           (vars  : list sovar_sig)
           (rhs   : @SOTerm o) :=
  wf_soterm rhs
  # socovered rhs vars
  # correct_abs_params (opabs_params opabs)
  # no_utokens rhs.

Lemma correct_abs_proof_irrelevance {p} :
  forall opabs vars (rhs : @SOTerm p),
  forall x y : correct_abs opabs vars rhs,
    x = y.
Proof.
  intros.
  destruct x, y; repnd.
  eauto with pi.
Qed.

Hint Extern 0 =>
let h := fresh "h" in
match goal with
  | [ H1 : correct_abs ?o ?v ?r , H2 : correct_abs ?o ?v ?r |- _ ] =>
    pose proof (correct_abs_proof_irrelevance o v r H2 H1) as h; subst
end : pi.

Inductive library_entry {o} :=
| lib_abs :
    forall opabs : opabs,
    forall vars  : list sovar_sig,
    forall rhs   : @SOTerm o,
    forall correct : correct_abs opabs vars rhs,
      library_entry.

Definition matching_bterms {o} (vars : list sovar_sig) (bs : list (@BTerm o)) :=
  map (fun v => snd v) vars = map num_bvars bs.

Definition matching_entry {o} oa1 oa2 (vars : list sovar_sig) (bs : list (@BTerm o)) :=
  opabs_name oa1 = opabs_name oa2
  # opabs_sign oa1 = opabs_sign oa2
  # matching_parameters (opabs_params oa1) (opabs_params oa2)
  # matching_bterms vars bs.

Definition not_matching_entry {o} oa1 oa2 (vars : list sovar_sig) (bs : list (@BTerm o)) :=
  opabs_name oa1 <> opabs_name oa2
  [+] opabs_sign oa1 <> opabs_sign oa2
  [+] !matching_parameters (opabs_params oa1) (opabs_params oa2)
  [+] !matching_bterms vars bs.

Definition matching_entry_deq {o} oa1 oa2 (vars : list sovar_sig) (bs : list (@BTerm o)) :
  matching_entry oa1 oa2 vars bs
  + not_matching_entry oa1 oa2 vars bs.
Proof.
  unfold matching_entry, not_matching_entry.
  destruct (String.string_dec (opabs_name oa1) (opabs_name oa2));
  try (complete (right; auto));
  destruct (opsign_dec (opabs_sign oa1) (opabs_sign oa2));
  try (complete (right; auto));
  remember (matching_parametersb (opabs_params oa1) (opabs_params oa2)) as m;
  destruct m;
  try (complete (right; right; right; left; intro k;
                 unfold matching_parameters in k; rw <- Heqm in k; inversion k));
  destruct (opsign_dec (map (fun v => snd v) vars) (map num_bvars bs));
  try (complete (right; auto)).
  left; dands; auto.
  unfold matching_parameters.
  rewrite <- Heqm; sp.
Qed.

Fixpoint mk_abs_subst {o} (vs : list sovar_sig) (bs : list (@BTerm o)) : @SOSub o :=
  match vs, bs with
    | (v,n) :: vs, (bterm vars t) :: bs =>
      if deq_nat n (length vars)
      then (v, sosk vars t) :: mk_abs_subst vs bs
      else []
    | _, _ => []
  end.

Lemma mk_abs_subst_nil_r {o} :
  forall vars, @mk_abs_subst o vars [] = [].
Proof.
  induction vars; simpl; sp.
  dsovar_sigs; auto.
Qed.

Definition mk_instance {o}
           (vars : list sovar_sig)
           (bs   : list (@BTerm o))
           (rhs  : SOTerm) :=
  sosub (mk_abs_subst vars bs) rhs.

Definition unfold_abs_entry {o}
           (entry : @library_entry o)
           (opabs : opabs)
           (bs : list (@BTerm o)): option (@NTerm o) :=
  match entry with
    | lib_abs oa vars rhs correct =>
      if matching_entry_deq opabs oa vars bs
      then Some (mk_instance vars bs rhs)
      (* we have to substitute the param vars too *)
      else None
  end.

Definition library {o} := list (@library_entry o).

Definition emlib {o} : @library o := [].

Fixpoint find_entry {o} lib oa0 (bs : list (@BTerm o)) : option (@library_entry o) :=
  match lib with
    | [] => None
    | (lib_abs oa vars rhs correct as entry) :: l =>
      if matching_entry_deq oa0 oa vars bs
      then Some entry
      else find_entry l oa0 bs
  end.

Definition found_entry {o}
           lib oa0 (bs : list (@BTerm o))
           oa vars rhs correct :=
  find_entry lib oa0 bs = Some (lib_abs oa vars rhs correct).

Lemma found_entry_implies_matching_entry {o} :
  forall lib oa0 (bs : list (@BTerm o))
         oa vars rhs correct,
    found_entry lib oa0 bs oa vars rhs correct
    -> matching_entry oa0 oa vars bs.
Proof.
  introv f.
  unfold found_entry in f.
  induction lib; allsimpl.
  inversion f.
  destruct a.
  destruct (matching_entry_deq oa0 opabs vars0 bs); auto.
  inversion f; subst; auto.
Qed.

Fixpoint unfold_abs {o}
         (lib : @library o)
         (opabs : opabs)
         (bs : list (@BTerm o)): option (@NTerm o) :=
  match lib with
    | [] => None
    | entry :: lib =>
      match unfold_abs_entry entry opabs bs with
        | Some t => Some t
        | None => unfold_abs lib opabs bs
      end
  end.

Definition unfold {o} (lib : @library o) (t : @NTerm o) : option (@NTerm o) :=
  match t with
    | oterm (Abs opabs) bs => unfold_abs lib opabs bs
    | _ => None
  end.

Lemma mk_abs_subst_some_prop1 {o} :
  forall vars (bs : list (@BTerm o)) v vs t,
    LIn (v,sosk vs t) (mk_abs_subst vars bs)
    -> LIn (bterm vs t) bs.
Proof.
  induction vars; introv e; allsimpl; tcsp.
  destruct a.
  destruct bs; allsimpl; tcsp.
  destruct b; allsimpl; tcsp.
  boolvar; subst; allsimpl; tcsp.
  dorn e; cpx; ginv; tcsp.
  apply IHvars in e; tcsp.
Qed.

Lemma mk_abs_subst_some_prop2 {o} :
  forall (vars : list sovar_sig) (bs : list (@BTerm o)),
    matching_bterms vars bs
    -> vars = sodom (mk_abs_subst vars bs).
Proof.
  unfold matching_bterms.
  induction vars; introv e; allsimpl; tcsp.
  destruct a; allsimpl.
  destruct bs; allsimpl; tcsp; cpx; clear e.
  destruct b; allunfold @num_bvars; simpl.
  boolvar; tcsp; GC.
  apply eq_cons; auto.
Qed.

Lemma mk_abs_subst_some_prop3 {o} :
  forall vars (bs : list (@BTerm o)),
    subsovars (sodom (mk_abs_subst vars bs)) vars.
Proof.
  induction vars; introv; allsimpl; tcsp.
  destruct a; allsimpl.
  destruct bs; allsimpl; tcsp; cpx.
  destruct b; allsimpl; tcsp;
  try (complete (allunfold @num_bvars; allsimpl; cpx)).
  boolvar; subst; tcsp.
  apply subsovars_cons_lr; auto.
Qed.

Lemma sorange_mk_abs_subst {o} :
  forall (bs : list (@BTerm o)) vars,
    matching_bterms vars bs
    -> sorange (mk_abs_subst vars bs) = bs.
Proof.
  unfold matching_bterms.
  induction bs; simpl; introv m; destruct vars; allsimpl; cpx.
  destruct s; destruct a; boolvar; subst; allsimpl; subst.
  - apply eq_cons; auto.
  - allunfold @num_bvars; allsimpl; sp.
Qed.

Lemma isprogram_subst_lib {o} :
  forall oa0 oa vars rhs (lib : @library o) bs correct,
    found_entry lib oa0 bs oa vars rhs correct
    -> (forall b, LIn b bs -> isprogram_bt b)
    -> isprogram (mk_instance vars bs rhs).
Proof.
  introv f i.
  unfold correct_abs in correct; repnd.
  apply isprogram_sosub; auto.
  - rw <- @mk_abs_subst_some_prop2; auto.
    apply found_entry_implies_matching_entry in f.
    unfold matching_entry in f; repnd; auto.
  - apply sosub_prog_prop1.
    introv k.
    rw @sorange_mk_abs_subst in k; auto.
    apply found_entry_implies_matching_entry in f.
    unfold matching_entry in f; repnd; auto.
Qed.

Lemma matching_entry_change_bs {o} :
  forall oa1 oa2 vars (bs bs2 : list (@BTerm o)),
    matching_entry oa1 oa2 vars bs
    -> map num_bvars bs = map num_bvars bs2
    -> matching_entry oa1 oa2 vars bs2.
Proof.
  introv m e; allunfold @matching_entry; repnd; dands; auto.
  unfold matching_bterms.
  rewrite <- e; auto.
Qed.

Lemma not_matching_entry_change_bs {o} :
  forall oa1 oa2 vars (bs bs2 : list (@BTerm o)),
    not_matching_entry oa1 oa2 vars bs
    -> map num_bvars bs = map num_bvars bs2
    -> not_matching_entry oa1 oa2 vars bs2.
Proof.
  introv m e; allunfold @not_matching_entry;
  repeat (dorn m; tcsp).
  right; right; right.
  unfold matching_bterms.
  rewrite <- e; auto.
Qed.

Lemma matching_parameters_proof_irrelevance :
  forall ps1 ps2,
  forall x y : matching_parameters ps1 ps2,
    x = y.
Proof.
  introv; introv.
  apply UIP_dec.
  apply bool_dec.
Qed.

Hint Extern 0 =>
let h := fresh "h" in
match goal with
  | [ H1 : matching_parameters ?ps1 ?ps2 , H2 : matching_parameters ?ps1 ?ps2 |- _ ] =>
    pose proof (matching_parameters_proof_irrelevance ps1 ps2 H2 H1) as h; subst
end : pi.

Lemma decidable_eq_matching_parameters :
  forall oa1 oa2, decidable (matching_parameters (opabs_params oa1) (opabs_params oa2)).
Proof.
  introv.
  destruct oa1, oa2; simpl.
  unfold matching_parameters.
  pose proof (bool_dec true (matching_parametersb opabs_params opabs_params0)) as h;
    dorn h; try (rw <- h); try (complete (left; sp)).
  right; intro k; rw k in h; sp.
Qed.
Hint Immediate decidable_eq_matching_parameters.

Lemma not_matching_entry_iff {o} :
  forall oa1 oa2 vars (bs : list (@BTerm o)),
    not_matching_entry oa1 oa2 vars bs
    <=> !matching_entry oa1 oa2 vars bs.
Proof.
  introv; unfold matching_entry, not_matching_entry; split; intro k; repnd.
  - intro h; repnd.
    repeat (dorn k; tcsp).
  - apply not_over_and in k; auto.
    dorn k; tcsp.
    apply not_over_and in k; auto.
    dorn k; tcsp.
    apply not_over_and in k; auto.
Qed.

Lemma found_entry_change_bs {o} :
  forall oa0 oa vars rhs (lib : @library o) bs correct bs2,
    found_entry lib oa0 bs oa vars rhs correct
    -> map num_bvars bs = map num_bvars bs2
    -> found_entry lib oa0 bs2 oa vars rhs correct.
Proof.
  induction lib; introv f e.
  - allunfold @found_entry; allsimpl; inversion f.
  - allunfold @found_entry; allsimpl.
    destruct a.
    destruct (matching_entry_deq oa0 opabs vars0 bs).
    + pose proof (matching_entry_change_bs oa0 opabs vars0 bs bs2) as h; repeat (autodimp h hyp).
      destruct (matching_entry_deq oa0 opabs vars0 bs2); auto.
      apply not_matching_entry_iff in n; sp.
    + pose proof (not_matching_entry_change_bs oa0 opabs vars0 bs bs2) as h; repeat (autodimp h hyp).
      destruct (matching_entry_deq oa0 opabs vars0 bs2); auto.
      apply not_matching_entry_iff in h; sp.
      apply IHlib with (bs := bs); auto.
Qed.

Lemma unfold_abs_success_change_bs {o} :
  forall (lib : @library o) oa1 oa2 bs1 bs2 vars rhs correct,
    map num_bvars bs1 = map num_bvars bs2
    -> found_entry lib oa1 bs1 oa2 vars rhs correct
    -> unfold_abs lib oa1 bs2 = Some (mk_instance vars bs2 rhs).
Proof.
  induction lib; introv e f; allsimpl.
  - unfold found_entry in f; simpl in f; inversion f.
  - unfold found_entry in f; simpl in f; destruct a.
    unfold unfold_abs_entry.
    destruct (matching_entry_deq oa1 opabs vars0 bs1).
    + inversion f; subst; GC.
      assert (correct0 = correct) as h by (eauto with pi); subst; GC.
      apply (matching_entry_change_bs oa1 oa2 vars bs1 bs2) in m; auto.
      destruct (matching_entry_deq oa1 oa2 vars bs2); auto.
      apply not_matching_entry_iff in n; sp.
    + apply (not_matching_entry_change_bs oa1 opabs vars0 bs1 bs2) in n; auto.
      destruct (matching_entry_deq oa1 opabs vars0 bs2); auto.
      * apply not_matching_entry_iff in n; sp.
      * eapply IHlib; eauto.
Qed.

(*
Lemma matching_bterms_implies_b {o} :
  forall vars (bs : list (@BTerm o)) b,
    matching_bterms vars bs
    -> LIn b bs
    -> {t : NTerm & b = bterm [] t}.
Proof.
  unfold matching_bterms; introv m i.
  destruct b.
  exists n.
  assert (num_bvars (bterm l n) = 0) as h.
  - assert (LIn (num_bvars (bterm l n)) (map num_bvars bs)) as k.
    + rw in_map_iff.
      exists (bterm l n); auto.
    + rw <- m in k.
      rw in_map_iff in k; exrepnd; auto.
  - unfold num_bvars in h; simpl in h; destruct l; cpx.
Qed.
*)

(*
Lemma bterm_if_found_entry {o} :
  forall lib oa (bs : list (@BTerm o)) oa2 vars rhs correct,
    found_entry lib oa bs oa2 vars rhs correct
    -> forall b, LIn b bs -> {t : NTerm & b = bterm [] t}.
Proof.
  introv fe i.
  apply found_entry_implies_matching_entry in fe.
  unfold matching_entry in fe; repnd.
  eapply matching_bterms_implies_b in fe; eauto.
Qed.
*)

Lemma matching_bterms_cons {o} :
  forall vars (bs : list (@BTerm o)) v b,
    matching_bterms (v :: vars) (b :: bs)
    <=> (snd v = num_bvars b # matching_bterms vars bs).
Proof.
  unfold matching_bterms; split; introv m; repnd; allsimpl; cpx.
  allrw; auto.
Qed.

Lemma mk_abs_subst_as_combine {o} :
  forall vars (bs : list (@BTerm o)),
    matching_bterms vars bs
    -> mk_abs_subst vars bs = combine (sovars2vars vars) (map bterm2sk bs).
Proof.
  induction vars; destruct bs; simpl; introv m; auto; destruct a; auto.
  destruct b; boolvar; allsimpl; subst.
  - apply eq_cons; auto.
    apply IHvars.
    apply matching_bterms_cons in m; sp.
  - provefalse.
    apply matching_bterms_cons in m; repnd; allsimpl.
    allunfold @num_bvars; allsimpl; sp.
Qed.

Definition bound_vars_entry {o} (entry : @library_entry o) : list sovar_sig :=
  match entry with
    | lib_abs opabs vars rhs correct => vars ++ so_bound_vars rhs
  end.

Fixpoint bound_vars_lib {o} (lib : @library o) : list sovar_sig :=
  match lib with
    | [] => []
    | entry :: entries => bound_vars_entry entry ++ bound_vars_lib entries
  end.

Lemma ni_bound_vars_if_found_entry {o} :
  forall (lib : @library o) v oa1 bs oa2 vars rhs correct,
    !LIn v (bound_vars_lib lib)
    -> found_entry lib oa1 bs oa2 vars rhs correct
    -> !LIn v (so_bound_vars rhs).
Proof.
  unfold found_entry; induction lib; introv ni fe; simpl in fe.
  - inversion fe.
  - destruct a.
    destruct (matching_entry_deq oa1 opabs vars0 bs).
    + inversion fe; subst.
      allsimpl; allrw in_app_iff; allrw not_over_or; repnd; auto.
    + eapply IHlib in fe; eauto.
      allsimpl; allrw in_app_iff; allrw not_over_or; repnd; auto.
Qed.

(*
Lemma lubst_sub_mk_abs_subst {o} :
  forall (bs : list (@BTerm o)) vars sub,
    prog_sub sub
    -> mk_abs_subst vars (map (fun b => lsubst_bterm_aux b sub) bs)
       = lsubst_sub (mk_abs_subst vars bs) sub.
Proof.
  induction bs; simpl; introv ps; destruct vars; simpl; auto.
  destruct a; simpl.
  destruct l; simpl; auto.
  rw @sub_filter_nil_r.
  apply eq_cons; auto.
  change_to_lsubst_aux4; auto.
Qed.
*)

Lemma in_filter_out_fo_vars_iff :
  forall v n l,
    LIn (v, n) (filter_out_fo_vars l) <=> (n > 0 # LIn (v, n) l).
Proof.
  induction l; split; intro i; repnd; allsimpl; tcsp;
  destruct a; destruct n1; allsimpl; tcsp.
  - apply IHl in i; tcsp.
  - dorn i; cpx.
    + sp; omega.
    + apply IHl in i; repnd; tcsp.
  - dorn i; cpx.
    + provefalse; inversion i0.
    + apply IHl; sp.
  - dorn i; cpx.
    right; apply IHl; auto.
Qed.

Lemma socovered_implies_cover_so_vars {o} :
  forall (t : @SOTerm o) vars bs,
    socovered t vars
    -> matching_bterms vars bs
    -> cover_so_vars t (mk_abs_subst vars bs).
Proof.
  introv cov m.
  unfold socovered in cov.
  unfold cover_so_vars.
  allrw subsovars_prop; introv i.
  destruct x.
  allrw in_filter_out_fo_vars_iff; repnd; dands; auto.
  apply cov in i.
  rw <- @mk_abs_subst_some_prop2; auto.
Qed.

Lemma mk_instance_alpha_congr {p} :
  forall (rhs1 rhs2 : @SOTerm p) (vars : list sovar_sig) (bs1 bs2 : list BTerm),
    so_alphaeq rhs1 rhs2
    -> length vars = length bs1
    -> length vars = length bs2
    -> socovered rhs1 vars
    -> socovered rhs2 vars
    -> matching_bterms vars bs1
    -> matching_bterms vars bs2
    -> bin_rel_bterm alphaeqbt bs1 bs2
    -> alphaeq (mk_instance vars bs1 rhs1) (mk_instance vars bs2 rhs2).
Proof.
  introv aeq len1 len2 cov1 cov2 m1 m2 aeqs.
  unfold mk_instance.
  applydup @mk_abs_subst_as_combine in m1 as e1.
  applydup @mk_abs_subst_as_combine in m2 as e2.
  rw e1; rw e2.

  pose proof (sosub_alpha_congr
                rhs1 rhs2
                (sovars2vars vars)
                (map bterm2sk bs1)
                (map bterm2sk bs2)) as h.
  apply h; auto; clear h.

  - unfold sovars2vars; allrw map_length; auto.

  - unfold sovars2vars; allrw map_length; auto.

  - rw <- e1; apply socovered_implies_cover_so_vars; auto.

  - rw <- e2; apply socovered_implies_cover_so_vars; auto.

  - unfold bin_rel_sk.
    unfold bin_rel_bterm in aeqs.
    allunfold @binrel_list.
    allrw map_length; repnd; dands; auto.
    introv i.
    applydup aeqs in i.

    assert (default_sk = bterm2sk (@default_bt p)) as e by auto.

    rw e; allrw map_nth.
    remember (nth n bs1 default_bt) as bt1; clear Heqbt1.
    remember (nth n bs2 default_bt) as bt2; clear Heqbt2.
    destruct bt1, bt2; simpl.
    apply alphaeq_sk_iff_alphaeq_bterm; auto.
Qed.


(**
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.
*)

From Coq Require Import Reals Psatz ssreflect.
Require Import Rcomplements Rbar Lim_seq Continuity Derive Series 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 Lib.Extra.
Require Import CompCert.Events.
Require Import Common.Definitions.
Require Import Common.Linking.
Require Import Common.CompCertExtensions.

From mathcomp
  Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Section Suffix.

Variable T : eqType.

Implicit Types (x : T) (s : seq T).

Fixpoint suffix_rec s1 s2 : bool :=
  (s1 == s2) ||
  if s2 is x :: s2' then suffix_rec s1 s2' else false.

Definition suffix := locked suffix_rec.

Lemma suffix_refl : reflexive suffix.
Proof. by case=> [|??]; rewrite /suffix -lock //= eqxx. Qed.

Lemma suffix_cons s1 x s2 :
  suffix s1 (x :: s2) = (s1 == x :: s2) || suffix s1 s2.
Proof. by rewrite /suffix; unlock. Qed.

Lemma suffix_nil s1 : suffix s1 [::] = (s1 == [::]).
Proof. by rewrite /suffix -lock /= orbF. Qed.

End Suffix.

Section Traces.

Inductive stack_state := StackState {
  (* The current running component.  *)
  cur_comp : Component.id;

  (* Other running components further down the stack. *)
  callers  : list Component.id
}.

Definition stack_state0 := StackState Component.main [::].

Implicit Types (t : trace) (C : Component.id) (s : stack_state) (intf : Program.interface).

Fixpoint well_bracketed_trace s t : bool :=
  match t with
  | [::] => true
  | e :: t' =>
    (cur_comp s == cur_comp_of_event e) &&
    match e with
    | ECall C _ _ C' =>
      well_bracketed_trace (StackState C' (C :: callers s)) t'
    | ERet C _ C' =>
      match callers s with
      | [] => false
      | head :: tail =>
        (head == C') && well_bracketed_trace (StackState C' tail) t'
      end
    end
  end.

Definition run_event s e :=
  match e with
  | ECall C _ _ C' => StackState C' (C :: callers s)
  | ERet  C _   C' => StackState C' (tail (callers s))
  end.

Definition run_trace s t := foldl run_event s t.

Lemma run_trace1 s t e : run_trace s (rcons t e) = run_event (run_trace s t) e.
Proof. by rewrite -cats1 /run_trace foldl_cat. Qed.

Lemma well_bracketed_trace_cat s t1 t2 :
  well_bracketed_trace s (t1 ++ t2) =
  well_bracketed_trace s t1 &&
  well_bracketed_trace (run_trace s t1) t2.
Proof.
elim: t1 s=> [//|[C ? ? C'|C ? C'] t1 IH] [Ccur callers] /=.
  by rewrite IH andbA.
case: eqP callers => [_ {Ccur}|_] //= [|top callers] //=.
by rewrite IH andbA.
Qed.

Definition seq_of_stack_state s := cur_comp s :: callers s.

Coercion seq_of_stack_state : stack_state >-> seq.

Lemma seq_of_stack_state_inj : injective seq_of_stack_state.
Proof. by case=> [??] [??] [-> ->]. Qed.

Lemma well_bracketed_trace_suffix t C C' Cs :
  well_bracketed_trace stack_state0 t ->
  suffix [:: C, C' & Cs] (run_trace stack_state0 t) ->
  exists t1 P arg t2, t = t1 ++ ECall C' P arg C :: t2.
Proof.
set s0 := stack_state0.
elim/last_ind: t=> [|t e IH] //=.
  by rewrite suffix_cons suffix_nil /= orbF => _ /eqP.
have -> : well_bracketed_trace s0 (rcons t e) =
          well_bracketed_trace s0 t &&
          well_bracketed_trace (run_trace s0 t) [:: e].
  by rewrite -cats1 well_bracketed_trace_cat andbC.
rewrite run_trace1; case: e => [C1 P arg C2|C1 ? C2] /=.
  rewrite andbT; case/andP=> wb_t /eqP <- {C1} /=.
  rewrite -[_ :: callers _]/(run_trace s0 t : seq _) suffix_cons /=.
  case/orP=> [/eqP|Hsuff].
    case: (run_trace _ _)=> [? ?] [<- <- <-] /=.
    by eexists t, _, _, [::]; rewrite cats1.
  case/(_ wb_t Hsuff): IH=> [t1 [P' [arg' [t2 ->]]]].
  by eexists t1, P', arg', (rcons t2 _); rewrite rcons_cat; split; eauto.
case/and3P=> wb_t /eqP e1 e2.
have -> : StackState C2 (tl (callers (run_trace s0 t))) =
          callers (run_trace s0 t) :> seq _.
  by case: (callers _) e2=> [|e cs] //= /andP [/eqP ->].
move=> Hsuff; have {Hsuff} Hsuff: suffix [:: C, C' & Cs] (run_trace s0 t).
  by rewrite suffix_cons Hsuff orbT.
case/(_ wb_t Hsuff): IH=> [t1 [P [arg [t2 ->]]]].
by eexists t1, P, arg, (rcons _ _); rewrite rcons_cat.
Qed.

Lemma well_bracketed_trace_inv t C res C' :
  well_bracketed_trace stack_state0 (t ++ [:: ERet C res C']) ->
  exists t1 P arg t2, t = t1 ++ ECall C' P arg C :: t2.
Proof.
rewrite -[t]cat0s.
elim: t {1 3}nil=> [|e t IH] pre //=; last first.
  rewrite -cat1s [pre ++ _]catA; exact: IH.
rewrite cats0 well_bracketed_trace_cat /=.
case/and3P=> wb_t /eqP e_C e_C'.
have : suffix [:: C, C' & tail (callers (run_trace stack_state0 pre))]
              (run_trace stack_state0 pre).
  case: run_trace e_C e_C'=> [? [|??]] //=; rewrite andbT.
  by move=> -> /eqP ->; rewrite suffix_refl.
exact: well_bracketed_trace_suffix=> //.
Qed.

Definition well_formed_event intf (e: event) : bool :=
  match e with
  | ECall C P _ C' => (C != C') && imported_procedure_b intf C C' P
  | ERet  C _   C' => (C != C')
  end.

Definition well_formed_trace intf (t: trace) : bool :=
  well_bracketed_trace stack_state0 t &&
  all (well_formed_event intf) t.

Definition declared_event_comps intf e :=
  [&& cur_comp_of_event e \in domm intf &
      next_comp_of_event e \in domm intf].

Lemma well_formed_trace_int intf t :
  well_formed_trace intf t ->
  closed_interface intf ->
  all (declared_event_comps intf) t.
Proof.
case/andP=> wb wf clos; rewrite /declared_event_comps.
apply/allP; case=> [C P v C'|C v C'] /=; rewrite !mem_domm.
- move/(allP wf)=> /andP [_ imp].
  move: (imp); rewrite /imported_procedure_b; case: getm => //= _ _.
  by case/imported_procedure_iff/clos: imp=> ? [->].
- move=> in_p; case/path.splitP: in_p wb wf => {t} t1 t2.
  rewrite -cats1 /= well_bracketed_trace_cat.
  case/andP=> /well_bracketed_trace_inv [t11 [P [v' [t12 ->]]]] _ wf.
  have : well_formed_event intf (ECall C' P v' C).
    by move/allP: wf; apply; rewrite !mem_cat inE eqxx /= orbT.
  case/andP=> _ imp.
  case/imported_procedure_iff/clos: (imp)=> ? [-> _] /=.
  by move: imp; rewrite /imported_procedure_b; case: getm.
Qed.

End Traces.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 589 to 610, whose indices in         *)
(* the_configs range over segment [588, 610).                                 *)
(******************************************************************************)

Lemma red588to610 : reducible_in_range 588 610 the_configs.
Proof. CheckReducible. Qed.


Require Export VST.floyd.proofauto.
Require Export VST.floyd.reassoc_seq.
Require Export aes.aes.
Require Export aes.GF_ops_LL.
Require Export aes.tablesLL.
Require Export aes.spec_utils_LL.
Require Export aes.list_utils.
Require Export aes.spec_encryption_LL.

Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition t_struct_aesctx := Tstruct _mbedtls_aes_context_struct noattr.
Definition t_struct_tables := Tstruct _aes_tables_struct noattr.

Definition tables_initialized (tables : val) := data_at Ews t_struct_tables
  (map Vint FSb, (map Vint FT0, (map Vint FT1, (map Vint FT2, (map Vint FT3,
  (map Vint RSb, (map Vint RT0, (map Vint RT1, (map Vint RT2, (map Vint RT3,
  (map Vint RCON))))))))))) tables.

Definition Vundef256 : list val := repeat Vundef 256%nat.

Definition tables_uninitialized tables := data_at Ews t_struct_tables (Vundef256,
  (Vundef256, (Vundef256, (Vundef256, (Vundef256, (Vundef256,
  (Vundef256, (Vundef256, (Vundef256, (Vundef256,
  (repeat Vundef 10))))))))))) tables.

Definition gen_tables_spec :=
  DECLARE _aes_gen_tables
    WITH gv: globals
    PRE [  ]
      PROP ()
      LOCAL (gvars gv)
      SEP (tables_uninitialized (gv _tables))
    POST [ tvoid ]
      PROP ()
      LOCAL ()
      SEP (tables_initialized (gv _tables))
.

(* TODO replace this HL spec by a LL spec, and move HL spec to actual spec *)

Definition word_to_int (w : (int * int * int * int)) : int :=
  match w with (b0, b1, b2, b3) =>
    (Int.or (Int.or (Int.or
             b0
    (Int.shl b1 (Int.repr  8)))
    (Int.shl b2 (Int.repr 16)))
    (Int.shl b3 (Int.repr 24)))
  end.

(* SubWord function from section 5.2: apply S-box to each byte in a word *)
Definition SubWord (w: int) : int := word_to_int (
  (Znth (byte0 w) FSb),
  (Znth (byte1 w) FSb),
  (Znth (byte2 w) FSb),
  (Znth (byte3 w) FSb)
).

Definition RotWord(i: int): int :=
  Int.or (Int.and (Int.shl i (Int.repr 8)) (Int.repr (-1))) (Int.shru i (Int.repr 24)).

(* round constant (RCon) array, described in section 5.2 and explicitly written
 * out in appendix A.3 (256-bit key expansion example) *)
Definition RCon : list int := map (fun i => Int.shl i (Int.repr 24)) [
  (* 0x01000000 *) (Int.repr 1);
  (* 0x02000000 *) (Int.repr 2);
  (* 0x04000000 *) (Int.repr 4);
  (* 0x08000000 *) (Int.repr 8);
  (* 0x10000000 *) (Int.repr 16);
  (* 0x20000000 *) (Int.repr 32);
  (* 0x40000000 *) (Int.repr 64)
].

Definition GrowKeyByOne(w: list int): list int :=
  let i := Zlength w in
  let temp := (Znth (i-1) w) in
  let temp' := if (i mod Nk =? 0) then
    Int.xor (SubWord (RotWord temp)) (Znth (i/Nk) RCon)
  else if (i mod Nk =? 4) then
    SubWord temp
  else
    temp
  in
    w ++ [Int.xor (Znth (i-8) w) temp'].

Fixpoint pow_fun{T: Type}(f: T -> T)(n: nat)(a: T): T := match n with
| O => a
| S m => f (pow_fun f m a)
end.

(* +2 because 1 is for the initial round which is not counted, and 1 superfluous round key is
   created in the last loop iteration, because each iteration creates 2 round keys.
   -Nk because the first two round keys are just the unexpanded key.
  Note that (Nb*(Nr+2)-Nk) = 56. *)
Definition KeyExpansion2: list int -> list int := pow_fun GrowKeyByOne (Z.to_nat (Nb*(Nr+2)-Nk)).

(* arr: list of bytes *)
Definition get_uint32_le (arr: list Z) (i: Z) : int :=
 (Int.or (Int.or (Int.or
            (Int.repr (Znth  i    arr))
   (Int.shl (Int.repr (Znth (i+1) arr)) (Int.repr  8)))
   (Int.shl (Int.repr (Znth (i+2) arr)) (Int.repr 16)))
   (Int.shl (Int.repr (Znth (i+3) arr)) (Int.repr 24))).

Definition key_bytes_to_key_words(key_bytes: list Z): list int :=
  fill_list 8 (fun i => get_uint32_le key_bytes (i*4)).

(* end TODO *)

(* Note: clightgen turns global variables of type int to pointers to int, to make them addressable,
   so aes_init_done is a pointer to int, not an int! *)
Definition key_expansion_spec :=
  DECLARE _mbedtls_aes_setkey_enc
    WITH ctx : val, key : val, ctx_sh : share, key_sh : share, key_chars : list Z,
         init_done : Z, ish: share, gv: globals
    PRE [ _ctx OF (tptr t_struct_aesctx), _key OF (tptr tuchar), _keybits OF tuint  ]
      PROP (writable_share ctx_sh; readable_share key_sh; readable_share ish;
            Zlength key_chars = 32;
            init_done = 1 (*TODO also prove case where init_done=0*))
      LOCAL (temp _ctx ctx; temp _key key; temp _keybits (Vint (Int.repr 256));
             gvars gv)
      SEP (data_at ctx_sh t_struct_aesctx
                   (Vint Int.zero,
                   (nullval,
                   (map Vint (repeat_op_table 68 Int.zero id)))) ctx;
           data_at key_sh (tarray tuchar (4*8)) (map Vint (map Int.repr key_chars)) key;
           (*if init_done ?= 1 then tables_initialized tables else tables_uninitialized tables*)
           data_at ish tint (Vint (Int.repr init_done)) (gv _aes_init_done);
           tables_initialized (gv _tables))
    POST [  tint ]
      PROP ()
      LOCAL (temp ret_temp (Vint Int.zero))
      SEP (data_at key_sh (tarray tuchar (4*8)) (map Vint (map Int.repr key_chars)) key;
           data_at ctx_sh t_struct_aesctx
                   (Vint (Int.repr 14),
                   ((field_address t_struct_aesctx [StructField _buf] ctx),
                   (map Vint (KeyExpansion2 (key_bytes_to_key_words key_chars))
                    ++ (repeat_op_table 4 (Vint Int.zero) id)))) ctx;
           data_at ish tint (Vint (Int.repr init_done)) (gv _aes_init_done);
           tables_initialized (gv _tables)).

Definition encryption_spec_ll :=
  DECLARE _mbedtls_aes_encrypt
  WITH ctx : val, input : val, output : val, (* arguments *)
       ctx_sh : share, in_sh : share, out_sh : share, (* shares *)
       plaintext : list Z, (* 16 chars *)
       exp_key : list Z, (* expanded key, 4*(Nr+1)=60 32-bit integers *)
       gv: globals (* global var *)
  PRE [ _ctx OF (tptr t_struct_aesctx), _input OF (tptr tuchar), _output OF (tptr tuchar) ]
    PROP (Zlength plaintext = 16; Zlength exp_key = 60;
          readable_share ctx_sh; readable_share in_sh; writable_share out_sh)
    LOCAL (temp _ctx ctx; temp _input input; temp _output output; gvars gv)
    SEP (data_at ctx_sh (t_struct_aesctx) (
          (Vint (Int.repr Nr)),
          ((field_address t_struct_aesctx [StructField _buf] ctx),
          (map Vint (map Int.repr (exp_key ++ (list_repeat (8%nat) 0)))))
          (* The following weaker precondition would also be provable, but less conveniently, and   *)
          (* since mbedtls_aes_init zeroes the whole buffer, we exploit this to simplify the proof  *)
          (* ((map Vint (map Int.repr exp_key)) ++ (list_repeat (8%nat) Vundef))) *)
         ) ctx;
         data_at in_sh (tarray tuchar 16) (map Vint (map Int.repr plaintext)) input;
         data_at_ out_sh (tarray tuchar 16) output;
         tables_initialized (gv _tables))
  POST [ tvoid ]
    PROP() LOCAL()
    SEP (data_at ctx_sh (t_struct_aesctx) (
          (Vint (Int.repr Nr)),
          ((field_address t_struct_aesctx [StructField _buf] ctx),
          (map Vint (map Int.repr (exp_key ++ (list_repeat (8%nat) 0)))))
         ) ctx;
         data_at in_sh  (tarray tuchar 16)
                 (map Vint (map Int.repr plaintext)) input;
         data_at out_sh (tarray tuchar 16)
                 (map Vint (mbed_tls_aes_enc plaintext (exp_key ++ (list_repeat (8%nat) 0)))) output;
         tables_initialized (gv _tables)).

Definition Gprog : funspecs := ltac:(with_library prog [
  gen_tables_spec; key_expansion_spec; encryption_spec_ll
]).

(* This is to make sure do_compute_expr (invoked by load_tac and others), which calls hnf on the
   expression it's computing, does not unfold field_address.
   TODO floyd: Ideally, we'd have "Global Opaque field_address field_address0" in the library,
   but some proofs want to unfold field_address (they shouldn't, though). *)
Global Opaque field_address.

(* entailer! calls simpl, and if simpl tries to evaluate a column of the final AES encryption result,
   it takes forever, so we have to prevent this: *)
Arguments col _ _ : simpl never.
(* Same problem with "Z.land _ 255" *)
Arguments Z.land _ _ : simpl never.

(* This one is to prevent simplification of "12 - _", which is fast, but produces silly verbose goals *)
Arguments Nat.sub _ _ : simpl never.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 239 to 253, whose indices in         *)
(* the_configs range over segment [238, 253).                                 *)
(******************************************************************************)

Lemma red238to253 : reducible_in_range 238 253 the_configs.
Proof. CheckReducible. 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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Tools for small-step operational semantics *)

(** This module defines generic operations and theorems over
  the one-step transition relations that are used to specify
  operational semantics in small-step style. *)

Require Import Relations.
Require Import Wellfounded.
Require Import Coqlib.
Require Import Events.
Require Import Globalenvs.
Require Import Integers.
Require Import Memory.

Set Implicit Arguments.

(** * Closures of transitions relations *)

Section CLOSURES.

Variable state: Type.

(** A one-step transition relation has the following signature.
  It is parameterized by a global environment, which does not
  change during the transition.  It relates the initial state
  of the transition with its final state.  The [trace] parameter
  captures the observable events possibly generated during the
  transition. *)

Variable step: state -> trace -> state -> Prop.

(** No transitions: stuck state *)

Definition nostep (s: state) : Prop :=
  forall t s', ~(step s t s').

(** Zero, one or several transitions.  Also known as Kleene closure,
    or reflexive transitive closure. *)

Inductive star : state -> trace -> state -> Prop :=
  | star_refl: forall s,
      star s E0 s
  | star_step: forall s1 t1 s2 t2 s3 t,
      step s1 t1 s2 -> star s2 t2 s3 -> t = t1 ** t2 ->
      star s1 t s3.

Lemma star_one:
  forall s1 t s2, step s1 t s2 -> star s1 t s2.
Proof.
  intros. eapply star_step; eauto. apply star_refl. traceEq.
Qed.

Lemma star_two:
  forall s1 t1 s2 t2 s3 t,
  step s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  star s1 t s3.
Proof.
  intros. eapply star_step; eauto. apply star_one; auto.
Qed.

Lemma star_three:
  forall s1 t1 s2 t2 s3 t3 s4 t,
  step s1 t1 s2 -> step s2 t2 s3 -> step s3 t3 s4 -> t = t1 ** t2 ** t3 ->
  star s1 t s4.
Proof.
  intros. eapply star_step; eauto. eapply star_two; eauto.
Qed.

Lemma star_four:
  forall s1 t1 s2 t2 s3 t3 s4 t4 s5 t,
  step s1 t1 s2 -> step s2 t2 s3 ->
  step s3 t3 s4 -> step s4 t4 s5 -> t = t1 ** t2 ** t3 ** t4 ->
  star s1 t s5.
Proof.
  intros. eapply star_step; eauto. eapply star_three; eauto.
Qed.

Lemma star_trans:
  forall s1 t1 s2, star s1 t1 s2 ->
  forall t2 s3 t, star s2 t2 s3 -> t = t1 ** t2 -> star s1 t s3.
Proof.
  induction 1; intros.
  rewrite H0. simpl. auto.
  eapply star_step; eauto. traceEq.
Qed.

Lemma star_left:
  forall s1 t1 s2 t2 s3 t,
  step s1 t1 s2 -> star s2 t2 s3 -> t = t1 ** t2 ->
  star s1 t s3.
Proof star_step.

Lemma star_right:
  forall s1 t1 s2 t2 s3 t,
  star s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  star s1 t s3.
Proof.
  intros. eapply star_trans. eauto. apply star_one. eauto. auto.
Qed.

Lemma star_E0_ind:
  forall (P: state -> state -> Prop),
  (forall s, P s s) ->
  (forall s1 s2 s3, step s1 E0 s2 -> P s2 s3 -> P s1 s3) ->
  forall s1 s2, star s1 E0 s2 -> P s1 s2.
Proof.
  intros P BASE REC.
  assert (forall s1 t s2, star s1 t s2 -> t = E0 -> P s1 s2).
    induction 1; intros; subst.
    auto.
    destruct (Eapp_E0_inv _ _ H2). subst. eauto.
  eauto.
Qed.

(** One or several transitions.  Also known as the transitive closure. *)

Inductive plus : state -> trace -> state -> Prop :=
  | plus_left: forall s1 t1 s2 t2 s3 t,
      step s1 t1 s2 -> star s2 t2 s3 -> t = t1 ** t2 ->
      plus s1 t s3.

Lemma plus_one:
  forall s1 t s2,
  step s1 t s2 -> plus s1 t s2.
Proof.
  intros. econstructor; eauto. apply star_refl. traceEq.
Qed.

Lemma plus_two:
  forall s1 t1 s2 t2 s3 t,
  step s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  plus s1 t s3.
Proof.
  intros. eapply plus_left; eauto. apply star_one; auto.
Qed.

Lemma plus_three:
  forall s1 t1 s2 t2 s3 t3 s4 t,
  step s1 t1 s2 -> step s2 t2 s3 -> step s3 t3 s4 -> t = t1 ** t2 ** t3 ->
  plus s1 t s4.
Proof.
  intros. eapply plus_left; eauto. eapply star_two; eauto.
Qed.

Lemma plus_four:
  forall s1 t1 s2 t2 s3 t3 s4 t4 s5 t,
  step s1 t1 s2 -> step s2 t2 s3 ->
  step s3 t3 s4 -> step s4 t4 s5 -> t = t1 ** t2 ** t3 ** t4 ->
  plus s1 t s5.
Proof.
  intros. eapply plus_left; eauto. eapply star_three; eauto.
Qed.

Lemma plus_star:
  forall s1 t s2, plus s1 t s2 -> star s1 t s2.
Proof.
  intros. inversion H; subst.
  eapply star_step; eauto.
Qed.

Lemma plus_right:
  forall s1 t1 s2 t2 s3 t,
  star s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  plus s1 t s3.
Proof.
  intros. inversion H; subst. simpl. apply plus_one. auto.
  rewrite Eapp_assoc. eapply plus_left; eauto.
  eapply star_right; eauto.
Qed.

Lemma plus_left':
  forall s1 t1 s2 t2 s3 t,
  step s1 t1 s2 -> plus s2 t2 s3 -> t = t1 ** t2 ->
  plus s1 t s3.
Proof.
  intros. eapply plus_left; eauto. apply plus_star; auto.
Qed.

Lemma plus_right':
  forall s1 t1 s2 t2 s3 t,
  plus s1 t1 s2 -> step s2 t2 s3 -> t = t1 ** t2 ->
  plus s1 t s3.
Proof.
  intros. eapply plus_right; eauto. apply plus_star; auto.
Qed.

Lemma plus_star_trans:
  forall s1 t1 s2 t2 s3 t,
  plus s1 t1 s2 -> star s2 t2 s3 -> t = t1 ** t2 -> plus s1 t s3.
Proof.
  intros. inversion H; subst.
  econstructor; eauto. eapply star_trans; eauto.
  traceEq.
Qed.

Lemma star_plus_trans:
  forall s1 t1 s2 t2 s3 t,
  star s1 t1 s2 -> plus s2 t2 s3 -> t = t1 ** t2 -> plus s1 t s3.
Proof.
  intros. inversion H; subst.
  simpl; auto.
  rewrite Eapp_assoc.
  econstructor. eauto. eapply star_trans. eauto.
  apply plus_star. eauto. eauto. auto.
Qed.

Lemma plus_trans:
  forall s1 t1 s2 t2 s3 t,
  plus s1 t1 s2 -> plus s2 t2 s3 -> t = t1 ** t2 -> plus s1 t s3.
Proof.
  intros. eapply plus_star_trans. eauto. apply plus_star. eauto. auto.
Qed.

Lemma plus_inv:
  forall s1 t s2,
  plus s1 t s2 ->
  step s1 t s2 \/ exists s', exists t1, exists t2, step s1 t1 s' /\ plus s' t2 s2 /\ t = t1 ** t2.
Proof.
  intros. inversion H; subst. inversion H1; subst.
  left. rewrite E0_right. auto.
  right. exists s3; exists t1; exists (t0 ** t3); split. auto.
  split. econstructor; eauto. auto.
Qed.

Lemma star_inv:
  forall s1 t s2,
  star s1 t s2 ->
  (s2 = s1 /\ t = E0) \/ plus s1 t s2.
Proof.
  intros. inv H. left; auto. right; econstructor; eauto.
Qed.

Lemma plus_ind2:
  forall (P: state -> trace -> state -> Prop),
  (forall s1 t s2, step s1 t s2 -> P s1 t s2) ->
  (forall s1 t1 s2 t2 s3 t,
   step s1 t1 s2 -> plus s2 t2 s3 -> P s2 t2 s3 -> t = t1 ** t2 ->
   P s1 t s3) ->
  forall s1 t s2, plus s1 t s2 -> P s1 t s2.
Proof.
  intros P BASE IND.
  assert (forall s1 t s2, star s1 t s2 ->
         forall s0 t0, step s0 t0 s1 ->
         P s0 (t0 ** t) s2).
  induction 1; intros.
  rewrite E0_right. apply BASE; auto.
  eapply IND. eauto. econstructor; eauto. subst t. eapply IHstar; eauto. auto.

  intros. inv H0. eauto.
Qed.

Lemma plus_E0_ind:
  forall (P: state -> state -> Prop),
  (forall s1 s2 s3, step s1 E0 s2 -> star s2 E0 s3 -> P s1 s3) ->
  forall s1 s2, plus s1 E0 s2 -> P s1 s2.
Proof.
  intros. inv H0. exploit Eapp_E0_inv; eauto. intros [A B]; subst. eauto.
Qed.
End CLOSURES.

(** * Transition semantics *)

(** The general form of a transition semantics. *)

Record semantics : Type := Semantics {
  state: Type;
  funtype: Type;
  vartype: Type;
  step : Genv.t funtype vartype -> (state * mem) -> trace -> (state * mem) -> Prop;
  initial_state: (state * mem) -> Prop;
  final_state: (state * mem) -> int -> Prop;
  globalenv: Genv.t funtype vartype;
  step_forward :
    forall ge s1 m1 t s2 m2,
    step ge (s1,m1) t (s2,m2) -> Mem.forward m1 m2
}.

(** Handy notations. *)

Notation " 'Step' L " := (step L (globalenv L)) (at level 1) : smallstep_scope.
Notation " 'Star' L " := (star (step L (globalenv L))) (at level 1) : smallstep_scope.
Notation " 'Plus' L " := (plus (step L (globalenv L))) (at level 1) : smallstep_scope.
Notation " 'Nostep' L " := (nostep (step L (globalenv L))) (at level 1) : smallstep_scope.

Open Scope smallstep_scope.

(** * Forward simulations between two transition semantics. *)

(** The general form of a forward simulation. *)

Record forward_simulation (L1 L2: semantics) : Type :=
  Forward_simulation {
    fsim_index: Type;
    fsim_order: fsim_index -> fsim_index -> Prop;
    fsim_order_wf: well_founded fsim_order;
    fsim_match_states :> fsim_index -> (state L1 * mem) -> (state L2 * mem) -> Prop;
    fsim_match_initial_states:
      forall s1, initial_state L1 s1 ->
      exists i, exists s2, initial_state L2 s2 /\ fsim_match_states i s1 s2;
    fsim_match_final_states:
      forall i s1 s2 r,
      fsim_match_states i s1 s2 -> final_state L1 s1 r -> final_state L2 s2 r;
    fsim_simulation:
      forall s1 t s1', Step L1 s1 t s1' ->
      forall i s2, fsim_match_states i s1 s2 ->
      exists i', exists s2',
         (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ fsim_order i' i))
      /\ fsim_match_states i' s1' s2';
    fsim_symbols_preserved:
      forall id, Genv.find_symbol (globalenv L2) id = Genv.find_symbol (globalenv L1) id
  }.

Implicit Arguments forward_simulation [].

(** An alternate form of the simulation diagram *)

Lemma fsim_simulation':
  forall L1 L2 (S: forward_simulation L1 L2),
  forall i s1 t s1', Step L1 s1 t s1' ->
  forall s2, S i s1 s2 ->
  (exists i', exists s2', Plus L2 s2 t s2' /\ S i' s1' s2')
  \/ (exists i', fsim_order S i' i /\ t = E0 /\ S i' s1' s2).
Proof.
  intros. exploit fsim_simulation; eauto.
  intros [i' [s2' [A B]]]. intuition.
  left; exists i'; exists s2'; auto.
  inv H2.
  right; exists i'; auto.
  left; exists i'; exists s2'; split; auto. econstructor; eauto.
Qed.

(** ** Forward simulation diagrams. *)

(** Various simulation diagrams that imply forward simulation *)

Section FORWARD_SIMU_DIAGRAMS.

Variable L1: semantics.
Variable L2: semantics.

Hypothesis symbols_preserved:
  forall id, Genv.find_symbol (globalenv L2) id = Genv.find_symbol (globalenv L1) id.

Variable match_states: (state L1 * mem) -> (state L2 * mem) -> Prop.

Hypothesis match_initial_states:
  forall s1, initial_state L1 s1 ->
  exists s2, initial_state L2 s2 /\ match_states s1 s2.

Hypothesis match_final_states:
  forall s1 s2 r,
  match_states s1 s2 ->
  final_state L1 s1 r ->
  final_state L2 s2 r.

(** Simulation when one transition in the first program
    corresponds to zero, one or several transitions in the second program.
    However, there is no stuttering: infinitely many transitions
    in the source program must correspond to infinitely many
    transitions in the second program. *)

Section SIMULATION_STAR_WF.

(** [order] is a well-founded ordering associated with states
  of the first semantics.  Stuttering steps must correspond
  to states that decrease w.r.t. [order]. *)

Variable order: (state L1 * mem) -> (state L1 * mem) -> Prop.
Hypothesis order_wf: well_founded order.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2',
  (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ order s1' s1))
  /\ match_states s1' s2'.

Lemma forward_simulation_star_wf: forward_simulation L1 L2.
Proof.
  apply Forward_simulation with
    (fsim_order := order)
    (fsim_match_states := fun idx s1 s2 => idx = s1 /\ match_states s1 s2);
  auto.
  intros. exploit match_initial_states; eauto. intros [s2 [A B]].
    exists s1; exists s2; auto.
  intros. destruct H. eapply match_final_states; eauto.
  intros. destruct H0. subst i. exploit simulation; eauto. intros [s2' [A B]].
  exists s1'; exists s2'; intuition.
Qed.

End SIMULATION_STAR_WF.

Section SIMULATION_STAR.

(** We now consider the case where we have a nonnegative integer measure
  associated with states of the first semantics.  It must decrease when we take
  a stuttering step. *)

Variable measure: (state L1 * mem) -> nat.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  (exists s2', Plus L2 s2 t s2' /\ match_states s1' s2')
  \/ (measure s1' < measure s1 /\ t = E0 /\ match_states s1' s2)%nat.

Lemma forward_simulation_star: forward_simulation L1 L2.
Proof.
  apply forward_simulation_star_wf with (ltof _ measure).
  apply well_founded_ltof.
  intros. exploit simulation; eauto. intros [[s2' [A B]] | [A [B C]]].
  exists s2'; auto.
  exists s2; split. right; split. rewrite B. apply star_refl. auto. auto.
Qed.

End SIMULATION_STAR.

(** Simulation when one transition in the first program corresponds
    to one or several transitions in the second program. *)

Section SIMULATION_PLUS.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2', Plus L2 s2 t s2' /\ match_states s1' s2'.

Lemma forward_simulation_plus: forward_simulation L1 L2.
Proof.
  apply forward_simulation_star with (measure := fun _ => O).
  intros. exploit simulation; eauto.
Qed.

End SIMULATION_PLUS.

(** Lock-step simulation: each transition in the first semantics
    corresponds to exactly one transition in the second semantics. *)

Section SIMULATION_STEP.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2', Step L2 s2 t s2' /\ match_states s1' s2'.

Lemma forward_simulation_step: forward_simulation L1 L2.
Proof.
  apply forward_simulation_plus.
  intros. exploit simulation; eauto. intros [s2' [A B]].
  exists s2'; split; auto. apply plus_one; auto.
Qed.

End SIMULATION_STEP.

(** Simulation when one transition in the first program
    corresponds to zero or one transitions in the second program.
    However, there is no stuttering: infinitely many transitions
    in the source program must correspond to infinitely many
    transitions in the second program. *)

Section SIMULATION_OPT.

Variable measure: (state L1 * mem) -> nat.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  (exists s2', Step L2 s2 t s2' /\ match_states s1' s2')
  \/ (measure s1' < measure s1 /\ t = E0 /\ match_states s1' s2)%nat.

Lemma forward_simulation_opt: forward_simulation L1 L2.
Proof.
  apply forward_simulation_star with measure.
  intros. exploit simulation; eauto. intros [[s2' [A B]] | [A [B C]]].
  left; exists s2'; split; auto. apply plus_one; auto.
  right; auto.
Qed.

End SIMULATION_OPT.

End FORWARD_SIMU_DIAGRAMS.

(** ** Forward simulation of transition sequences *)

Section SIMULATION_SEQUENCES.

Variable L1: semantics.
Variable L2: semantics.
Variable S: forward_simulation L1 L2.

Lemma simulation_star:
  forall s1 t s1', Star L1 s1 t s1' ->
  forall i s2, S i s1 s2 ->
  exists i', exists s2', Star L2 s2 t s2' /\ S i' s1' s2'.
Proof.
  induction 1; intros.
  exists i; exists s2; split; auto. apply star_refl.
  exploit fsim_simulation; eauto. intros [i' [s2' [A B]]].
  exploit IHstar; eauto. intros [i'' [s2'' [C D]]].
  exists i''; exists s2''; split; auto. eapply star_trans; eauto.
  intuition. apply plus_star; auto.
Qed.

Lemma simulation_plus:
  forall s1 t s1', Plus L1 s1 t s1' ->
  forall i s2, S i s1 s2 ->
  (exists i', exists s2', Plus L2 s2 t s2' /\ S i' s1' s2')
  \/ (exists i', clos_trans _ (fsim_order S) i' i /\ t = E0 /\ S i' s1' s2).
Proof.
  induction 1 using plus_ind2; intros.
(* base case *)
  exploit fsim_simulation'; eauto. intros [A | [i' A]].
  left; auto.
  right; exists i'; intuition.
(* inductive case *)
  exploit fsim_simulation'; eauto. intros [[i' [s2' [A B]]] | [i' [A [B C]]]].
  exploit simulation_star. apply plus_star; eauto. eauto.
  intros [i'' [s2'' [P Q]]].
  left; exists i''; exists s2''; split; auto. eapply plus_star_trans; eauto.
  exploit IHplus; eauto. intros [[i'' [s2'' [P Q]]] | [i'' [P [Q R]]]].
  subst. simpl. left; exists i''; exists s2''; auto.
  subst. simpl. right; exists i''; intuition.
  eapply t_trans; eauto. eapply t_step; eauto.
Qed.
End SIMULATION_SEQUENCES.

(** ** Composing two forward simulations *)

Section COMPOSE_SIMULATIONS.

Variable L1: semantics.
Variable L2: semantics.
Variable L3: semantics.
Variable S12: forward_simulation L1 L2.
Variable S23: forward_simulation L2 L3.

Let ff_index : Type := (fsim_index S23 * fsim_index S12)%type.

Let ff_order : ff_index -> ff_index -> Prop :=
  lex_ord (clos_trans _ (fsim_order S23)) (fsim_order S12).

Let ff_match_states (i: ff_index) (s1: state L1 * mem) (s3: state L3 * mem) : Prop :=
  exists s2, S12 (snd i) s1 s2 /\ S23 (fst i) s2 s3.

Lemma compose_forward_simulation: forward_simulation L1 L3.
Proof.
  apply Forward_simulation with (fsim_order := ff_order) (fsim_match_states := ff_match_states).
(* well founded *)
  unfold ff_order. apply wf_lex_ord. apply wf_clos_trans. apply fsim_order_wf. apply fsim_order_wf.
(* initial states *)
  intros. exploit (fsim_match_initial_states S12); eauto. intros [i [s2 [A B]]].
  exploit (fsim_match_initial_states S23); eauto. intros [i' [s3 [C D]]].
  exists (i', i); exists s3; split; auto. exists s2; auto.
(* final states *)
  intros. destruct H as [s3 [A B]].
  eapply (fsim_match_final_states S23); eauto.
  eapply (fsim_match_final_states S12); eauto.
(* simulation *)
  intros. destruct H0 as [s3 [A B]]. destruct i as [i2 i1]; simpl in *.
  exploit (fsim_simulation' S12); eauto. intros [[i1' [s3' [C D]]] | [i1' [C [D E]]]].
  (* L2 makes one or several steps. *)
  exploit simulation_plus; eauto. intros [[i2' [s2' [P Q]]] | [i2' [P [Q R]]]].
  (* L3 makes one or several steps *)
  exists (i2', i1'); exists s2'; split. auto. exists s3'; auto.
  (* L3 makes no step *)
  exists (i2', i1'); exists s2; split.
  right; split. subst t; apply star_refl. red. left. auto.
  exists s3'; auto.
  (* L2 makes no step *)
  exists (i2, i1'); exists s2; split.
  right; split. subst t; apply star_refl. red. right. auto.
  exists s3; auto.
(* symbols *)
  intros. transitivity (Genv.find_symbol (globalenv L2) id); apply fsim_symbols_preserved; auto.
Qed.

End COMPOSE_SIMULATIONS.

(** * Receptiveness and determinacy *)

Definition single_events (L: semantics) : Prop :=
  forall s t s', Step L s t s' -> (length t <= 1)%nat.

Record receptive (L: semantics) : Prop :=
  Receptive {
    sr_receptive: forall s t1 s1 t2,
      Step L s t1 s1 -> match_traces (globalenv L) t1 t2 -> exists s2, Step L s t2 s2;
    sr_traces:
      single_events L
  }.

Record determinate (L: semantics) : Prop :=
  Determinate {
    sd_determ: forall s t1 s1 t2 s2,
      Step L s t1 s1 -> Step L s t2 s2 ->
      match_traces (globalenv L) t1 t2 /\ (t1 = t2 -> s1 = s2);
    sd_traces:
      single_events L;
    sd_initial_determ: forall s1 s2,
      initial_state L s1 -> initial_state L s2 -> s1 = s2;
    sd_final_nostep: forall s r,
      final_state L s r -> Nostep L s;
    sd_final_determ: forall s r1 r2,
      final_state L s r1 -> final_state L s r2 -> r1 = r2
  }.

Section DETERMINACY.

Variable L: semantics.
Hypothesis DET: determinate L.

Lemma sd_determ_1:
  forall s t1 s1 t2 s2,
  Step L s t1 s1 -> Step L s t2 s2 -> match_traces (globalenv L) t1 t2.
Proof.
  intros. eapply sd_determ; eauto.
Qed.

Lemma sd_determ_2:
  forall s t s1 s2,
  Step L s t s1 -> Step L s t s2 -> s1 = s2.
Proof.
  intros. eapply sd_determ; eauto.
Qed.

Lemma star_determinacy:
  forall s t s', Star L s t s' ->
  forall s'', Star L s t s'' -> Star L s' E0 s'' \/ Star L s'' E0 s'.
Proof.
  induction 1; intros.
  auto.
  inv H2.
  right. eapply star_step; eauto.
  exploit sd_determ_1. eexact H. eexact H3. intros MT.
  exploit (sd_traces DET). eexact H. intros L1.
  exploit (sd_traces DET). eexact H3. intros L2.
  assert (t1 = t0 /\ t2 = t3).
    destruct t1. inv MT. auto.
    destruct t1; simpl in L1; try omegaContradiction.
    destruct t0. inv MT. destruct t0; simpl in L2; try omegaContradiction.
    simpl in H5. split. congruence. congruence.
  destruct H1; subst.
  assert (s2 = s4) by (eapply sd_determ_2; eauto). subst s4.
  auto.
Qed.

End DETERMINACY.


From discprob.basic Require Import base sval order monad bigop_ext nify seq_ext.
Require Import Reals Psatz Omega.

Require ClassicalEpsilon.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
Global Set Bullet Behavior "Strict Subproofs".
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype seq div choice fintype finset finfun bigop.
Require Import stdpp.tactics.
Local Open Scope R_scope.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.idxval Require Import ival pival ival_dist pival_dist pidist_singleton extrema.

Definition pspec {A: Type} (m: pidist A) (P: A → Prop) :=
  ∀ y, In_psupport y m → P y.

Section pspec.

  Context {A: Type}.
  Implicit Types m : pidist A.
  Implicit Types P : A → Prop.

Lemma pspec_mret (x: A) P:
  P x → pspec (mret x) P.
Proof.
  intros HP y. intros (I&i&Hin&Heq&Hgt).
  rewrite -Heq. inversion Hin as [Heq']. subst => //=.
Qed.

Lemma pspec_union m1 m2 P:
  pspec m1 P → pspec m2 P → pspec (pidist_union m1 m2) P.
Proof.
  intros HP1 HP2. intros a (I&i&Hin&?&?).
  destruct Hin.
  * eapply HP1; eauto. eexists; eauto.
  * eapply HP2; eauto. eexists; eauto.
Qed.

Lemma pspec_union_inv_l m1 m2 P:
  pspec (pidist_union m1 m2) P →
  pspec m1 P.
Proof.
  intros HP. intros a (I&i&Hin&?&?).
  eapply HP. eapply In_psupport_alt. exists I; split_and!; eauto.
  * by left.
  * eexists; eauto.
Qed.

Lemma pspec_union_inv_r m1 m2 P:
  pspec (pidist_union m1 m2) P →
  pspec m2 P.
Proof.
  intros HP. intros a (I&i&Hin&?&?).
  eapply HP. eapply In_psupport_alt. exists I; split_and!; eauto.
  * by right.
  * eexists; eauto.
Qed.

Lemma In_isupport_proper (a: A) (I1 I2: ival A):
  eq_ival I1 I2 →
  In_isupport a I1 →
  In_isupport a I2.
Proof.
  intros Heq Hin.
  destruct Heq as (w1&w2&?&?&Hind&Hval).
  destruct Hin as (i1&Heq&Hgt).
  assert (Hgti: Rgt_dec (val I1 i1) 0).
  { destruct Rgt_dec => //=. }
  unshelve (eexists).
  { exact (sval (w1 (exist _ i1 Hgti))).  }
  rewrite Hind Hval //=.
Qed.

Lemma In_psupport_proper (a: A) (I1 I2: pival A):
  eq_pival I1 I2 →
  In_psupport a I1 →
  In_psupport a I2.
Proof.
  intros Heqpi (I&i&Hin&Heq&Hval).
  apply In_psupport_alt.
  destruct (Heqpi) as (Hle1&Hle2).
  destruct (Hle1 _ Hin) as (I'&HeqI'&Hin').
  exists I'; split; auto. eapply In_isupport_proper; try eassumption.
  subst. eexists; eauto.
Qed.

Global Instance pspec_proper:
  Proper (@eq_pidist A ==> pointwise_relation A iff ==> iff) pspec.
Proof.
  intros m1 m2 Heq P1 P2 Hiff.
  split.
  - intros Hm x Hin. apply Hiff. apply Hm. eapply In_psupport_proper; eauto.
    by symmetry.
  - intros Hm x Hin. apply Hiff. apply Hm. eapply In_psupport_proper; eauto.
Qed.

Lemma In_isupport_iscale p (I: ival A) x:
  In_isupport x (iscale p I) → In_isupport x I.
Proof.
  intros (i&Heq&Hval).
  subst. rewrite //=. exists i; split; eauto.
  rewrite //= in Hval.
  apply Rlt_gt.
  destruct (Rabs_pos p).
  * eapply Rmult_gt_reg_l; first eassumption.
    nra.
  * nra.
Qed.

Lemma In_psupport_pscale p (Is: pival A) x:
  In_psupport x (pscale p Is) → In_psupport x Is.
Proof.
  intros (I&i&Hin&Heq&Hval).
  apply pscale_in_inv in Hin as (I'&?&?).
  apply In_psupport_alt.
  exists I'; split; eauto.
  eapply In_isupport_iscale.
  eapply In_isupport_proper; eauto. subst.
  eexists; eauto.
Qed.

Lemma pspec_pidist_plus p Hpf m1 m2 P:
  pspec m1 P → pspec m2 P → pspec (pidist_plus p Hpf m1 m2) P.
Proof.
  intros HP1 HP2. intros a (I&i&Hin&?&Hval).
  destruct Hin as (I1&I2&Hin1&Hin2&Heq).
  subst. rewrite //= in Hval. destruct i as [i|i].
  * eapply HP1. rewrite //=. eapply In_psupport_pscale; eauto.
    exists I1; eauto.
  * eapply HP2. rewrite //=. eapply In_psupport_pscale; eauto.
    exists I2; eauto.
Qed.

Lemma pspec_conseq m (P Q: A → Prop):
  pspec m P → (∀ a, P a → Q a) → pspec m Q.
Proof.
  intros HP HPQ a Hin. apply HPQ; eauto.
Qed.

Lemma pspec_mbind {B: Type} (f: A → pidist B) m (P: A → Prop) (Q: B → Prop):
  pspec m P →
  (∀ a, P a → pspec (f a) Q) →
  pspec (mbind f m) Q.
Proof.
  intros Hinput Hbody b Hin.
  edestruct (@In_psupport_bind_inv) as (x&Hin'&I&i&?&?); eauto.
  eapply Hbody; eauto. exists I, i. eauto.
Qed.

Lemma pspec_bounded m (f: A → R):
  (∃ c, pspec m (λ x, Rabs (f x) <= c)) →
  bounded_fun_on f (λ x, In_psupport x m).
Proof.
  intros (c&Hspec). exists c. intros. eapply Hspec; eauto.
Qed.

Lemma bounded_psupp_pidist_plus f p Hpf (Is1 Is2: pidist A):
    bounded_fun_on f (λ i, In_psupport i Is1) →
    bounded_fun_on f (λ i, In_psupport i Is2) →
    bounded_fun_on f (λ i, In_psupport i (pidist_plus p Hpf Is1 Is2)).
Proof.
  intros (max1&Hm1).
  intros (max2&Hm2).
  exists (Rmax max1 max2).
  eapply pspec_pidist_plus.
  * eapply pspec_conseq; rewrite /pspec; first apply Hm1.
    intros. setoid_rewrite <-Rmax_l. auto.
  * eapply pspec_conseq; rewrite /pspec; first apply Hm2.
    intros. setoid_rewrite <-Rmax_r. auto.
Qed.

End pspec.

Tactic Notation "pbind" open_constr(P) :=
  match goal with
  | [ |- pspec (mbind ?f ?m) ?Q ] =>
    intros; eapply (@pspec_mbind _ _ f m P); auto
  end.


(** * Groupoid, the precategory of strict groupoid categories *)
Require Import Category.Core Functor.Core Category.Strict.
Require Import Cat.Core.
Require Import GroupoidCategory.Core.
Require Import Functor.Paths.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

Section groupoid_cat.
  Context `{Funext}.

  Let P : PreCategory -> Type
    := fun C => IsGroupoid C /\ IsStrictCategory C.
  Let HF : forall C D, P C -> P D -> IsHSet (Functor C D)
    := fun C D HC HD => @trunc_functor _ C D _ (snd HD) _.

  (** There is a full precategory of [cat] which is the strict groupoid precategories *)

  Definition groupoid_cat : PreCategory
    := @sub_pre_cat _ P HF.
End groupoid_cat.